From 9a8270a43a22d2cb1fab51ac27492abda4cd45fb Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sun, 5 Apr 2009 20:11:35 +0200 Subject: [PATCH] some renaming now adding an advice for marking a tuple dirty --- bson/writer/writer.factor | 5 +- mongodb/tuple/persistent/persistent.factor | 68 +++++++++++++++------- mongodb/tuple/state/state.factor | 39 ++++++++++--- mongodb/tuple/tuple.factor | 9 ++- 4 files changed, 87 insertions(+), 34 deletions(-) diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 2b1fc54537..4ad1d7fdcc 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors calendar fry io io.binary io.encodings io.encodings.binary io.encodings.utf8 io.streams.byte-array kernel math math.parser namespaces quotations sequences sequences.private serialize strings -words ; +words combinators.short-circuit ; IN: bson.writer @@ -164,3 +164,6 @@ PRIVATE> : assoc>stream ( assoc -- ) bson-write ; inline +: mdb-special-value? ( value -- ? ) + { [ timestamp? ] [ quotation? ] [ mdbregexp? ] + [ oid? ] [ byte-array? ] } 1|| ; \ No newline at end of file diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 6d5e1837a7..329d9cb0c7 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -1,10 +1,11 @@ -USING: accessors assocs classes fry kernel linked-assocs math mirrors -namespaces sequences strings vectors words bson.constants -continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; +USING: accessors assocs bson.constants combinators.short-circuit +constructors continuations fry kernel mirrors mongodb.tuple.collection +mongodb.tuple.state namespaces sequences words bson.writer combinators +hashtables linked-assocs ; IN: mongodb.tuple.persistent -SYMBOL: mdb-store-list +SYMBOLS: object-map ; GENERIC: tuple>assoc ( tuple -- assoc ) @@ -15,7 +16,7 @@ DEFER: assoc>tuple tuple-class ( tuple-info -- class ) - [ first ] keep second lookup ; inline + [ first ] keep second lookup ; inline : tuple-instance ( tuple-info -- instance ) mdbinfo>tuple-class new ; inline @@ -27,7 +28,7 @@ DEFER: assoc>tuple : make-tuple ( assoc -- tuple ) prepare-assoc>tuple '[ dup _ at assoc>tuple swap _ set-at ] each - [ set-persistent ] keep ; inline recursive + [ mark-persistent ] keep ; inline recursive : at+ ( value key assoc -- value ) 2dup key? @@ -38,21 +39,43 @@ DEFER: assoc>tuple [ assoc? not ] [ drop f ] if ; inline : add-storable ( assoc ns -- ) - [ H{ } clone ] dip mdb-store-list get at+ + [ H{ } clone ] dip object-map get at+ [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline : write-field? ( tuple key value -- ? ) - [ [ 2drop ] dip not ] [ drop transient-slot? ] 3bi or not ; inline + pick mdb-persistent? [ + { [ [ 2drop ] dip not ] + [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline + +TUPLE: cond-value value quot ; + +CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; + +: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) + over needs-store? + [ over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + ] [ drop ] if + [ tuple-collection name>> ] [ _id>> ] bi ; inline + +: write-field ( value quot: ( tuple -- assoc ) -- value' ) + { + { [ dup value>> mdb-special-value? ] [ value>> ] } + { [ dup value>> mdb-persistent? ] + [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] } + { [ dup value>> data-tuple? ] + [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] } + { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ] + [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] } + [ value>> ] + } cond ; inline recursive : write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- ) - swap dupd ! m t q q a + swap ! m t q q a '[ _ 2over write-field? - [ dup mdb-persistent? - [ _ keep - [ tuple-collection ] keep - [ add-storable ] dip - [ tuple-collection ] [ _id>> ] bi ] - [ dup data-tuple? _ [ ] if ] if swap _ set-at ] [ 2drop ] if + [ _ write-field swap _ set-at ] + [ 2drop ] if ] assoc-each ; : prepare-assoc ( tuple -- assoc mirror tuple assoc ) @@ -60,20 +83,21 @@ DEFER: assoc>tuple : ensure-mdb-info ( tuple -- tuple ) dup _id>> [ >>_id ] unless - [ set-persistent ] keep ; inline + [ mark-persistent ] keep ; inline -: with-store-list ( quot: ( -- ) -- store-assoc ) - [ H{ } clone dup mdb-store-list ] dip with-variable ; inline +: with-object-map ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup object-map ] dip with-variable ; inline : (tuple>assoc) ( tuple -- assoc ) [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep - over set-tuple-info ; + over set-tuple-info ; inline PRIVATE> -GENERIC: tuple>storable ( tuple -- storable ) -M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) - '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline +GENERIC: tuple>storable ( tuple -- storable ) + +M: mdb-persistent tuple>storable ( mdb-persistent -- object-map ) + '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline M: mdb-persistent tuple>assoc ( tuple -- assoc ) ensure-mdb-info (tuple>assoc) ; diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor index e0e045e31d..ace7b16c8f 100644 --- a/mongodb/tuple/state/state.factor +++ b/mongodb/tuple/state/state.factor @@ -1,4 +1,5 @@ -USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; +USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection +advice words classes.tuple slots ; IN: mongodb.tuple.state @@ -7,9 +8,13 @@ IN: mongodb.tuple.state CONSTANT: MDB_TUPLE_INFO "_mfd_t_info" CONSTANT: MDB_DIRTY_FLAG "d?" CONSTANT: MDB_PERSISTENT_FLAG "p?" +CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set" PRIVATE> +: advised-with? ( name word loc -- ? ) + word-prop key? ; inline + : ( tuple -- tuple-info ) class V{ } clone tuck [ [ name>> ] dip push ] @@ -28,17 +33,35 @@ PRIVATE> dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline : dirty? ( tuple -- ? ) - MDB_DIRTY_FLAG tuple-meta at ; + [ MDB_DIRTY_FLAG ] dip tuple-meta at ; -: set-dirty ( tuple -- ) - [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; +: mark-dirty ( tuple -- ) + [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ; : persistent? ( tuple -- ? ) - MDB_PERSISTENT_FLAG tuple-meta at ; + [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ; -: set-persistent ( tuple -- ) - [ t MDB_PERSISTENT_FLAG ] dip tuple-meta set-at ; +: mark-persistent ( tuple -- ) + [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep + [ f MDB_DIRTY_FLAG ] dip set-at ; : needs-store? ( tuple -- ? ) - [ persistent? not ] [ dirty? ] bi or ; + [ persistent? not ] [ dirty? ] bi or ; + + +: annotate-writers ( class -- ) + dup all-slots [ name>> ] map + MDB_ADDON_SLOTS '[ _ memq? not ] filter + [ (annotate-writer) ] with each ; \ No newline at end of file diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index 089a3ec121..f99e32aaf1 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -1,7 +1,7 @@ USING: accessors assocs classes.mixin classes.tuple -classes.tuple.parser compiler.units fry kernel mongodb.driver +classes.tuple.parser compiler.units fry kernel sequences mongodb.driver mongodb.msg mongodb.tuple.collection mongodb.tuple.index -mongodb.tuple.persistent mongodb.tuple.state sequences strings ; +mongodb.tuple.persistent mongodb.tuple.state strings ; IN: mongodb.tuple @@ -13,7 +13,8 @@ SYNTAX: MDBTUPLE: : define-persistent ( class collection options -- ) [ ] dip [ [ 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 + [ dup annotate-writers ] dip set-slot-map ; : ensure-table ( class -- ) @@ -39,8 +40,10 @@ SYNTAX: MDBTUPLE: > id-selector ;