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

another checkpoint - tuple integration seems to work

db4
Sascha Matzke 2009-04-04 16:13:56 +02:00
parent c80084d606
commit a61796fe76
9 changed files with 79 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bson/constants/constants.factor
View File

@ -2,10 +2,8 @@ USING: accessors constructors kernel strings uuid ;
IN: bson.constants
TUPLE: objid id ;
: <objid> ( -- objid )
objid new uuid1 >>id ; inline
uuid1 ; inline
TUPLE: oid { a initial: 0 } { b initial: 0 } ;

5
bson/reader/reader.factor
View File

@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref )
read-cstring
read-cstring objref boa ;
M: bson-binary-uuid element-binary-read ( size type -- object )
2drop
read-cstring
objid boa ;
M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ;

8
bson/writer/writer.factor
View File

@ -77,7 +77,6 @@ M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
M: oid bson-type? ( word -- type ) drop T_OID ;
M: objid bson-type? ( objid -- type ) drop T_Binary ;
M: objref bson-type? ( objref -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
@ -126,16 +125,11 @@ M: quotation bson-write ( quotation -- )
M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
M: objid bson-write ( oid -- )
id>> [ binary ] dip '[ _ write-cstring ] with-byte-writer
[ length write-int32 ] keep
T_Binary_UUID write-byte write ;
M: objref bson-write ( objref -- )
[ binary ] dip
'[ _
[ ns>> write-cstring ]
[ objid>> id>> write-cstring ] bi ] with-byte-writer
[ objid>> write-cstring ] bi ] with-byte-writer
[ length write-int32 ] keep
T_Binary_Custom write-byte write ;

1
mongodb/driver/driver.factor
View File

@ -195,6 +195,7 @@ MEMO: reserved-namespace? ( name -- ? )
PRIVATE>
MEMO: ensure-collection ( collection -- fq-collection )
dup mdb-collection? [ name>> ] when
"." split1 over mdb name>> =
[ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi

54
mongodb/tuple/collection/collection.factor
View File

@ -1,10 +1,16 @@
USING: accessors arrays assocs bson.constants classes classes.tuple
continuations fry kernel mongodb.driver sequences
combinators continuations fry kernel mongodb.driver sequences strings
vectors words ;
IN: mongodb.tuple
SINGLETONS: +transient+ +load+ ;
IN: mongodb.tuple.collection
FROM: mongodb.tuple => +transient+ +load+ ;
MIXIN: mdb-persistent
SLOT: _id
@ -14,7 +20,7 @@ TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
GENERIC: tuple-collection ( object -- mdb-collection )
GENERIC: mdb-slot-list ( tuple -- string )
GENERIC: mdb-slot-map ( tuple -- string )
<PRIVATE
@ -27,7 +33,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
[ nip ]
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
: (mdb-slot-list) ( class -- slot-defs )
: (mdb-slot-map) ( class -- slot-defs )
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
: split-optl ( seq -- key options )
@ -59,8 +65,8 @@ PRIVATE>
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
: set-slot-options ( class options -- )
'[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep
: set-slot-map ( class options -- )
'[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep
dup tuple-collection link-collection ; inline
M: tuple-class tuple-collection ( tuple -- mdb-collection )
@ -69,22 +75,44 @@ M: tuple-class tuple-collection ( tuple -- mdb-collection )
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
class (mdb-collection) ;
M: mdb-persistent mdb-slot-list ( tuple -- string )
class (mdb-slot-list) ;
M: mdb-persistent mdb-slot-map ( tuple -- string )
class (mdb-slot-map) ;
M: tuple-class mdb-slot-list ( class -- assoc )
(mdb-slot-list) ;
M: tuple-class mdb-slot-map ( class -- assoc )
(mdb-slot-map) ;
M: mdb-collection mdb-slot-list ( collection -- assoc )
classes>> [ mdb-slot-list ] map assoc-combine ;
M: mdb-collection mdb-slot-map ( collection -- assoc )
classes>> [ mdb-slot-map ] map assoc-combine ;
<PRIVATE
: collection-map ( -- assoc )
MDB_COLLECTION_MAP mdb-persistent word-prop
mdb-persistent MDB_COLLECTION_MAP word-prop
[ mdb-persistent MDB_COLLECTION_MAP H{ } clone
[ set-word-prop ] keep ] unless* ; inline
: slot-option? ( tuple slot option -- ? )
[ swap mdb-slot-map at ] dip
'[ _ swap key? ] [ f ] if* ;
: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
PRIVATE>
GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
collection-map [ ] [ key? ] 2bi
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
[ [ >>name ] keep ] dip set-at ] if ; inline
M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
[ name>> <mdb-tuple-collection> ] keep
{
[ capped>> >>capped ]
[ size>> >>size ]
[ max>> >>max ]
} cleave ;
: transient-slot? ( tuple slot -- ? )
+transient+ slot-option? ;
: load-slot? ( tuple slot -- ? )
+load+ slot-option? ;

10
mongodb/tuple/index/index.factor
View File

@ -1,11 +1,15 @@
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
mongodb.tuple.collection combinators mongodb.tuple.collection ;
IN: mongodb.tuple
SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
IN: mongodb.tuple.index
TUPLE: tuple-index name spec ;
FROM: mongodb.tuple => +fieldindex+ +compoundindex+ +deepindex+ ;
SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
TUPLE: tuple-index name spec ;
<PRIVATE
@ -47,7 +51,7 @@ SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ;
PRIVATE>
: tuple-index-list ( mdb-collection/class -- seq )
mdb-slot-list V{ } clone tuck
mdb-slot-map V{ } clone tuck
'[ [ is-index-declaration? ] filter
build-index-seq _ push
] assoc-each flatten ;

19
mongodb/tuple/persistent/persistent.factor
View File

@ -11,7 +11,6 @@ GENERIC: tuple>assoc ( tuple -- assoc )
GENERIC: tuple>selector ( tuple -- selector )
DEFER: assoc>tuple
DEFER: mdb-persistent?
<PRIVATE
@ -41,19 +40,23 @@ DEFER: mdb-persistent?
: add-storable ( assoc ns -- )
[ H{ } clone ] dip mdb-store-list get at+
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
: write-tuple-fields ( mirror assoc conv-quot -- )
swap [ dup ] dip ! m a a q
'[ [ dup mdb-persistent?
: write-field? ( tuple key value -- ? )
[ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline
: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
swap dupd ! m t q q a
'[ _ 2over write-field?
[ dup mdb-persistent?
[ _ keep
[ tuple-collection ] keep
[ add-storable ] dip
[ tuple-collection ] [ _id>> ] bi <objref> ]
[ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if*
[ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if
] assoc-each ;
: prepare-assoc ( tuple -- assoc mirror assoc )
<mirror> H{ } clone tuck ; inline
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
H{ } clone swap [ <mirror> ] keep pick ; inline
: ensure-mdb-info ( tuple -- tuple )
dup _id>> [ <objid> >>_id ] unless

10
mongodb/tuple/state/state.factor
View File

@ -28,17 +28,17 @@ PRIVATE>
dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
: dirty? ( tuple -- ? )
MDB_DIRTY_FLAG tuple-meta at ;
MDB_DIRTY_FLAG tuple-meta at ;
: set-dirty ( tuple -- )
t MDB_DIRTY_FLAG tuple-meta set-at ;
[ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
: persistent? ( tuple -- ? )
MDB_PERSISTENT_FLAG tuple-meta at ;
MDB_PERSISTENT_FLAG tuple-meta at ;
: set-persistent ( tuple -- )
t MDB_PERSISTENT_FLAG tuple-meta set-at ;
[ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ;
: needs-store? ( tuple -- ? )
[ persistent? not ] [ dirty? ] bi or ;
[ persistent? not ] [ dirty? ] bi or ;

26
mongodb/tuple/tuple.factor
View File

@ -1,28 +1,26 @@
USING: accessors assocs classes classes.mixin classes.tuple vectors math
classes.tuple.parser formatting generalizations kernel sequences fry combinators
linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants
prettyprint strings compiler.units slots tools.walker words arrays ;
USING: accessors assocs classes.mixin classes.tuple
classes.tuple.parser compiler.units fry kernel mongodb.driver
mongodb.msg mongodb.tuple.collection mongodb.tuple.index
mongodb.tuple.persistent mongodb.tuple.state sequences strings ;
IN: mongodb.tuple
USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection
mongodb.tuple.index mongodb.msg ;
SYNTAX: MDBTUPLE:
parse-tuple-definition
mdb-check-slots
define-tuple-class ;
: define-persistent ( class collection options -- )
[ <mdb-tuple-collection> ] dip
[ [ dup ] dip link-collection ] dip ! cl options
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
set-slot-options ;
set-slot-map ;
: ensure-table ( class -- )
tuple-collection
[ create-collection ]
[ [ tuple-index-list ] keep
'[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each
'[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each
] bi ;
: ensure-tables ( classes -- )
@ -31,7 +29,7 @@ SYNTAX: MDBTUPLE:
: drop-table ( class -- )
tuple-collection
[ [ tuple-index-list ] keep
'[ _ swap name>> drop-index ] each ]
'[ _ name>> swap name>> drop-index ] each ]
[ name>> drop-collection ] bi ;
: recreate-table ( class -- )
@ -41,19 +39,19 @@ SYNTAX: MDBTUPLE:
<PRIVATE
GENERIC: id-selector ( object -- selector )
M: objid id-selector ( objid -- selector )
M: string id-selector ( objid -- selector )
"_id" H{ } clone [ set-at ] keep ; inline
M: mdb-persistent id-selector ( mdb-persistent -- selector )
id>> id-selector ;
_id>> id-selector ;
: (save-tuples) ( collection assoc -- )
swap '[ [ _ ] 2dip
[ id-selector ] dip
<update> update ] assoc-each ; inline
<update> >upsert update ] assoc-each ; inline
PRIVATE>
: save-tuple ( tuple -- )
tuple>assoc [ (save-tuples) ] assoc-each ;
tuple>storable [ (save-tuples) ] assoc-each ;
: update-tuple ( tuple -- )
save-tuple ;