Sascha Matzke
parent
661ec38c02
commit
8c0927f17a
|
|
@ -162,7 +162,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
|
|||
[ create-collection ] keep ;
|
||||
|
||||
: prepare-index ( collection -- )
|
||||
"_x_idx" H{ { "x" 1 } } ensure-index ;
|
||||
"_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
|
||||
|
||||
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
|
||||
prepare-collection
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ HELP: <mdb-collection>
|
|||
}
|
||||
{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } }
|
||||
{ $examples
|
||||
{ $example "\"mycollection\" <mdb-collection> t >>capped" } } ;
|
||||
{ $example "! creates a mdb-collection instance capped to a maximum of 1000000 entries"
|
||||
"\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" } } ;
|
||||
|
||||
HELP: <mdb>
|
||||
{ $values
|
||||
|
|
@ -26,8 +27,8 @@ HELP: <mdb>
|
|||
HELP: <query>
|
||||
{ $values
|
||||
{ "collection" "collection to query" }
|
||||
{ "query" "query assoc" }
|
||||
{ "mdb-query" "mdb-query-msg instance" }
|
||||
{ "assoc" "query assoc" }
|
||||
{ "mdb-query-msg" "mdb-query-msg instance" }
|
||||
}
|
||||
{ $description "Creates a new mdb-query-msg instance. "
|
||||
"This word must be called from within a with-db scope."
|
||||
|
|
@ -41,176 +42,164 @@ HELP: <update>
|
|||
{ "collection" "collection to update" }
|
||||
{ "selector" "selector assoc (selects which object(s) to update" }
|
||||
{ "object" "updated object or update instruction" }
|
||||
{ "update-msg" "mdb-update-msg instance" }
|
||||
{ "mdb-update-msg" "mdb-update-msg instance" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Creates an update message for the object(s) identified by the given selector."
|
||||
"MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push"
|
||||
"For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ;
|
||||
|
||||
HELP: >upsert
|
||||
{ $values
|
||||
{ "mdb-update-msg" null }
|
||||
{ "mdb-update-msg" null }
|
||||
{ "mdb-update-msg" "a mdb-update-msg" }
|
||||
{ "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: DIRTY?
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: MDB-GENERAL-ERROR
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Marks a mdb-update-msg as upsert operation"
|
||||
"(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
|
||||
|
||||
HELP: PARTIAL?
|
||||
{ $values
|
||||
|
||||
{ "value" null }
|
||||
{ $values
|
||||
{ "value" "partial?" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "key which refers to a partially loaded object" } ;
|
||||
|
||||
HELP: asc
|
||||
{ $values
|
||||
{ "key" null }
|
||||
{ "spec" null }
|
||||
{ "key" "sort key" }
|
||||
{ "spec" "sort spec" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: boolean
|
||||
{ $var-description "" } ;
|
||||
{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
|
||||
|
||||
HELP: count
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "query" null }
|
||||
{ "result" null }
|
||||
{ "mdb-query-msg" "query" }
|
||||
{ "result" "number of objects in the collection that match the query" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "count objects in a collection" } ;
|
||||
|
||||
HELP: create-collection
|
||||
{ $values
|
||||
{ "name" null }
|
||||
{ "name" "collection name" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Creates a new collection with the given name." } ;
|
||||
|
||||
HELP: delete
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "selector" null }
|
||||
{ "collection" "a collection" }
|
||||
{ "selector" "assoc which identifies the objects to be removed from the collection" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "removes objects from the collection (with lasterror check)" } ;
|
||||
|
||||
HELP: delete-unsafe
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "selector" null }
|
||||
{ "collection" "a collection" }
|
||||
{ "selector" "assoc which identifies the objects to be removed from the collection" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "removes objects from the collection (without error check)" } ;
|
||||
|
||||
HELP: desc
|
||||
{ $values
|
||||
{ "key" null }
|
||||
{ "spec" null }
|
||||
{ "key" "sort key" }
|
||||
{ "spec" "sort spec" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
|
||||
|
||||
HELP: drop-collection
|
||||
{ $values
|
||||
{ "name" null }
|
||||
{ "name" "a collection" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "removes the collection and all objects in it from the database" } ;
|
||||
|
||||
HELP: drop-index
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "name" null }
|
||||
{ "collection" "a collection" }
|
||||
{ "name" "an index name" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "drops the specified index from the collection" } ;
|
||||
|
||||
HELP: ensure-collection
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "fq-collection" null }
|
||||
{ "collection" "a collection; e.g. mycollection " }
|
||||
{ "fq-collection" "full qualified collection name; e.g. db.mycollection" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "ensures that the collection exists in the database and returns its full qualified name" } ;
|
||||
|
||||
HELP: ensure-index
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "name" null }
|
||||
{ "spec" null }
|
||||
{ "collection" "a collection" }
|
||||
{ "name" "index name" }
|
||||
{ "spec" "index spec" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Ensures the existence of the given index. "
|
||||
"For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
|
||||
{ $examples
|
||||
{ $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index" }
|
||||
{ $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index" } } ;
|
||||
|
||||
HELP: explain.
|
||||
{ $values
|
||||
{ "mdb-query" null }
|
||||
{ "mdb-query-msg" "a query message" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Prints the execution plan for the given query" } ;
|
||||
|
||||
HELP: find
|
||||
{ $values
|
||||
{ "mdb-query" null }
|
||||
{ "cursor" null }
|
||||
{ "result" null }
|
||||
{ "mdb-query" "a query" }
|
||||
{ "cursor" "a cursor (if there are more results) or f" }
|
||||
{ "result" "a sequences of objects" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "executes the given query" }
|
||||
{ $examples
|
||||
{ $example "\"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find " } } ;
|
||||
|
||||
HELP: find-one
|
||||
{ $values
|
||||
{ "mdb-query" null }
|
||||
{ "result" null }
|
||||
{ "mdb-query" "a query" }
|
||||
{ "result" "a single object or f" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
HELP: get-more
|
||||
{ $values
|
||||
{ "mdb-cursor" null }
|
||||
{ "mdb-cursor" null }
|
||||
{ "objects" null }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Executes the query and returns one object at most" } ;
|
||||
|
||||
HELP: hint
|
||||
{ $values
|
||||
{ "mdb-query" null }
|
||||
{ "index-hint" null }
|
||||
{ "mdb-query" null }
|
||||
{ "mdb-query" "a query" }
|
||||
{ "index-hint" "a hint to an index" }
|
||||
{ "mdb-query" "modified query object" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Annotates the query with a hint to an index. "
|
||||
"For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
|
||||
{ $examples
|
||||
{ $example "\"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find" } } ;
|
||||
|
||||
HELP: lasterror
|
||||
{ $values
|
||||
|
||||
{ "error" null }
|
||||
{ "error" "error message or f" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Checks if the last operation resulted in an error on the MongoDB side"
|
||||
"For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ;
|
||||
|
||||
HELP: limit
|
||||
{ $values
|
||||
{ "mdb-query" null }
|
||||
{ "limit#" null }
|
||||
{ "mdb-query" null }
|
||||
{ "mdb-query" "a query" }
|
||||
{ "limit#" "number of objects that should be returned at most" }
|
||||
{ "mdb-query" "modified query object" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Limits the number of returned objects to limit#" }
|
||||
{ $examples
|
||||
{ $example "\"mycollection\" H{ } <query> 10 limit find" } } ;
|
||||
|
||||
HELP: load-collection-list
|
||||
{ $values
|
||||
|
||||
{ "collection-list" null }
|
||||
{ "collection-list" "list of collections in the current database" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Returns a list of all collections that exist in the current database" } ;
|
||||
|
||||
HELP: load-index-list
|
||||
{ $values
|
||||
|
||||
{ "index-list" null }
|
||||
{ "index-list" "list of indexes" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Returns a list of all indexes that exist in the current database" } ;
|
||||
|
||||
HELP: mdb-collection
|
||||
{ $var-description "" } ;
|
||||
|
|
@ -220,8 +209,7 @@ HELP: mdb-cursor
|
|||
|
||||
HELP: mdb-error
|
||||
{ $values
|
||||
{ "id" null }
|
||||
{ "msg" null }
|
||||
{ "msg" "error message" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
|
||||
|
|
@ -234,10 +222,11 @@ HELP: r/
|
|||
|
||||
HELP: save
|
||||
{ $values
|
||||
{ "collection" null }
|
||||
{ "assoc" assoc }
|
||||
{ "collection" "a collection" }
|
||||
{ "assoc" "object" }
|
||||
}
|
||||
{ $description "" } ;
|
||||
{ $description "Saves the object to the given collection."
|
||||
" If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ;
|
||||
|
||||
HELP: save-unsafe
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: accessors assocs bson.constants bson.writer combinators
|
||||
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
|
||||
math math.parser memoize mongodb.connection mongodb.msg mongodb.operations namespaces
|
||||
parser prettyprint sequences sets splitting strings uuid arrays ;
|
||||
namespaces parser prettyprint sequences sets splitting strings uuid arrays
|
||||
math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
|
||||
|
||||
IN: mongodb.driver
|
||||
|
||||
|
|
@ -10,72 +10,72 @@ TUPLE: mdb-pool < pool mdb ;
|
|||
|
||||
TUPLE: mdb-cursor id query ;
|
||||
|
||||
UNION: boolean t POSTPONE: f ;
|
||||
|
||||
TUPLE: mdb-collection
|
||||
{ name string }
|
||||
{ capped boolean initial: f }
|
||||
{ size integer initial: -1 }
|
||||
{ max integer initial: -1 } ;
|
||||
|
||||
: <mdb-collection> ( name -- collection )
|
||||
[ mdb-collection new ] dip >>name ; inline
|
||||
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
|
||||
|
||||
TUPLE: index-spec
|
||||
{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ;
|
||||
|
||||
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
|
||||
|
||||
: unique-index ( index-spec -- index-spec )
|
||||
t >>unique? ;
|
||||
|
||||
M: mdb-pool make-connection
|
||||
mdb>> mdb-open ;
|
||||
|
||||
: <mdb-pool> ( mdb -- pool ) mdb-pool <pool> swap >>mdb ;
|
||||
|
||||
CONSTANT: MDB-GENERAL-ERROR 1
|
||||
: <mdb-pool> ( mdb -- pool ) [ mdb-pool <pool> ] dip >>mdb ; inline
|
||||
|
||||
CONSTANT: PARTIAL? "partial?"
|
||||
CONSTANT: DIRTY? "dirty?"
|
||||
|
||||
ERROR: mdb-error id msg ;
|
||||
ERROR: mdb-error msg ;
|
||||
|
||||
: >pwd-digest ( user password -- digest )
|
||||
"mongo" swap 3array ":" join md5-checksum ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: <mdb-cursor> ( id query/get-more -- cursor )
|
||||
GENERIC: <mdb-cursor> ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor )
|
||||
|
||||
M: mdb-query-msg <mdb-cursor>
|
||||
mdb-cursor boa ;
|
||||
|
||||
M: mdb-getmore-msg <mdb-cursor>
|
||||
query>> mdb-cursor boa ;
|
||||
|
||||
: >mdbregexp ( value -- regexp )
|
||||
first <mdbregexp> ; inline
|
||||
|
||||
PRIVATE>
|
||||
GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
|
||||
|
||||
SYNTAX: r/ ( token -- mdbregexp )
|
||||
\ / [ >mdbregexp ] parse-literal ;
|
||||
|
||||
: with-db ( mdb quot -- ... )
|
||||
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
|
||||
|
||||
: build-id-selector ( assoc -- selector )
|
||||
[ MDB_OID_FIELD swap at ] keep
|
||||
H{ } clone [ set-at ] keep ;
|
||||
|
||||
GENERIC: update-query ( result query/cursor -- )
|
||||
M: mdb-query-msg update-query
|
||||
swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
|
||||
|
||||
M: mdb-getmore-msg update-query
|
||||
query>> update-query ;
|
||||
|
||||
: make-cursor ( mdb-result-msg query/cursor -- cursor/f )
|
||||
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
|
||||
over cursor>> 0 >
|
||||
[ [ update-query ]
|
||||
[ [ cursor>> ] dip <mdb-cursor> ] 2bi
|
||||
] [ 2drop f ] if ;
|
||||
|
||||
DEFER: send-query
|
||||
GENERIC: verify-query-result ( result query/get-more -- mdb-result-msg query/get-more )
|
||||
|
||||
GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
|
||||
|
||||
M: mdb-query-msg verify-query-result ;
|
||||
|
||||
M: mdb-getmore-msg verify-query-result
|
||||
over flags>> ResultFlag_CursorNotFound =
|
||||
[ nip query>> [ send-query-plain ] keep ] when ;
|
||||
|
||||
: send-query ( query/get-more -- cursor/f result )
|
||||
: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
|
||||
[ send-query-plain ] keep
|
||||
verify-query-result
|
||||
[ collection>> >>collection drop ]
|
||||
|
|
@ -85,16 +85,27 @@ M: mdb-getmore-msg verify-query-result
|
|||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: r/ ( token -- mdbregexp )
|
||||
\ / [ >mdbregexp ] parse-literal ;
|
||||
|
||||
: with-db ( mdb quot -- * )
|
||||
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
|
||||
|
||||
: >id-selector ( assoc -- selector )
|
||||
[ MDB_OID_FIELD swap at ] keep
|
||||
H{ } clone [ set-at ] keep ;
|
||||
|
||||
: <mdb> ( db host port -- mdb )
|
||||
<inet> t [ <mdb-node> ] keep
|
||||
H{ } clone [ set-at ] keep <mdb-db>
|
||||
[ verify-nodes ] keep ;
|
||||
|
||||
GENERIC: create-collection ( name -- )
|
||||
|
||||
M: string create-collection
|
||||
<mdb-collection> create-collection ;
|
||||
|
||||
M: mdb-collection create-collection ( mdb-collection -- )
|
||||
M: mdb-collection create-collection
|
||||
[ cmd-collection ] dip
|
||||
<linked-hash> [
|
||||
[ [ name>> "create" ] dip set-at ]
|
||||
|
|
@ -116,8 +127,6 @@ M: mdb-collection create-collection ( mdb-collection -- )
|
|||
[ ";$." intersect length 0 > ] keep
|
||||
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
|
||||
|
||||
USE: tools.continuations
|
||||
|
||||
: (ensure-collection) ( collection -- )
|
||||
mdb-instance collections>> dup keys length 0 =
|
||||
[ load-collection-list
|
||||
|
|
@ -127,10 +136,10 @@ USE: tools.continuations
|
|||
[ dup ] dip key? [ drop ]
|
||||
[ [ ensure-valid-collection-name ] keep create-collection ] if ;
|
||||
|
||||
MEMO: reserved-namespace? ( name -- ? )
|
||||
: reserved-namespace? ( name -- ? )
|
||||
[ "$cmd" = ] [ "system" head? ] bi or ;
|
||||
|
||||
MEMO: check-collection ( collection -- fq-collection )
|
||||
|
||||
: check-collection ( collection -- fq-collection )
|
||||
dup mdb-collection? [ name>> ] when
|
||||
"." split1 over mdb-instance name>> =
|
||||
[ nip ] [ drop ] if
|
||||
|
|
@ -140,54 +149,67 @@ MEMO: check-collection ( collection -- fq-collection )
|
|||
|
||||
: fix-query-collection ( mdb-query -- mdb-query )
|
||||
[ check-collection ] change-collection ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <query> ( collection query -- mdb-query )
|
||||
<mdb-query-msg> ; inline
|
||||
GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
|
||||
|
||||
GENERIC# limit 1 ( mdb-query limit# -- mdb-query )
|
||||
M: mdb-query-msg limit ( query limit# -- mdb-query )
|
||||
>>return# ; inline
|
||||
|
||||
GENERIC# skip 1 ( mdb-query skip# -- mdb-query )
|
||||
M: mdb-query-msg skip ( query skip# -- mdb-query )
|
||||
>>skip# ; inline
|
||||
|
||||
: asc ( key -- spec ) [ 1 ] dip H{ } clone [ set-at ] keep ; inline
|
||||
: desc ( key -- spec ) [ -1 ] dip H{ } clone [ set-at ] keep ; inline
|
||||
|
||||
GENERIC# sort 1 ( mdb-query quot -- mdb-query )
|
||||
M: mdb-query-msg sort ( query qout -- mdb-query )
|
||||
[ { } ] dip with-datastack >>orderby ;
|
||||
|
||||
GENERIC# hint 1 ( mdb-query index-hint -- mdb-query )
|
||||
M: mdb-query-msg hint ( mdb-query index-hint -- mdb-query )
|
||||
>>hint ;
|
||||
|
||||
GENERIC: get-more ( mdb-cursor -- mdb-cursor objects )
|
||||
M: mdb-cursor get-more ( mdb-cursor -- mdb-cursor objects )
|
||||
M: mdb-cursor get-more
|
||||
[ [ query>> dup [ collection>> ] [ return#>> ] bi ]
|
||||
[ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
|
||||
[ f f ] if* ;
|
||||
|
||||
GENERIC: find ( mdb-query -- cursor result )
|
||||
PRIVATE>
|
||||
|
||||
: <query> ( collection assoc -- mdb-query-msg )
|
||||
<mdb-query-msg> ; inline
|
||||
|
||||
GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query )
|
||||
|
||||
M: mdb-query-msg limit
|
||||
>>return# ; inline
|
||||
|
||||
GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
|
||||
|
||||
M: mdb-query-msg skip
|
||||
>>skip# ; inline
|
||||
|
||||
: asc ( key -- spec ) 1 2array ; inline
|
||||
: desc ( key -- spec ) -1 2array ; inline
|
||||
|
||||
GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
|
||||
|
||||
M: mdb-query-msg sort
|
||||
output>array >>orderby ; inline
|
||||
|
||||
: key-spec ( spec-quot -- spec-assoc )
|
||||
output>array >hashtable ; inline
|
||||
|
||||
GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
|
||||
|
||||
M: mdb-query-msg hint
|
||||
>>hint ;
|
||||
|
||||
GENERIC: find ( mdb-query-msg/mdb-cursor -- mdb-cursor seq )
|
||||
|
||||
M: mdb-query-msg find
|
||||
fix-query-collection send-query ;
|
||||
|
||||
M: mdb-cursor find
|
||||
get-more ;
|
||||
|
||||
GENERIC: explain. ( mdb-query -- )
|
||||
GENERIC: explain. ( mdb-query-msg -- )
|
||||
|
||||
M: mdb-query-msg explain.
|
||||
t >>explain find nip . ;
|
||||
|
||||
GENERIC: find-one ( mdb-query -- result/f )
|
||||
GENERIC: find-one ( mdb-query-msg -- result/f )
|
||||
|
||||
M: mdb-query-msg find-one
|
||||
fix-query-collection
|
||||
1 >>return# send-query-plain objects>>
|
||||
dup empty? [ drop f ] [ first ] if ;
|
||||
|
||||
GENERIC: count ( mdb-query -- result )
|
||||
GENERIC: count ( mdb-query-msg -- result )
|
||||
|
||||
M: mdb-query-msg count
|
||||
[ collection>> "count" H{ } clone [ set-at ] keep ] keep
|
||||
query>> [ over [ "query" ] dip set-at ] when*
|
||||
|
|
@ -199,18 +221,20 @@ M: mdb-query-msg count
|
|||
find-one [ "err" ] dip at ;
|
||||
|
||||
GENERIC: validate. ( collection -- )
|
||||
|
||||
M: string validate.
|
||||
[ cmd-collection ] dip
|
||||
"validate" H{ } clone [ set-at ] keep
|
||||
<mdb-query-msg> find-one [ check-ok nip ] keep
|
||||
'[ "result" _ at print ] [ ] if ;
|
||||
|
||||
M: mdb-collection validate.
|
||||
name>> validate. ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: send-message-check-error ( message -- )
|
||||
send-message lasterror [ [ MDB-GENERAL-ERROR ] dip mdb-error ] when* ;
|
||||
send-message lasterror [ mdb-error ] when* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -224,15 +248,16 @@ M: assoc save-unsafe
|
|||
[ check-collection ] dip
|
||||
<mdb-insert-msg> send-message ;
|
||||
|
||||
GENERIC: ensure-index ( collection name spec -- )
|
||||
M: assoc ensure-index
|
||||
H{ } clone
|
||||
[ [ uuid1 "_id" ] dip set-at ] keep
|
||||
[ [ "key" ] dip set-at ] keep
|
||||
[ [ "name" ] dip set-at ] keep
|
||||
[ [ index-ns "ns" ] dip set-at ] keep
|
||||
[ index-collection ] dip
|
||||
save ;
|
||||
GENERIC: ensure-index ( index-spec -- )
|
||||
M: index-spec ensure-index
|
||||
<linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
|
||||
[ { [ [ name>> "name" ] dip set-at ]
|
||||
[ [ ns>> index-ns "ns" ] dip set-at ]
|
||||
[ [ key>> "key" ] dip set-at ]
|
||||
[ swap unique?>>
|
||||
[ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave
|
||||
] keep
|
||||
[ index-collection ] dip save ;
|
||||
|
||||
: drop-index ( collection name -- )
|
||||
H{ } clone
|
||||
|
|
@ -277,6 +302,4 @@ M: assoc delete-unsafe
|
|||
"drop" H{ } clone [ set-at ] keep
|
||||
<mdb-query-msg> find-one drop ;
|
||||
|
||||
: >pwd-digest ( user password -- digest )
|
||||
"mongo" swap 3array ":" join md5-checksum ;
|
||||
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
|
|||
[ >>collection ] dip
|
||||
>>objects OP_Insert >>opcode ;
|
||||
|
||||
M: hashtable <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
|
||||
M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
|
||||
[ mdb-insert-msg new ] 2dip
|
||||
[ >>collection ] dip
|
||||
V{ } clone tuck push
|
||||
|
|
|
|||
Loading…
Reference in New Issue