Description
Serialization and deserialization of arbitrary objects
Version
- 0.9 doesn't use easyffi anymore
- 0.8 Made fallback-handler more useful and fixed a bug [Thanks to Daishi Kato]
- 0.7 Added fallback-handler to `deserialize'
- 0.6 Nasty little bug in backreferences fixed
- 0.5 Hash-table-deserialization bug reported by Kabir Soorya
- 0.4 Fixed small bug in port-serialization; added note about continuations
- 0.3 Serialization of hash-tables is more storage efficient; added `chicken-dump' program
- 0.2 Failure handling for some cases was invalid
- 0.1 Initial release
Usage
(require-extension s11n)
Documentation
This extension allows serializing and deserializing arbitrary data (including procedures and continuations) into/from ports. Circular data is support as well as uninterned symbols. Foreign-pointer objects and ports other than the default input-, output- and error-ports can not be serialized. Threads may be serialized provided they are not running or ready (this means suspended or created but not yet started threads).
The serialized data is endianness- and word-size dependent.
To enable serialization of procedures and continuations, CHICKEN has to be built with the --enable-procedure-tables configuration option. In particular, any compiled module that is referenced in serialized data has to be compiled with a CHICKEN version that has procedure tables enabled.
Compiled procedures and continuations can be deserialized, provided that the same executable or libraries are loaded/linked - the compiled code must be available so that the deserialization process can find the associated code.
Continuations can be serialized but care has to be taken about what exactly is stored in such an object. Every invocation of call-with-current-continuation includes the complete list of pending dynamic-wind thunks (and their dynamic environment) which is likely to include non-serializable state.
Since the deserialization process breaks any assumptions about a unique identity of objects, TinyCLOS instances and classes can currently not be deserialized.
CHICKEN version 2.207 or higher is required to use this extension.
- procedure: (serialize X [PORT [SERIALIZER]])
-
Writes a binary representation of X into PORT which defaults to the value of (current-output-port). If the serialization is unable to handle some object, the procedure SERIALIZER is invoked with that object as it's sole argument. The procedure should either signal an error or return a placeholder object that is to be serialized instead. If no serializer is specified, an error will be signalled.
- procedure: (deserialize [PORT [DESERIALIZER]])
-
Reads a binary representation of a Scheme data object from PORT which defaults to the value of (current-input-port). The deserialized object is returned.
If DESERIALIZER is given, then it will be called for procedure objects that can not be deserialized (normally because a serialized file was generated by a different version of CHICKEN) with the procedure-id (internal name) and the deserialized closure object as argument.
A separate tool is also available, named chicken-dump that writes a description about the contents of a serialized file. Just invoke
chicken-dump FILENAME
on the command prompt.
License
Copyright (c) 2005, Felix Winkelmann. All rights reserved.
Permission is hereby granted, free of charge, to any person obtaining a
copy of this software and associated documentation files (the Software),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
#|-------------------- 0.9.3 |# "./s11n.meta" 291
;;; s11n.meta -*- Scheme -*-
((egg "s11n.egg")
(synopsis "Serialization of arbitrary data.")
(category parsing)
(license "BSD")
(author "felix")
(depends matchable)
(files "constants.scm" "s11n.meta" "s11n-c.c" "s11n.html" "s11n.setup" "s11n.scm" "tests/run.scm" "chicken-dump.scm"))
#|-------------------- 0.9.3 |# "./s11n.scm" 7319
;;;; s11n.scm
(declare
(fixnum))
(module s11n (serialize deserialize serialization-mode)
(import scheme chicken foreign)
(use srfi-69 extras)
(include "constants.scm")
#>
#include "s11n-c.c"
<#
(define procedure_to_id
(foreign-lambda* c-string ((scheme-object p))
"return(C_lookup_procedure_id((void *)C_block_item(p, 0)));") )
(define fixnum_to_bytes (##core#primitive "fixnum_to_bytes"))
(define word_to_bytes (##core#primitive "word_to_bytes"))
(define header_to_bytes (##core#primitive "header_to_bytes"))
(define serialization-mode (make-parameter 'host))
(define (serialize x #!optional (port (current-output-port)) serializer)
(let ((table (make-hash-table eq?))
(pos 0) )
(define (emitb b)
(write-char (integer->char b) port) )
(define (emit s)
(display s port) )
(define (emitw w)
(display (word_to_bytes w) port) )
(define (walkslots x i)
(let ((len (##sys#size x)))
(do ((i i (add1 i)))
((>= i len))
(walk (##sys#slot x i)) ) ) )
(define (emitbytes x)
(let ((len (##sys#size x)))
(do ((i 0 (add1 i)))
((>= i len))
(emitb (##sys#byte x i)) ) ) )
(define (fail msg x)
(if serializer
(walk (serializer x))
(error 'serialize (string-append "unable to serialize object - " msg) x)))
(define (walk x)
#+debug
(fprintf
(current-error-port)
"Emitting: ~a"
(##sys#with-print-length-limit
80
(lambda () (with-output-to-string (cut pp x)))))
(cond ((fixnum? x)
(emitb fixnum-tag)
(emit (fixnum_to_bytes x)) )
((char? x)
(emitb char-tag)
(emitw (char->integer x)) )
((##sys#immediate? x)
(select x
(((##core#undefined)) (emitb void-tag))
((#t) (emitb true-tag))
((#f) (emitb false-tag))
((#!eof) (emitb eof-tag))
(('()) (emitb null-tag))
(else (fail "can not serialize immediate value" x))) )
((hash-table-ref/default table x #f) =>
(lambda (pos)
(emitb backref-tag)
(emitw pos) ) )
(else
(hash-table-set! table x pos)
(set! pos (add1 pos))
(cond ((procedure? x)
(emitb procedure-tag)
(emit (header_to_bytes x))
(let ((id (procedure_to_id x)))
(cond ((not id)
(set! pos (sub1 pos))
(fail "unable to serialize procedure (no table entry found)" x) )
(else
(walk id)
(walkslots x 1) ) ) ) )
((##core#inline "C_specialp" x)
(cond ((port? x)
(let ((name (##sys#slot x 3)))
(cond ((string=? "(stdin)" name)
(emitb stdport-tag)
(emitb 0) )
((string=? "(stdout)" name)
(emitb stdport-tag)
(emitb 1) )
((string=? "(stderr)" name)
(emitb stdport-tag)
(emitb 2) )
((not (zero? (##sys#pointer->address x)))
(fail "can not serialize stream port" x) )
(else
(emitb vector-tag)
(emit (header_to_bytes x))
(emitw 0)
(walkslots x 1) ) ) ) )
(else
(fail "can not serialize pointer-like object" x)
#| (emitb special-tag)
(emit (header_to_bytes x))
(walkslots x 1) |#) ) )
((##core#inline "C_byteblockp" x)
(emitb bytevector-tag)
(emit (header_to_bytes x))
(emitbytes x) )
((symbol? x)
(emitb
(if (not (##core#inline "C_lookup_symbol" x))
gensym-tag
symbol-tag) )
(walk (##sys#slot x 1)) )
((hash-table? x)
(emitb hash-table-tag)
(walk (hash-table->alist x))
(walkslots x 3) )
(else
(emitb vector-tag)
(emit (header_to_bytes x))
(walkslots x 0) ) ) ) ) )
(when (eq? (serialization-mode) 'portable)
(emitb (if (##sys#fudge 3) sixtyfour-bit-tag thirtytwo-bit-tag))
(emitb +endianness-tag+) )
(walk x) ) )
(define bytes_to_block (##core#primitive "bytes_to_block"))
(define stdin-port ##sys#standard-input)
(define stdout-port ##sys#standard-output)
(define stderr-port ##sys#standard-error)
(define (deserialize #!optional (port (current-input-port)) fallback (safe #t))
(let ((backrefs (make-vector 100))
(backref-count 0) )
(define (getb)
(let ((c (read-char port)))
(if (eof-object? c)
(error 'deserialize "unexpected end of input" port)
(char->integer c))))
(define (getw)
(##core#inline "bytes_to_word" (read-string +sizeof-ulong+ port)) )
(define (addref x)
(when (>= backref-count (vector-length backrefs))
(set! backrefs (vector-resize backrefs (* 2 backref-count))) )
(vector-set! backrefs backref-count x)
(set! backref-count (add1 backref-count))
x)
(define (fetchslots x i)
(let ((len (##sys#size x)))
(do ((i i (add1 i)))
((>= i len) x)
(##sys#setslot x i (fetch)) ) ) )
(define (fetch)
(let ((tag (getb)))
(select tag
((sixtyfour-bit-tag) (fetch))
((thirtytwo-bit-tag) (fetch))
((big-endian-tag) (fetch))
((little-endian-tag) (fetch))
((void-tag) (void))
((null-tag) '())
((eof-tag) #!eof)
((true-tag) #t)
((false-tag) #f)
((backref-tag)
(let ((w (getw)))
(vector-ref backrefs w)) )
((fixnum-tag)
(##core#inline "bytes_to_fixnum" (read-string +sizeof-word+ port)) )
((char-tag)
(integer->char (getw)) )
((gensym-tag)
(addref #f)
(let* ((r (sub1 backref-count))
(x (##sys#make-symbol (fetch))) )
(vector-set! backrefs r x)
x) )
((symbol-tag)
(addref #f)
(let* ((r (sub1 backref-count))
(x (##sys#intern-symbol (fetch)) ))
(vector-set! backrefs r x)
x) )
((stdport-tag)
(addref #f)
(let* ((n (getb))
(r (sub1 backref-count))
(p (case n
((0) stdin-port)
((1) stdout-port)
((2) stderr-port)
(else (error 'deserialize "invalid standard-port number" n)) ) ) )
(vector-set! backrefs r p)
p) )
((hash-table-tag)
(addref #f)
(let ((r (sub1 backref-count))
(ht (##sys#make-structure 'hash-table #f 0 #f #f)) )
(vector-set! backrefs r ht)
(let* ((table (fetch))
(test (fetch))
(hashf (fetch))
(ht2 (alist->hash-table table)) )
(##sys#setslot ht 1 (##sys#slot ht2 1))
(##sys#setslot ht 2 (##sys#slot ht2 2))
(##sys#setslot ht 3 test)
(##sys#setslot ht 4 hashf)
ht) ) )
(else
(let* ((h (read-string +sizeof-header+ port))
(x (addref (bytes_to_block h)))
(r (sub1 backref-count)) )
(##core#inline "set_header" x h)
(select tag
((bytevector-tag)
(##core#inline "insert_bytes" x (read-string (##sys#size x) port))
x)
((vector-tag) (fetchslots x 0))
#;((special-tag)
(when safe
(error 'deserialize "unable to deserialize pointer-like object" x) )
(##core#inline "insert_bytes" x (read-string +sizeof-word+ port))
(fetchslots x 1) )
((procedure-tag)
(let ((id (fetch)))
(cond ((##core#inline "set_procedure_ptr" x (##sys#make-c-string id))
(fetchslots x 1) )
(fallback
(let ((proc (fallback id (fetchslots x 1))))
(vector-set! backrefs r proc)
proc) )
(else (error 'deserialize "unable to deserialize procedure - no table entry found" id))) ) )
(else (error 'deserialize "invalid tag" tag)) ) ) ) ) ) )
(fetch) ) )
)
#|-------------------- 0.9.3 |# "./s11n.setup" 264
(compile s11n.scm -O2 -d1 -s -j s11n)
(compile s11n.import.scm -O2 -d0 -s)
(compile chicken-dump.scm -O2 -d1 -disable-interrupts -b)
(install-extension 's11n
`("s11n.import.so" "s11n.so")
`((version "0.9.3")))
(install-program 'chicken-dump "chicken-dump")
![[Picture of an egg]](egg.jpg)