Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
acd0439cf2
|
|
@ -23,7 +23,7 @@ IN: bootstrap.compiler
|
|||
|
||||
"cpu." cpu name>> append require
|
||||
|
||||
enable-compiler
|
||||
enable-optimizer
|
||||
|
||||
! Push all tuple layouts to tenured space to improve method caching
|
||||
gc
|
||||
|
|
|
|||
|
|
@ -4,16 +4,16 @@ compiler.units help.markup help.syntax io parser quotations
|
|||
sequences words ;
|
||||
IN: compiler
|
||||
|
||||
HELP: enable-compiler
|
||||
HELP: enable-optimizer
|
||||
{ $description "Enables the optimizing compiler." } ;
|
||||
|
||||
HELP: disable-compiler
|
||||
HELP: disable-optimizer
|
||||
{ $description "Disable the optimizing compiler." } ;
|
||||
|
||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||
{ $subsection disable-compiler }
|
||||
{ $subsection enable-compiler }
|
||||
{ $subsection disable-optimizer }
|
||||
{ $subsection enable-optimizer }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"Compiling a single quotation:"
|
||||
|
|
|
|||
|
|
@ -192,10 +192,13 @@ M: optimizing-compiler recompile ( words -- alist )
|
|||
compiled get >alist
|
||||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
: with-optimizer ( quot -- )
|
||||
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||
|
||||
: enable-optimizer ( -- )
|
||||
optimizing-compiler compiler-impl set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
: disable-optimizer ( -- )
|
||||
f compiler-impl set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.tests.generic
|
||||
USING: tools.test math kernel compiler.units definitions ;
|
||||
|
||||
GENERIC: bad ( -- )
|
||||
M: integer bad ;
|
||||
M: object bad ;
|
||||
|
||||
[ 0 bad ] must-fail
|
||||
[ "" bad ] must-fail
|
||||
|
||||
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
USING: compiler.units definitions tools.test sequences ;
|
||||
IN: compiler.tests.redefine14
|
||||
|
||||
! TUPLE: bad ;
|
||||
!
|
||||
! M: bad length 1 2 3 ;
|
||||
!
|
||||
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
|
||||
TUPLE: bad ;
|
||||
|
||||
M: bad length 1 2 3 ;
|
||||
|
||||
[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,49 @@
|
|||
IN: compiler.tests.redefine17
|
||||
USING: tools.test classes.mixin compiler.units arrays kernel.private
|
||||
strings sequences vocabs definitions kernel ;
|
||||
|
||||
<< "compiler.tests.redefine17" words forget-all >>
|
||||
|
||||
GENERIC: bong ( a -- b )
|
||||
|
||||
M: array bong ;
|
||||
|
||||
M: string bong length ;
|
||||
|
||||
MIXIN: mixin
|
||||
|
||||
INSTANCE: array mixin
|
||||
|
||||
: blah ( a -- b ) { mixin } declare bong ;
|
||||
|
||||
[ { } ] [ { } blah ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 0 ] [ "" blah ] unit-test
|
||||
|
||||
MIXIN: mixin1
|
||||
|
||||
INSTANCE: string mixin1
|
||||
|
||||
MIXIN: mixin2
|
||||
|
||||
GENERIC: billy ( a -- b )
|
||||
|
||||
M: mixin2 billy ;
|
||||
|
||||
M: array billy drop "BILLY" ;
|
||||
|
||||
INSTANCE: string mixin2
|
||||
|
||||
: bully ( a -- b ) { mixin1 } declare billy ;
|
||||
|
||||
[ "" ] [ "" bully ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "BILLY" ] [ { } bully ] unit-test
|
||||
|
|
@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
|
|||
|
||||
: <value-info> ( -- info ) \ value-info new ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
all-slots
|
||||
[ read-only>> [ drop f ] unless ] 2map
|
||||
f prefix ;
|
||||
|
||||
DEFER: <literal-info>
|
||||
|
||||
: tuple-slot-infos ( tuple -- slots )
|
||||
[ tuple-slots ] [ class all-slots ] bi
|
||||
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
|
||||
f prefix ;
|
||||
|
||||
: init-literal-info ( info -- info )
|
||||
dup literal>> class >>class
|
||||
dup literal>> dup real? [ [a,a] >>interval ] [
|
||||
[ [-inf,inf] >>interval ] dip
|
||||
dup tuple? [
|
||||
[ tuple-slots [ <literal-info> ] map ] [ class ] bi
|
||||
read-only-slots >>slots
|
||||
] [ drop ] if
|
||||
dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
|
||||
] if ; inline
|
||||
|
||||
: init-value-info ( info -- info )
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
|||
compiler.tree.debugger compiler.tree.checker
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals ;
|
||||
math.intervals quotations ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
|
@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
|
|||
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
|
||||
|
||||
[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
|
||||
|
||||
! Mutable tuples with circularity should not cause problems
|
||||
TUPLE: circle me ;
|
||||
|
||||
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
|
||||
|
|
@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ [ literal>> ] map ] dip prefix >tuple
|
||||
<literal-info> ;
|
||||
|
||||
: read-only-slots ( values class -- slots )
|
||||
all-slots
|
||||
[ read-only>> [ value-info ] [ drop f ] if ] 2map
|
||||
f prefix ;
|
||||
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ [ value-info ] map ] dip [ read-only-slots ] keep
|
||||
[ read-only-slots ] keep
|
||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ rest-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
|
|||
check_sse2 ;
|
||||
|
||||
"-no-sse2" (command-line) member? [
|
||||
optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
|
||||
[ { check_sse2 } compile ] with-optimizer
|
||||
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
sse2? [
|
||||
|
|
|
|||
|
|
@ -79,6 +79,13 @@ M: one-word-elt next-elt
|
|||
drop
|
||||
[ f next-word ] modify-col ;
|
||||
|
||||
SINGLETON: word-start-elt
|
||||
|
||||
M: word-start-elt prev-elt
|
||||
drop one-word-elt prev-elt ;
|
||||
|
||||
M: word-start-elt next-elt 2drop ;
|
||||
|
||||
SINGLETON: word-elt
|
||||
|
||||
M: word-elt prev-elt
|
||||
|
|
|
|||
|
|
@ -199,10 +199,10 @@ IN: peg.tests
|
|||
|
||||
USE: compiler
|
||||
|
||||
[ ] [ disable-compiler ] unit-test
|
||||
[ ] [ disable-optimizer ] unit-test
|
||||
|
||||
[ ] [ "" epsilon parse drop ] unit-test
|
||||
|
||||
[ ] [ enable-compiler ] unit-test
|
||||
[ ] [ enable-optimizer ] unit-test
|
||||
|
||||
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,7 +19,6 @@ IN: stack-checker.transforms
|
|||
rstate recursive-state
|
||||
[ word stack quot call-transformer ] with-variable
|
||||
[
|
||||
word inlined-dependency depends-on
|
||||
values [ length meta-d shorten-by ] [ #drop, ] bi
|
||||
rstate infer-quot
|
||||
] [ word infer-word ] if* ;
|
||||
|
|
|
|||
|
|
@ -16,4 +16,5 @@ IN: tools.deploy.test
|
|||
: run-temp-image ( -- )
|
||||
vm
|
||||
"-i=" "test.image" temp-file append
|
||||
2array try-process ;
|
||||
2array
|
||||
<process> swap >>command +closed+ >>stdin try-process ;
|
||||
|
|
@ -74,8 +74,6 @@ SYMBOL: failures
|
|||
|
||||
SYMBOL: changed-vocabs
|
||||
|
||||
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
||||
|
||||
: changed-vocab ( vocab -- )
|
||||
dup vocab changed-vocabs get and
|
||||
[ dup changed-vocabs get set-at ] [ drop ] if ;
|
||||
|
|
@ -287,3 +285,12 @@ MEMO: all-authors ( -- seq )
|
|||
\ all-vocabs-seq reset-memoized
|
||||
\ all-authors reset-memoized
|
||||
\ all-tags reset-memoized ;
|
||||
|
||||
SINGLETON: cache-observer
|
||||
|
||||
M: cache-observer vocabs-changed drop reset-cache ;
|
||||
|
||||
[
|
||||
f changed-vocabs set-global
|
||||
cache-observer add-vocab-observer
|
||||
] "tools.vocabs" add-init-hook
|
||||
|
|
@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30
|
|||
[ slider-max* 1 max ]
|
||||
bi / ;
|
||||
|
||||
: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ;
|
||||
: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ;
|
||||
: slider>screen ( m slider -- n ) slider-scale * ;
|
||||
: screen>slider ( m slider -- n ) slider-scale / ;
|
||||
|
||||
M: slider model-changed nip elevator>> relayout-1 ;
|
||||
|
||||
|
|
@ -133,7 +133,7 @@ elevator H{
|
|||
swap >>orientation ;
|
||||
|
||||
: thumb-loc ( slider -- loc )
|
||||
[ slider-value ] keep slider>screen ;
|
||||
[ slider-value ] keep slider>screen elevator-padding + ;
|
||||
|
||||
: layout-thumb-loc ( thumb slider -- )
|
||||
[ thumb-loc ] [ orientation>> ] bi n*v
|
||||
|
|
|
|||
|
|
@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string )
|
|||
|
||||
M: macosx keysym>string >upper ;
|
||||
|
||||
M: object keysym>string ;
|
||||
M: object keysym>string dup length 1 = [ >lower ] when ;
|
||||
|
||||
M: key-down gesture>string
|
||||
[ mods>> ] [ sym>> ] bi
|
||||
{
|
||||
{ [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
|
||||
{ [ dup " " = ] [ drop "SPACE" ] }
|
||||
[ keysym>string ]
|
||||
[ ]
|
||||
} cond
|
||||
[ modifiers>string ] dip append ;
|
||||
[ modifiers>string ] [ keysym>string ] bi* append ;
|
||||
|
||||
M: button-up gesture>string
|
||||
[
|
||||
|
|
|
|||
|
|
@ -25,7 +25,10 @@ M: browser-gadget set-history-value
|
|||
|
||||
: show-help ( link browser-gadget -- )
|
||||
[ >link ] dip
|
||||
[ [ add-recent ] [ history>> add-history ] bi* ]
|
||||
[
|
||||
2dup model>> value>> =
|
||||
[ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
|
||||
]
|
||||
[ model>> set-model ]
|
||||
2bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ;
|
|||
|
||||
GENERIC: completion-element ( completion-mode -- element )
|
||||
|
||||
M: object completion-element drop one-word-elt ;
|
||||
M: object completion-element drop word-start-elt ;
|
||||
M: history-completion completion-element drop one-line-elt ;
|
||||
|
||||
GENERIC: completion-banner ( completion-mode -- string )
|
||||
|
|
@ -72,13 +72,13 @@ M: vocab-completion row-color
|
|||
drop vocab? COLOR: black COLOR: dark-gray ? ;
|
||||
|
||||
: complete-IN:/USE:? ( tokens -- ? )
|
||||
2 short tail* { "IN:" "USE:" } intersects? ;
|
||||
1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
|
||||
|
||||
: chop-; ( seq -- seq' )
|
||||
{ ";" } split1-last [ ] [ ] ?if ;
|
||||
|
||||
: complete-USING:? ( tokens -- ? )
|
||||
chop-; { "USING:" } intersects? ;
|
||||
chop-; 1 short head* { "USING:" } intersects? ;
|
||||
|
||||
: complete-CHAR:? ( tokens -- ? )
|
||||
2 short tail* "CHAR:" swap member? ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ IN: compiler.units.tests
|
|||
] unit-test
|
||||
|
||||
[ "A" "B" ] [
|
||||
disable-compiler
|
||||
disable-optimizer
|
||||
|
||||
gensym "a" set
|
||||
gensym "b" set
|
||||
|
|
@ -33,7 +33,7 @@ IN: compiler.units.tests
|
|||
] with-compilation-unit
|
||||
"b" get execute
|
||||
|
||||
enable-compiler
|
||||
enable-optimizer
|
||||
] unit-test
|
||||
|
||||
! Check that we notify observers
|
||||
|
|
|
|||
|
|
@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist )
|
|||
! Non-optimizing compiler
|
||||
M: f recompile [ dup def>> ] { } map>assoc ;
|
||||
|
||||
: without-optimizer ( quot -- )
|
||||
[ f compiler-impl ] dip with-variable ; inline
|
||||
|
||||
! Trivial compiler. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
SINGLETON: dummy-compiler
|
||||
|
|
@ -58,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
[ V{ } clone definition-observers set-global ]
|
||||
"compiler.units" add-init-hook
|
||||
|
||||
! This goes here because vocabs cannot depend on init
|
||||
[ V{ } clone vocab-observers set-global ]
|
||||
"vocabs" add-init-hook
|
||||
|
||||
: add-definition-observer ( obj -- )
|
||||
definition-observers get push ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations continuations.private kernel
|
||||
kernel.private sequences assocs namespaces namespaces.private ;
|
||||
kernel.private sequences assocs namespaces namespaces.private
|
||||
continuations continuations.private ;
|
||||
IN: init
|
||||
|
||||
SYMBOL: init-hooks
|
||||
|
|
|
|||
|
|
@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ;
|
|||
|
||||
M: f vocab-main ;
|
||||
|
||||
SYMBOL: vocab-observers
|
||||
|
||||
GENERIC: vocabs-changed ( obj -- )
|
||||
|
||||
: add-vocab-observer ( obj -- )
|
||||
vocab-observers get push ;
|
||||
|
||||
: remove-vocab-observer ( obj -- )
|
||||
vocab-observers get delq ;
|
||||
|
||||
: notify-vocab-observers ( -- )
|
||||
vocab-observers get [ vocabs-changed ] each ;
|
||||
|
||||
: create-vocab ( name -- vocab )
|
||||
dictionary get [ <vocab> ] cache ;
|
||||
dictionary get [ <vocab> ] cache
|
||||
notify-vocab-observers ;
|
||||
|
||||
ERROR: no-vocab name ;
|
||||
|
||||
|
|
@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
|
|||
|
||||
: forget-vocab ( vocab -- )
|
||||
dup words forget-all
|
||||
vocab-name dictionary get delete-at ;
|
||||
vocab-name dictionary get delete-at
|
||||
notify-vocab-observers ;
|
||||
|
||||
M: vocab-spec forget* forget-vocab ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,6 @@
|
|||
USING: vocabs.loader ;
|
||||
|
||||
IN: bson
|
||||
|
||||
"bson.reader" require
|
||||
"bson.writer" require
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
USING: accessors constructors kernel strings uuid ;
|
||||
|
||||
IN: bson.constants
|
||||
|
||||
: <objid> ( -- objid )
|
||||
uuid1 ; inline
|
||||
|
||||
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
|
||||
|
||||
TUPLE: objref ns objid ;
|
||||
|
||||
CONSTRUCTOR: objref ( ns objid -- objref ) ;
|
||||
|
||||
TUPLE: mdbregexp { regexp string } { options string } ;
|
||||
|
||||
: <mdbregexp> ( string -- mdbregexp )
|
||||
[ mdbregexp new ] dip >>regexp ;
|
||||
|
||||
|
||||
CONSTANT: MDB_OID_FIELD "_id"
|
||||
CONSTANT: MDB_META_FIELD "_mfd"
|
||||
|
||||
CONSTANT: T_EOO 0
|
||||
CONSTANT: T_Double 1
|
||||
CONSTANT: T_Integer 16
|
||||
CONSTANT: T_Boolean 8
|
||||
CONSTANT: T_String 2
|
||||
CONSTANT: T_Object 3
|
||||
CONSTANT: T_Array 4
|
||||
CONSTANT: T_Binary 5
|
||||
CONSTANT: T_Undefined 6
|
||||
CONSTANT: T_OID 7
|
||||
CONSTANT: T_Date 9
|
||||
CONSTANT: T_NULL 10
|
||||
CONSTANT: T_Regexp 11
|
||||
CONSTANT: T_DBRef 12
|
||||
CONSTANT: T_Code 13
|
||||
CONSTANT: T_ScopedCode 17
|
||||
CONSTANT: T_Symbol 14
|
||||
CONSTANT: T_JSTypeMax 16
|
||||
CONSTANT: T_MaxKey 127
|
||||
|
||||
CONSTANT: T_Binary_Function 1
|
||||
CONSTANT: T_Binary_Bytes 2
|
||||
CONSTANT: T_Binary_UUID 3
|
||||
CONSTANT: T_Binary_MD5 5
|
||||
CONSTANT: T_Binary_Custom 128
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,200 @@
|
|||
USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
|
||||
io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
|
||||
sequences serialize arrays calendar io.encodings ;
|
||||
|
||||
IN: bson.reader
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: element { type integer } name ;
|
||||
TUPLE: state
|
||||
{ size initial: -1 } { read initial: 0 } exemplar
|
||||
result scope element ;
|
||||
|
||||
: <state> ( exemplar -- state )
|
||||
[ state new ] dip
|
||||
[ clone >>exemplar ] keep
|
||||
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
|
||||
V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
|
||||
|
||||
PREDICATE: bson-eoo < integer T_EOO = ;
|
||||
PREDICATE: bson-not-eoo < integer T_EOO > ;
|
||||
|
||||
PREDICATE: bson-double < integer T_Double = ;
|
||||
PREDICATE: bson-integer < integer T_Integer = ;
|
||||
PREDICATE: bson-string < integer T_String = ;
|
||||
PREDICATE: bson-object < integer T_Object = ;
|
||||
PREDICATE: bson-array < integer T_Array = ;
|
||||
PREDICATE: bson-binary < integer T_Binary = ;
|
||||
PREDICATE: bson-regexp < integer T_Regexp = ;
|
||||
PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
|
||||
PREDICATE: bson-binary-function < integer T_Binary_Function = ;
|
||||
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
|
||||
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
|
||||
PREDICATE: bson-oid < integer T_OID = ;
|
||||
PREDICATE: bson-boolean < integer T_Boolean = ;
|
||||
PREDICATE: bson-date < integer T_Date = ;
|
||||
PREDICATE: bson-null < integer T_NULL = ;
|
||||
PREDICATE: bson-ref < integer T_DBRef = ;
|
||||
|
||||
GENERIC: element-read ( type -- cont? )
|
||||
GENERIC: element-data-read ( type -- object )
|
||||
GENERIC: element-binary-read ( length type -- object )
|
||||
|
||||
: byte-array>number ( seq -- number )
|
||||
byte-array>bignum >integer ; inline
|
||||
|
||||
: get-state ( -- state )
|
||||
state get ; inline
|
||||
|
||||
: count-bytes ( count -- )
|
||||
[ get-state ] dip '[ _ + ] change-read drop ; inline
|
||||
|
||||
: read-int32 ( -- int32 )
|
||||
4 [ read byte-array>number ] [ count-bytes ] bi ; inline
|
||||
|
||||
: read-longlong ( -- longlong )
|
||||
8 [ read byte-array>number ] [ count-bytes ] bi ; inline
|
||||
|
||||
: read-double ( -- double )
|
||||
8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
|
||||
|
||||
: read-byte-raw ( -- byte-raw )
|
||||
1 [ read ] [ count-bytes ] bi ; inline
|
||||
|
||||
: read-byte ( -- byte )
|
||||
read-byte-raw first ; inline
|
||||
|
||||
: read-cstring ( -- string )
|
||||
input-stream get utf8 <decoder>
|
||||
"\0" swap stream-read-until drop ; inline
|
||||
|
||||
: read-sized-string ( length -- string )
|
||||
drop read-cstring ; inline
|
||||
|
||||
: read-element-type ( -- type )
|
||||
read-byte ; inline
|
||||
|
||||
: push-element ( type name -- element )
|
||||
element boa
|
||||
[ get-state element>> push ] keep ; inline
|
||||
|
||||
: pop-element ( -- element )
|
||||
get-state element>> pop ; inline
|
||||
|
||||
: peek-scope ( -- ht )
|
||||
get-state scope>> peek ; inline
|
||||
|
||||
: read-elements ( -- )
|
||||
read-element-type
|
||||
element-read
|
||||
[ read-elements ] when ; inline recursive
|
||||
|
||||
GENERIC: fix-result ( assoc type -- result )
|
||||
|
||||
M: bson-object fix-result ( assoc type -- result )
|
||||
drop ;
|
||||
|
||||
M: bson-array fix-result ( assoc type -- result )
|
||||
drop
|
||||
values ;
|
||||
|
||||
GENERIC: end-element ( type -- )
|
||||
|
||||
M: bson-object end-element ( type -- )
|
||||
drop ;
|
||||
|
||||
M: bson-array end-element ( type -- )
|
||||
drop ;
|
||||
|
||||
M: object end-element ( type -- )
|
||||
drop
|
||||
pop-element drop ;
|
||||
|
||||
M: bson-eoo element-read ( type -- cont? )
|
||||
drop
|
||||
get-state scope>> [ pop ] keep swap ! vec assoc
|
||||
pop-element [ type>> ] keep ! vec assoc element
|
||||
[ fix-result ] dip
|
||||
rot length 0 > ! assoc element
|
||||
[ name>> peek-scope set-at t ]
|
||||
[ drop [ get-state ] dip >>result drop f ] if ;
|
||||
|
||||
M: bson-not-eoo element-read ( type -- cont? )
|
||||
[ peek-scope ] dip ! scope type
|
||||
'[ _ read-cstring push-element [ name>> ] [ type>> ] bi
|
||||
[ element-data-read ] keep
|
||||
end-element
|
||||
swap
|
||||
] dip set-at t ;
|
||||
|
||||
: [scope-changer] ( state -- state quot )
|
||||
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
|
||||
|
||||
: (object-data-read) ( type -- object )
|
||||
drop
|
||||
read-int32 drop
|
||||
get-state
|
||||
[scope-changer] change-scope
|
||||
scope>> peek ; inline
|
||||
|
||||
M: bson-object element-data-read ( type -- object )
|
||||
(object-data-read) ;
|
||||
|
||||
M: bson-array element-data-read ( type -- object )
|
||||
(object-data-read) ;
|
||||
|
||||
M: bson-string element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32 read-sized-string ;
|
||||
|
||||
M: bson-integer element-data-read ( type -- object )
|
||||
drop
|
||||
read-int32 ;
|
||||
|
||||
M: bson-double element-data-read ( type -- double )
|
||||
drop
|
||||
read-double ;
|
||||
|
||||
M: bson-boolean element-data-read ( type -- boolean )
|
||||
drop
|
||||
read-byte 1 = ;
|
||||
|
||||
M: bson-date element-data-read ( type -- timestamp )
|
||||
drop
|
||||
read-longlong millis>timestamp ;
|
||||
|
||||
M: bson-binary element-data-read ( type -- binary )
|
||||
drop
|
||||
read-int32 read-byte element-binary-read ;
|
||||
|
||||
M: bson-regexp element-data-read ( type -- mdbregexp )
|
||||
drop mdbregexp new
|
||||
read-cstring >>regexp read-cstring >>options ;
|
||||
|
||||
M: bson-null element-data-read ( type -- bf )
|
||||
drop
|
||||
f ;
|
||||
|
||||
M: bson-oid element-data-read ( type -- oid )
|
||||
drop
|
||||
read-longlong
|
||||
read-int32 oid boa ;
|
||||
|
||||
M: bson-binary-custom element-binary-read ( size type -- dbref )
|
||||
2drop
|
||||
read-cstring
|
||||
read-cstring objref boa ;
|
||||
|
||||
M: bson-binary-bytes element-binary-read ( size type -- bytes )
|
||||
drop read ;
|
||||
|
||||
M: bson-binary-function element-binary-read ( size type -- quot )
|
||||
drop read bytes>object ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stream>assoc ( exemplar -- assoc bytes-read )
|
||||
<state> dup state
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
[ result>> ] [ read>> ] bi ;
|
||||
|
|
@ -0,0 +1,164 @@
|
|||
! Copyright (C) 2008 Sascha Matzke.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs bson.constants byte-arrays byte-vectors
|
||||
calendar fry io io.binary io.encodings io.encodings.binary
|
||||
io.encodings.utf8 io.streams.byte-array kernel math math.parser
|
||||
namespaces quotations sequences sequences.private serialize strings
|
||||
words combinators.short-circuit literals ;
|
||||
|
||||
IN: bson.writer
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: shared-buffer
|
||||
|
||||
CONSTANT: INT32-SIZE 4
|
||||
CONSTANT: CHAR-SIZE 1
|
||||
CONSTANT: INT64-SIZE 8
|
||||
|
||||
: (buffer) ( -- buffer )
|
||||
shared-buffer get
|
||||
[ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
|
||||
|
||||
: >le-stream ( x n -- )
|
||||
swap
|
||||
'[ _ swap nth-byte 0 B{ 0 }
|
||||
[ set-nth-unsafe ] keep write ] each ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: reset-buffer ( buffer -- )
|
||||
0 >>length drop ; inline
|
||||
|
||||
: ensure-buffer ( -- )
|
||||
(buffer) drop ; inline
|
||||
|
||||
: with-buffer ( quot -- byte-vector )
|
||||
[ (buffer) [ reset-buffer ] keep dup ] dip
|
||||
with-output-stream* dup encoder? [ stream>> ] when ; inline
|
||||
|
||||
: with-length ( quot: ( -- ) -- bytes-written start-index )
|
||||
[ (buffer) [ length ] keep ] dip call
|
||||
length swap [ - ] keep ; inline
|
||||
|
||||
: with-length-prefix ( quot: ( -- ) -- )
|
||||
[ B{ 0 0 0 0 } write ] prepose with-length
|
||||
[ INT32-SIZE >le ] dip (buffer)
|
||||
'[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
|
||||
[ 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
|
||||
|
||||
GENERIC: bson-type? ( obj -- type ) foldable flushable
|
||||
GENERIC: bson-write ( obj -- )
|
||||
|
||||
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
|
||||
|
||||
M: real bson-type? ( real -- type ) drop T_Double ;
|
||||
M: word bson-type? ( word -- type ) drop T_String ;
|
||||
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
|
||||
M: sequence bson-type? ( seq -- type ) drop T_Array ;
|
||||
M: string bson-type? ( string -- type ) drop T_String ;
|
||||
M: integer bson-type? ( integer -- type ) drop T_Integer ;
|
||||
M: assoc bson-type? ( assoc -- type ) drop T_Object ;
|
||||
M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
|
||||
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
|
||||
|
||||
M: oid bson-type? ( word -- type ) drop T_OID ;
|
||||
M: objref bson-type? ( objref -- type ) drop T_Binary ;
|
||||
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
|
||||
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
|
||||
|
||||
: write-utf8-string ( string -- )
|
||||
output-stream get utf8 <encoder> stream-write ; inline
|
||||
|
||||
: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
|
||||
: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
|
||||
: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
|
||||
: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
|
||||
: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline
|
||||
|
||||
: write-eoo ( -- ) T_EOO write-byte ; inline
|
||||
: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
|
||||
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
|
||||
|
||||
M: f bson-write ( f -- )
|
||||
drop 0 write-byte ;
|
||||
|
||||
M: t bson-write ( t -- )
|
||||
drop 1 write-byte ;
|
||||
|
||||
M: string bson-write ( obj -- )
|
||||
'[ _ write-cstring ] with-length-prefix-excl ;
|
||||
|
||||
M: integer bson-write ( num -- )
|
||||
write-int32 ;
|
||||
|
||||
M: real bson-write ( num -- )
|
||||
>float write-double ;
|
||||
|
||||
M: timestamp bson-write ( timestamp -- )
|
||||
timestamp>millis write-longlong ;
|
||||
|
||||
M: byte-array bson-write ( binary -- )
|
||||
[ length write-int32 ] keep
|
||||
T_Binary_Bytes write-byte
|
||||
write ;
|
||||
|
||||
M: quotation bson-write ( quotation -- )
|
||||
object>bytes [ length write-int32 ] keep
|
||||
T_Binary_Function write-byte
|
||||
write ;
|
||||
|
||||
M: oid bson-write ( oid -- )
|
||||
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
|
||||
|
||||
M: objref bson-write ( objref -- )
|
||||
[ binary ] dip
|
||||
'[ _
|
||||
[ ns>> write-cstring ]
|
||||
[ objid>> write-cstring ] bi ] with-byte-writer
|
||||
[ length write-int32 ] keep
|
||||
T_Binary_Custom write-byte write ;
|
||||
|
||||
M: mdbregexp bson-write ( regexp -- )
|
||||
[ regexp>> write-cstring ]
|
||||
[ options>> write-cstring ] bi ;
|
||||
|
||||
M: sequence bson-write ( array -- )
|
||||
'[ _ [ [ write-type ] dip number>string
|
||||
write-cstring bson-write ] each-index
|
||||
write-eoo ] with-length-prefix ;
|
||||
|
||||
: write-oid ( assoc -- )
|
||||
[ MDB_OID_FIELD ] dip at
|
||||
[ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
|
||||
|
||||
: skip-field? ( name -- boolean )
|
||||
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
|
||||
|
||||
M: assoc bson-write ( assoc -- )
|
||||
'[ _ [ write-oid ] keep
|
||||
[ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
|
||||
write-eoo ] with-length-prefix ;
|
||||
|
||||
M: word bson-write name>> bson-write ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: assoc>bv ( assoc -- byte-vector )
|
||||
[ '[ _ bson-write ] with-buffer ] with-scope ; inline
|
||||
|
||||
: assoc>stream ( assoc -- )
|
||||
bson-write ; inline
|
||||
|
||||
: mdb-special-value? ( value -- ? )
|
||||
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
|
||||
[ oid? ] [ byte-array? ] } 1|| ;
|
||||
|
|
@ -0,0 +1,312 @@
|
|||
USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
|
||||
sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
|
||||
accessors words mongodb.driver strings math.parser tools.walker bson.writer
|
||||
tools.continuations ;
|
||||
|
||||
IN: mongodb.benchmark
|
||||
|
||||
SYMBOL: collection
|
||||
|
||||
: get* ( symbol default -- value )
|
||||
[ get ] dip or ; inline
|
||||
|
||||
: ensure-number ( v -- n )
|
||||
dup string? [ string>number ] when ; inline
|
||||
|
||||
: trial-size ( -- size )
|
||||
"per-trial" 5000 get* ensure-number ; inline flushable
|
||||
|
||||
: batch-size ( -- size )
|
||||
"batch-size" 100 get* ensure-number ; inline flushable
|
||||
|
||||
TUPLE: result doc collection index batch lasterror ;
|
||||
|
||||
: <result> ( -- ) result new result set ; inline
|
||||
|
||||
|
||||
CONSTANT: CHECK-KEY f
|
||||
|
||||
CONSTANT: DOC-SMALL H{ }
|
||||
|
||||
CONSTANT: DOC-MEDIUM H{ { "integer" 5 }
|
||||
{ "number" 5.05 }
|
||||
{ "boolean" f }
|
||||
{ "array"
|
||||
{ "test" "benchmark" } } }
|
||||
|
||||
CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
|
||||
{ "total_word_count" 6743 }
|
||||
{ "access_time" f }
|
||||
{ "meta_tags" H{ { "description" "i am a long description string" }
|
||||
{ "author" "Holly Man" }
|
||||
{ "dynamically_created_meta_tag" "who know\n what" } } }
|
||||
{ "page_structure" H{ { "counted_tags" 3450 }
|
||||
{ "no_of_js_attached" 10 }
|
||||
{ "no_of_images" 6 } } }
|
||||
{ "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo"
|
||||
"10gen" "web" "open" "source" "application" "paas"
|
||||
"platform-as-a-service" "technology" "helps"
|
||||
"developers" "focus" "building" "mongodb" "mongo" } } }
|
||||
|
||||
: set-doc ( name -- )
|
||||
[ result ] dip '[ _ >>doc ] change ; inline
|
||||
|
||||
: small-doc ( -- quot )
|
||||
"small" set-doc [ ] ; inline
|
||||
|
||||
: medium-doc ( -- quot )
|
||||
"medium" set-doc [ ] ; inline
|
||||
|
||||
: large-doc ( -- quot )
|
||||
"large" set-doc [ ] ; inline
|
||||
|
||||
: small-doc-prepare ( -- quot: ( i -- doc ) )
|
||||
small-doc drop
|
||||
'[ "x" DOC-SMALL clone [ set-at ] keep ] ;
|
||||
|
||||
: medium-doc-prepare ( -- quot: ( i -- doc ) )
|
||||
medium-doc drop
|
||||
'[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
|
||||
|
||||
: large-doc-prepare ( -- quot: ( i -- doc ) )
|
||||
large-doc drop
|
||||
[ "x" DOC-LARGE clone [ set-at ] keep
|
||||
[ now "access-time" ] dip
|
||||
[ set-at ] keep ] ;
|
||||
|
||||
: (insert) ( quot: ( i -- doc ) collection -- )
|
||||
[ trial-size ] 2dip
|
||||
'[ _ call( i -- doc ) [ _ ] dip
|
||||
result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
|
||||
|
||||
: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
|
||||
[ [ * ] keep 1 range boa ] dip
|
||||
'[ _ call( i -- doc ) ] map ;
|
||||
|
||||
: (insert-batch) ( quot: ( i -- doc ) collection -- )
|
||||
[ trial-size batch-size [ / ] keep ] 2dip
|
||||
'[ _ _ (prepare-batch) [ _ ] dip
|
||||
result get lasterror>> [ save ] [ save-unsafe ] if
|
||||
] each-integer ;
|
||||
|
||||
: bchar ( boolean -- char )
|
||||
[ "t" ] [ "f" ] if ; inline
|
||||
|
||||
: collection-name ( -- collection )
|
||||
collection "benchmark" get*
|
||||
result get doc>>
|
||||
result get index>> bchar
|
||||
"%s-%s-%s" sprintf
|
||||
[ [ result get ] dip >>collection drop ] keep ;
|
||||
|
||||
: prepare-collection ( -- collection )
|
||||
collection-name
|
||||
[ "_x_idx" drop-index ] keep
|
||||
[ drop-collection ] keep
|
||||
[ create-collection ] keep ;
|
||||
|
||||
: prepare-index ( collection -- )
|
||||
"_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
|
||||
|
||||
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
|
||||
prepare-collection
|
||||
result get index>> [ [ prepare-index ] keep ] when
|
||||
result get batch>>
|
||||
[ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
|
||||
|
||||
: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
|
||||
'[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
|
||||
|
||||
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
|
||||
[ 0 ] dip call( i -- doc ) assoc>bv
|
||||
'[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ;
|
||||
|
||||
: check-for-key ( assoc key -- )
|
||||
CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
|
||||
|
||||
: (check-find-result) ( result -- )
|
||||
"x" check-for-key ; inline
|
||||
|
||||
: (find) ( cursor -- )
|
||||
[ find [ (check-find-result) ] each (find) ] when* ; inline recursive
|
||||
|
||||
: find-one ( quot -- quot: ( -- ) )
|
||||
drop
|
||||
[ trial-size
|
||||
collection-name
|
||||
trial-size 2 / "x" H{ } clone [ set-at ] keep
|
||||
'[ _ _ <query> 1 limit (find) ] times ] ;
|
||||
|
||||
: find-all ( quot -- quot: ( -- ) )
|
||||
drop
|
||||
collection-name
|
||||
H{ } clone
|
||||
'[ _ _ <query> (find) ] ;
|
||||
|
||||
: find-range ( quot -- quot: ( -- ) )
|
||||
drop
|
||||
[ trial-size batch-size /i
|
||||
collection-name
|
||||
trial-size 2 / "$gt" H{ } clone [ set-at ] keep
|
||||
[ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
|
||||
"x" H{ } clone [ set-at ] keep
|
||||
'[ _ _ <query> (find) ] times ] ;
|
||||
|
||||
: batch ( -- )
|
||||
result [ t >>batch ] change ; inline
|
||||
|
||||
: index ( -- )
|
||||
result [ t >>index ] change ; inline
|
||||
|
||||
: errcheck ( -- )
|
||||
result [ t >>lasterror ] change ; inline
|
||||
|
||||
: print-result ( time -- )
|
||||
[ result get [ collection>> ] keep
|
||||
[ batch>> bchar ] keep
|
||||
[ index>> bchar ] keep
|
||||
lasterror>> bchar
|
||||
trial-size ] dip
|
||||
1000000 / /i
|
||||
"%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
|
||||
sprintf print flush ;
|
||||
|
||||
: print-separator ( -- )
|
||||
"----------------------------------------------------------------" print flush ; inline
|
||||
|
||||
: print-separator-bold ( -- )
|
||||
"================================================================" print flush ; inline
|
||||
|
||||
: print-header ( -- )
|
||||
trial-size
|
||||
batch-size
|
||||
"MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
|
||||
sprintf print flush
|
||||
print-separator-bold ;
|
||||
|
||||
: with-result ( options quot -- )
|
||||
'[ <result> _ call( options -- time ) print-result ] with-scope ;
|
||||
|
||||
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
|
||||
'[ _ swap _
|
||||
'[ [ [ _ execute( -- quot ) ] dip
|
||||
[ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
|
||||
print-separator ] ;
|
||||
|
||||
: run-serialization-bench ( doc-word-seq feat-seq -- )
|
||||
"Serialization Tests" print
|
||||
print-separator-bold
|
||||
\ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
: run-deserialization-bench ( doc-word-seq feat-seq -- )
|
||||
"Deserialization Tests" print
|
||||
print-separator-bold
|
||||
\ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
: run-insert-bench ( doc-word-seq feat-seq -- )
|
||||
"Insert Tests" print
|
||||
print-separator-bold
|
||||
\ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
: run-find-one-bench ( doc-word-seq feat-seq -- )
|
||||
"Query Tests - Find-One" print
|
||||
print-separator-bold
|
||||
\ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
: run-find-all-bench ( doc-word-seq feat-seq -- )
|
||||
"Query Tests - Find-All" print
|
||||
print-separator-bold
|
||||
\ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
: run-find-range-bench ( doc-word-seq feat-seq -- )
|
||||
"Query Tests - Find-Range" print
|
||||
print-separator-bold
|
||||
\ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
|
||||
|
||||
|
||||
: run-benchmarks ( -- )
|
||||
"db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
|
||||
[ print-header
|
||||
! serialization
|
||||
{ small-doc-prepare medium-doc-prepare
|
||||
large-doc-prepare }
|
||||
{ { } } run-serialization-bench
|
||||
! deserialization
|
||||
{ small-doc-prepare medium-doc-prepare
|
||||
large-doc-prepare }
|
||||
{ { } } run-deserialization-bench
|
||||
! insert
|
||||
{ small-doc-prepare medium-doc-prepare
|
||||
large-doc-prepare }
|
||||
{ { } { index } { errcheck } { index errcheck }
|
||||
{ batch } { batch errcheck } { batch index errcheck }
|
||||
} run-insert-bench
|
||||
! find-one
|
||||
{ small-doc medium-doc large-doc }
|
||||
{ { } { index } } run-find-one-bench
|
||||
! find-all
|
||||
{ small-doc medium-doc large-doc }
|
||||
{ { } { index } } run-find-all-bench
|
||||
! find-range
|
||||
{ small-doc medium-doc large-doc }
|
||||
{ { } { index } } run-find-range-bench
|
||||
] with-db ;
|
||||
|
||||
MAIN: run-benchmarks
|
||||
|
||||
|
|
@ -0,0 +1,146 @@
|
|||
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
|
||||
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
|
||||
arrays hashtables sequences.deep vectors locals ;
|
||||
|
||||
IN: mongodb.connection
|
||||
|
||||
: md5-checksum ( string -- digest )
|
||||
utf8 encode md5 checksum-bytes hex-string ; inline
|
||||
|
||||
TUPLE: mdb-db name username pwd-digest nodes collections ;
|
||||
|
||||
TUPLE: mdb-node master? { address inet } remote ;
|
||||
|
||||
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
|
||||
|
||||
TUPLE: mdb-connection instance node handle remote local ;
|
||||
|
||||
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
||||
|
||||
: check-ok ( result -- errmsg ? )
|
||||
[ [ "errmsg" ] dip at ]
|
||||
[ [ "ok" ] dip at >integer 1 = ] bi ; inline
|
||||
|
||||
: <mdb-db> ( name nodes -- mdb-db )
|
||||
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
|
||||
|
||||
: master-node ( mdb -- node )
|
||||
nodes>> t swap at ;
|
||||
|
||||
: slave-node ( mdb -- node )
|
||||
nodes>> f swap at ;
|
||||
|
||||
: with-connection ( connection quot -- * )
|
||||
[ mdb-connection set ] prepose with-scope ; inline
|
||||
|
||||
: mdb-instance ( -- mdb )
|
||||
mdb-connection get instance>> ; inline
|
||||
|
||||
: index-collection ( -- ns )
|
||||
mdb-instance name>> "%s.system.indexes" sprintf ; inline
|
||||
|
||||
: namespaces-collection ( -- ns )
|
||||
mdb-instance name>> "%s.system.namespaces" sprintf ; inline
|
||||
|
||||
: cmd-collection ( -- ns )
|
||||
mdb-instance name>> "%s.$cmd" sprintf ; inline
|
||||
|
||||
: index-ns ( colname -- index-ns )
|
||||
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
|
||||
|
||||
: send-message ( message -- )
|
||||
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
|
||||
|
||||
: send-query-plain ( query-message -- result )
|
||||
[ mdb-connection get handle>> ] dip
|
||||
'[ _ write-message read-message ] with-stream* ;
|
||||
|
||||
: send-query-1result ( collection assoc -- result )
|
||||
<mdb-query-msg>
|
||||
1 >>return#
|
||||
send-query-plain objects>>
|
||||
[ f ] [ first ] if-empty ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: get-nonce ( -- nonce )
|
||||
cmd-collection H{ { "getnonce" 1 } } send-query-1result
|
||||
[ "nonce" swap at ] [ f ] if* ;
|
||||
|
||||
: auth? ( mdb -- ? )
|
||||
[ username>> ] [ pwd-digest>> ] bi and ;
|
||||
|
||||
: calculate-key-digest ( nonce -- digest )
|
||||
mdb-instance
|
||||
[ username>> ]
|
||||
[ pwd-digest>> ] bi
|
||||
3array concat md5-checksum ; inline
|
||||
|
||||
: build-auth-query ( -- query-assoc )
|
||||
{ "authenticate" 1 }
|
||||
"user" mdb-instance username>> 2array
|
||||
"nonce" get-nonce 2array
|
||||
3array >hashtable
|
||||
[ [ "nonce" ] dip at calculate-key-digest "key" ] keep
|
||||
[ set-at ] keep ;
|
||||
|
||||
: perform-authentication ( -- )
|
||||
cmd-collection build-auth-query send-query-1result
|
||||
check-ok [ drop ] [ throw ] if ; inline
|
||||
|
||||
: authenticate-connection ( mdb-connection -- )
|
||||
[ mdb-connection get instance>> auth?
|
||||
[ perform-authentication ] when
|
||||
] with-connection ; inline
|
||||
|
||||
: open-connection ( mdb-connection node -- mdb-connection )
|
||||
[ >>node ] [ address>> ] bi
|
||||
[ >>remote ] keep binary <client>
|
||||
[ >>handle ] dip >>local ;
|
||||
|
||||
: get-ismaster ( -- result )
|
||||
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
|
||||
|
||||
: split-host-str ( hoststr -- host port )
|
||||
":" split [ first ] [ second string>number ] bi ; inline
|
||||
|
||||
: eval-ismaster-result ( node result -- )
|
||||
[ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
|
||||
[ [ "remote" ] dip at
|
||||
[ split-host-str <inet> f <mdb-node> >>remote ] when*
|
||||
drop ] 2bi ;
|
||||
|
||||
: check-node ( mdb node -- )
|
||||
[ <mdb-connection> &dispose ] dip
|
||||
[ open-connection ] keep swap
|
||||
[ get-ismaster eval-ismaster-result ] with-connection ;
|
||||
|
||||
: nodelist>table ( seq -- assoc )
|
||||
[ [ master?>> ] keep 2array ] map >hashtable ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: verify-nodes ( mdb -- )
|
||||
[ [let* | acc [ V{ } clone ]
|
||||
node1 [ mdb dup master-node [ check-node ] keep ]
|
||||
node2 [ mdb node1 remote>>
|
||||
[ [ check-node ] keep ]
|
||||
[ drop f ] if* ]
|
||||
| node1 [ acc push ] when*
|
||||
node2 [ acc push ] when*
|
||||
mdb acc nodelist>table >>nodes drop
|
||||
]
|
||||
] with-destructors ;
|
||||
|
||||
: mdb-open ( mdb -- mdb-connection )
|
||||
clone [ <mdb-connection> ] keep
|
||||
master-node open-connection
|
||||
[ authenticate-connection ] keep ;
|
||||
|
||||
: mdb-close ( mdb-connection -- )
|
||||
[ dispose f ] change-handle drop ;
|
||||
|
||||
M: mdb-connection dispose
|
||||
mdb-close ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Sascha Matzke
|
||||
|
|
@ -0,0 +1,288 @@
|
|||
! Copyright (C) 2009 Your name.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs help.markup help.syntax kernel quotations ;
|
||||
IN: mongodb.driver
|
||||
|
||||
HELP: <mdb-collection>
|
||||
{ $values
|
||||
{ "name" "name of the collection" }
|
||||
{ "collection" "mdb-collection instance" }
|
||||
}
|
||||
{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" "" } }
|
||||
{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ;
|
||||
|
||||
HELP: <mdb>
|
||||
{ $values
|
||||
{ "db" "name of the database to use" }
|
||||
{ "host" "host name or IP address" }
|
||||
{ "port" "port number" }
|
||||
{ "mdb" "mdb-db instance" }
|
||||
}
|
||||
{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 <mdb>" "" } } ;
|
||||
|
||||
HELP: <query>
|
||||
{ $values
|
||||
{ "collection" "collection to query" }
|
||||
{ "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."
|
||||
"For more see: "
|
||||
{ $link with-db } }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: mongodb.driver ;" "\"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" }
|
||||
{ "mdb-update-msg" "mdb-update-msg instance" }
|
||||
}
|
||||
{ $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" "a mdb-update-msg" }
|
||||
{ "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
|
||||
}
|
||||
{ $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" "partial?" }
|
||||
}
|
||||
{ $description "key which refers to a partially loaded object" } ;
|
||||
|
||||
HELP: asc
|
||||
{ $values
|
||||
{ "key" "sort key" }
|
||||
{ "spec" "sort spec" }
|
||||
}
|
||||
{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
|
||||
|
||||
HELP: count
|
||||
{ $values
|
||||
{ "mdb-query-msg" "query" }
|
||||
{ "result" "number of objects in the collection that match the query" }
|
||||
}
|
||||
{ $description "count objects in a collection" } ;
|
||||
|
||||
HELP: create-collection
|
||||
{ $values
|
||||
{ "name" "collection name" }
|
||||
}
|
||||
{ $description "Creates a new collection with the given name." } ;
|
||||
|
||||
HELP: delete
|
||||
{ $values
|
||||
{ "collection" "a collection" }
|
||||
{ "selector" "assoc which identifies the objects to be removed from the collection" }
|
||||
}
|
||||
{ $description "removes objects from the collection (with lasterror check)" } ;
|
||||
|
||||
HELP: delete-unsafe
|
||||
{ $values
|
||||
{ "collection" "a collection" }
|
||||
{ "selector" "assoc which identifies the objects to be removed from the collection" }
|
||||
}
|
||||
{ $description "removes objects from the collection (without error check)" } ;
|
||||
|
||||
HELP: desc
|
||||
{ $values
|
||||
{ "key" "sort key" }
|
||||
{ "spec" "sort spec" }
|
||||
}
|
||||
{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
|
||||
|
||||
HELP: drop-collection
|
||||
{ $values
|
||||
{ "name" "a collection" }
|
||||
}
|
||||
{ $description "removes the collection and all objects in it from the database" } ;
|
||||
|
||||
HELP: drop-index
|
||||
{ $values
|
||||
{ "collection" "a collection" }
|
||||
{ "name" "an index name" }
|
||||
}
|
||||
{ $description "drops the specified index from the collection" } ;
|
||||
|
||||
HELP: ensure-collection
|
||||
{ $values
|
||||
{ "name" "a collection; e.g. mycollection " }
|
||||
}
|
||||
{ $description "ensures that the collection exists in the database" } ;
|
||||
|
||||
HELP: ensure-index
|
||||
{ $values
|
||||
{ "index-spec" "an index specification" }
|
||||
}
|
||||
{ $description "Ensures the existence of the given index. "
|
||||
"For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: mongodb.driver ;"
|
||||
"\"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" "" } } ;
|
||||
|
||||
HELP: explain.
|
||||
{ $values
|
||||
{ "mdb-query-msg" "a query message" }
|
||||
}
|
||||
{ $description "Prints the execution plan for the given query" } ;
|
||||
|
||||
HELP: find
|
||||
{ $values
|
||||
{ "selector" "a mdb-query or mdb-cursor" }
|
||||
{ "mdb-cursor/f" "a cursor (if there are more results) or f" }
|
||||
{ "seq" "a sequences of objects" }
|
||||
}
|
||||
{ $description "executes the given query" }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: mongodb.driver ;"
|
||||
"\"db\" \"127.0.0.1\" 27017 <mdb>"
|
||||
"[ \"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find ] with-db" "" } } ;
|
||||
|
||||
HELP: find-one
|
||||
{ $values
|
||||
{ "mdb-query-msg" "a query" }
|
||||
{ "result/f" "a single object or f" }
|
||||
}
|
||||
{ $description "Executes the query and returns one object at most" } ;
|
||||
|
||||
HELP: hint
|
||||
{ $values
|
||||
{ "mdb-query-msg" "a query" }
|
||||
{ "index-hint" "a hint to an index" }
|
||||
{ "mdb-query-msg" "modified query object" }
|
||||
}
|
||||
{ $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
|
||||
{ $unchecked-example "USING: mongodb.driver ;"
|
||||
"\"db\" \"127.0.0.1\" 27017 <mdb>"
|
||||
"[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find ] with-db" "" } } ;
|
||||
|
||||
HELP: lasterror
|
||||
{ $values
|
||||
|
||||
{ "error" "error message or f" }
|
||||
}
|
||||
{ $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-msg" "a query" }
|
||||
{ "limit#" "number of objects that should be returned at most" }
|
||||
{ "mdb-query-msg" "modified query object" }
|
||||
}
|
||||
{ $description "Limits the number of returned objects to limit#" }
|
||||
{ $examples
|
||||
{ $unchecked-example "USING: mongodb.driver ;"
|
||||
"\"db\" \"127.0.0.1\" 27017 <mdb>"
|
||||
"[ \"mycollection\" H{ } <query> 10 limit find ] with-db" "" } } ;
|
||||
|
||||
HELP: load-collection-list
|
||||
{ $values
|
||||
|
||||
{ "collection-list" "list of collections in the current database" }
|
||||
}
|
||||
{ $description "Returns a list of all collections that exist in the current database" } ;
|
||||
|
||||
HELP: load-index-list
|
||||
{ $values
|
||||
|
||||
{ "index-list" "list of indexes" }
|
||||
}
|
||||
{ $description "Returns a list of all indexes that exist in the current database" } ;
|
||||
|
||||
HELP: mdb-collection
|
||||
{ $var-description "MongoDB collection" } ;
|
||||
|
||||
HELP: mdb-cursor
|
||||
{ $var-description "MongoDB cursor" } ;
|
||||
|
||||
HELP: mdb-error
|
||||
{ $values
|
||||
{ "msg" "error message" }
|
||||
}
|
||||
{ $description "error class" } ;
|
||||
|
||||
HELP: r/
|
||||
{ $values
|
||||
{ "token" "a regexp string" }
|
||||
{ "mdbregexp" "a mdbregexp tuple instance" }
|
||||
}
|
||||
{ $description "creates a new mdbregexp instance" } ;
|
||||
|
||||
HELP: save
|
||||
{ $values
|
||||
{ "collection" "a collection" }
|
||||
{ "assoc" "object" }
|
||||
}
|
||||
{ $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
|
||||
{ "collection" "a collection" }
|
||||
{ "assoc" "object" }
|
||||
}
|
||||
{ $description "Save the object to the given collection without automatic error check" } ;
|
||||
|
||||
HELP: skip
|
||||
{ $values
|
||||
{ "mdb-query-msg" "a query message" }
|
||||
{ "skip#" "number of objects to skip" }
|
||||
{ "mdb-query-msg" "annotated query message" }
|
||||
}
|
||||
{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
|
||||
|
||||
HELP: sort
|
||||
{ $values
|
||||
{ "mdb-query-msg" "a query message" }
|
||||
{ "sort-quot" "a quotation with sort specifiers" }
|
||||
{ "mdb-query-msg" "annotated query message" }
|
||||
}
|
||||
{ $description "annotates the query message for sort specifiers" } ;
|
||||
|
||||
HELP: update
|
||||
{ $values
|
||||
{ "mdb-update-msg" "a mdb-update message" }
|
||||
}
|
||||
{ $description "performs an update" } ;
|
||||
|
||||
HELP: update-unsafe
|
||||
{ $values
|
||||
{ "mdb-update-msg" "a mdb-update message" }
|
||||
}
|
||||
{ $description "performs an update without automatic error check" } ;
|
||||
|
||||
HELP: validate.
|
||||
{ $values
|
||||
{ "collection" "collection to validate" }
|
||||
}
|
||||
{ $description "validates the collection" } ;
|
||||
|
||||
HELP: with-db
|
||||
{ $values
|
||||
{ "mdb" "mdb instance" }
|
||||
{ "quot" "quotation to execute with the given mdb instance as context" }
|
||||
}
|
||||
{ $description "executes a quotation with the given mdb instance in its context" } ;
|
||||
|
||||
ARTICLE: "mongodb.driver" "MongoDB factor driver"
|
||||
{ $vocab-link "mongodb.driver" }
|
||||
;
|
||||
|
||||
ABOUT: "mongodb.driver"
|
||||
|
||||
|
|
@ -0,0 +1,305 @@
|
|||
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 ;
|
||||
|
||||
IN: mongodb.driver
|
||||
|
||||
TUPLE: mdb-pool < pool mdb ;
|
||||
|
||||
TUPLE: mdb-cursor id query ;
|
||||
|
||||
TUPLE: mdb-collection
|
||||
{ name string }
|
||||
{ capped boolean initial: f }
|
||||
{ size integer initial: -1 }
|
||||
{ max integer initial: -1 } ;
|
||||
|
||||
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> ] dip >>mdb ; inline
|
||||
|
||||
CONSTANT: PARTIAL? "partial?"
|
||||
|
||||
ERROR: mdb-error msg ;
|
||||
|
||||
: >pwd-digest ( user password -- digest )
|
||||
"mongo" swap 3array ":" join md5-checksum ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
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
|
||||
|
||||
GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
|
||||
|
||||
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 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 ( 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 ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
|
||||
[ send-query-plain ] keep
|
||||
verify-query-result
|
||||
[ collection>> >>collection drop ]
|
||||
[ return#>> >>requested# ]
|
||||
[ make-cursor ] 2tri
|
||||
swap objects>> ;
|
||||
|
||||
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
|
||||
[ 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 ;
|
||||
|
||||
: load-collection-list ( -- collection-list )
|
||||
namespaces-collection
|
||||
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: ensure-valid-collection-name ( collection -- )
|
||||
[ ";$." intersect length 0 > ] keep
|
||||
'[ _ "%s contains invalid characters ( . $ ; )" sprintf 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 ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: fix-query-collection ( mdb-query -- mdb-query )
|
||||
[ check-collection ] change-collection ; inline
|
||||
|
||||
GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
|
||||
|
||||
M: mdb-cursor get-more
|
||||
[ [ query>> dup [ collection>> ] [ return#>> ] bi ]
|
||||
[ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
|
||||
[ f f ] if* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <query> ( collection assoc -- mdb-query-msg )
|
||||
<mdb-query-msg> ; inline
|
||||
|
||||
GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
|
||||
|
||||
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 ( selector -- mdb-cursor/f seq )
|
||||
|
||||
M: mdb-query-msg find
|
||||
fix-query-collection send-query ;
|
||||
|
||||
M: mdb-cursor find
|
||||
get-more ;
|
||||
|
||||
GENERIC: explain. ( mdb-query-msg -- )
|
||||
|
||||
M: mdb-query-msg explain.
|
||||
t >>explain find nip . ;
|
||||
|
||||
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-msg -- result )
|
||||
|
||||
M: mdb-query-msg count
|
||||
[ collection>> "count" H{ } clone [ set-at ] keep ] keep
|
||||
query>> [ over [ "query" ] dip set-at ] when*
|
||||
[ cmd-collection ] dip <mdb-query-msg> find-one
|
||||
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
|
||||
|
||||
: lasterror ( -- error )
|
||||
cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
|
||||
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-error ] when* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: save ( collection assoc -- )
|
||||
M: assoc save
|
||||
[ check-collection ] dip
|
||||
<mdb-insert-msg> send-message-check-error ;
|
||||
|
||||
GENERIC: save-unsafe ( collection assoc -- )
|
||||
M: assoc save-unsafe
|
||||
[ check-collection ] dip
|
||||
<mdb-insert-msg> send-message ;
|
||||
|
||||
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
|
||||
[ [ "index" ] dip set-at ] keep
|
||||
[ [ "deleteIndexes" ] dip set-at ] keep
|
||||
[ cmd-collection ] dip <mdb-query-msg>
|
||||
find-one drop ;
|
||||
|
||||
: <update> ( collection selector object -- mdb-update-msg )
|
||||
[ check-collection ] 2dip <mdb-update-msg> ;
|
||||
|
||||
: >upsert ( mdb-update-msg -- mdb-update-msg )
|
||||
1 >>upsert? ;
|
||||
|
||||
GENERIC: update ( mdb-update-msg -- )
|
||||
M: mdb-update-msg update
|
||||
send-message-check-error ;
|
||||
|
||||
GENERIC: update-unsafe ( mdb-update-msg -- )
|
||||
M: mdb-update-msg update-unsafe
|
||||
send-message ;
|
||||
|
||||
GENERIC: delete ( collection selector -- )
|
||||
M: assoc delete
|
||||
[ check-collection ] dip
|
||||
<mdb-delete-msg> send-message-check-error ;
|
||||
|
||||
GENERIC: delete-unsafe ( collection selector -- )
|
||||
M: assoc delete-unsafe
|
||||
[ check-collection ] dip
|
||||
<mdb-delete-msg> send-message ;
|
||||
|
||||
: load-index-list ( -- index-list )
|
||||
index-collection
|
||||
H{ } clone <mdb-query-msg> find nip ;
|
||||
|
||||
: ensure-collection ( name -- )
|
||||
check-collection drop ;
|
||||
|
||||
: drop-collection ( name -- )
|
||||
[ cmd-collection ] dip
|
||||
"drop" H{ } clone [ set-at ] keep
|
||||
<mdb-query-msg> find-one drop ;
|
||||
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
A driver for the MongoDB document-oriented database (http://www.mongodb.org)
|
||||
|
|
@ -0,0 +1 @@
|
|||
database
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
USING: accessors fry io io.encodings.binary io.servers.connection
|
||||
io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
|
||||
namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
|
||||
json.writer mongodb.operations.private mongodb.operations ;
|
||||
|
||||
IN: mongodb.mmm
|
||||
|
||||
SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
|
||||
|
||||
GENERIC: dump-message ( message -- )
|
||||
|
||||
: check-options ( -- )
|
||||
mmm-port get [ 27040 mmm-port set ] unless
|
||||
mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
|
||||
mmm-server-port get [ 27017 mmm-server-port set ] unless
|
||||
mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
|
||||
|
||||
: read-msg-binary ( -- )
|
||||
read-int32
|
||||
[ write-int32 ] keep
|
||||
4 - read write ;
|
||||
|
||||
: read-request-header ( -- msg-stub )
|
||||
mdb-msg new
|
||||
read-int32 MSG-HEADER-SIZE - >>length
|
||||
read-int32 >>req-id
|
||||
read-int32 >>resp-id
|
||||
read-int32 >>opcode ;
|
||||
|
||||
: read-request ( -- msg-stub binary )
|
||||
binary [ read-msg-binary ] with-byte-writer
|
||||
[ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
|
||||
|
||||
: dump-request ( msg-stub binary -- )
|
||||
[ mmm-dump-output get ] 2dip
|
||||
'[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
|
||||
|
||||
: read-reply ( -- binary )
|
||||
binary [ read-msg-binary ] with-byte-writer ;
|
||||
|
||||
: forward-request-read-reply ( msg-stub binary -- binary )
|
||||
[ mmm-server get binary ] 2dip
|
||||
'[ _ opcode>> _ write flush
|
||||
OP_Query =
|
||||
[ read-reply ]
|
||||
[ f ] if ] with-client ;
|
||||
|
||||
: dump-reply ( binary -- )
|
||||
[ mmm-dump-output get ] dip
|
||||
'[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
|
||||
|
||||
: message-prefix ( message -- prefix message )
|
||||
[ now timestamp>http-string ] dip
|
||||
[ class name>> ] keep
|
||||
[ "%s: %s" sprintf ] dip ; inline
|
||||
|
||||
M: mdb-query-msg dump-message ( message -- )
|
||||
message-prefix
|
||||
[ collection>> ] keep
|
||||
query>> >json
|
||||
"%s -> %s: %s \n" printf ;
|
||||
|
||||
M: mdb-insert-msg dump-message ( message -- )
|
||||
message-prefix
|
||||
[ collection>> ] keep
|
||||
objects>> >json
|
||||
"%s -> %s : %s \n" printf ;
|
||||
|
||||
M: mdb-reply-msg dump-message ( message -- )
|
||||
message-prefix
|
||||
[ cursor>> ] keep
|
||||
[ start#>> ] keep
|
||||
[ returned#>> ] keep
|
||||
objects>> >json
|
||||
"%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
|
||||
|
||||
M: mdb-msg dump-message ( message -- )
|
||||
message-prefix drop "%s \n" printf ;
|
||||
|
||||
: forward-reply ( binary -- )
|
||||
write flush ;
|
||||
|
||||
: handle-mmm-connection ( -- )
|
||||
read-request
|
||||
[ dump-request ] 2keep
|
||||
forward-request-read-reply
|
||||
[ dump-reply ] keep
|
||||
forward-reply ;
|
||||
|
||||
: start-mmm-server ( -- )
|
||||
output-stream get mmm-dump-output set
|
||||
<threaded-server> [ mmm-t-srv set ] keep
|
||||
"127.0.0.1" mmm-port get <inet4> >>insecure
|
||||
binary >>encoding
|
||||
[ handle-mmm-connection ] >>handler
|
||||
start-server* ;
|
||||
|
||||
: run-mmm ( -- )
|
||||
check-options
|
||||
start-mmm-server ;
|
||||
|
||||
MAIN: run-mmm
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
USING: accessors assocs hashtables constructors kernel linked-assocs math
|
||||
sequences strings ;
|
||||
|
||||
IN: mongodb.msg
|
||||
|
||||
CONSTANT: OP_Reply 1
|
||||
CONSTANT: OP_Message 1000
|
||||
CONSTANT: OP_Update 2001
|
||||
CONSTANT: OP_Insert 2002
|
||||
CONSTANT: OP_Query 2004
|
||||
CONSTANT: OP_GetMore 2005
|
||||
CONSTANT: OP_Delete 2006
|
||||
CONSTANT: OP_KillCursors 2007
|
||||
|
||||
CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
|
||||
CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
|
||||
CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
|
||||
|
||||
TUPLE: mdb-msg
|
||||
{ opcode integer }
|
||||
{ req-id integer initial: 0 }
|
||||
{ resp-id integer initial: 0 }
|
||||
{ length integer initial: 0 }
|
||||
{ flags integer initial: 0 } ;
|
||||
|
||||
TUPLE: mdb-query-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ skip# integer initial: 0 }
|
||||
{ return# integer initial: 0 }
|
||||
{ query assoc }
|
||||
{ returnfields assoc }
|
||||
{ orderby sequence }
|
||||
explain hint ;
|
||||
|
||||
TUPLE: mdb-insert-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ objects sequence } ;
|
||||
|
||||
TUPLE: mdb-update-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ upsert? integer initial: 0 }
|
||||
{ selector assoc }
|
||||
{ object assoc } ;
|
||||
|
||||
TUPLE: mdb-delete-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ selector assoc } ;
|
||||
|
||||
TUPLE: mdb-getmore-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ return# integer initial: 0 }
|
||||
{ cursor integer initial: 0 }
|
||||
{ query mdb-query-msg } ;
|
||||
|
||||
TUPLE: mdb-killcursors-msg < mdb-msg
|
||||
{ cursors# integer initial: 0 }
|
||||
{ cursors sequence } ;
|
||||
|
||||
TUPLE: mdb-reply-msg < mdb-msg
|
||||
{ collection string }
|
||||
{ cursor integer initial: 0 }
|
||||
{ start# integer initial: 0 }
|
||||
{ requested# integer initial: 0 }
|
||||
{ returned# integer initial: 0 }
|
||||
{ objects sequence } ;
|
||||
|
||||
|
||||
CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
|
||||
OP_GetMore >>opcode ; inline
|
||||
|
||||
CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg )
|
||||
OP_Delete >>opcode ; inline
|
||||
|
||||
CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg )
|
||||
OP_Query >>opcode ; inline
|
||||
|
||||
GENERIC: <mdb-killcursors-msg> ( object -- mdb-killcursors-msg )
|
||||
|
||||
M: sequence <mdb-killcursors-msg> ( sequences -- mdb-killcursors-msg )
|
||||
[ mdb-killcursors-msg new ] dip
|
||||
[ length >>cursors# ] keep
|
||||
>>cursors OP_KillCursors >>opcode ; inline
|
||||
|
||||
M: integer <mdb-killcursors-msg> ( integer -- mdb-killcursors-msg )
|
||||
V{ } clone [ push ] keep <mdb-killcursors-msg> ;
|
||||
|
||||
GENERIC: <mdb-insert-msg> ( collection objects -- mdb-insert-msg )
|
||||
|
||||
M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
|
||||
[ mdb-insert-msg new ] 2dip
|
||||
[ >>collection ] dip
|
||||
>>objects OP_Insert >>opcode ;
|
||||
|
||||
M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
|
||||
[ mdb-insert-msg new ] 2dip
|
||||
[ >>collection ] dip
|
||||
V{ } clone tuck push
|
||||
>>objects OP_Insert >>opcode ;
|
||||
|
||||
|
||||
CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg )
|
||||
OP_Update >>opcode ; inline
|
||||
|
||||
CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline
|
||||
|
||||
|
|
@ -0,0 +1,222 @@
|
|||
USING: accessors assocs bson.reader bson.writer byte-arrays
|
||||
byte-vectors combinators formatting fry io io.binary io.encodings.private
|
||||
io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
|
||||
kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
|
||||
|
||||
IN: alien.c-types
|
||||
|
||||
M: byte-vector byte-length length ;
|
||||
|
||||
IN: mongodb.operations
|
||||
|
||||
<PRIVATE
|
||||
|
||||
PREDICATE: mdb-reply-op < integer OP_Reply = ;
|
||||
PREDICATE: mdb-query-op < integer OP_Query = ;
|
||||
PREDICATE: mdb-insert-op < integer OP_Insert = ;
|
||||
PREDICATE: mdb-update-op < integer OP_Update = ;
|
||||
PREDICATE: mdb-delete-op < integer OP_Delete = ;
|
||||
PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
|
||||
PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: write-message ( message -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: MSG-HEADER-SIZE 16
|
||||
|
||||
SYMBOL: msg-bytes-read
|
||||
|
||||
: bytes-read> ( -- integer )
|
||||
msg-bytes-read get ; inline
|
||||
|
||||
: >bytes-read ( integer -- )
|
||||
msg-bytes-read set ; inline
|
||||
|
||||
: change-bytes-read ( integer -- )
|
||||
bytes-read> [ 0 ] unless* + >bytes-read ; inline
|
||||
|
||||
: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
|
||||
: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline
|
||||
: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
|
||||
: read-byte ( -- byte ) read-byte-raw first ; inline
|
||||
|
||||
: (read-cstring) ( acc -- )
|
||||
[ read-byte ] dip ! b acc
|
||||
2dup push ! b acc
|
||||
[ 0 = ] dip ! bool acc
|
||||
'[ _ (read-cstring) ] unless ; inline recursive
|
||||
|
||||
: read-cstring ( -- string )
|
||||
BV{ } clone
|
||||
[ (read-cstring) ] keep
|
||||
[ zero? ] trim-tail
|
||||
>byte-array utf8 decode ; inline
|
||||
|
||||
GENERIC: (read-message) ( message opcode -- message )
|
||||
|
||||
: copy-header ( message msg-stub -- message )
|
||||
[ length>> ] keep [ >>length ] dip
|
||||
[ req-id>> ] keep [ >>req-id ] dip
|
||||
[ resp-id>> ] keep [ >>resp-id ] dip
|
||||
[ opcode>> ] keep [ >>opcode ] dip
|
||||
flags>> >>flags ;
|
||||
|
||||
M: mdb-query-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-query-msg new ] dip copy-header
|
||||
read-cstring >>collection
|
||||
read-int32 >>skip#
|
||||
read-int32 >>return#
|
||||
H{ } stream>assoc change-bytes-read >>query
|
||||
dup length>> bytes-read> >
|
||||
[ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
|
||||
|
||||
M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-insert-msg new ] dip copy-header
|
||||
read-cstring >>collection
|
||||
V{ } clone >>objects
|
||||
[ '[ _ length>> bytes-read> > ] ] keep tuck
|
||||
'[ H{ } stream>assoc change-bytes-read _ objects>> push ]
|
||||
while ;
|
||||
|
||||
M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-delete-msg new ] dip copy-header
|
||||
read-cstring >>collection
|
||||
H{ } stream>assoc change-bytes-read >>selector ;
|
||||
|
||||
M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-getmore-msg new ] dip copy-header
|
||||
read-cstring >>collection
|
||||
read-int32 >>return#
|
||||
read-longlong >>cursor ;
|
||||
|
||||
M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-killcursors-msg new ] dip copy-header
|
||||
read-int32 >>cursors#
|
||||
V{ } clone >>cursors
|
||||
[ [ cursors#>> ] keep
|
||||
'[ read-longlong _ cursors>> push ] times ] keep ;
|
||||
|
||||
M: mdb-update-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ mdb-update-msg new ] dip copy-header
|
||||
read-cstring >>collection
|
||||
read-int32 >>upsert?
|
||||
H{ } stream>assoc change-bytes-read >>selector
|
||||
H{ } stream>assoc change-bytes-read >>object ;
|
||||
|
||||
M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
[ <mdb-reply-msg> ] dip copy-header
|
||||
read-longlong >>cursor
|
||||
read-int32 >>start#
|
||||
read-int32 [ >>returned# ] keep
|
||||
[ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
|
||||
|
||||
: read-header ( message -- message )
|
||||
read-int32 >>length
|
||||
read-int32 >>req-id
|
||||
read-int32 >>resp-id
|
||||
read-int32 >>opcode
|
||||
read-int32 >>flags ; inline
|
||||
|
||||
: write-header ( message -- )
|
||||
[ req-id>> write-int32 ] keep
|
||||
[ resp-id>> write-int32 ] keep
|
||||
opcode>> write-int32 ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: read-message ( -- message )
|
||||
mdb-msg new
|
||||
0 >bytes-read
|
||||
read-header
|
||||
[ ] [ opcode>> ] bi (read-message) ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
USE: tools.walker
|
||||
|
||||
: 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
|
||||
! [ dump-to-file ] keep
|
||||
write flush ; inline
|
||||
|
||||
: build-query-object ( query -- selector )
|
||||
[let | selector [ H{ } clone ] |
|
||||
{ [ orderby>> [ "orderby" selector set-at ] when* ]
|
||||
[ explain>> [ "$explain" selector set-at ] when* ]
|
||||
[ hint>> [ "$hint" selector set-at ] when* ]
|
||||
[ query>> "query" selector set-at ]
|
||||
} cleave
|
||||
selector
|
||||
] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: mdb-query-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ collection>> write-cstring ] keep
|
||||
[ skip#>> write-int32 ] keep
|
||||
[ return#>> write-int32 ] keep
|
||||
[ build-query-object assoc>stream ] keep
|
||||
returnfields>> [ assoc>stream ] when*
|
||||
] (write-message) ;
|
||||
|
||||
M: mdb-insert-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ collection>> write-cstring ] keep
|
||||
objects>> [ assoc>stream ] each
|
||||
] (write-message) ;
|
||||
|
||||
M: mdb-update-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ collection>> write-cstring ] keep
|
||||
[ upsert?>> write-int32 ] keep
|
||||
[ selector>> assoc>stream ] keep
|
||||
object>> assoc>stream
|
||||
] (write-message) ;
|
||||
|
||||
M: mdb-delete-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ collection>> write-cstring ] keep
|
||||
0 write-int32
|
||||
selector>> assoc>stream
|
||||
] (write-message) ;
|
||||
|
||||
M: mdb-getmore-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ collection>> write-cstring ] keep
|
||||
[ return#>> write-int32 ] keep
|
||||
cursor>> write-longlong
|
||||
] (write-message) ;
|
||||
|
||||
M: mdb-killcursors-msg write-message ( message -- )
|
||||
dup
|
||||
'[ _
|
||||
[ flags>> write-int32 ] keep
|
||||
[ cursors#>> write-int32 ] keep
|
||||
cursors>> [ write-longlong ] each
|
||||
] (write-message) ;
|
||||
|
||||
|
|
@ -0,0 +1,117 @@
|
|||
|
||||
USING: accessors arrays assocs bson.constants classes classes.tuple
|
||||
combinators continuations fry kernel mongodb.driver sequences strings
|
||||
vectors words combinators.smart literals ;
|
||||
|
||||
IN: mongodb.tuple
|
||||
|
||||
SINGLETONS: +transient+ +load+ ;
|
||||
|
||||
IN: mongodb.tuple.collection
|
||||
|
||||
FROM: mongodb.tuple => +transient+ +load+ ;
|
||||
|
||||
MIXIN: mdb-persistent
|
||||
|
||||
SLOT: _id
|
||||
SLOT: _mfd
|
||||
|
||||
TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
|
||||
|
||||
GENERIC: tuple-collection ( object -- mdb-collection )
|
||||
|
||||
GENERIC: mdb-slot-map ( tuple -- string )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: MDB_COLLECTION "_mdb_col"
|
||||
CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list"
|
||||
CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
|
||||
|
||||
: (mdb-collection) ( class -- mdb-collection )
|
||||
dup MDB_COLLECTION word-prop
|
||||
[ nip ]
|
||||
[ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
|
||||
|
||||
: (mdb-slot-map) ( class -- slot-defs )
|
||||
superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
|
||||
|
||||
: split-optl ( seq -- key options )
|
||||
[ first ] [ rest ] bi ; inline
|
||||
|
||||
: opt>assoc ( seq -- assoc )
|
||||
[ dup assoc?
|
||||
[ 1array { "" } append ] unless ] map ;
|
||||
|
||||
: optl>map ( seq -- map )
|
||||
H{ } clone tuck
|
||||
'[ split-optl opt>assoc swap _ set-at ] each ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: MDB_ADDON_SLOTS ( -- slots )
|
||||
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
|
||||
|
||||
: link-class ( collection class -- )
|
||||
over classes>>
|
||||
[ 2dup member? [ 2drop ] [ push ] if ]
|
||||
[ 1vector >>classes ] if* drop ; inline
|
||||
|
||||
: link-collection ( class collection -- )
|
||||
[ swap link-class ]
|
||||
[ MDB_COLLECTION set-word-prop ] 2bi ; inline
|
||||
|
||||
: mdb-check-slots ( superclass slots -- superclass slots )
|
||||
over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
|
||||
[ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
|
||||
|
||||
: set-slot-map ( class options -- )
|
||||
optl>map MDB_SLOTDEF_LIST set-word-prop ; inline
|
||||
|
||||
M: tuple-class tuple-collection ( tuple -- mdb-collection )
|
||||
(mdb-collection) ;
|
||||
|
||||
M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
|
||||
class (mdb-collection) ;
|
||||
|
||||
M: mdb-persistent mdb-slot-map ( tuple -- string )
|
||||
class (mdb-slot-map) ;
|
||||
|
||||
M: tuple-class mdb-slot-map ( class -- assoc )
|
||||
(mdb-slot-map) ;
|
||||
|
||||
M: mdb-collection mdb-slot-map ( collection -- assoc )
|
||||
classes>> [ mdb-slot-map ] map assoc-combine ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: collection-map ( -- assoc )
|
||||
mdb-persistent MDB_COLLECTION_MAP word-prop
|
||||
[ mdb-persistent MDB_COLLECTION_MAP H{ } clone
|
||||
[ set-word-prop ] keep ] unless* ; inline
|
||||
|
||||
: slot-option? ( tuple slot option -- ? )
|
||||
[ swap mdb-slot-map at ] dip
|
||||
'[ _ swap key? ] [ f ] if* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
||||
M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
|
||||
collection-map [ ] [ key? ] 2bi
|
||||
[ at ] [ [ mdb-tuple-collection new dup ] 2dip
|
||||
[ [ >>name ] keep ] dip set-at ] if ; inline
|
||||
M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
|
||||
M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
|
||||
[ name>> <mdb-tuple-collection> ] keep
|
||||
{
|
||||
[ capped>> >>capped ]
|
||||
[ size>> >>size ]
|
||||
[ max>> >>max ]
|
||||
} cleave ;
|
||||
|
||||
: transient-slot? ( tuple slot -- ? )
|
||||
+transient+ slot-option? ;
|
||||
|
||||
: load-slot? ( tuple slot -- ? )
|
||||
+load+ slot-option? ;
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
|
||||
mongodb.tuple.collection combinators mongodb.tuple.collection ;
|
||||
|
||||
IN: mongodb.tuple
|
||||
|
||||
SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||
|
||||
IN: mongodb.tuple.index
|
||||
|
||||
TUPLE: tuple-index name spec ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: index-type ( type -- name )
|
||||
{ { +fieldindex+ [ "field" ] }
|
||||
{ +deepindex+ [ "deep" ] }
|
||||
{ +compoundindex+ [ "compound" ] } } case ;
|
||||
|
||||
: index-name ( slot index-spec -- name )
|
||||
[ first index-type ] keep
|
||||
rest "-" join
|
||||
"%s-%s-%s-Idx" sprintf ;
|
||||
|
||||
: build-index ( element slot -- assoc )
|
||||
swap [ <linked-hash> ] 2dip
|
||||
[ rest ] keep first ! assoc slot options itype
|
||||
{ { +fieldindex+ [ drop [ 1 ] dip pick set-at ] }
|
||||
{ +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
|
||||
{ +compoundindex+ [
|
||||
2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
|
||||
over '[ _ [ 1 ] 2dip set-at ] each ] }
|
||||
} case ;
|
||||
|
||||
: build-index-seq ( slot optlist -- index-seq )
|
||||
[ V{ } clone ] 2dip pick ! v{} slot optl v{}
|
||||
[ swap ] dip ! v{} optl slot v{ }
|
||||
'[ _ tuple-index new ! element slot exemplar
|
||||
2over swap index-name >>name ! element slot clone
|
||||
[ build-index ] dip swap >>spec _ push
|
||||
] each ;
|
||||
|
||||
: is-index-declaration? ( entry -- ? )
|
||||
first
|
||||
{ { +fieldindex+ [ t ] }
|
||||
{ +compoundindex+ [ t ] }
|
||||
{ +deepindex+ [ t ] }
|
||||
[ drop f ] } case ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: tuple-index-list ( mdb-collection/class -- seq )
|
||||
mdb-slot-map V{ } clone tuck
|
||||
'[ [ is-index-declaration? ] filter
|
||||
build-index-seq _ push
|
||||
] assoc-each flatten ;
|
||||
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
USING: accessors assocs bson.constants combinators.short-circuit
|
||||
constructors continuations fry kernel mirrors mongodb.tuple.collection
|
||||
mongodb.tuple.state namespaces sequences words bson.writer combinators
|
||||
hashtables linked-assocs ;
|
||||
|
||||
IN: mongodb.tuple.persistent
|
||||
|
||||
SYMBOLS: object-map ;
|
||||
|
||||
GENERIC: tuple>assoc ( tuple -- assoc )
|
||||
|
||||
GENERIC: tuple>selector ( tuple -- selector )
|
||||
|
||||
DEFER: assoc>tuple
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: mdbinfo>tuple-class ( tuple-info -- class )
|
||||
[ first ] keep second lookup ; inline
|
||||
|
||||
: tuple-instance ( tuple-info -- instance )
|
||||
mdbinfo>tuple-class new ; inline
|
||||
|
||||
: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
|
||||
[ tuple-info tuple-instance dup
|
||||
<mirror> [ keys ] keep ] keep swap ; inline
|
||||
|
||||
: make-tuple ( assoc -- tuple )
|
||||
prepare-assoc>tuple
|
||||
'[ dup _ at assoc>tuple swap _ set-at ] each
|
||||
[ mark-persistent ] keep ; inline recursive
|
||||
|
||||
: at+ ( value key assoc -- value )
|
||||
2dup key?
|
||||
[ at nip ] [ [ dup ] 2dip set-at ] if ; inline
|
||||
|
||||
: data-tuple? ( tuple -- ? )
|
||||
dup tuple?
|
||||
[ assoc? not ] [ drop f ] if ; inline
|
||||
|
||||
: add-storable ( assoc ns -- )
|
||||
[ H{ } clone ] dip object-map get at+
|
||||
[ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
|
||||
|
||||
: write-field? ( tuple key value -- ? )
|
||||
pick mdb-persistent? [
|
||||
{ [ [ 2drop ] dip not ]
|
||||
[ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
|
||||
|
||||
TUPLE: cond-value value quot ;
|
||||
|
||||
CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
|
||||
|
||||
: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
|
||||
over [ (( tuple -- assoc )) call-effect ] dip
|
||||
[ tuple-collection name>> ] keep
|
||||
[ add-storable ] dip
|
||||
[ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
|
||||
|
||||
: write-field ( value quot: ( tuple -- assoc ) -- value' )
|
||||
<cond-value> {
|
||||
{ [ dup value>> mdb-special-value? ] [ value>> ] }
|
||||
{ [ dup value>> mdb-persistent? ]
|
||||
[ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
|
||||
{ [ dup value>> data-tuple? ]
|
||||
[ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] }
|
||||
{ [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
|
||||
[ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
|
||||
[ value>> ]
|
||||
} cond ; inline recursive
|
||||
|
||||
: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
|
||||
swap ! m t q q a
|
||||
'[ _ 2over write-field?
|
||||
[ _ write-field swap _ set-at ]
|
||||
[ 2drop ] if
|
||||
] assoc-each ;
|
||||
|
||||
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
|
||||
H{ } clone swap [ <mirror> ] keep pick ; inline
|
||||
|
||||
: ensure-mdb-info ( tuple -- tuple )
|
||||
dup _id>> [ <objid> >>_id ] unless
|
||||
[ mark-persistent ] keep ; inline
|
||||
|
||||
: with-object-map ( quot: ( -- ) -- store-assoc )
|
||||
[ H{ } clone dup object-map ] dip with-variable ; inline
|
||||
|
||||
: (tuple>assoc) ( tuple -- assoc )
|
||||
[ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
|
||||
over set-tuple-info ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
GENERIC: tuple>storable ( tuple -- storable )
|
||||
|
||||
M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
|
||||
'[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
|
||||
|
||||
M: mdb-persistent tuple>assoc ( tuple -- assoc )
|
||||
ensure-mdb-info (tuple>assoc) ;
|
||||
|
||||
M: tuple tuple>assoc ( tuple -- assoc )
|
||||
(tuple>assoc) ;
|
||||
|
||||
M: tuple tuple>selector ( tuple -- assoc )
|
||||
prepare-assoc [ tuple>selector ] write-tuple-fields ;
|
||||
|
||||
: assoc>tuple ( assoc -- tuple )
|
||||
dup assoc?
|
||||
[ [ dup tuple-info?
|
||||
[ make-tuple ]
|
||||
[ ] if ] [ drop ] recover
|
||||
] [ ] if ; inline recursive
|
||||
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
|
||||
words classes.tuple slots generic ;
|
||||
|
||||
IN: mongodb.tuple.state
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
|
||||
CONSTANT: MDB_DIRTY_FLAG "d?"
|
||||
CONSTANT: MDB_PERSISTENT_FLAG "p?"
|
||||
CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set"
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYMBOL: mdb-dirty-handling?
|
||||
|
||||
: advised-with? ( name word loc -- ? )
|
||||
word-prop key? ; inline
|
||||
|
||||
: <tuple-info> ( tuple -- tuple-info )
|
||||
class V{ } clone tuck
|
||||
[ [ name>> ] dip push ]
|
||||
[ [ vocabulary>> ] dip push ] 2bi ; inline
|
||||
|
||||
: tuple-info ( assoc -- tuple-info )
|
||||
[ MDB_TUPLE_INFO ] dip at ; inline
|
||||
|
||||
: set-tuple-info ( tuple assoc -- )
|
||||
[ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
|
||||
|
||||
: tuple-info? ( assoc -- ? )
|
||||
[ MDB_TUPLE_INFO ] dip key? ;
|
||||
|
||||
: tuple-meta ( tuple -- assoc )
|
||||
dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline
|
||||
|
||||
: dirty? ( tuple -- ? )
|
||||
[ MDB_DIRTY_FLAG ] dip tuple-meta at ;
|
||||
|
||||
: mark-dirty ( tuple -- )
|
||||
[ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
|
||||
|
||||
: persistent? ( tuple -- ? )
|
||||
[ MDB_PERSISTENT_FLAG ] dip tuple-meta at ;
|
||||
|
||||
: mark-persistent ( tuple -- )
|
||||
[ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep
|
||||
[ f MDB_DIRTY_FLAG ] dip set-at ;
|
||||
|
||||
: needs-store? ( tuple -- ? )
|
||||
[ persistent? not ] [ dirty? ] bi or ;
|
||||
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
USING: accessors assocs classes.mixin classes.tuple
|
||||
classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
|
||||
mongodb.msg mongodb.tuple.collection mongodb.tuple.index
|
||||
mongodb.tuple.persistent mongodb.tuple.state strings ;
|
||||
|
||||
IN: mongodb.tuple
|
||||
|
||||
SYNTAX: MDBTUPLE:
|
||||
parse-tuple-definition
|
||||
mdb-check-slots
|
||||
define-tuple-class ;
|
||||
|
||||
: define-persistent ( class collection options -- )
|
||||
[ [ <mdb-tuple-collection> dupd link-collection ] when* ] dip
|
||||
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
||||
! [ dup annotate-writers ] dip
|
||||
set-slot-map ;
|
||||
|
||||
: ensure-table ( class -- )
|
||||
tuple-collection
|
||||
[ create-collection ]
|
||||
[ [ tuple-index-list ] keep
|
||||
'[ _ name>> swap [ name>> ] [ spec>> ] bi <index-spec> ensure-index ] each
|
||||
] bi ;
|
||||
|
||||
: ensure-tables ( classes -- )
|
||||
[ ensure-table ] each ;
|
||||
|
||||
: drop-table ( class -- )
|
||||
tuple-collection
|
||||
[ [ tuple-index-list ] keep
|
||||
'[ _ name>> swap name>> drop-index ] each ]
|
||||
[ name>> drop-collection ] bi ;
|
||||
|
||||
: recreate-table ( class -- )
|
||||
[ drop-table ]
|
||||
[ ensure-table ] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
GENERIC: id-selector ( object -- selector )
|
||||
|
||||
M: string id-selector ( objid -- selector )
|
||||
"_id" H{ } clone [ set-at ] keep ; inline
|
||||
|
||||
M: mdb-persistent id-selector ( mdb-persistent -- selector )
|
||||
_id>> id-selector ;
|
||||
|
||||
: (save-tuples) ( collection assoc -- )
|
||||
swap '[ [ _ ] 2dip
|
||||
[ id-selector ] dip
|
||||
<update> >upsert update ] assoc-each ; inline
|
||||
PRIVATE>
|
||||
|
||||
: save-tuple ( tuple -- )
|
||||
tuple>storable [ (save-tuples) ] assoc-each ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
save-tuple ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
save-tuple ;
|
||||
|
||||
: delete-tuple ( tuple -- )
|
||||
dup persistent?
|
||||
[ [ tuple-collection name>> ] keep
|
||||
id-selector delete ] [ drop ] if ;
|
||||
|
||||
: tuple>query ( tuple -- query )
|
||||
[ tuple-collection name>> ] keep
|
||||
tuple>selector <query> ;
|
||||
|
||||
: select-tuple ( tuple/query -- tuple/f )
|
||||
dup mdb-query-msg? [ tuple>query ] unless
|
||||
find-one [ assoc>tuple ] [ f ] if* ;
|
||||
|
||||
: select-tuples ( tuple/query -- cursor tuples/f )
|
||||
dup mdb-query-msg? [ tuple>query ] unless
|
||||
find [ assoc>tuple ] map ;
|
||||
|
||||
: count-tuples ( tuple/query -- n )
|
||||
dup mdb-query-msg? [ tuple>query ] unless count ;
|
||||
Loading…
Reference in New Issue