diff --git a/mongodb/bson/bson.factor b/mongodb/bson/bson.factor index f6cd002b48..27033094de 100644 --- a/mongodb/bson/bson.factor +++ b/mongodb/bson/bson.factor @@ -1,4 +1,6 @@ + IN: mongodb.bson + USE: vocabs.loader SINGLETON: bson-null diff --git a/mongodb/bson/constants/constants.factor b/mongodb/bson/constants/constants.factor index 9163d06ba4..80e9933740 100644 --- a/mongodb/bson/constants/constants.factor +++ b/mongodb/bson/constants/constants.factor @@ -23,7 +23,11 @@ IN: mongodb.bson.constants : T_JSTypeMax ( -- type ) 16 ; inline : T_MaxKey ( -- type ) 127 ; inline +: T_Binary_Bytes ( -- subtype ) 2 ; inline +: T_Binary_Function ( -- subtype ) 1 ; inline +: S_Name ( -- name ) "__t_name" ; inline +: S_Vocab ( -- name ) "__t_vocab" ; inline ! todo Move to mongo vocab diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index abbb1a2c12..dcfabfb947 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,6 +1,7 @@ -USING: io io.encodings.utf8 io.encodings.binary math match kernel sequences +USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint - mongodb.bson.constants assocs alien.c-types alien.strings fry ; + mongodb.bson.constants assocs alien.c-types alien.strings fry words + tools.walker serialize ; IN: mongodb.bson.reader @@ -8,97 +9,171 @@ ERROR: size-mismatch actual declared ; ( -- state ) - state new H{ } clone [ >>result ] [ >>scope ] bi ; + state new H{ } clone + [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi + V{ } clone [ T_Object "" element boa swap push ] keep >>element ; -PREDICATE: bson-eoo < integer T_EOO = ; +PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-not-eoo < integer T_EOO > ; -PREDICATE: bson-double < integer T_Double = ; + +PREDICATE: bson-double < integer T_Double = ; PREDICATE: bson-integer < integer T_Integer = ; -PREDICATE: bson-string < integer T_String = ; -PREDICATE: bson-object < integer T_Object = ; -PREDICATE: bson-array < integer T_Array = ; -PREDICATE: bson-binary < integer T_Binary = ; -PREDICATE: bson-oid < integer T_OID = ; +PREDICATE: bson-string < integer T_String = ; +PREDICATE: bson-object < integer T_Object = ; +PREDICATE: bson-array < integer T_Array = ; +PREDICATE: bson-binary < integer T_Binary = ; +PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ; +PREDICATE: bson-binary-function < integer T_Binary_Function = ; +PREDICATE: bson-oid < integer T_OID = ; PREDICATE: bson-boolean < integer T_Boolean = ; -PREDICATE: bson-date < integer T_Date = ; -PREDICATE: bson-null < integer T_NULL = ; -PREDICATE: bson-ref < integer T_DBRef = ; +PREDICATE: bson-date < integer T_Date = ; +PREDICATE: bson-null < integer T_NULL = ; +PREDICATE: bson-ref < integer T_DBRef = ; GENERIC: element-read ( type -- cont? ) - GENERIC: element-data-read ( type -- object ) +GENERIC: element-binary-read ( length type -- object ) : get-state ( -- state ) - state get ; + state get ; inline : count-bytes ( count -- ) - [ get-state ] dip '[ _ + ] change-read drop ; + [ get-state ] dip '[ _ + ] change-read drop ; inline : read-int32 ( -- int32 ) - 4 [ read *int ] [ count-bytes ] bi ; + 4 [ read *int ] [ count-bytes ] bi ; inline + +: read-double ( -- double ) + 8 [ read *double ] [ count-bytes ] bi ; inline : read-byte-raw ( -- byte-raw ) - 1 [ read ] [ count-bytes ] bi ; + 1 [ read ] [ count-bytes ] bi ; inline : read-byte ( -- byte ) - read-byte-raw *char ; + read-byte-raw *char ; inline : (read-cstring) ( acc -- acc ) read-byte-raw dup B{ 0 } = [ append ] - [ append (read-cstring) ] if ; + [ append (read-cstring) ] if ; : read-cstring ( -- string ) B{ } clone (read-cstring) utf8 alien>string ; - -: object-size ( -- size ) - read-int32 ; - +: read-sized-string ( length -- string ) + [ read ] [ count-bytes ] bi + utf8 alien>string ; : read-element-type ( -- type ) read-byte ; -: element-name ( -- name ) - read-cstring ; +: push-element ( type name -- element ) + element boa + [ get-state element>> push ] keep ; + +: pop-element ( -- element ) + get-state element>> pop ; + +: peek-scope ( -- ht ) + get-state scope>> peek ; : read-elements ( -- ) read-element-type element-read [ read-elements ] when ; +: make-tuple ( assoc -- tuple ) + [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc + [ lookup new ] dip ! instance assoc + [ dup [ keys ] keep ] dip ! instance array mirror assoc + '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; + +GENERIC: fix-result ( assoc type -- result ) + +M: bson-object fix-result ( assoc type -- result ) + drop + [ ] [ S_Name swap key? ] bi + [ make-tuple ] [ ] if ; + +M: bson-array fix-result ( assoc type -- result ) + drop + values ; M: bson-eoo element-read ( type -- cont? ) drop - f ; + get-state scope>> [ pop ] keep swap ! vec assoc + pop-element [ type>> ] keep ! vec assoc type element + [ fix-result ] dip ! vec result element + rot length 0 > ! result element + [ name>> peek-scope set-at t ] + [ drop [ get-state ] dip >>result drop f ] if ; M: bson-not-eoo element-read ( type -- cont? ) - [ element-name ] dip - element-data-read - swap - get-state scope>> + [ peek-scope ] dip ! scope type + '[ _ + read-cstring push-element [ name>> ] [ type>> ] bi + element-data-read + swap + ] dip set-at t ; +M: bson-object element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; +M: bson-array element-data-read ( type -- object ) + drop + read-int32 drop + get-state + [ [ [ H{ } clone ] dip push ] keep ] change-scope + scope>> peek ; + M: bson-string element-data-read ( type -- object ) drop - read-int32 drop - read-cstring ; + read-int32 read-sized-string + pop-element drop ; M: bson-integer element-data-read ( type -- object ) drop - read-int32 ; + read-int32 + pop-element drop ; + +M: bson-double element-data-read ( type -- double ) + drop + read-double + pop-element drop ; + +M: bson-boolean element-data-read ( type -- boolean ) + drop + read-byte t = + pop-element drop ; + +M: bson-binary element-data-read ( type -- binary ) + drop + read-int32 read-byte element-binary-read + pop-element drop ; + +M: bson-binary-bytes element-binary-read ( size type -- bytes ) + drop read ; + +M: bson-binary-function element-binary-read ( size type -- quot ) + drop read bytes>object ; PRIVATE> : bson> ( arr -- ht ) binary [ dup state - [ object-size >>size read-elements ] with-variable + [ read-int32 >>size read-elements ] with-variable + result>> ] with-byte-reader ; diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 8550a720fe..7cb1cc4cdb 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -1,100 +1,131 @@ ! Copyright (C) 2008 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary +USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string + io.encodings.binary classes byte-arrays quotations serialize io.encodings.utf8 strings splitting math.parser - sequences math assocs classes words make fry - prettyprint hashtables mirrors bson alien.strings alien.c-types + sequences math assocs classes words make fry mongodb.persistent + prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; IN: mongodb.bson.writer +#! Writes the object out to a stream in BSON format + write ] keep ; +M: oid bson-type? ( word -- type ) drop T_OID ; +M: real bson-type? ( real -- type ) drop T_Double ; +M: word bson-type? ( word -- type ) drop T_String ; +M: tuple bson-type? ( tuple -- type ) drop T_Object ; +M: assoc bson-type? ( hashtable -- type ) drop T_Object ; +M: string bson-type? ( string -- type ) drop T_String ; +M: integer bson-type? ( integer -- type ) drop T_Integer ; +M: sequence bson-type? ( seq -- type ) drop T_Array ; +M: quotation bson-type? ( quotation -- type ) drop T_Binary ; +M: bson-null bson-type? ( null -- type ) drop T_NULL ; +M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; -: write-cstring ( string -- ) - utf8 string>alien write ; +: write-byte ( byte -- ) write ; +: write-int32 ( int -- ) write ; +: write-double ( real -- ) write ; +: write-cstring ( string -- ) utf8 string>alien write ; +: write-longlong ( object -- ) write ; + +: write-eoo ( -- ) T_EOO write-byte ; +: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; +: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; + +: write-tuple-info ( object -- ) + class + [ [ S_Name ] dip name>> write-pair ] + [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; + +M: f bson-write ( f -- ) + drop 0 write-byte ; + +M: t bson-write ( t -- ) + drop 1 write-byte ; + +M: bson-null bson-write ( null -- ) + drop ; + +M: string bson-write ( obj -- ) + utf8 string>alien + [ length write-int32 ] keep + write ; + +M: integer bson-write ( num -- ) + write-int32 ; + +M: real bson-write ( num -- ) + >float write-double ; + +M: byte-array bson-write ( binary -- ) + [ length write-int32 ] keep + T_Binary_Bytes write-byte + write ; + +M: quotation bson-write ( quotation -- ) + object>bytes [ length write-int32 ] keep + T_Binary_Function write-byte + write ; + +M: oid bson-write ( oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; + +M: sequence bson-write ( array -- ) + '[ _ [ [ write-type ] dip number>string write-cstring bson-write ] + each-index ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: persistent-tuple bson-write ( persistent-tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: tuple bson-write ( tuple -- ) + dup + '[ + _ write-tuple-info + _ [ write-pair ] assoc-each + ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: assoc bson-write ( hashtable -- ) + '[ _ [ write-pair ] assoc-each ] + binary swap with-byte-writer + [ length 5 + bson-write ] keep + write + write-eoo ; + +M: word bson-write name>> bson-write ; PRIVATE> -#! Writes the object out to a stream in BSON format -GENERIC: bson-print ( obj -- ) - -: (>bson) ( obj -- byte-array ) - '[ _ bson-print ] binary swap with-byte-writer ; - GENERIC: >bson ( obj -- byte-aray ) M: tuple >bson ( tuble -- byte-array ) - (>bson) ; + '[ _ bson-write ] binary swap with-byte-writer ; M: hashtable >bson ( hashmap -- byte-array ) - (>bson) ; - -M: f bson-print ( f -- ) - drop 0 write ; - -M: t bson-print ( t -- ) - drop 1 write ; - -M: bson-null bson-print ( null -- ) - drop ; - -M: string bson-print ( obj -- ) - utf8 string>alien - [ length write ] keep - write ; - -M: integer bson-print ( num -- ) - write ; - -M: real bson-print ( num -- ) - >float write ; - -M: sequence bson-print ( array -- ) - '[ _ [ [ write-type ] dip number>string write-cstring bson-print ] - each-index ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep - write - T_EOO write ; + '[ _ bson-write ] binary swap with-byte-writer ; -M: tuple bson-print ( tuple -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: hashtable bson-print ( hashtable -- ) - '[ _ [ write-type [ write-cstring ] dip bson-print ] assoc-each ] - binary swap with-byte-writer - [ length 5 + bson-print ] keep write - T_EOO bson-print ; - -M: word bson-print name>> bson-print ;