IN: bson.constants
-TUPLE: objid id ;
-
: <objid> ( -- objid )
- objid new uuid1 >>id ; inline
+ uuid1 ; inline
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
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 ;
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 ;
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 ;
PRIVATE>
MEMO: ensure-collection ( collection -- fq-collection )
+ dup mdb-collection? [ name>> ] when
"." split1 over mdb name>> =
[ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi
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
GENERIC: tuple-collection ( object -- mdb-collection )
-GENERIC: mdb-slot-list ( tuple -- string )
+GENERIC: mdb-slot-map ( tuple -- string )
<PRIVATE
[ 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 )
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 )
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? ;
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
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 ;
GENERIC: tuple>selector ( tuple -- selector )
DEFER: assoc>tuple
-DEFER: mdb-persistent?
<PRIVATE
: 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
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 ;
-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 -- )
: 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 -- )
<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 ;