extra/bson/reader/reader.factor

   1 USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
   2 io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
   3 sequences serialize arrays calendar io.encodings ;
   4
   5 IN: bson.reader
   6
   7 <PRIVATE
   8
   9 TUPLE: element { type integer } name ;
  10 TUPLE: state
  11     { size initial: -1 } { read initial: 0 } exemplar
  12     result scope element ;
  13
  14 : <state> ( exemplar -- state )
  15     [ state new ] dip
  16     [ clone >>exemplar ] keep
  17     clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
  18     V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
  19
  20 PREDICATE: bson-eoo     < integer T_EOO = ;
  21 PREDICATE: bson-not-eoo < integer T_EOO > ;
  22
  23 PREDICATE: bson-double  < integer T_Double = ;
  24 PREDICATE: bson-integer < integer T_Integer = ;
  25 PREDICATE: bson-string  < integer T_String = ;
  26 PREDICATE: bson-object  < integer T_Object = ;
  27 PREDICATE: bson-array   < integer T_Array = ;
  28 PREDICATE: bson-binary  < integer T_Binary = ;
  29 PREDICATE: bson-regexp  < integer T_Regexp = ;
  30 PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
  31 PREDICATE: bson-binary-function < integer T_Binary_Function = ;
  32 PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
  33 PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
  34 PREDICATE: bson-oid     < integer T_OID = ;
  35 PREDICATE: bson-boolean < integer T_Boolean = ;
  36 PREDICATE: bson-date    < integer T_Date = ;
  37 PREDICATE: bson-null    < integer T_NULL = ;
  38 PREDICATE: bson-ref     < integer T_DBRef = ;
  39
  40 GENERIC: element-read ( type -- cont? )
  41 GENERIC: element-data-read ( type -- object )
  42 GENERIC: element-binary-read ( length type -- object )
  43
  44 : byte-array>number ( seq -- number )
  45     byte-array>bignum >integer ; inline
  46
  47 : get-state ( -- state )
  48     state get ; inline
  49
  50 : count-bytes ( count -- )
  51     [ get-state ] dip '[ _ + ] change-read drop ; inline
  52
  53 : read-int32 ( -- int32 )
  54     4 [ read byte-array>number ] [ count-bytes ] bi  ; inline
  55
  56 : read-longlong ( -- longlong )
  57     8 [ read byte-array>number ] [ count-bytes ] bi ; inline
  58
  59 : read-double ( -- double )
  60     8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
  61
  62 : read-byte-raw ( -- byte-raw )
  63     1 [ read ] [ count-bytes ] bi ; inline
  64
  65 : read-byte ( -- byte )
  66     read-byte-raw first ; inline
  67
  68 : read-cstring ( -- string )
  69     input-stream get utf8 <decoder>
  70     "\0" swap stream-read-until drop ; inline
  71
  72 : read-sized-string ( length -- string )
  73     drop read-cstring ; inline
  74
  75 : read-element-type ( -- type )
  76     read-byte ; inline
  77
  78 : push-element ( type name -- element )
  79     element boa
  80     [ get-state element>> push ] keep ; inline
  81
  82 : pop-element ( -- element )
  83     get-state element>> pop ; inline
  84
  85 : peek-scope ( -- ht )
  86     get-state scope>> peek ; inline
  87
  88 : read-elements ( -- )
  89     read-element-type
  90     element-read
  91     [ read-elements ] when ; inline recursive
  92
  93 GENERIC: fix-result ( assoc type -- result )
  94
  95 M: bson-object fix-result ( assoc type -- result )
  96     drop ;
  97
  98 M: bson-array fix-result ( assoc type -- result )
  99     drop
 100     values ;
 101
 102 GENERIC: end-element ( type -- )
 103
 104 M: bson-object end-element ( type -- )
 105     drop ;
 106
 107 M: bson-array end-element ( type -- )
 108     drop ;
 109
 110 M: object end-element ( type -- )
 111     drop
 112     pop-element drop ;
 113
 114 M: bson-eoo element-read ( type -- cont? )
 115     drop
 116     get-state scope>> [ pop ] keep swap ! vec assoc
 117     pop-element [ type>> ] keep       ! vec assoc element
 118     [ fix-result ] dip
 119     rot length 0 >                      ! assoc element
 120     [ name>> peek-scope set-at t ]
 121     [ drop [ get-state ] dip >>result drop f ] if ;
 122
 123 M: bson-not-eoo element-read ( type -- cont? )
 124     [ peek-scope ] dip                                 ! scope type
 125     '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
 126        [ element-data-read ] keep
 127        end-element
 128        swap
 129     ] dip set-at t ;
 130
 131 : [scope-changer] ( state -- state quot )
 132     dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
 133
 134 : (object-data-read) ( type -- object )
 135     drop
 136     read-int32 drop
 137     get-state
 138     [scope-changer] change-scope
 139     scope>> peek ; inline
 140
 141 M: bson-object element-data-read ( type -- object )
 142     (object-data-read) ;
 143
 144 M: bson-array element-data-read ( type -- object )
 145     (object-data-read) ;
 146
 147 M: bson-string element-data-read ( type -- object )
 148     drop
 149     read-int32 read-sized-string ;
 150
 151 M: bson-integer element-data-read ( type -- object )
 152     drop
 153     read-int32 ;
 154
 155 M: bson-double element-data-read ( type -- double )
 156     drop
 157     read-double ;
 158
 159 M: bson-boolean element-data-read ( type -- boolean )
 160    drop
 161    read-byte 1 = ;
 162
 163 M: bson-date element-data-read ( type -- timestamp )
 164    drop
 165    read-longlong millis>timestamp ;
 166
 167 M: bson-binary element-data-read ( type -- binary )
 168    drop
 169    read-int32 read-byte element-binary-read ;
 170
 171 M: bson-regexp element-data-read ( type -- mdbregexp )
 172    drop mdbregexp new
 173    read-cstring >>regexp read-cstring >>options ;
 174
 175 M: bson-null element-data-read ( type -- bf  )
 176     drop
 177     f ;
 178
 179 M: bson-oid element-data-read ( type -- oid )
 180     drop
 181     read-longlong
 182     read-int32 oid boa ;
 183
 184 M: bson-binary-custom element-binary-read ( size type -- dbref )
 185     2drop
 186     read-cstring
 187     read-cstring objref boa ;
 188
 189 M: bson-binary-bytes element-binary-read ( size type -- bytes )
 190     drop read ;
 191
 192 M: bson-binary-function element-binary-read ( size type -- quot )
 193     drop read bytes>object ;
 194
 195 PRIVATE>
 196
 197 : stream>assoc ( exemplar -- assoc bytes-read )
 198     <state> dup state
 199     [ read-int32 >>size read-elements ] with-variable
 200     [ result>> ] [ read>> ] bi ;