1 ! Copyright (C) 2010 Sascha Matzke.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs bson.constants byte-arrays
4 calendar combinators.short-circuit fry hashtables io io.binary
5 io.encodings.utf8 io.encodings io.streams.byte-array
6 kernel linked-assocs literals math math.parser namespaces byte-vectors
7 quotations sequences serialize strings vectors dlists alien.accessors ;
8 FROM: words => word? word ;
9 FROM: typed => TYPED: ;
10 FROM: combinators => cond ;
15 CONSTANT: INT32-SIZE 4
16 CONSTANT: INT64-SIZE 8
20 TYPED: get-output ( -- stream: byte-vector )
21 output-stream get ; inline
23 TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
24 [ get-output [ length ] [ ] bi ] dip
25 call length swap [ - ] keep ; inline
27 : (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
28 [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
29 [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
31 : with-length-prefix ( quot: ( .. -- .. ) -- )
32 [ ] (with-length-prefix) ; inline
34 : with-length-prefix-excl ( quot: ( .. -- .. ) -- )
35 [ 4 - ] (with-length-prefix) ; inline
40 iota [ nth-byte write1 ] with each ; inline
42 TYPED: write-int32 ( int: integer -- )
43 INT32-SIZE write-le ; inline
45 TYPED: write-double ( real: float -- )
46 double>bits INT64-SIZE write-le ; inline
48 TYPED: write-utf8-string ( string: string -- )
49 get-output utf8 encode-string ; inline
51 TYPED: write-cstring ( string: string -- )
52 write-utf8-string 0 write1 ; inline
54 : write-longlong ( object -- )
55 INT64-SIZE write-le ; inline
57 : write-eoo ( -- ) T_EOO write1 ; inline
59 TYPED: write-header ( name: string object type: integer -- object )
60 write1 [ write-cstring ] dip ; inline
64 TYPED: write-byte-array ( binary: byte-array -- )
65 [ length write-int32 ]
66 [ T_Binary_Default write1 write ] bi ; inline
68 TYPED: write-mdbregexp ( regexp: mdbregexp -- )
69 [ regexp>> write-cstring ]
70 [ options>> write-cstring ] bi ; inline
72 TYPED: write-sequence ( array: sequence -- )
74 _ [ number>string swap write-pair ] each-index
76 ] with-length-prefix ; inline recursive
78 TYPED: write-oid ( oid: oid -- )
79 [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
81 : write-oid-field ( assoc -- )
82 [ MDB_OID_FIELD dup ] dip at
83 [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
86 : skip-field? ( name value -- name value boolean )
87 over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
89 UNION: hashtables hashtable linked-assoc ;
91 TYPED: write-assoc ( assoc: hashtables -- )
92 '[ _ [ write-oid-field ] [
93 [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
95 ] with-length-prefix ; inline recursive
97 UNION: code word quotation ;
99 TYPED: (serialize-code) ( code: code -- )
101 [ length write-int32 ]
102 [ T_Binary_Custom write1 write ] bi ; inline
104 : write-string-length ( string -- )
106 [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
108 TYPED: write-string ( string: string -- )
109 dup write-string-length write-cstring ; inline
111 TYPED: write-boolean ( bool: boolean -- )
112 [ 1 write1 ] [ 0 write1 ] if ; inline
114 TYPED: write-pair ( name: string obj -- )
117 [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
118 [ T_Object write-header write-assoc ]
120 [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
121 [ T_Array write-header write-sequence ]
124 [ T_Binary write-header write-byte-array ]
127 [ T_String write-header write-string ]
130 [ T_OID write-header write-oid ]
133 [ T_Integer write-header write-int32 ]
136 [ T_Boolean write-header write-boolean ]
139 [ T_Double write-header >float write-double ]
142 [ T_Date write-header timestamp>millis write-longlong ]
145 [ T_Regexp write-header write-mdbregexp ]
148 [ T_Binary write-header (serialize-code) ]
151 [ T_Binary write-header (serialize-code) ]
154 [ T_Object write-header dbref>assoc write-assoc ]
157 [ T_NULL write-header drop ]
163 TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
164 [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
166 TYPED: assoc>stream ( assoc: hashtables -- )
169 TYPED: mdb-special-value? ( value -- ?: boolean )