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

various changes

db4
Sascha Matzke 2009-01-23 06:53:08 +01:00
parent 28809b0ec0
commit 3e433f52a2
6 changed files with 237 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
bson/bson.factor
View File

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

55
bson/constants/constants.factor
View File

@ -1,31 +1,40 @@
USING: alien.c-types ; USING: alien.c-types accessors kernel calendar random math.bitwise math unix ;
IN: bson.constants IN: bson.constants
TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: oid { a initial: 0 } { b initial: 0 } ;
: <oid> ( -- oid )
oid new
now timestamp>micros >>a
8 random-bits 16 shift HEX: FF0000 mask
getpid HEX: FFFF mask
bitor >>b ;
: T_EOO ( -- type ) 0 ; inline TUPLE: dbref ns oid ;
: T_Double ( -- type ) 1 ; inline
: T_Integer ( -- type ) 16 ; inline
: T_Boolean ( -- type ) 8 ; inline CONSTANT: T_EOO 0
: T_String ( -- type ) 2 ; inline CONSTANT: T_Double 1
: T_Object ( -- type ) 3 ; inline CONSTANT: T_Integer 16
: T_Array ( -- type ) 4 ; inline CONSTANT: T_Boolean 8
: T_Binary ( -- type ) 5 ; inline CONSTANT: T_String 2
: T_Undefined ( -- type ) 6 ; inline CONSTANT: T_Object 3
: T_OID ( -- type ) 7 ; inline CONSTANT: T_Array 4
: T_Date ( -- type ) 9 ; inline CONSTANT: T_Binary 5
: T_NULL ( -- type ) 10 ; inline CONSTANT: T_Undefined 6
: T_Regexp ( -- type ) 11 ; inline CONSTANT: T_OID 7
: T_DBRef ( -- type ) 12 ; inline CONSTANT: T_Date 9
: T_Code ( -- type ) 13 ; inline CONSTANT: T_NULL 10
: T_ScopedCode ( -- type ) 17 ; inline CONSTANT: T_Regexp 11
: T_Symbol ( -- type ) 14 ; inline CONSTANT: T_DBRef 12
: T_JSTypeMax ( -- type ) 16 ; inline CONSTANT: T_Code 13
: T_MaxKey ( -- type ) 127 ; inline CONSTANT: T_ScopedCode 17
CONSTANT: T_Symbol 14
: T_Binary_Bytes ( -- subtype ) 2 ; inline CONSTANT: T_JSTypeMax 16
: T_Binary_Function ( -- subtype ) 1 ; inline CONSTANT: T_MaxKey 127
CONSTANT: T_Binary_Bytes 2
CONSTANT: T_Binary_Function 1

76
bson/reader/reader.factor
View File

@ -1,21 +1,21 @@
USING: mirrors 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
bson.constants assocs alien.c-types alien.strings fry words bson.constants assocs alien.c-types alien.strings fry words
tools.walker serialize locals byte-arrays ; serialize byte-arrays ;
IN: bson.reader IN: bson.reader
ERROR: size-mismatch actual declared ;
<PRIVATE <PRIVATE
TUPLE: element { type integer } name ; TUPLE: element { type integer } name ;
TUPLE: state { size initial: -1 } { read initial: 0 } exemplar result scope element ; TUPLE: state
{ size initial: -1 } { read initial: 0 } exemplar
result scope element ;
:: <state> ( exemplar -- state ) : <state> ( exemplar -- state )
state new [ state new ] dip
exemplar clone >>exemplar [ clone >>exemplar ] keep
exemplar clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline V{ } clone [ T_Object "" element boa swap push ] keep >>element ; inline
PREDICATE: bson-eoo < integer T_EOO = ; PREDICATE: bson-eoo < integer T_EOO = ;
@ -101,6 +101,18 @@ M: bson-array fix-result ( assoc type -- result )
drop drop
values ; values ;
GENERIC: end-element ( type -- )
M: bson-object end-element ( type -- )
drop ;
M: bson-array end-element ( type -- )
drop ;
M: object end-element ( type -- )
drop
pop-element drop ;
M: bson-eoo element-read ( type -- cont? ) M: bson-eoo element-read ( type -- cont? )
drop drop
get-state scope>> [ pop ] keep swap ! vec assoc get-state scope>> [ pop ] keep swap ! vec assoc
@ -113,9 +125,10 @@ M: bson-eoo element-read ( type -- cont? )
M: bson-not-eoo element-read ( type -- cont? ) M: bson-not-eoo element-read ( type -- cont? )
[ peek-scope ] dip ! scope type [ peek-scope ] dip ! scope type
'[ _ '[ _
read-cstring push-element [ name>> ] [ type>> ] bi read-cstring push-element [ name>> ] [ type>> ] bi
element-data-read [ element-data-read ] keep
swap end-element
swap
] dip ] dip
set-at set-at
t ; t ;
@ -124,8 +137,7 @@ M: bson-oid element-data-read ( type -- object )
drop drop
read-longlong read-longlong
read-int32 read-int32
oid boa oid boa ;
pop-element drop ;
: [scope-changer] ( state -- state quot ) : [scope-changer] ( state -- state quot )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
@ -145,28 +157,34 @@ M: bson-array element-data-read ( type -- object )
M: bson-string element-data-read ( type -- object ) M: bson-string element-data-read ( type -- object )
drop drop
read-int32 read-sized-string read-int32 read-sized-string ;
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 ) M: bson-double element-data-read ( type -- double )
drop drop
read-double read-double ;
pop-element drop ;
M: bson-boolean element-data-read ( type -- boolean ) M: bson-boolean element-data-read ( type -- boolean )
drop drop
read-byte t = read-byte t = ;
pop-element drop ;
M: bson-ref element-data-read ( type -- dbref )
drop
read-int32
read-sized-string
T_OID element-data-read
dbref boa ;
M: bson-binary element-data-read ( type -- binary ) M: bson-binary element-data-read ( type -- binary )
drop drop
read-int32 read-byte element-binary-read read-int32 read-byte element-binary-read ;
pop-element drop ;
M: bson-null element-data-read ( type -- bf )
drop
f ;
M: bson-binary-bytes element-binary-read ( size type -- bytes ) M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ; drop read ;
@ -176,17 +194,13 @@ M: bson-binary-function element-binary-read ( size type -- quot )
PRIVATE> PRIVATE>
GENERIC: stream>assoc ( exemplar -- assoc ) : stream>assoc ( exemplar -- assoc )
M: assoc stream>assoc ( exemplar -- assoc )
<state> dup state <state> dup state
[ read-int32 >>size read-elements ] with-variable [ read-int32 >>size read-elements ] with-variable
result>> ; result>> ;
USING: multi-methods ; : array>assoc ( array exemplar -- assoc )
GENERIC: array>assoc ( array exemplar -- assoc )
METHOD: array>assoc { byte-array assoc } ( array exemplar -- assoc )
[ binary ] dip '[ _ stream>assoc ] with-byte-reader ; [ binary ] dip '[ _ stream>assoc ] with-byte-reader ;
: array>hashtable ( array -- assoc )
H{ } array>assoc ;

13
bson/writer/writer.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bson bson.constants accessors kernel io.streams.string USING: bson bson.constants accessors kernel io.streams.string
io.encodings.binary classes byte-arrays quotations serialize io.encodings.binary classes byte-arrays quotations serialize
io.encodings.utf8 strings splitting math.parser locals io.encodings.utf8 strings splitting math.parser
sequences math assocs classes words make fry sequences math assocs classes words make fry
prettyprint hashtables mirrors alien.strings alien.c-types prettyprint hashtables mirrors alien.strings alien.c-types
io.streams.byte-array io ; io.streams.byte-array io ;
@ -20,6 +20,7 @@ M: t bson-type? ( boolean -- type ) drop T_Boolean ;
M: f 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: oid bson-type? ( word -- type ) drop T_OID ;
M: dbref bson-type? ( dbref -- type ) drop T_DBRef ;
M: real bson-type? ( real -- type ) drop T_Double ; M: real bson-type? ( real -- type ) drop T_Double ;
M: word bson-type? ( word -- type ) drop T_String ; M: word bson-type? ( word -- type ) drop T_String ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ; M: tuple bson-type? ( tuple -- type ) drop T_Object ;
@ -28,7 +29,6 @@ M: string bson-type? ( string -- type ) drop T_String ;
M: integer bson-type? ( integer -- type ) drop T_Integer ; M: integer bson-type? ( integer -- type ) drop T_Integer ;
M: sequence bson-type? ( seq -- type ) drop T_Array ; M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 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 ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
: write-byte ( byte -- ) <char> write ; inline : write-byte ( byte -- ) <char> write ; inline
@ -48,9 +48,6 @@ M: f bson-write ( f -- )
M: t bson-write ( t -- ) M: t bson-write ( t -- )
drop 1 write-byte ; drop 1 write-byte ;
M: bson-null bson-write ( null -- )
drop ;
M: string bson-write ( obj -- ) M: string bson-write ( obj -- )
utf8 string>alien utf8 string>alien
[ length write-int32 ] keep [ length write-int32 ] keep
@ -75,6 +72,12 @@ M: quotation bson-write ( quotation -- )
M: oid bson-write ( oid -- ) M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ; [ a>> write-longlong ] [ b>> write-int32 ] bi ;
M: dbref bson-write ( dbref -- )
[ ns>> utf8 string>alien
[ length write-int32 ] keep write
]
[ oid>> bson-write ] bi ;
M: sequence bson-write ( array -- ) M: sequence bson-write ( array -- )
'[ _ [ [ write-type ] dip number>string write-cstring bson-write ] '[ _ [ [ write-type ] dip number>string write-cstring bson-write ]
each-index ] each-index ]

48
mongodb/mongodb.factor
View File

@ -1,15 +1,49 @@
USING: mongodb.persistent ; USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple
namespaces sequences splitting ;
IN: mongodb IN: mongodb
INTERSECTION: storable mdb-persistent ;
<PRIVATE
GENERIC: store ( tuple/ht -- tuple/ht ) : prepare-find ( example -- query )
GENERIC: load ( example -- tuple/ht ) [ mdb-collection>> get-collection-fqn ] keep
H{ } tuple>query <mdb-query-msg> ; inline
M: tuple store ( tuple -- tuple ) PRIVATE>
[ check-persistent-tuple ] keep ;
M: persistent-tuple store ( ptuple -- ptuple )
; : <mdb> ( db host port -- mdb )
(<mdb>) ;
GENERIC: store ( tuple/ht -- )
GENERIC: find ( example -- tuple/ht )
GENERIC: findOne ( exampe -- tuple/ht )
GENERIC: load ( object -- object )
M: storable store ( tuple -- )
prepare-store ! H { collection { ... values ... }
[ [ <mdb-insert-msg> ] 2dip
[ get-collection-fqn >>collection ] dip
objects>>
[ mdb>> master>> binary ] dip '[ _ write-request ] with-client
] assoc-each ;
M: storable find ( example -- result )
prepare-find (find)
build-result ;
M: storable findOne ( example -- result )
prepare-find (find-one)
dup returned#>> 1 =
[ objects>> first ]
[ drop f ] if ;

166
mongodb/persistent/persistent.factor
View File

@ -1,81 +1,129 @@
USING: accessors classes classes.mixin classes.tuple compiler.units USING: accessors assocs classes fry kernel linked-assocs math mirrors
fry kernel words locals mirrors formatting assocs hashtables ; namespaces sequences strings vectors words bson.constants
continuations ;
IN: mongodb.persistent IN: mongodb.persistent
MIXIN: persistent-tuple MIXIN: mdb-persistent
SLOT: _p_oid SLOT: _id
SLOT: _p_info
TUPLE: oid { a initial: 0 } { b initial: 0 } ; CONSTANT: MDB_P_SLOTS { "_id" }
CONSTANT: MDB_OID "_id"
: MDB_CLASS ( -- string ) "p_class" ; inline SYMBOL: mdb-op-seq
: MDB_VOCAB ( -- string ) "p_vocab" ; inline
: MDB_MT ( -- string ) "p_mt" ; inline
: MDB_CT ( -- string ) "p_ct" ; inline
: MDB_COL ( -- string ) "p_col" ; inline
PREDICATE: pinfo-hashtable < hashtable [ MDB_CLASS swap key? ] [ MDB_VOCAB swap key? ] bi and ; GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc )
: P_OID ( -- name ) "_p_oid" ; inline : tuple>linked-assoc ( tuple -- linked-assoc )
: P_INFO ( -- name ) "_p_info" ; inline <linked-hash> tuple>assoc ; inline
: P_SLOTS ( -- array ) GENERIC# tuple>query 1 ( tuple examplar -- query-assoc )
{ "_p_oid" "_p_info" } ;
GENERIC: mdb-collection>> ( tuple -- string )
GENERIC: mdb-slot-definitions>> ( tuple -- string )
DEFER: assoc>tuple
DEFER: create-mdb-command
<PRIVATE <PRIVATE
: P_VOCAB ( -- string ) CONSTANT: MDB_INFO "_mdb_info"
"mongodb.persistent" ; inline
:: define-persistent-tuple ( superclass name -- class ) : <dbref> ( tuple -- dbref )
[let | pclass [ name P_VOCAB create ] | [ mdb-collection>> ] [ _id>> ] bi dbref boa ; inline
[ pclass pclass [ ] curry define ] with-compilation-unit
[ pclass superclass P_SLOTS define-tuple-class
pclass persistent-tuple add-mixin-instance ] with-compilation-unit
pclass ] ;
:: copy-slots ( tuple 'tuple -- 'tuple ) : mdbinfo>tuple-class ( mdbinfo -- class )
[let | tm1 [ tuple <mirror> ] [ first ] keep second lookup ; inline
tm2 [ 'tuple <mirror> ] |
tm1 [ swap tm2 set-at ] assoc-each : make-tuple ( assoc -- tuple )
tm2 object>> ] ; [ MDB_INFO swap at mdbinfo>tuple-class new ] keep ! instance assoc
[ dup <mirror> [ keys ] keep ] dip ! instance array mirror assoc
'[ dup _ [ _ at assoc>tuple ] dip [ swap ] dip set-at ] each ;
: persistent-info ( tuple -- pinfo )
class V{ } clone tuck
[ [ name>> ] dip push ]
[ [ vocabulary>> ] dip push ] 2bi ; inline
: id-or-f? ( key value -- key value boolean )
over "_id" =
[ dup f = ] dip or ; inline
: write-persistent-info ( mirror exemplar assoc -- )
[ drop ] dip
2dup [ "_id" ] 2dip [ over [ at ] dip ] dip set-at
[ object>> persistent-info MDB_INFO ] dip set-at ;
: persistent-tuple? ( object -- object boolean )
dup mdb-persistent? ; inline
: ensure-value-ht ( key ht -- vht )
2dup key?
[ at ]
[ [ H{ } clone dup ] 2dip set-at ] if ; inline
: data-tuple? ( tuple -- ? )
dup tuple? [ assoc? [ f ] [ t ] if ] [ drop f ] if ;
: write-tuple-fields ( mirror exemplar assoc -- )
[ dup ] dip ! m e e a
'[ id-or-f?
[ 2drop ]
[ persistent-tuple?
[ _ keep
[ mdb-collection>> ] keep
[ create-mdb-command ] dip
<dbref> ]
[ dup data-tuple? _ [ ] if ] if
swap _ set-at
] if
] assoc-each ;
: prepare-assoc ( tuple exemplar -- assoc mirror exemplar assoc )
[ <mirror> ] dip dup clone swap [ tuck ] dip swap ; inline
: ensure-mdb-info ( tuple -- tuple )
dup _id>> [ <oid> >>_id ] unless ; inline
: with-op-seq ( quot -- op-seq )
[
[ H{ } clone mdb-op-seq set ] dip call mdb-op-seq get
] with-scope ; inline
PRIVATE> PRIVATE>
GENERIC: persistent-tuple-class ( tuple -- class ) : create-mdb-command ( assoc ns -- )
mdb-op-seq get
ensure-value-ht
[ dup [ MDB_OID ] dip at ] dip
set-at ; inline
M: tuple persistent-tuple-class ( tuple -- class ) : prepare-store ( mdb-persistent -- op-seq )
class persistent-tuple-class ; '[ _ [ tuple>linked-assoc ] keep mdb-collection>> create-mdb-command ]
with-op-seq ; inline
M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) M: mdb-persistent tuple>assoc ( tuple exemplar -- assoc )
[ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup [ ensure-mdb-info ] dip ! tuple exemplar
persistent-tuple-class ; prepare-assoc
[ write-persistent-info ]
[ [ '[ _ tuple>assoc ] ] dip write-tuple-fields ] 3bi ;
M: tuple-class persistent-tuple-class ( class -- class' ) M: tuple tuple>assoc ( tuple exemplar -- assoc )
[ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class [ drop persistent-info MDB_INFO ] 2keep
[ "%s_%s" sprintf ] dip swap dup ! class new_name new_name prepare-assoc [ '[ _ tuple>assoc ] ] write-tuple-fields
P_VOCAB lookup dup ! class new_name vo/f vo/f [ set-at ] keep ;
[ [ drop drop ] dip ] [ drop define-persistent-tuple ] if ;
M: tuple tuple>query ( tuple examplar -- assoc )
prepare-assoc [ '[ _ tuple>query ] ] dip write-tuple-fields ;
: assoc>tuple ( assoc -- tuple )
dup assoc?
[ [ dup MDB_INFO swap key?
[ make-tuple ]
[ ] if ] [ drop ] recover
] [ ] if ; inline
GENERIC: make-persistent ( tuple -- 'tuple )
M: tuple make-persistent ( tuple -- 'tuple )
[let* | tuple [ ]
tclass [ tuple class ]
'tuple [ tclass persistent-tuple-class new ]
pinfo [ H{ } clone ] |
tuple 'tuple copy-slots
oid new >>_p_oid
tclass name>> MDB_CLASS pinfo set-at
tclass vocabulary>> MDB_VOCAB pinfo set-at
0 MDB_MT pinfo set-at
0 MDB_CT pinfo set-at
"" MDB_COL pinfo set-at
pinfo >>_p_info
] ;
M: persistent-tuple make-persistent ( tuple -- tuple )
;