extra/bson/writer/writer.factor

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