removed usages of sprintf
made collection handling more concise
parent
774e23ea3f
commit
f5df1162de
|
@ -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
|
||||||
|
|
|
@ -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* ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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,22 +106,16 @@ 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
|
||||||
|
@ -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
|
: ensure-collection-map ( mdb-instance -- assoc )
|
||||||
[ dup ] dip key? [ drop ]
|
dup collections>> dup keys length 0 =
|
||||||
[ [ ensure-valid-collection-name ] keep create-collection ] if ;
|
[ 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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue