working round-trip bson (tuples - strings, numbers, other tuples as members ) >bson/bson>
Sascha Matzke
parent
ccd75d2a5e
commit
dc825d21c5
|
|
@ -0,0 +1,7 @@
|
|||
IN: mongodb.bson
|
||||
USE: vocabs.loader
|
||||
|
||||
SINGLETON: bson-null
|
||||
|
||||
"mongodb.bson.reader" require
|
||||
"mongodb.bson.writer" require
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
USING: alien.c-types ;
|
||||
|
||||
IN: mongodb.bson.constants
|
||||
|
||||
|
||||
: T_EOO ( -- type ) 0 ; inline
|
||||
: T_Double ( -- type ) 1 ; inline
|
||||
: T_Integer ( -- type ) 16 ; inline
|
||||
: T_Boolean ( -- type ) 8 ; inline
|
||||
: T_String ( -- type ) 2 ; inline
|
||||
: T_Object ( -- type ) 3 ; inline
|
||||
: T_Array ( -- type ) 4 ; inline
|
||||
: T_Binary ( -- type ) 5 ; inline
|
||||
: T_Undefined ( -- type ) 6 ; inline
|
||||
: T_OID ( -- type ) 7 ; inline
|
||||
: T_Date ( -- type ) 9 ; inline
|
||||
: T_NULL ( -- type ) 10 ; inline
|
||||
: T_Regexp ( -- type ) 11 ; inline
|
||||
: T_DBRef ( -- type ) 12 ; inline
|
||||
: T_Code ( -- type ) 13 ; inline
|
||||
: T_ScopedCode ( -- type ) 17 ; inline
|
||||
: T_Symbol ( -- type ) 14 ; inline
|
||||
: T_JSTypeMax ( -- type ) 16 ; inline
|
||||
: T_MaxKey ( -- type ) 127 ; inline
|
||||
|
||||
|
||||
|
||||
! todo Move to mongo vocab
|
||||
|
||||
: OP_Reply ( -- const )
|
||||
1 <int> ; inline
|
||||
|
||||
: OP_Message ( -- const )
|
||||
1000 <int> ; inline
|
||||
|
||||
: OP_Update ( -- const )
|
||||
2001 <int> ; inline
|
||||
|
||||
: OP_Insert ( -- const )
|
||||
2002 <int> ; inline
|
||||
|
||||
: OP_Query ( -- const )
|
||||
2004 <int> ; inline
|
||||
|
||||
: OP_GetMore ( -- const )
|
||||
2005 <int> ; inline
|
||||
|
||||
: OP_Delete ( -- const )
|
||||
2006 <int> ; inline
|
||||
|
||||
: OP_KillCursors ( -- const )
|
||||
2007 <int> ; inline
|
||||
|
||||
|
|
@ -0,0 +1,104 @@
|
|||
USING: 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 ;
|
||||
|
||||
IN: mongodb.bson.reader
|
||||
|
||||
ERROR: size-mismatch actual declared ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: state { size initial: -1 } { read initial: 0 } result scope ;
|
||||
|
||||
: <state> ( -- state )
|
||||
state new H{ } clone [ >>result ] [ >>scope ] bi ;
|
||||
|
||||
PREDICATE: bson-eoo < integer T_EOO = ;
|
||||
PREDICATE: bson-not-eoo < integer T_EOO > ;
|
||||
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-boolean < integer T_Boolean = ;
|
||||
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 )
|
||||
|
||||
: get-state ( -- state )
|
||||
state get ;
|
||||
|
||||
: count-bytes ( count -- )
|
||||
[ get-state ] dip '[ _ + ] change-read drop ;
|
||||
|
||||
: read-int32 ( -- int32 )
|
||||
4 [ read *int ] [ count-bytes ] bi ;
|
||||
|
||||
: read-byte-raw ( -- byte-raw )
|
||||
1 [ read ] [ count-bytes ] bi ;
|
||||
|
||||
: read-byte ( -- byte )
|
||||
read-byte-raw *char ;
|
||||
|
||||
: (read-cstring) ( acc -- acc )
|
||||
read-byte-raw dup
|
||||
B{ 0 } =
|
||||
[ append ]
|
||||
[ append (read-cstring) ] if ;
|
||||
|
||||
: read-cstring ( -- string )
|
||||
B{ } clone
|
||||
(read-cstring) utf8 alien>string ;
|
||||
|
||||
|
||||
: object-size ( -- size )
|
||||
read-int32 ;
|
||||
|
||||
|
||||
: read-element-type ( -- type )
|
||||
read-byte ;
|
||||
|
||||
: element-name ( -- name )
|
||||
read-cstring ;
|
||||
|
||||
: read-elements ( -- )
|
||||
read-element-type
|
||||
element-read
|
||||
[ read-elements ] when ;
|
||||
|
||||
|
||||
M: bson-eoo element-read ( type -- cont? )
|
||||
drop
|
||||
f ;
|
||||
|
||||
M: bson-not-eoo element-read ( type -- cont? )
|
||||
[ element-name ] dip
|
||||
element-data-read
|
||||
swap
|
||||
get-state scope>>
|
||||
set-at
|
||||
t ;
|
||||
|
||||
|
||||
M: bson-string element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32 drop
|
||||
read-cstring ;
|
||||
|
||||
M: bson-integer element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32 ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bson> ( arr -- ht )
|
||||
binary
|
||||
[ <state> dup state
|
||||
[ object-size >>size read-elements ] with-variable
|
||||
] with-byte-reader ;
|
||||
|
|
@ -0,0 +1,100 @@
|
|||
! 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
|
||||
io.encodings.utf8 strings splitting math.parser
|
||||
sequences math assocs classes words make fry
|
||||
prettyprint hashtables mirrors bson alien.strings alien.c-types
|
||||
io.streams.byte-array io ;
|
||||
|
||||
IN: mongodb.bson.writer
|
||||
|
||||
<PRIVATE
|
||||
|
||||
#! Returns BSON type
|
||||
GENERIC: bson-type? ( obj -- type )
|
||||
|
||||
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 ;
|
||||
|
||||
: write-type ( obj -- obj )
|
||||
[ bson-type? <char> write ] keep ;
|
||||
|
||||
: write-cstring ( string -- )
|
||||
utf8 string>alien 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) ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
||||
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