From 3a03cadef68bc6602a08166914636bbbd97bfcaf Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Sat, 27 Dec 2008 16:57:54 +0100 Subject: [PATCH] some further persistent tuple work; not sure if the whole tuple persistence behavior should bleed into the bson reader/writer, of if to keep them "pure" --- mongodb/bson/reader/reader.factor | 17 +++++-- mongodb/bson/writer/writer.factor | 29 +++++------- mongodb/persistent/persistent.factor | 66 +++++++++++++++++++--------- 3 files changed, 69 insertions(+), 43 deletions(-) diff --git a/mongodb/bson/reader/reader.factor b/mongodb/bson/reader/reader.factor index dcfabfb947..276acc1263 100644 --- a/mongodb/bson/reader/reader.factor +++ b/mongodb/bson/reader/reader.factor @@ -1,7 +1,7 @@ USING: mirrors io io.encodings.utf8 io.encodings.binary math match kernel sequences splitting accessors io.streams.byte-array namespaces prettyprint mongodb.bson.constants assocs alien.c-types alien.strings fry words - tools.walker serialize ; + tools.walker serialize mongodb.persistent ; IN: mongodb.bson.reader @@ -47,6 +47,9 @@ GENERIC: element-binary-read ( length type -- object ) : read-int32 ( -- int32 ) 4 [ read *int ] [ count-bytes ] bi ; inline +: read-longlong ( -- longlong ) + 8 [ read *longlong ] [ count-bytes ] bi ; inline + : read-double ( -- double ) 8 [ read *double ] [ count-bytes ] bi ; inline @@ -89,8 +92,7 @@ GENERIC: element-binary-read ( length type -- object ) [ read-elements ] when ; : make-tuple ( assoc -- tuple ) - [ [ S_Name swap at ] [ S_Vocab swap at ] bi ] keep ! name vocab assoc - [ lookup new ] dip ! instance assoc + [ P_INFO swap at persistent-tuple-class new ] keep ! instance assoc [ dup [ keys ] keep ] dip ! instance array mirror assoc '[ dup _ [ _ at ] dip [ swap ] dip set-at ] each ; @@ -98,7 +100,7 @@ GENERIC: fix-result ( assoc type -- result ) M: bson-object fix-result ( assoc type -- result ) drop - [ ] [ S_Name swap key? ] bi + [ ] [ P_INFO swap key? ] bi [ make-tuple ] [ ] if ; M: bson-array fix-result ( assoc type -- result ) @@ -124,6 +126,13 @@ M: bson-not-eoo element-read ( type -- cont? ) set-at t ; +M: bson-oid element-data-read ( type -- object ) + drop + read-longlong + read-int32 + oid boa + pop-element drop ; + M: bson-object element-data-read ( type -- object ) drop read-int32 drop diff --git a/mongodb/bson/writer/writer.factor b/mongodb/bson/writer/writer.factor index 7cb1cc4cdb..44dca02991 100644 --- a/mongodb/bson/writer/writer.factor +++ b/mongodb/bson/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: mongodb.bson mongodb.bson.constants accessors kernel io.streams.string io.encodings.binary classes byte-arrays quotations serialize - io.encodings.utf8 strings splitting math.parser + io.encodings.utf8 strings splitting math.parser locals sequences math assocs classes words make fry mongodb.persistent prettyprint hashtables mirrors alien.strings alien.c-types io.streams.byte-array io ; @@ -41,10 +41,8 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; -: write-tuple-info ( object -- ) - class - [ [ S_Name ] dip name>> write-pair ] - [ [ S_Vocab ] dip vocabulary>> write-pair ] bi ; +:: write-tuple-info ( object -- ) + P_SLOTS [ [ ] [ object at ] bi write-pair ] each ; M: f bson-write ( f -- ) drop 0 write-byte ; @@ -87,27 +85,20 @@ M: sequence bson-write ( array -- ) write write-eoo ; +: check-p-field ( key value -- key value boolean ) + [ [ "_p_" swap start 0 = ] keep ] dip rot ; + M: persistent-tuple bson-write ( persistent-tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] + + '[ _ [ write-tuple-info ] + [ [ check-p-field [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] binary swap with-byte-writer [ length 5 + bson-write ] keep write write-eoo ; M: tuple bson-write ( tuple -- ) - dup - '[ - _ write-tuple-info - _ [ write-pair ] assoc-each - ] - binary swap with-byte-writer - [ length 5 + bson-write ] keep - write - write-eoo ; + make-persistent bson-write ; M: assoc bson-write ( hashtable -- ) '[ _ [ write-pair ] assoc-each ] diff --git a/mongodb/persistent/persistent.factor b/mongodb/persistent/persistent.factor index fff9778a94..d438fbf978 100644 --- a/mongodb/persistent/persistent.factor +++ b/mongodb/persistent/persistent.factor @@ -1,5 +1,5 @@ -USING: formatting words classes.mixin kernel fry compiler.units - accessors classes classes.tuple ; +USING: accessors classes classes.mixin classes.tuple compiler.units +fry kernel words locals mirrors formatting assocs hashtables ; IN: mongodb.persistent @@ -12,24 +12,35 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; : MDB_CLASS ( -- string ) "p_class" ; inline : MDB_VOCAB ( -- string ) "p_vocab" ; inline -: MDB_MODIF ( -- string ) "p_mt" ; inline -: MDB_CREAT ( -- string ) "p_ct" ; 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 ; + +: P_OID ( -- name ) "_p_oid" ; inline +: P_INFO ( -- name ) "_p_info" ; inline + +: P_SLOTS ( -- array ) + { "_p_oid" "_p_info" } ; ] + tm2 [ 'tuple ] | + tm1 [ swap tm2 set-at ] assoc-each + tm2 object>> ] ; PRIVATE> @@ -38,6 +49,10 @@ GENERIC: persistent-tuple-class ( tuple -- class ) M: tuple persistent-tuple-class ( tuple -- class ) class persistent-tuple-class ; +M: pinfo-hashtable persistent-tuple-class ( tuple -- class ) + [ MDB_CLASS swap at ] [ MDB_VOCAB swap at ] bi lookup + persistent-tuple-class ; + M: tuple-class persistent-tuple-class ( class -- class' ) [ [ vocabulary>> ] [ name>> ] bi ] keep ! name vocab class [ "%s_%s" sprintf ] dip swap dup ! class new_name new_name @@ -47,9 +62,20 @@ M: tuple-class persistent-tuple-class ( class -- class' ) GENERIC: make-persistent ( tuple -- 'tuple ) -! M: tuple make-persistent ( tuple -- 'tuple ) -! [let* | tuple [ ] -! class [ tuple class ] -! 'tuple [ class persistent-tuple-class new ] | -! -! ] ; +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 ) + ;