removed usages of sprintf
made collection handling more concise
Sascha Matzke
parent
774e23ea3f
commit
f5df1162de
|
|
@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
|
|||
[ create-collection ] keep ;
|
||||
|
||||
: 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: ( -- ) )
|
||||
prepare-collection
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
|
||||
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
|
||||
arrays hashtables sequences.deep vectors locals ;
|
||||
|
||||
|
|
@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
mdb-connection get instance>> ; inline
|
||||
|
||||
: index-collection ( -- ns )
|
||||
mdb-instance name>> "%s.system.indexes" sprintf ; inline
|
||||
mdb-instance name>> "system.indexes" 2array "." join ; inline
|
||||
|
||||
: namespaces-collection ( -- ns )
|
||||
mdb-instance name>> "%s.system.namespaces" sprintf ; inline
|
||||
mdb-instance name>> "system.namespaces" 2array "." join ; inline
|
||||
|
||||
: cmd-collection ( -- ns )
|
||||
mdb-instance name>> "%s.$cmd" sprintf ; inline
|
||||
mdb-instance name>> "$cmd" 2array "." join ; inline
|
||||
|
||||
: index-ns ( colname -- index-ns )
|
||||
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
|
||||
[ mdb-instance name>> ] dip 2array "." join ; inline
|
||||
|
||||
: send-message ( message -- )
|
||||
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
|
||||
|
|
|
|||
|
|
@ -131,7 +131,7 @@ HELP: ensure-index
|
|||
"\"db\" \"127.0.0.1\" 27017 <mdb>"
|
||||
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
|
||||
{ $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.
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: accessors assocs bson.constants bson.writer combinators combinators.smart
|
||||
constructors continuations destructors formatting fry io io.pools
|
||||
io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
|
||||
namespaces parser prettyprint sequences sets splitting strings uuid arrays
|
||||
math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
|
||||
USING: accessors arrays assocs bson.constants combinators
|
||||
combinators.smart constructors destructors formatting fry hashtables
|
||||
io io.pools io.sockets kernel linked-assocs math mongodb.connection
|
||||
mongodb.msg parser prettyprint sequences sets splitting strings
|
||||
tools.continuations uuid memoize locals ;
|
||||
|
||||
IN: mongodb.driver
|
||||
|
||||
|
|
@ -23,9 +23,6 @@ TUPLE: index-spec
|
|||
|
||||
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
|
||||
|
||||
: unique-index ( index-spec -- index-spec )
|
||||
t >>unique? ;
|
||||
|
||||
M: mdb-pool make-connection
|
||||
mdb>> mdb-open ;
|
||||
|
||||
|
|
@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result
|
|||
[ make-cursor ] 2tri
|
||||
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>
|
||||
|
||||
SYNTAX: r/ ( token -- mdbregexp )
|
||||
|
|
@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp )
|
|||
H{ } clone [ set-at ] keep <mdb-db>
|
||||
[ verify-nodes ] keep ;
|
||||
|
||||
GENERIC: create-collection ( name -- )
|
||||
GENERIC: create-collection ( name/collection -- )
|
||||
|
||||
M: string create-collection
|
||||
<mdb-collection> create-collection ;
|
||||
|
||||
M: mdb-collection create-collection
|
||||
[ cmd-collection ] dip
|
||||
<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 drop ;
|
||||
|
||||
[ [ cmd-collection ] dip
|
||||
<linked-hash> [ make-collection-assoc ] keep
|
||||
<mdb-query-msg> 1 >>return# send-query-plain drop ] keep
|
||||
[ ] [ name>> ] bi mdb-instance collections>> set-at ;
|
||||
|
||||
: load-collection-list ( -- collection-list )
|
||||
namespaces-collection
|
||||
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
|
||||
|
|
@ -125,27 +125,36 @@ M: mdb-collection create-collection
|
|||
|
||||
: ensure-valid-collection-name ( collection -- )
|
||||
[ ";$." intersect length 0 > ] keep
|
||||
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
|
||||
'[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline
|
||||
|
||||
: (ensure-collection) ( collection -- )
|
||||
mdb-instance collections>> dup keys length 0 =
|
||||
[ load-collection-list
|
||||
[ [ "options" ] dip key? ] filter
|
||||
[ [ "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 ;
|
||||
: build-collection-map ( -- assoc )
|
||||
H{ } clone load-collection-list
|
||||
[ [ "name" ] dip at "." split second <mdb-collection> ] map
|
||||
over '[ [ ] [ name>> ] bi _ set-at ] each ;
|
||||
|
||||
: 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 -- ? )
|
||||
[ "$cmd" = ] [ "system" head? ] bi or ;
|
||||
|
||||
: check-collection ( collection -- fq-collection )
|
||||
dup mdb-collection? [ name>> ] when
|
||||
"." split1 over mdb-instance name>> =
|
||||
[ nip ] [ drop ] if
|
||||
[ ] [ reserved-namespace? ] bi
|
||||
[ [ (ensure-collection) ] keep ] unless
|
||||
[ mdb-instance name>> ] dip "%s.%s" sprintf ;
|
||||
[let* | instance [ mdb-instance ]
|
||||
instance-name [ instance name>> ] |
|
||||
dup mdb-collection? [ name>> ] when
|
||||
"." split1 over instance-name =
|
||||
[ nip ] [ drop ] if
|
||||
[ ] [ reserved-namespace? ] bi
|
||||
[ instance (ensure-collection) ] unless
|
||||
[ instance-name ] dip 2array "." join ] ;
|
||||
|
||||
: fix-query-collection ( mdb-query -- mdb-query )
|
||||
[ check-collection ] change-collection ; inline
|
||||
|
|
|
|||
|
|
@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence )
|
|||
: user-defined-key-index ( class -- assoc )
|
||||
mdb-slot-map user-defined-key
|
||||
[ 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
|
||||
] [ 2drop H{ } clone ] if ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue