steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

some work

db4
Sascha Matzke 2008-12-19 14:57:01 +01:00
parent f67441f493
commit 752c637cb8
4 changed files with 225 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
mongodb/bson/bson.factor
View File

@ -1,4 +1,6 @@
IN: mongodb.bson IN: mongodb.bson
USE: vocabs.loader USE: vocabs.loader
SINGLETON: bson-null SINGLETON: bson-null

4
mongodb/bson/constants/constants.factor
View File

@ -23,7 +23,11 @@ IN: mongodb.bson.constants
: T_JSTypeMax ( -- type ) 16 ; inline : T_JSTypeMax ( -- type ) 16 ; inline
: T_MaxKey ( -- type ) 127 ; 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 ! todo Move to mongo vocab

145
mongodb/bson/reader/reader.factor
View File

@ -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 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 IN: mongodb.bson.reader
@ -8,43 +9,52 @@ ERROR: size-mismatch actual declared ;
<PRIVATE <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> ( -- 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-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-integer < integer T_Integer = ;
PREDICATE: bson-string < integer T_String = ; PREDICATE: bson-string < integer T_String = ;
PREDICATE: bson-object < integer T_Object = ; PREDICATE: bson-object < integer T_Object = ;
PREDICATE: bson-array < integer T_Array = ; PREDICATE: bson-array < integer T_Array = ;
PREDICATE: bson-binary < integer T_Binary = ; PREDICATE: bson-binary < integer T_Binary = ;
PREDICATE: bson-oid < integer T_OID = ; 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-boolean < integer T_Boolean = ;
PREDICATE: bson-date < integer T_Date = ; PREDICATE: bson-date < integer T_Date = ;
PREDICATE: bson-null < integer T_NULL = ; PREDICATE: bson-null < integer T_NULL = ;
PREDICATE: bson-ref < integer T_DBRef = ; PREDICATE: bson-ref < integer T_DBRef = ;
GENERIC: element-read ( type -- cont? ) GENERIC: element-read ( type -- cont? )
GENERIC: element-data-read ( type -- object ) GENERIC: element-data-read ( type -- object )
GENERIC: element-binary-read ( length type -- object )
: get-state ( -- state ) : get-state ( -- state )
state get ; state get ; inline
: count-bytes ( count -- ) : count-bytes ( count -- )
[ get-state ] dip '[ _ + ] change-read drop ; [ get-state ] dip '[ _ + ] change-read drop ; inline
: read-int32 ( -- int32 ) : 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 ) : read-byte-raw ( -- byte-raw )
1 [ read ] [ count-bytes ] bi ; 1 [ read ] [ count-bytes ] bi ; inline
: read-byte ( -- byte ) : read-byte ( -- byte )
read-byte-raw *char ; read-byte-raw *char ; inline
: (read-cstring) ( acc -- acc ) : (read-cstring) ( acc -- acc )
read-byte-raw dup read-byte-raw dup
@ -56,49 +66,114 @@ GENERIC: element-data-read ( type -- object )
B{ } clone B{ } clone
(read-cstring) utf8 alien>string ; (read-cstring) utf8 alien>string ;
: read-sized-string ( length -- string )
: object-size ( -- size ) [ read ] [ count-bytes ] bi
read-int32 ; utf8 alien>string ;
: read-element-type ( -- type ) : read-element-type ( -- type )
read-byte ; read-byte ;
: element-name ( -- name ) : push-element ( type name -- element )
read-cstring ; element boa
[ get-state element>> push ] keep ;
: pop-element ( -- element )
get-state element>> pop ;
: peek-scope ( -- ht )
get-state scope>> peek ;
: read-elements ( -- ) : read-elements ( -- )
read-element-type read-element-type
element-read element-read
[ read-elements ] when ; [ 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? ) M: bson-eoo element-read ( type -- cont? )
drop 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? ) M: bson-not-eoo element-read ( type -- cont? )
[ element-name ] dip [ peek-scope ] dip ! scope type
element-data-read '[ _
swap read-cstring push-element [ name>> ] [ type>> ] bi
get-state scope>> element-data-read
swap
] dip
set-at set-at
t ; 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 ) M: bson-string element-data-read ( type -- object )
drop drop
read-int32 drop read-int32 read-sized-string
read-cstring ; pop-element drop ;
M: bson-integer element-data-read ( type -- object ) M: bson-integer element-data-read ( type -- object )
drop 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> PRIVATE>
: bson> ( arr -- ht ) : bson> ( arr -- ht )
binary binary
[ <state> dup state [ <state> dup state
[ object-size >>size read-elements ] with-variable [ read-int32 >>size read-elements ] with-variable
result>>
] with-byte-reader ; ] with-byte-reader ;

185
mongodb/bson/writer/writer.factor
View File

@ -1,100 +1,131 @@
! Copyright (C) 2008 Sascha Matzke. ! Copyright (C) 2008 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license. ! 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 io.encodings.utf8 strings splitting math.parser
sequences math assocs classes words make fry sequences math assocs classes words make fry mongodb.persistent
prettyprint hashtables mirrors bson alien.strings alien.c-types prettyprint hashtables mirrors alien.strings alien.c-types
io.streams.byte-array io ; io.streams.byte-array io ;
IN: mongodb.bson.writer IN: mongodb.bson.writer
#! Writes the object out to a stream in BSON format
<PRIVATE <PRIVATE
#! Returns BSON type
GENERIC: bson-type? ( obj -- type ) GENERIC: bson-type? ( obj -- type )
GENERIC: bson-write ( obj -- )
M: t bson-type? ( boolean -- type ) M: t bson-type? ( boolean -- type ) drop T_Boolean ;
drop T_Boolean ; M: f 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 ) M: oid bson-type? ( word -- type ) drop T_OID ;
[ bson-type? <char> write ] keep ; 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 -- ) : write-byte ( byte -- ) <char> write ;
utf8 string>alien 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> 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 ) GENERIC: >bson ( obj -- byte-aray )
M: tuple >bson ( tuble -- byte-array ) M: tuple >bson ( tuble -- byte-array )
(>bson) ; '[ _ bson-write ] binary swap with-byte-writer ;
M: hashtable >bson ( hashmap -- byte-array ) M: hashtable >bson ( hashmap -- byte-array )
(>bson) ; '[ _ bson-write ] binary swap with-byte-writer ;
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 ;