diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor index 2d126857c3..e4bf14432a 100644 --- a/extra/bson/constants/constants.factor +++ b/extra/bson/constants/constants.factor @@ -19,6 +19,16 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: dbref ref id db ; +TUPLE: mongo-timestamp incr seconds ; + +: ( incr seconds -- mongo-timestamp ) + mongo-timestamp boa ; + +TUPLE: mongo-scoped-code code object ; + +: ( code object -- mongo-scoped-code ) + mongo-scoped-code boa ; + CONSTRUCTOR: dbref ( ref id -- dbref ) ; : dbref>assoc ( dbref -- assoc ) @@ -47,30 +57,31 @@ TUPLE: mdbregexp { regexp string } { options string } ; CONSTANT: MDB_OID_FIELD "_id" CONSTANT: MDB_META_FIELD "_mfd" -CONSTANT: T_EOO 0 -CONSTANT: T_Double 1 -CONSTANT: T_Integer 16 -CONSTANT: T_Boolean 8 -CONSTANT: T_String 2 -CONSTANT: T_Object 3 -CONSTANT: T_Array 4 -CONSTANT: T_Binary 5 -CONSTANT: T_Undefined 6 -CONSTANT: T_OID 7 -CONSTANT: T_Date 9 -CONSTANT: T_NULL 10 -CONSTANT: T_Regexp 11 -CONSTANT: T_DBRef 12 -CONSTANT: T_Code 13 -CONSTANT: T_ScopedCode 17 -CONSTANT: T_Symbol 14 -CONSTANT: T_JSTypeMax 16 -CONSTANT: T_MaxKey 127 - -CONSTANT: T_Binary_Function 1 -CONSTANT: T_Binary_Bytes 2 -CONSTANT: T_Binary_UUID 3 -CONSTANT: T_Binary_MD5 5 -CONSTANT: T_Binary_Custom 128 +CONSTANT: T_EOO 0 +CONSTANT: T_Double HEX: 1 +CONSTANT: T_String HEX: 2 +CONSTANT: T_Object HEX: 3 +CONSTANT: T_Array HEX: 4 +CONSTANT: T_Binary HEX: 5 +CONSTANT: T_Undefined HEX: 6 +CONSTANT: T_OID HEX: 7 +CONSTANT: T_Boolean HEX: 8 +CONSTANT: T_Date HEX: 9 +CONSTANT: T_NULL HEX: A +CONSTANT: T_Regexp HEX: B +CONSTANT: T_DBRef HEX: C +CONSTANT: T_Code HEX: D +CONSTANT: T_Symbol HEX: E +CONSTANT: T_ScopedCode HEX: F +CONSTANT: T_Integer HEX: 10 +CONSTANT: T_Timestamp HEX: 11 +CONSTANT: T_Integer64 HEX: 12 +CONSTANT: T_MinKey HEX: FF +CONSTANT: T_MaxKey HEX: 7F +CONSTANT: T_Binary_Function HEX: 1 +CONSTANT: T_Binary_Bytes HEX: 2 +CONSTANT: T_Binary_UUID HEX: 3 +CONSTANT: T_Binary_MD5 HEX: 5 +CONSTANT: T_Binary_Custom HEX: 80 diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index e0cf0bc4f4..852f46f951 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -10,65 +10,46 @@ FROM: typed => TYPED: ; IN: bson.reader +SYMBOL: state + +DEFER: stream>assoc + ( exemplar -- state ) - [ state new ] dip - { - [ clone >>exemplar ] - [ clone >>result ] - [ V{ } clone [ push ] keep >>scope ] - } cleave - (prepare-elements) >>elements ; - -TYPED: get-state ( -- state: state ) - state get ; inline - -TYPED: read-int32 ( -- int32: integer ) +: read-int32 ( -- int32 ) 4 read signed-le> ; inline -TYPED: read-longlong ( -- longlong: integer ) +: read-longlong ( -- longlong ) 8 read signed-le> ; inline -TYPED: read-double ( -- double: float ) +: read-double ( -- double ) 8 read le> bits>double ; inline -TYPED: read-byte-raw ( -- byte-raw: byte-array ) +: read-byte-raw ( -- byte-raw ) 1 read ; inline -TYPED: read-byte ( -- byte: integer ) +: read-byte ( -- byte ) read-byte-raw first ; inline -TYPED: read-cstring ( -- string: string ) +: read-cstring ( -- string ) "\0" read-until drop >string ; inline -TYPED: read-sized-string ( length: integer -- string: string ) +: read-sized-string ( length -- string ) read 1 head-slice* >string ; inline -TYPED: push-element ( type: integer name: string state: state -- ) - [ element boa ] dip elements>> push ; inline +: read-timestamp ( -- timestamp ) + 8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi ; -TYPED: pop-element ( state: state -- element: element ) - elements>> pop ; inline +: object-result ( quot -- object ) + [ + state get clone + [ clear-assoc ] [ ] [ ] tri state + ] dip with-variable ; inline -TYPED: peek-scope ( state: state -- ht ) - scope>> last ; inline - -: bson-object-data-read ( -- object ) - read-int32 drop get-state - [ exemplar>> clone dup ] [ scope>> ] bi push ; inline +: bson-object-data-read ( -- ) + read-int32 drop read-elements ; inline recursive : bson-binary-read ( -- binary ) read-int32 read-byte @@ -86,68 +67,35 @@ TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp ) TYPED: bson-oid-read ( -- oid: oid ) read-longlong read-int32 oid boa ; inline -TYPED: element-data-read ( type: integer -- object ) - { - { T_OID [ bson-oid-read ] } - { T_String [ read-int32 read-sized-string ] } - { T_Integer [ read-int32 ] } - { T_Binary [ bson-binary-read ] } - { T_Object [ bson-object-data-read ] } - { T_Array [ bson-object-data-read ] } - { T_Double [ read-double ] } - { T_Boolean [ read-byte 1 = ] } - { T_Date [ read-longlong millis>timestamp ] } - { T_Regexp [ bson-regexp-read ] } - { T_NULL [ f ] } - } case ; inline - -TYPED: bson-array? ( type: integer -- ?: boolean ) - T_Array = ; inline - -TYPED: bson-object? ( type: integer -- ?: boolean ) - T_Object = ; inline - : check-object ( assoc -- object ) dup dbref-assoc? [ assoc>dbref ] when ; inline -TYPED: fix-result ( assoc type: integer -- result ) +TYPED: element-data-read ( type: integer -- object ) { - { T_Array [ values ] } - { T_Object [ check-object ] } - } case ; inline + { T_OID [ bson-oid-read ] } + { T_String [ read-int32 read-sized-string ] } + { T_Integer [ read-int32 ] } + { T_Integer64 [ read-longlong ] } + { T_Binary [ bson-binary-read ] } + { T_Object [ [ bson-object-data-read ] object-result check-object ] } + { T_Array [ [ bson-object-data-read ] object-result values ] } + { T_Double [ read-double ] } + { T_Boolean [ read-byte 1 = ] } + { T_Date [ read-longlong millis>timestamp ] } + { T_Regexp [ bson-regexp-read ] } + { T_Timestamp [ read-timestamp ] } + { T_Code [ read-int32 read-sized-string ] } + { T_ScopedCode [ read-int32 drop read-cstring H{ } clone stream>assoc ] } + { T_NULL [ f ] } + } case ; inline recursive -TYPED: end-element ( type: integer -- ) - { [ bson-object? ] [ bson-array? ] } 1|| - [ get-state pop-element drop ] unless ; inline - -TYPED: (>state<) ( -- state: state scope: vector element: element ) - get-state [ ] [ scope>> ] [ pop-element ] tri ; inline - -TYPED: (prepare-result) ( scope: vector element: element -- result ) - [ pop ] [ type>> ] bi* fix-result ; inline - -: bson-eoo-element-read ( -- cont?: boolean ) - (>state<) - [ (prepare-result) ] [ ] [ drop empty? ] 2tri - [ 2drop >>result drop f ] - [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline - -TYPED: (prepare-object) ( type: integer -- object ) - [ element-data-read ] [ end-element ] bi ; inline - -:: (read-object) ( type name state -- ) - state peek-scope :> scope - type (prepare-object) name scope set-at ; inline - -TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean ) - read-cstring get-state - [ push-element ] - [ (read-object) t ] 3bi ; inline +TYPED: (read-object) ( type: integer name: string -- ) + [ element-data-read ] dip state get set-at ; inline recursive TYPED: (element-read) ( type: integer -- cont?: boolean ) dup T_EOO > - [ bson-not-eoo-element-read ] - [ drop bson-eoo-element-read ] if ; inline + [ read-cstring (read-object) t ] + [ drop f ] if ; inline recursive : read-elements ( -- ) read-byte (element-read) @@ -156,6 +104,6 @@ TYPED: (element-read) ( type: integer -- cont?: boolean ) PRIVATE> : stream>assoc ( exemplar -- assoc ) - read-int32 >>size - [ state [ read-elements ] with-variable ] - [ result>> ] bi ; + clone [ + state [ bson-object-data-read ] with-variable + ] keep ;