steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

added doc files 

optimized string write performance
db4
Sascha Matzke 2009-03-25 18:22:28 +01:00
parent 0378dda9b1
commit b57cdefde0
8 changed files with 212 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
bson/reader/reader-docs.factor
View File

@ -1,17 +0,0 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax kernel ;
IN: bson.reader
HELP: stream>assoc
{ $values
{ "exemplar" null }
{ "assoc" assoc } { "bytes-read" null }
}
{ $description "" } ;
ARTICLE: "bson.reader" "bson.reader"
{ $vocab-link "bson.reader" }
;
ABOUT: "bson.reader"

23
bson/writer/writer-docs.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax kernel ;
IN: bson.writer
HELP: assoc>bv
{ $values
{ "assoc" assoc }
{ "byte-array" null }
}
{ $description "" } ;
HELP: assoc>stream
{ $values
{ "assoc" assoc }
}
{ $description "" } ;
ARTICLE: "bson.writer" "bson.writer"
{ $vocab-link "bson.writer" }
;
ABOUT: "bson.writer"

47
bson/writer/writer.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Sascha Matzke. ! Copyright (C) 2008 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants byte-arrays byte-vectors USING: accessors assocs bson.constants byte-arrays byte-vectors
calendar fry io io.binary io.encodings io.encodings.string calendar fry io io.binary io.encodings io.encodings.string io.encodings.private
io.encodings.utf8 kernel math math.parser namespaces quotations io.encodings.utf8 kernel math math.parser namespaces quotations
sequences serialize strings tools.walker words ; sequences sequences.private serialize strings tools.walker words ;
IN: bson.writer IN: bson.writer
@ -20,18 +20,18 @@ CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer ) : (buffer) ( -- buffer )
shared-buffer get shared-buffer get
[ 4096 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
PRIVATE> PRIVATE>
: reset-buffer ( buffer -- )
0 >>length drop ; inline
: ensure-buffer ( -- ) : ensure-buffer ( -- )
(buffer) drop ; inline (buffer) drop ; inline
: reset-buffer ( -- )
(buffer) 0 >>length drop ; inline
: with-buffer ( quot -- byte-vector ) : with-buffer ( quot -- byte-vector )
[ (buffer) ] dip [ output-stream get ] compose [ (buffer) [ reset-buffer ] keep dup ] dip
with-output-stream* dup encoder? [ stream>> ] when ; inline with-output-stream* dup encoder? [ stream>> ] when ; inline
: with-length ( quot: ( -- ) -- bytes-written start-index ) : with-length ( quot: ( -- ) -- bytes-written start-index )
@ -41,9 +41,15 @@ PRIVATE>
: with-length-prefix ( quot: ( -- ) -- ) : with-length-prefix ( quot: ( -- ) -- )
[ B{ 0 0 0 0 } write ] prepose with-length [ B{ 0 0 0 0 } write ] prepose with-length
[ INT32-SIZE >le ] dip (buffer) [ INT32-SIZE >le ] dip (buffer)
'[ _ over [ nth ] dip _ + _ set-nth ] '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
[ INT32-SIZE ] dip each-integer ; inline [ INT32-SIZE ] dip each-integer ; inline
: with-length-prefix-excl ( quot: ( -- ) -- )
[ B{ 0 0 0 0 } write ] prepose with-length
[ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
'[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
[ INT32-SIZE ] dip each-integer ; inline
<PRIVATE <PRIVATE
GENERIC: bson-type? ( obj -- type ) foldable flushable GENERIC: bson-type? ( obj -- type ) foldable flushable
@ -68,10 +74,11 @@ M: objref bson-type? ( objref -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ; M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
: write-utf8-string ( string -- ) output-stream get utf8 encoder-write ; inline
: write-byte ( byte -- ) CHAR-SIZE >le write ; inline : write-byte ( byte -- ) CHAR-SIZE >le write ; inline
: write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline : write-cstring ( string -- ) write-utf8-string B{ 0 } write ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write-byte ; inline : write-eoo ( -- ) T_EOO write-byte ; inline
@ -85,9 +92,7 @@ M: t bson-write ( t -- )
drop 1 write-byte ; drop 1 write-byte ;
M: string bson-write ( obj -- ) M: string bson-write ( obj -- )
utf8 encode B{ 0 } append '[ _ write-cstring ] with-length-prefix-excl ;
[ length write-int32 ] keep
write ;
M: integer bson-write ( num -- ) M: integer bson-write ( num -- )
write-int32 ; write-int32 ;
@ -112,22 +117,18 @@ M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ; [ a>> write-longlong ] [ b>> write-int32 ] bi ;
M: objid bson-write ( oid -- ) M: objid bson-write ( oid -- )
id>> utf8 encode
[ length write-int32 ] keep
T_Binary_UUID write-byte T_Binary_UUID write-byte
write ; id>> '[ _ write-utf8-string ] with-length-prefix ;
M: objref bson-write ( objref -- ) M: objref bson-write ( objref -- )
[ ns>> utf8 encode ]
[ objid>> id>> utf8 encode ] bi
append
[ length write-int32 ] keep
T_Binary_Custom write-byte T_Binary_Custom write-byte
write ; '[ _
[ ns>> write-cstring ]
[ objid>> id>> write-cstring ] bi ] with-length-prefix ;
M: mdbregexp bson-write ( regexp -- ) M: mdbregexp bson-write ( regexp -- )
[ regexp>> utf8 encode write-cstring ] [ regexp>> write-cstring ]
[ options>> utf8 encode write-cstring ] bi ; [ options>> write-cstring ] bi ;
M: sequence bson-write ( array -- ) M: sequence bson-write ( array -- )
'[ _ [ [ write-type ] dip number>string '[ _ [ [ write-type ] dip number>string

29
mongodb/benchmark/benchmark.factor
View File

@ -1,6 +1,6 @@
USING: calendar math fry kernel assocs math.ranges USING: calendar math fry kernel assocs math.ranges
sequences formatting combinators namespaces io tools.time prettyprint sequences formatting combinators namespaces io tools.time prettyprint
accessors words mongodb.driver strings math.parser ; accessors words mongodb.driver strings math.parser tools.walker bson.writer ;
IN: mongodb.benchmark IN: mongodb.benchmark
@ -164,7 +164,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
"_x_idx" H{ { "x" 1 } } ensure-index ; inline "_x_idx" H{ { "x" 1 } } ensure-index ; inline
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection prepare-collection
result get index>> [ [ prepare-index ] keep ] when result get index>> [ [ prepare-index ] keep ] when
result get batch>> result get batch>>
[ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
@ -233,7 +233,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: run-insert-bench ( doc-word-seq feat-seq -- ) : run-insert-bench ( doc-word-seq feat-seq -- )
"Insert Tests" print "Insert Tests" print
print-separator-bold print-separator-bold
\ insert bench-quot each ; inline \ insert bench-quot each ; inline
: run-find-one-bench ( doc-word-seq feat-seq -- ) : run-find-one-bench ( doc-word-seq feat-seq -- )
@ -254,24 +254,23 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: run-benchmarks ( -- ) : run-benchmarks ( -- )
"db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb> "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
[ [ ensure-buffer
print-header print-header
! insert ! insert
{ small-doc-prepare medium-doc-prepare large-doc-prepare } ! { small-doc-prepare medium-doc-prepare
{ large-doc-prepare }
{ { } { index } { errcheck } { index errcheck } { { } { index } { errcheck } { index errcheck }
{ batch } { batch errcheck } { batch } { batch errcheck } { batch index errcheck }
{ batch index errcheck } } } run-insert-bench
run-insert-bench
! find-one ! find-one
{ small-doc medium-doc large-doc } ! { small-doc medium-doc large-doc }
{ { } { index } } run-find-one-bench ! { { } { index } } run-find-one-bench
! find-all ! find-all
{ small-doc medium-doc large-doc } ! { small-doc medium-doc large-doc }
{ { } { index } } run-find-all-bench ! { { } { index } } run-find-all-bench
! find-range ! find-range
{ small-doc medium-doc large-doc } ! { small-doc medium-doc large-doc }
{ { } { index } } run-find-range-bench ! { { } { index } } run-find-range-bench
] with-db ; ] with-db ;
MAIN: run-benchmarks MAIN: run-benchmarks

221
mongodb/driver/driver-docs.factor
View File

@ -5,297 +5,315 @@ IN: mongodb.driver
HELP: <mdb-collection> HELP: <mdb-collection>
{ $values { $values
{ "name" null } { "name" "name of the collection" }
{ "collection" null } { "collection" "mdb-collection instance" }
} }
{ $description "" } ; { $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } }
{ $examples
HELP: <mdb-cursor> { $example "\"mycollection\" <mdb-collection> t >>capped" } } ;
{ $values
{ "id" null } { "collection" null } { "return#" null }
{ "cursor" null }
}
{ $description "" } ;
HELP: <mdb> HELP: <mdb>
{ $values { $values
{ "db" null } { "host" null } { "port" null } { "db" "name of the database to use" }
{ "mdb" null } { "host" "host name or IP address" }
{ "port" "port number" }
{ "mdb" "mdb-db instance" }
} }
{ $description "" } ; { $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
{ $examples
{ $example "\"db\" \"127.0.0.1\" 27017 <mdb>" } } ;
HELP: <query> HELP: <query>
{ $values { $values
{ "collection" "the collection to be queried" } { "query" "query" } { "collection" "collection to query" }
{ "mdb-query" "mdb-query-msg tuple instance" } { "query" "query assoc" }
{ "mdb-query" "mdb-query-msg instance" }
} }
{ $description "create a new query instance" } ; { $description "Creates a new mdb-query-msg instance. "
"This word must be called from within a with-db scope."
"For more see: "
{ $link with-db } }
{ $examples
{ $example "\"mycollection\" H{ } <query>" } } ;
HELP: <update>
{ $values
{ "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" }
}
{ $description "" } ;
HELP: >upsert
{ $values
{ "mdb-update-msg" null }
{ "mdb-update-msg" null }
}
{ $description "" } ;
HELP: DIRTY? HELP: DIRTY?
{ $values { $values
{ "value" null } { "value" null }
} }
{ $description "" } ; { $description "" } ;
HELP: MDB-GENERAL-ERROR HELP: MDB-GENERAL-ERROR
{ $values { $values
{ "value" null } { "value" null }
} }
{ $description "" } ; { $description "" } ;
HELP: PARTIAL? HELP: PARTIAL?
{ $values { $values
{ "value" null } { "value" null }
} }
{ $description "" } ; { $description "" } ;
HELP: asc HELP: asc
{ $values { $values
{ "key" null } { "key" null }
{ "spec" null } { "spec" null }
} }
{ $description "" } ; { $description "" } ;
HELP: boolean HELP: boolean
{ $values { $var-description "" } ;
{ "value" null }
}
{ $description "" } ;
HELP: count HELP: count
{ $values { $values
{ "collection" null } { "query" null } { "collection" null }
{ "result" null } { "query" null }
{ "result" null }
} }
{ $description "" } ; { $description "" } ;
HELP: create-collection HELP: create-collection
{ $values { $values
{ "name" null } { "name" null }
} }
{ $description "" } ; { $description "" } ;
HELP: delete HELP: delete
{ $values { $values
{ "collection" null } { "selector" null } { "collection" null }
{ "selector" null }
} }
{ $description "" } ; { $description "" } ;
HELP: delete-unsafe HELP: delete-unsafe
{ $values { $values
{ "collection" null } { "selector" null } { "collection" null }
{ "selector" null }
} }
{ $description "" } ; { $description "" } ;
HELP: desc HELP: desc
{ $values { $values
{ "key" null } { "key" null }
{ "spec" null } { "spec" null }
} }
{ $description "" } ; { $description "" } ;
HELP: drop-collection HELP: drop-collection
{ $values { $values
{ "name" null } { "name" null }
} }
{ $description "" } ; { $description "" } ;
HELP: drop-index HELP: drop-index
{ $values { $values
{ "collection" null } { "name" null } { "collection" null }
{ "name" null }
} }
{ $description "" } ; { $description "" } ;
HELP: ensure-collection HELP: ensure-collection
{ $values { $values
{ "collection" null } { "collection" null }
{ "fq-collection" null } { "fq-collection" null }
} }
{ $description "" } ; { $description "" } ;
HELP: ensure-index HELP: ensure-index
{ $values { $values
{ "collection" null } { "name" null } { "spec" null } { "collection" null }
{ "name" null }
{ "spec" null }
} }
{ $description "" } ; { $description "" } ;
HELP: explain HELP: explain.
{ $values { $values
{ "mdb-query" null } { "mdb-query" null }
{ "result" null }
} }
{ $description "" } ; { $description "" } ;
HELP: find HELP: find
{ $values { $values
{ "mdb-query" null } { "mdb-query" null }
{ "cursor" null } { "result" null } { "cursor" null }
{ "result" null }
} }
{ $description "" } ; { $description "" } ;
HELP: find-one HELP: find-one
{ $values { $values
{ "mdb-query" null } { "mdb-query" null }
{ "result" null } { "result" null }
} }
{ $description "" } ; { $description "" } ;
HELP: get-more HELP: get-more
{ $values { $values
{ "mdb-cursor" null } { "mdb-cursor" null }
{ "mdb-cursor" null } { "objects" null } { "mdb-cursor" null }
{ "objects" null }
} }
{ $description "" } ; { $description "" } ;
HELP: hint HELP: hint
{ $values { $values
{ "mdb-query" null } { "index-hint" null } { "mdb-query" null }
{ "mdb-query" null } { "index-hint" null }
{ "mdb-query" null }
} }
{ $description "" } ; { $description "" } ;
HELP: lasterror HELP: lasterror
{ $values { $values
{ "error" null } { "error" null }
} }
{ $description "" } ; { $description "" } ;
HELP: limit HELP: limit
{ $values { $values
{ "mdb-query" null } { "limit#" null } { "mdb-query" null }
{ "mdb-query" null } { "limit#" null }
{ "mdb-query" null }
} }
{ $description "" } ; { $description "" } ;
HELP: load-collection-list HELP: load-collection-list
{ $values { $values
{ "collection-list" null } { "collection-list" null }
} }
{ $description "" } ; { $description "" } ;
HELP: load-index-list HELP: load-index-list
{ $values { $values
{ "index-list" null } { "index-list" null }
} }
{ $description "" } ; { $description "" } ;
HELP: master>> HELP: master>>
{ $values { $values
{ "mdb" null } { "mdb" null }
{ "inet" null } { "inet" null }
} }
{ $description "" } ; { $description "" } ;
HELP: mdb HELP: mdb
{ $values { $values
{ "mdb" null } { "mdb" null }
} }
{ $description "" } ; { $description "" } ;
HELP: mdb-collection HELP: mdb-collection
{ $values { $var-description "" } ;
{ "value" null }
}
{ $description "" } ;
HELP: mdb-cursor HELP: mdb-cursor
{ $values { $var-description "" } ;
{ "value" null }
}
{ $description "" } ;
HELP: mdb-db HELP: mdb-db
{ $values { $var-description "" } ;
{ "value" null }
}
{ $description "" } ;
HELP: mdb-error HELP: mdb-error
{ $values { $values
{ "id" null } { "msg" null } { "id" null }
{ "msg" null }
} }
{ $description "" } ; { $description "" } ;
HELP: mdb-instance HELP: mdb-instance
{ $values { $var-description "" } ;
{ "value" null }
}
{ $description "" } ;
HELP: mdb-node HELP: mdb-node
{ $var-description "" } ;
HELP: r/
{ $values { $values
{ "token" null }
{ "value" null } { "mdbregexp" null }
} }
{ $description "" } ; { $description "" } ;
HELP: save HELP: save
{ $values { $values
{ "collection" null } { "assoc" assoc } { "collection" null }
{ "assoc" assoc }
} }
{ $description "" } ; { $description "" } ;
HELP: save-unsafe HELP: save-unsafe
{ $values { $values
{ "collection" null } { "object" object } { "collection" null }
{ "object" object }
} }
{ $description "" } ; { $description "" } ;
HELP: skip HELP: skip
{ $values { $values
{ "mdb-query" null } { "skip#" null } { "mdb-query" null }
{ "mdb-query" null } { "skip#" null }
{ "mdb-query" null }
} }
{ $description "" } ; { $description "" } ;
HELP: slave>> HELP: slave>>
{ $values { $values
{ "mdb" null } { "mdb" null }
{ "inet" null } { "inet" null }
} }
{ $description "" } ; { $description "" } ;
HELP: sort HELP: sort
{ $values { $values
{ "mdb-query" null } { "quot" quotation } { "mdb-query" null }
{ "mdb-query" null } { "quot" quotation }
{ "mdb-query" null }
} }
{ $description "" } ; { $description "" } ;
HELP: update HELP: update
{ $values { $values
{ "collection" null } { "selector" null } { "object" object } { "mdb-update-msg" null }
} }
{ $description "" } ; { $description "" } ;
HELP: update-unsafe HELP: update-unsafe
{ $values { $values
{ "collection" null } { "selector" null } { "object" object } { "mdb-update-msg" null }
} }
{ $description "" } ; { $description "" } ;
HELP: validate HELP: validate.
{ $values { $values
{ "collection" null } { "collection" null }
} }
{ $description "" } ; { $description "" } ;
HELP: with-db HELP: with-db
{ $values { $values
{ "mdb" null } { "quot" quotation } { "mdb" null }
{ "..." null } { "quot" quotation }
} }
{ $description "" } ; { $description "" } ;
@ -304,3 +322,4 @@ ARTICLE: "mongodb.driver" "mongodb.driver"
; ;
ABOUT: "mongodb.driver" ABOUT: "mongodb.driver"

78
mongodb/driver/driver.factor
View File

@ -2,7 +2,7 @@ USING: accessors assocs bson.constants bson.writer combinators
constructors continuations destructors formatting fry io constructors continuations destructors formatting fry io
io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs
math math.parser memoize mongodb.msg mongodb.operations namespaces math math.parser memoize mongodb.msg mongodb.operations namespaces
parser sequences sets splitting strings uuid syntax ; parser prettyprint sequences sets splitting strings uuid ;
IN: mongodb.driver IN: mongodb.driver
@ -20,7 +20,6 @@ TUPLE: mdb-collection
{ size integer initial: -1 } { size integer initial: -1 }
{ max integer initial: -1 } ; { max integer initial: -1 } ;
CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTRUCTOR: mdb-collection ( name -- collection ) ;
CONSTANT: MDB-GENERAL-ERROR 1 CONSTANT: MDB-GENERAL-ERROR 1
@ -30,24 +29,6 @@ CONSTANT: DIRTY? "dirty?"
ERROR: mdb-error id msg ; ERROR: mdb-error id msg ;
<PRIVATE
SYMBOL: mdb-socket-stream
: mdb-stream>> ( -- stream )
mdb-socket-stream get ; inline
: check-ok ( result -- ? )
[ "ok" ] dip key? ; inline
: >mdbregexp ( value -- regexp )
first <mdbregexp> ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
SYMBOL: mdb-instance SYMBOL: mdb-instance
: mdb ( -- mdb ) : mdb ( -- mdb )
@ -59,14 +40,39 @@ SYMBOL: mdb-instance
: slave>> ( mdb -- inet ) : slave>> ( mdb -- inet )
nodes>> [ f ] dip at inet>> ; nodes>> [ f ] dip at inet>> ;
: with-db ( mdb quot: ( -- * ) -- * ) <PRIVATE
[ [ '[ ensure-buffer _ [ mdb-instance set ] keep
master>> [ remote-address set ] keep
binary <client> local-address set
mdb-socket-stream set ] ] dip compose
[ mdb-stream>> [ dispose ] when* ]
[ ] cleanup ] with-scope ; inline
CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ;
SYMBOL: mdb-socket-stream
: >>mdb-stream ( stream -- )
mdb-socket-stream set ; inline
: mdb-stream>> ( -- stream )
mdb-socket-stream get ; inline
: check-ok ( result -- ? )
[ "ok" ] dip key? ; inline
: >mdbregexp ( value -- regexp )
first <mdbregexp> ; inline
: prepare-mdb-session ( mdb -- stream )
[ mdb-instance set ] keep
master>> [ remote-address set ] keep
binary <client> local-address set ; inline
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- ... )
[ [ prepare-mdb-session ] dip
[ [ >>mdb-stream ] keep ] prepose
with-disposal ] with-scope ; inline
<PRIVATE <PRIVATE
: index-collection ( -- ns ) : index-collection ( -- ns )
@ -184,7 +190,7 @@ PRIVATE>
MEMO: ensure-collection ( collection -- fq-collection ) MEMO: ensure-collection ( collection -- fq-collection )
"." split1 over mdb name>> = "." split1 over mdb name>> =
[ [ drop ] dip ] [ drop ] if [ nip ] [ drop ] if
[ ] [ reserved-namespace? ] bi [ ] [ reserved-namespace? ] bi
[ [ (ensure-collection) ] keep ] unless [ [ (ensure-collection) ] keep ] unless
[ mdb name>> ] dip "%s.%s" sprintf ; inline [ mdb name>> ] dip "%s.%s" sprintf ; inline
@ -223,9 +229,9 @@ M: mdb-query-msg find
M: mdb-cursor find M: mdb-cursor find
get-more ; get-more ;
GENERIC: explain ( mdb-query -- result ) GENERIC: explain. ( mdb-query -- )
M: mdb-query-msg explain M: mdb-query-msg explain.
t >>explain find [ drop ] dip ; t >>explain find nip . ;
GENERIC: find-one ( mdb-query -- result ) GENERIC: find-one ( mdb-query -- result )
@ -243,14 +249,14 @@ M: assoc count
cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg> cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
find-one objects>> first [ "err" ] dip at ; find-one objects>> first [ "err" ] dip at ;
GENERIC: validate ( collection -- ) GENERIC: validate. ( collection -- )
M: string validate M: string validate.
[ cmd-collection ] dip [ cmd-collection ] dip
"validate" H{ } clone [ set-at ] keep "validate" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one objects>> first [ check-ok ] keep <mdb-query-msg> find-one objects>> first [ check-ok ] keep
'[ "result" _ at print ] when ; '[ "result" _ at print ] when ;
M: mdb-collection validate M: mdb-collection validate.
name>> validate ; name>> validate. ;
<PRIVATE <PRIVATE
@ -312,7 +318,7 @@ M: assoc delete-unsafe
: load-index-list ( -- index-list ) : load-index-list ( -- index-list )
index-collection index-collection
H{ } clone <mdb-query-msg> find [ drop ] dip ; H{ } clone <mdb-query-msg> find nip ;
: drop-collection ( name -- ) : drop-collection ( name -- )
[ cmd-collection ] dip [ cmd-collection ] dip

23
mongodb/operations/operations-docs.factor
View File

@ -1,23 +0,0 @@
! Copyright (C) 2009 Your name.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
IN: mongodb.operations
HELP: read-message
{ $values
{ "message" null }
}
{ $description "" } ;
HELP: write-message
{ $values
{ "message" null }
}
{ $description "" } ;
ARTICLE: "mongodb.operations" "mongodb.operations"
{ $vocab-link "mongodb.operations" }
;
ABOUT: "mongodb.operations"

19
mongodb/operations/operations.factor
View File

@ -1,7 +1,7 @@
USING: accessors bson.reader bson.writer byte-arrays byte-vectors fry USING: accessors assocs bson.reader bson.writer byte-arrays
io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 byte-vectors combinators formatting fry io io.binary io.encodings.private
io.streams.byte-array kernel math mongodb.msg namespaces sequences io.encodings.binary io.encodings.string io.encodings.utf8 io.files
locals assocs combinators linked-assocs ; kernel locals math mongodb.msg namespaces sequences uuid ;
IN: alien.c-types IN: alien.c-types
@ -41,7 +41,7 @@ SYMBOL: msg-bytes-read
: write-byte ( byte -- ) 1 >le write ; inline : write-byte ( byte -- ) 1 >le write ; inline
: write-int32 ( int -- ) 4 >le write ; inline : write-int32 ( int -- ) 4 >le write ; inline
: write-double ( real -- ) double>bits 8 >le write ; inline : write-double ( real -- ) double>bits 8 >le write ; inline
: write-cstring ( string -- ) utf8 encode B{ 0 } append write ; inline : write-cstring ( string -- ) output-stream get utf8 encoder-write 0 write-byte ; inline
: write-longlong ( object -- ) 8 >le write ; inline : write-longlong ( object -- ) 8 >le write ; inline
: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline : read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
@ -150,9 +150,14 @@ PRIVATE>
USE: tools.walker USE: tools.walker
: (write-message) ( message quot -- ) : dump-to-file ( array -- )
[ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
'[ _ write ] with-file-writer ;
: (write-message) ( message quot -- )
'[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
write flush reset-buffer ; inline ! [ dump-to-file ] keep
write flush ; inline
: build-query-object ( query -- selector ) : build-query-object ( query -- selector )
[let | selector [ H{ } clone ] | [let | selector [ H{ } clone ] |