removed usages of sprintf

made collection handling more concise
Sascha Matzke 2009-07-05 13:28:41 +02:00
parent 774e23ea3f
commit f5df1162de
5 changed files with 52 additions and 43 deletions

View File

@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ create-collection ] keep ; [ create-collection ] keep ;
: prepare-index ( collection -- ) : prepare-index ( collection -- )
"_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ; "_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ;
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection prepare-collection

View File

@ -1,6 +1,6 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.operations namespaces destructors math.parser mongodb.msg mongodb.operations namespaces destructors
constructors sequences splitting checksums checksums.md5 formatting constructors sequences splitting checksums checksums.md5
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ; arrays hashtables sequences.deep vectors locals ;
@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
mdb-connection get instance>> ; inline mdb-connection get instance>> ; inline
: index-collection ( -- ns ) : index-collection ( -- ns )
mdb-instance name>> "%s.system.indexes" sprintf ; inline mdb-instance name>> "system.indexes" 2array "." join ; inline
: namespaces-collection ( -- ns ) : namespaces-collection ( -- ns )
mdb-instance name>> "%s.system.namespaces" sprintf ; inline mdb-instance name>> "system.namespaces" 2array "." join ; inline
: cmd-collection ( -- ns ) : cmd-collection ( -- ns )
mdb-instance name>> "%s.$cmd" sprintf ; inline mdb-instance name>> "$cmd" 2array "." join ; inline
: index-ns ( colname -- index-ns ) : index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline [ mdb-instance name>> ] dip 2array "." join ; inline
: send-message ( message -- ) : send-message ( message -- )
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;

View File

@ -131,7 +131,7 @@ HELP: ensure-index
"\"db\" \"127.0.0.1\" 27017 <mdb>" "\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" } "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
{ $unchecked-example "USING: mongodb.driver ;" { $unchecked-example "USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ; "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> t >>unique? ensure-index ] with-db" "" } } ;
HELP: explain. HELP: explain.
{ $values { $values

View File

@ -1,8 +1,8 @@
USING: accessors assocs bson.constants bson.writer combinators combinators.smart USING: accessors arrays assocs bson.constants combinators
constructors continuations destructors formatting fry io io.pools combinators.smart constructors destructors formatting fry hashtables
io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables io io.pools io.sockets kernel linked-assocs math mongodb.connection
namespaces parser prettyprint sequences sets splitting strings uuid arrays mongodb.msg parser prettyprint sequences sets splitting strings
math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ; tools.continuations uuid memoize locals ;
IN: mongodb.driver IN: mongodb.driver
@ -23,9 +23,6 @@ TUPLE: index-spec
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ; CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
: unique-index ( index-spec -- index-spec )
t >>unique? ;
M: mdb-pool make-connection M: mdb-pool make-connection
mdb>> mdb-open ; mdb>> mdb-open ;
@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result
[ make-cursor ] 2tri [ make-cursor ] 2tri
swap objects>> ; swap objects>> ;
: make-collection-assoc ( collection assoc -- )
[ [ 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 ;
PRIVATE> PRIVATE>
SYNTAX: r/ ( token -- mdbregexp ) SYNTAX: r/ ( token -- mdbregexp )
@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp )
H{ } clone [ set-at ] keep <mdb-db> H{ } clone [ set-at ] keep <mdb-db>
[ verify-nodes ] keep ; [ verify-nodes ] keep ;
GENERIC: create-collection ( name -- ) GENERIC: create-collection ( name/collection -- )
M: string create-collection M: string create-collection
<mdb-collection> create-collection ; <mdb-collection> create-collection ;
M: mdb-collection create-collection M: mdb-collection create-collection
[ cmd-collection ] dip [ [ cmd-collection ] dip
<linked-hash> [ <linked-hash> [ make-collection-assoc ] keep
[ [ name>> "create" ] dip set-at ] <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
[ [ [ capped>> ] keep ] dip [ ] [ name>> ] bi mdb-instance collections>> set-at ;
'[ _ _
[ [ 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 drop ;
: load-collection-list ( -- collection-list ) : load-collection-list ( -- collection-list )
namespaces-collection namespaces-collection
H{ } clone <mdb-query-msg> send-query-plain objects>> ; H{ } clone <mdb-query-msg> send-query-plain objects>> ;
@ -125,27 +125,36 @@ M: mdb-collection create-collection
: ensure-valid-collection-name ( collection -- ) : ensure-valid-collection-name ( collection -- )
[ ";$." intersect length 0 > ] keep [ ";$." intersect length 0 > ] keep
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline '[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline
: (ensure-collection) ( collection -- ) : build-collection-map ( -- assoc )
mdb-instance collections>> dup keys length 0 = H{ } clone load-collection-list
[ load-collection-list [ [ "name" ] dip at "." split second <mdb-collection> ] map
[ [ "options" ] dip key? ] filter over '[ [ ] [ name>> ] bi _ set-at ] each ;
[ [ "name" ] dip at "." split second <mdb-collection> ] map
over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
[ dup ] dip key? [ drop ]
[ [ ensure-valid-collection-name ] keep create-collection ] if ;
: ensure-collection-map ( mdb-instance -- assoc )
dup collections>> dup keys length 0 =
[ drop build-collection-map [ >>collections drop ] keep ]
[ nip ] if ;
: (ensure-collection) ( collection mdb-instance -- collection )
ensure-collection-map [ dup ] dip key?
[ ] [ [ ensure-valid-collection-name ]
[ create-collection ]
[ ] tri ] if ;
: reserved-namespace? ( name -- ? ) : reserved-namespace? ( name -- ? )
[ "$cmd" = ] [ "system" head? ] bi or ; [ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection ) : check-collection ( collection -- fq-collection )
dup mdb-collection? [ name>> ] when [let* | instance [ mdb-instance ]
"." split1 over mdb-instance name>> = instance-name [ instance name>> ] |
[ nip ] [ drop ] if dup mdb-collection? [ name>> ] when
[ ] [ reserved-namespace? ] bi "." split1 over instance-name =
[ [ (ensure-collection) ] keep ] unless [ nip ] [ drop ] if
[ mdb-instance name>> ] dip "%s.%s" sprintf ; [ ] [ reserved-namespace? ] bi
[ instance (ensure-collection) ] unless
[ instance-name ] dip 2array "." join ] ;
: fix-query-collection ( mdb-query -- mdb-query ) : fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline [ check-collection ] change-collection ; inline

View File

@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence )
: user-defined-key-index ( class -- assoc ) : user-defined-key-index ( class -- assoc )
mdb-slot-map user-defined-key mdb-slot-map user-defined-key
[ drop [ "user-defined-key-index" 1 ] dip [ drop [ "user-defined-key-index" 1 ] dip
H{ } clone [ set-at ] keep <tuple-index> unique-index H{ } clone [ set-at ] keep <tuple-index> t >>unique?
[ ] [ name>> ] bi H{ } clone [ set-at ] keep [ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ; ] [ 2drop H{ } clone ] if ;