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

made bson a toplevel vocab

db4
Sascha Matzke 2009-01-03 12:48:11 +01:00
parent 3a03cadef6
commit 28809b0ec0
6 changed files with 161 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
bson/bson.factor Normal file
View File

@ -0,0 +1,9 @@
IN: bson
USE: vocabs.loader
SINGLETON: bson-null
"bson.reader" require
"bson.writer" require

32
mongodb/bson/constants/constants.factor → bson/constants/constants.factor
View File

@ -1,6 +1,8 @@
USING: alien.c-types ;
IN: mongodb.bson.constants
IN: bson.constants
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
: T_EOO ( -- type ) 0 ; inline
@ -26,32 +28,4 @@ IN: mongodb.bson.constants
: 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
: 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

90
mongodb/bson/reader/reader.factor → bson/reader/reader.factor
View File

@ -1,21 +1,22 @@
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 words
tools.walker serialize mongodb.persistent ;
bson.constants assocs alien.c-types alien.strings fry words
tools.walker serialize locals byte-arrays ;
IN: mongodb.bson.reader
IN: bson.reader
ERROR: size-mismatch actual declared ;
<PRIVATE
TUPLE: element { type integer } name ;
TUPLE: state { size initial: -1 } { read initial: 0 } result scope element ;
TUPLE: state { size initial: -1 } { read initial: 0 } exemplar result scope element ;
: <state> ( -- state )
state new H{ } clone
[ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
:: <state> ( exemplar -- state )
state new
exemplar clone >>exemplar
exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline
PREDICATE: bson-eoo < integer T_EOO = ;
PREDICATE: bson-not-eoo < integer T_EOO > ;
@ -63,45 +64,38 @@ GENERIC: element-binary-read ( length type -- object )
read-byte-raw dup
B{ 0 } =
[ append ]
[ append (read-cstring) ] if ;
[ append (read-cstring) ] if ; inline recursive
: read-cstring ( -- string )
B{ } clone
(read-cstring) utf8 alien>string ;
(read-cstring) utf8 alien>string ; inline
: read-sized-string ( length -- string )
[ read ] [ count-bytes ] bi
utf8 alien>string ;
utf8 alien>string ; inline
: read-element-type ( -- type )
read-byte ;
read-byte ; inline
: push-element ( type name -- element )
element boa
[ get-state element>> push ] keep ;
[ get-state element>> push ] keep ; inline
: pop-element ( -- element )
get-state element>> pop ;
get-state element>> pop ; inline
: peek-scope ( -- ht )
get-state scope>> peek ;
get-state scope>> peek ; inline
: read-elements ( -- )
read-element-type
element-read
[ read-elements ] when ;
: make-tuple ( assoc -- tuple )
[ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc
[ dup <mirror> [ keys ] keep ] dip ! instance array mirror assoc
'[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ;
[ read-elements ] when ; inline recursive
GENERIC: fix-result ( assoc type -- result )
M: bson-object fix-result ( assoc type -- result )
drop
[ ] [ P_INFO swap key? ] bi
[ make-tuple ] [ ] if ;
drop ;
M: bson-array fix-result ( assoc type -- result )
drop
@ -109,10 +103,10 @@ M: bson-array fix-result ( assoc type -- result )
M: bson-eoo element-read ( type -- cont? )
drop
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
get-state scope>> [ pop ] keep swap ! vec assoc
pop-element [ type>> ] keep ! vec assoc element
[ fix-result ] dip
rot length 0 > ! assoc element
[ name>> peek-scope set-at t ]
[ drop [ get-state ] dip >>result drop f ] if ;
@ -133,19 +127,21 @@ M: bson-oid element-data-read ( type -- object )
oid boa
pop-element drop ;
M: bson-object element-data-read ( type -- object )
drop
read-int32 drop
get-state
[ [ [ H{ } clone ] dip push ] keep ] change-scope
scope>> peek ;
: [scope-changer] ( state -- state quot )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
M: bson-array element-data-read ( type -- object )
: (object-data-read) ( type -- object )
drop
read-int32 drop
get-state
[ [ [ H{ } clone ] dip push ] keep ] change-scope
scope>> peek ;
[scope-changer] change-scope
scope>> peek ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
M: bson-array element-data-read ( type -- object )
(object-data-read) ;
M: bson-string element-data-read ( type -- object )
drop
@ -179,10 +175,18 @@ M: bson-binary-function element-binary-read ( size type -- quot )
drop read bytes>object ;
PRIVATE>
: bson> ( arr -- ht )
binary
[ <state> dup state
GENERIC: stream>assoc ( exemplar -- assoc )
M: assoc stream>assoc ( exemplar -- assoc )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
result>>
] with-byte-reader ;
result>> ;
USING: multi-methods ;
GENERIC: array>assoc ( array exemplar -- assoc )
METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc )
[ binary ] dip '[ _ stream>assoc ] with-byte-reader ;

102
bson/writer/writer.factor Normal file
View File

@ -0,0 +1,102 @@
! Copyright (C) 2008 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
USING: bson bson.constants accessors kernel io.streams.string
io.encodings.binary classes byte-arrays quotations serialize
io.encodings.utf8 strings splitting math.parser locals
sequences math assocs classes words make fry
prettyprint hashtables mirrors alien.strings alien.c-types
io.streams.byte-array io ;
IN: bson.writer
#! Writes the object out to a stream in BSON format
<PRIVATE
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: 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-byte ( byte -- ) <char> write ; inline
: write-int32 ( int -- ) <int> write ; inline
: write-double ( real -- ) <double> write ; inline
: write-cstring ( string -- ) utf8 string>alien write ; inline
: write-longlong ( object -- ) <longlong> write ; inline
: write-eoo ( -- ) T_EOO write-byte ; inline
: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
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: 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>
: assoc>array ( assoc -- byte-array )
'[ _ bson-write ] binary swap with-byte-writer ; inline
: assoc>stream ( assoc -- )
bson-write ; inline

9
mongodb/bson/bson.factor
View File

@ -1,9 +0,0 @@
IN: mongodb.bson
USE: vocabs.loader
SINGLETON: bson-null
"mongodb.bson.reader" require
"mongodb.bson.writer" require

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

@ -1,122 +0,0 @@
! 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 classes byte-arrays quotations serialize
io.encodings.utf8 strings splitting math.parser locals
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
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: 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-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 -- )
P_SLOTS [ [ ] [ object at ] bi write-pair ] each ;
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 ;
: check-p-field ( key value -- key value boolean )
[ [ "_p_" swap start 0 = ] keep ] dip rot ;
M: persistent-tuple bson-write ( persistent-tuple -- )
<mirror>
'[ _ [ write-tuple-info ]
[ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ]
binary swap with-byte-writer
[ length 5 + bson-write ] keep
write
write-eoo ;
M: tuple bson-write ( tuple -- )
make-persistent bson-write ;
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>
GENERIC: >bson ( obj -- byte-aray )
M: tuple >bson ( tuble -- byte-array )
'[ _ bson-write ] binary swap with-byte-writer ;
M: hashtable >bson ( hashmap -- byte-array )
'[ _ bson-write ] binary swap with-byte-writer ;