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 fry hashtables io io.binary
6 io.encodings io.encodings.utf8 io.streams.byte-array kernel
7 linked-assocs literals math math.parser namespaces quotations
8 sequences serialize strings typed vectors words ;
13 CONSTANT: INT32-SIZE 4
14 CONSTANT: INT64-SIZE 8
18 TYPED: get-output ( -- stream: byte-vector )
19 output-stream get ; inline
21 TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
22 [ get-output [ length ] [ ] bi ] dip
23 call length swap [ - ] keep ; inline
25 : (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
26 [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
27 [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
29 : with-length-prefix ( quot: ( .. -- .. ) -- )
30 [ ] (with-length-prefix) ; inline
32 : with-length-prefix-excl ( quot: ( .. -- .. ) -- )
33 [ 4 - ] (with-length-prefix) ; inline
38 iota [ nth-byte write1 ] with each ; inline
40 TYPED: write-int32 ( int: integer -- )
41 INT32-SIZE write-le ; inline
43 TYPED: write-double ( real: float -- )
44 double>bits INT64-SIZE write-le ; inline
46 TYPED: write-utf8-string ( string: string -- )
47 get-output utf8 encode-string ; inline
49 TYPED: write-cstring ( string: string -- )
50 write-utf8-string 0 write1 ; inline
52 : write-longlong ( object -- )
53 INT64-SIZE write-le ; inline
55 : write-eoo ( -- ) T_EOO write1 ; inline
57 TYPED: write-header ( name: string object type: integer -- object )
58 write1 [ write-cstring ] dip ; inline
62 TYPED: write-byte-array ( binary: byte-array -- )
63 [ length write-int32 ]
64 [ T_Binary_Default write1 write ] bi ; inline
66 TYPED: write-mdbregexp ( regexp: mdbregexp -- )
67 [ regexp>> write-cstring ]
68 [ options>> write-cstring ] bi ; inline
70 TYPED: write-sequence ( array: sequence -- )
72 _ [ number>string swap write-pair ] each-index
74 ] with-length-prefix ; inline recursive
76 TYPED: write-oid ( oid: oid -- )
77 [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
79 : write-oid-field ( assoc -- )
80 [ MDB_OID_FIELD dup ] dip at
81 [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
84 : skip-field? ( name value -- name value boolean )
85 over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
87 UNION: hashtables hashtable linked-assoc ;
89 TYPED: write-assoc ( assoc: hashtables -- )
90 '[ _ [ write-oid-field ] [
91 [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
93 ] with-length-prefix ; inline recursive
95 UNION: code word quotation ;
97 TYPED: (serialize-code) ( code: code -- )
99 [ length write-int32 ]
100 [ T_Binary_Custom write1 write ] bi ; inline
102 : write-string-length ( string -- )
104 [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
106 TYPED: write-string ( string: string -- )
107 dup write-string-length write-cstring ; inline
109 TYPED: write-boolean ( bool: boolean -- )
110 [ 1 write1 ] [ 0 write1 ] if ; inline
112 TYPED: write-pair ( name: string obj -- )
115 [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
116 [ T_Object write-header write-assoc ]
118 [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
119 [ T_Array write-header write-sequence ]
122 [ T_Binary write-header write-byte-array ]
125 [ T_String write-header write-string ]
128 [ T_OID write-header write-oid ]
131 [ T_Integer write-header write-int32 ]
134 [ T_Boolean write-header write-boolean ]
137 [ T_Double write-header >float write-double ]
140 [ T_Date write-header timestamp>millis write-longlong ]
143 [ T_Regexp write-header write-mdbregexp ]
146 [ T_Binary write-header (serialize-code) ]
149 [ T_Binary write-header (serialize-code) ]
152 [ T_Object write-header dbref>assoc write-assoc ]
155 [ T_NULL write-header drop ]
161 TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
162 [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
164 TYPED: assoc>stream ( assoc: hashtables -- )
167 TYPED: mdb-special-value? ( value -- ?: boolean )