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

View File

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

View File

@ -186,11 +186,6 @@ M: bson-binary-custom element-binary-read ( size type -- dbref )
read-cstring read-cstring
read-cstring objref boa ; 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 ) M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ; drop read ;

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: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
M: oid bson-type? ( word -- type ) drop T_OID ; 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: objref bson-type? ( objref -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- 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 -- ) M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ; [ 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 -- ) M: objref bson-write ( objref -- )
[ binary ] dip [ binary ] dip
'[ _ '[ _
[ ns>> write-cstring ] [ ns>> write-cstring ]
[ objid>> id>> write-cstring ] bi ] with-byte-writer [ objid>> write-cstring ] bi ] with-byte-writer
[ length write-int32 ] keep [ length write-int32 ] keep
T_Binary_Custom write-byte write ; T_Binary_Custom write-byte write ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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