extra/bson/writer/writer.factor

   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 ;
  11 IN: bson.writer
  12
  13 <PRIVATE
  14
  15 CONSTANT: INT32-SIZE 4
  16 CONSTANT: INT64-SIZE 8
  17
  18 PRIVATE>
  19
  20 TYPED: get-output ( -- stream: byte-vector )
  21     output-stream get ; inline
  22
  23 TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
  24     [ get-output [ length ] [ ] bi ] dip
  25     call length swap [ - ] keep ; inline
  26
  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
  30
  31 : with-length-prefix ( quot: ( .. -- .. ) -- )
  32     [ ] (with-length-prefix) ; inline
  33
  34 : with-length-prefix-excl ( quot: ( .. -- .. ) -- )
  35     [ 4 - ] (with-length-prefix) ; inline
  36
  37 <PRIVATE
  38
  39 : write-le ( x n -- )
  40     iota [ nth-byte write1 ] with each ; inline
  41
  42 TYPED: write-int32 ( int: integer -- )
  43     INT32-SIZE write-le ; inline
  44
  45 TYPED: write-double ( real: float -- )
  46     double>bits INT64-SIZE write-le ; inline
  47
  48 TYPED: write-utf8-string ( string: string -- )
  49     get-output utf8 encode-string ; inline
  50
  51 TYPED: write-cstring ( string: string -- )
  52     write-utf8-string 0 write1 ; inline
  53
  54 : write-longlong ( object -- )
  55     INT64-SIZE write-le ; inline
  56
  57 : write-eoo ( -- ) T_EOO write1 ; inline
  58
  59 TYPED: write-header ( name: string object type: integer -- object )
  60     write1 [ write-cstring ] dip ; inline
  61
  62 DEFER: write-pair
  63
  64 TYPED: write-byte-array ( binary: byte-array -- )
  65     [ length write-int32 ]
  66     [ T_Binary_Default write1 write ] bi ; inline
  67
  68 TYPED: write-mdbregexp ( regexp: mdbregexp -- )
  69    [ regexp>> write-cstring ]
  70    [ options>> write-cstring ] bi ; inline
  71
  72 TYPED: write-sequence ( array: sequence -- )
  73    '[
  74         _ [ number>string swap write-pair ] each-index
  75         write-eoo
  76     ] with-length-prefix ; inline recursive
  77
  78 TYPED: write-oid ( oid: oid -- )
  79     [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
  80
  81 : write-oid-field ( assoc -- )
  82     [ MDB_OID_FIELD dup ] dip at
  83     [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
  84     [ drop ] if* ; inline
  85
  86 : skip-field? ( name value -- name value boolean )
  87     over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
  88
  89 UNION: hashtables hashtable linked-assoc ;
  90
  91 TYPED: write-assoc ( assoc: hashtables -- )
  92     '[ _ [ write-oid-field ] [
  93             [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
  94          ] bi write-eoo
  95     ] with-length-prefix ; inline recursive
  96
  97 UNION: code word quotation ;
  98
  99 TYPED: (serialize-code) ( code: code -- )
 100   object>bytes
 101   [ length write-int32 ]
 102   [ T_Binary_Custom write1 write ] bi ; inline
 103
 104 : write-string-length ( string -- )
 105     [ length>> 1 + ]
 106     [ aux>> [ length ] [ 0 ] if* ] bi + write-int32 ; inline
 107
 108 TYPED: write-string ( string: string -- )
 109     dup write-string-length write-cstring ; inline
 110
 111 TYPED: write-boolean ( bool: boolean -- )
 112     [ 1 write1 ] [ 0 write1 ] if ; inline
 113
 114 TYPED: write-pair ( name: string obj -- )
 115     {
 116         {
 117             [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
 118             [ T_Object write-header write-assoc ]
 119         } {
 120             [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
 121             [ T_Array write-header write-sequence ]
 122         } {
 123             [ dup byte-array? ]
 124             [ T_Binary write-header write-byte-array ]
 125         } {
 126             [ dup string? ]
 127             [ T_String write-header write-string ]
 128         } {
 129             [ dup oid? ]
 130             [ T_OID write-header write-oid ]
 131         } {
 132             [ dup integer? ]
 133             [ T_Integer write-header write-int32 ]
 134         } {
 135             [ dup boolean? ]
 136             [ T_Boolean write-header write-boolean ]
 137         } {
 138             [ dup real? ]
 139             [ T_Double write-header >float write-double ]
 140         } {
 141             [ dup timestamp? ]
 142             [ T_Date write-header timestamp>millis write-longlong ]
 143         } {
 144             [ dup mdbregexp? ]
 145             [ T_Regexp write-header write-mdbregexp ]
 146         } {
 147             [ dup quotation? ]
 148             [ T_Binary write-header (serialize-code) ]
 149         } {
 150             [ dup word? ]
 151             [ T_Binary write-header (serialize-code) ]
 152         } {
 153             [ dup dbref? ]
 154             [ T_Object write-header dbref>assoc write-assoc ]
 155         } {
 156             [ dup f = ]
 157             [ T_NULL write-header drop ]
 158         }
 159     } cond ;
 160
 161 PRIVATE>
 162
 163 TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
 164     [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
 165
 166 TYPED: assoc>stream ( assoc: hashtables -- )
 167     write-assoc ; inline
 168
 169 TYPED: mdb-special-value? ( value -- ?: boolean )
 170     {
 171         [ timestamp? ]
 172         [ quotation? ]
 173         [ mdbregexp? ]
 174         [ oid? ]
 175         [ byte-array? ]
 176     } 1|| ; inline