some work
Sascha Matzke
parent
f67441f493
commit
752c637cb8
|
|
@ -1,4 +1,6 @@
|
|||
|
||||
IN: mongodb.bson
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
SINGLETON: bson-null
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,43 +9,52 @@ ERROR: size-mismatch actual declared ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: state { size initial: -1 } { read initial: 0 } result scope ;
|
||||
TUPLE: element { type integer } name ;
|
||||
TUPLE: state { size initial: -1 } { read initial: 0 } result scope element ;
|
||||
|
||||
: <state> ( -- 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
|
||||
|
|
@ -56,49 +66,114 @@ GENERIC: element-data-read ( type -- object )
|
|||
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 <mirror> [ 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
|
||||
[ <state> dup state
|
||||
[ object-size >>size read-elements ] with-variable
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
result>>
|
||||
] with-byte-reader ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
#! Returns BSON type
|
||||
GENERIC: bson-type? ( obj -- type )
|
||||
GENERIC: bson-write ( obj -- )
|
||||
|
||||
M: t bson-type? ( boolean -- type )
|
||||
drop T_Boolean ;
|
||||
M: f bson-type? ( boolean -- type )
|
||||
drop T_Boolean ;
|
||||
M: bson-null bson-type? ( null -- type )
|
||||
drop T_NULL ;
|
||||
M: string bson-type? ( string -- type )
|
||||
drop T_String ;
|
||||
M: integer bson-type? ( integer -- type )
|
||||
drop T_Integer ;
|
||||
M: real bson-type? ( real -- type )
|
||||
drop T_Double ;
|
||||
M: sequence bson-type? ( seq -- type )
|
||||
drop T_Array ;
|
||||
M: tuple bson-type? ( tuple -- type )
|
||||
drop T_Object ;
|
||||
M: hashtable bson-type? ( hashtable -- type )
|
||||
drop T_Object ;
|
||||
M: word bson-type? ( word -- type )
|
||||
drop T_String ;
|
||||
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
|
||||
: write-type ( obj -- obj )
|
||||
[ bson-type? <char> 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 -- ) <char> write ;
|
||||
: write-int32 ( int -- ) <int> write ;
|
||||
: write-double ( real -- ) <double> write ;
|
||||
: write-cstring ( string -- ) utf8 string>alien write ;
|
||||
: write-longlong ( object -- ) <longlong> 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
|
||||
<mirror> '[
|
||||
_ 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
|
||||
<mirror> '[
|
||||
_ 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 <char> write ;
|
||||
|
||||
M: t bson-print ( t -- )
|
||||
drop 1 <char> write ;
|
||||
|
||||
M: bson-null bson-print ( null -- )
|
||||
drop ;
|
||||
|
||||
M: string bson-print ( obj -- )
|
||||
utf8 string>alien
|
||||
[ length <int> write ] keep
|
||||
write ;
|
||||
|
||||
M: integer bson-print ( num -- )
|
||||
<int> write ;
|
||||
|
||||
M: real bson-print ( num -- )
|
||||
>float <double> 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 -- )
|
||||
<mirror> '[ _ [ 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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue