made most "front" methods generic

switched back to assoc generic type
db4
Sascha Matzke 2009-03-03 22:44:24 +01:00
parent 75c28ee62f
commit 66cf30ac1c
2 changed files with 44 additions and 19 deletions

View File

@ -3,7 +3,7 @@
USING: accessors assocs bson.constants byte-arrays fry io io.binary
io.encodings.binary io.encodings.string io.encodings.utf8
io.streams.byte-array kernel math math.parser quotations sequences
serialize strings words hashtables ;
serialize strings words ;
IN: bson.writer
@ -23,7 +23,7 @@ M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: string bson-type? ( string -- type ) drop T_String ;
M: integer bson-type? ( integer -- type ) drop T_Integer ;
M: hashtable bson-type? ( hashtable -- type ) drop T_Object ;
M: assoc bson-type? ( assoc -- type ) drop T_Object ;
M: oid bson-type? ( word -- type ) drop T_OID ;
M: objid bson-type? ( objid -- type ) drop T_Binary ;
@ -94,14 +94,14 @@ M: sequence bson-write ( array -- )
write
write-eoo ;
: write-oid ( hashtable -- )
: write-oid ( assoc -- )
[ MDB_OID_FIELD ] dip at*
[ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline
: skip-field? ( name -- boolean )
{ MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline
M: hashtable bson-write ( hashtable -- )
M: assoc bson-write ( assoc -- )
'[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ]
binary swap with-byte-writer
[ length 5 + bson-write ] keep

View File

@ -134,10 +134,21 @@ PRIVATE>
'[ dup master?>> _ set-at ] each
H{ } clone mdb-db boa ;
: create-collection ( name -- )
GENERIC: create-collection ( name -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection ( mdb-collection -- )
[ cmd-collection ] dip
"create" H{ } clone [ set-at ] keep
<mdb-query-msg> 1 >>return# send-query-plain objects>> first check-ok
<linked-hash> [
[ [ name>> "create" ] dip set-at ]
[ [ [ capped>> ] keep ] dip
'[ _ _
[ [ drop t "capped" ] dip set-at ]
[ [ size>> "size" ] dip set-at ]
[ [ max>> "max" ] dip set-at ] 2tri ] when
] 2bi
] keep <mdb-query-msg> 1 >>return# send-query-plain objects>> first check-ok
[ "could not create collection" throw ] unless ;
: load-collection-list ( -- collection-list )
@ -194,10 +205,12 @@ GENERIC# hint 1 ( mdb-query index-hint -- mdb-query )
M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query )
>>hint ;
: find ( mdb-query -- cursor result )
GENERIC: find ( mdb-query -- cursor result )
M: mdb-query-msg find
send-query ;
: explain ( mdb-query -- result )
GENERIC: explain ( mdb-query -- result )
M: mdb-query-msg explain
t >>explain find [ drop ] dip ;
GENERIC: get-more ( mdb-cursor -- mdb-cursor objects )
@ -205,10 +218,12 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects )
[ [ collection>> ] [ return#>> ] [ id>> ] tri <mdb-getmore-msg> send-query ]
[ f f ] if* ;
: find-one ( mdb-query -- result )
GENERIC: find-one ( mdb-query -- result )
M: mdb-query-msg find-one
1 >>return# send-query-plain ;
: count ( collection query -- result )
GENERIC: count ( collection query -- result )
M: assoc count
[ "count" H{ } clone [ set-at ] keep ] dip
[ over [ "query" ] dip set-at ] when*
[ cmd-collection ] dip <mdb-query-msg> find-one objects>> first
@ -218,11 +233,14 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects )
cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
find-one objects>> [ "err" ] at ;
: validate ( collection -- )
GENERIC: validate ( collection -- )
M: string validate
[ cmd-collection ] dip
"validate" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one objects>> first [ check-ok ] keep
'[ "result" _ at print ] when ;
M: mdb-collection validate
name>> validate ;
<PRIVATE
@ -231,15 +249,18 @@ M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects )
PRIVATE>
: save ( collection object -- )
GENERIC: save ( collection assoc -- )
M: assoc save
[ ensure-collection ] dip
<mdb-insert-msg> send-message-check-error ;
: save-unsafe ( collection object -- )
GENERIC: save-unsafe ( collection object -- )
M: assoc save-unsafe
[ ensure-collection ] dip
<mdb-insert-msg> send-message ;
: ensure-index ( collection name spec -- )
GENERIC: ensure-index ( collection name spec -- )
M: assoc ensure-index
H{ } clone
[ [ "key" ] dip set-at ] keep
[ [ "name" ] dip set-at ] keep
@ -254,19 +275,23 @@ PRIVATE>
[ cmd-collection ] dip <mdb-query-msg> find-one objects>> first
check-ok [ "could not drop index" throw ] unless ;
: update ( collection selector object -- )
GENERIC: update ( collection selector object -- )
M: assoc update
[ ensure-collection ] dip
<mdb-update-msg> send-message-check-error ;
: update-unsafe ( collection selector object -- )
GENERIC: update-unsafe ( collection selector object -- )
M: assoc update-unsafe
[ ensure-collection ] dip
<mdb-update-msg> send-message ;
: delete ( collection selector -- )
GENERIC: delete ( collection selector -- )
M: assoc delete
[ ensure-collection ] dip
<mdb-delete-msg> send-message-check-error ;
: delete-unsafe ( collection selector -- )
GENERIC: delete-unsafe ( collection selector -- )
M: assoc delete-unsafe
[ ensure-collection ] dip
<mdb-delete-msg> send-message ;