1 ! Copyright (C) 2010 Sascha Matzke.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.accessors arrays assocs bson.constants
4 byte-arrays byte-vectors calendar combinators
5 combinators.short-circuit dlists endian hashtables io
6 io.encodings io.encodings.utf8 kernel linked-assocs math
7 math.parser namespaces quotations sequences serialize strings
13 CONSTANT: INT32-SIZE 4
14 CONSTANT: INT64-SIZE 8
16 TYPED: get-output ( -- stream: byte-vector )
17 output-stream get ; inline
19 TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
20 [ get-output [ length ] [ ] bi ] dip
21 call length swap [ - ] keep ; inline
23 : (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
24 [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
25 [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
27 : with-length-prefix ( quot: ( .. -- .. ) -- )
28 [ ] (with-length-prefix) ; inline
30 : with-length-prefix-excl ( quot: ( .. -- .. ) -- )
31 [ 4 - ] (with-length-prefix) ; inline
34 <iota> [ nth-byte write1 ] with each ; inline
36 TYPED: write-int32 ( int: integer -- )
37 INT32-SIZE write-le ; inline
39 TYPED: write-double ( real: float -- )
40 double>bits INT64-SIZE write-le ; inline
42 TYPED: write-utf8-string ( string: string -- )
43 get-output utf8 encode-string ; inline
45 TYPED: write-cstring ( string: string -- )
46 write-utf8-string 0 write1 ; inline
48 : write-longlong ( object -- )
49 INT64-SIZE write-le ; inline
51 : write-eoo ( -- ) T_EOO write1 ; inline
53 TYPED: write-header ( name: string object type: integer -- object )
54 write1 [ write-cstring ] dip ; inline
58 TYPED: write-byte-array ( binary: byte-array -- )
59 [ length write-int32 ]
60 [ T_Binary_Default write1 write ] bi ; inline
62 TYPED: write-mdbregexp ( regexp: mdbregexp -- )
63 [ regexp>> write-cstring ]
64 [ options>> write-cstring ] bi ; inline
66 TYPED: write-sequence ( array: sequence -- )
68 _ [ number>string swap write-pair ] each-index
70 ] with-length-prefix ; inline recursive
72 TYPED: write-oid ( oid: oid -- )
73 [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
75 : write-oid-field ( assoc -- )
76 [ MDB_OID_FIELD dup ] dip at
77 [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
80 : skip-field? ( name value -- name value boolean )
81 over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
83 UNION: hashtables hashtable linked-assoc ;
85 TYPED: write-assoc ( assoc: hashtables -- )
86 '[ _ [ write-oid-field ] [
87 [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
89 ] with-length-prefix ; inline recursive
91 UNION: code word quotation ;
93 TYPED: (serialize-code) ( code: code -- )
95 [ length write-int32 ]
96 [ T_Binary_Custom write1 write ] bi ; inline
98 : write-string-length ( string -- )
100 [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
102 TYPED: write-string ( string: string -- )
103 dup write-string-length write-cstring ; inline
105 TYPED: write-boolean ( bool: boolean -- )
106 [ 1 write1 ] [ 0 write1 ] if ; inline
108 TYPED: write-pair ( name: string obj -- )
111 [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
112 [ T_Object write-header write-assoc ]
114 [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
115 [ T_Array write-header write-sequence ]
118 [ T_Binary write-header write-byte-array ]
121 [ T_String write-header write-string ]
124 [ T_OID write-header write-oid ]
127 [ T_Integer write-header write-int32 ]
130 [ T_Boolean write-header write-boolean ]
133 [ T_Double write-header >float write-double ]
136 [ T_Date write-header timestamp>millis write-longlong ]
139 [ T_Regexp write-header write-mdbregexp ]
142 [ T_Binary write-header (serialize-code) ]
145 [ T_Binary write-header (serialize-code) ]
148 [ T_Object write-header dbref>assoc write-assoc ]
151 [ T_NULL write-header drop ]
157 TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
158 [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
160 TYPED: assoc>stream ( assoc: hashtables -- )
163 TYPED: mdb-special-value? ( value -- ?: boolean )