clean:
del vm\*.obj
if exist factor.lib del factor.lib
+ if exist factor.res del factor.res
if exist factor.com del factor.com
if exist factor.exe del factor.exe
if exist factor.dll del factor.dll
: pprint-c-type ( c-type -- )
[ c-type-string ] keep present-text ;
-M: pointer pprint* \ pointer: pprint-word to>> pprint-c-type ;
+M: pointer pprint*
+ <flow \ pointer: pprint-word to>> pprint* block> ;
M: typedef-word definer drop \ TYPEDEF: f ;
: load-vocab-roots ( -- )
"user-init" get [
"factor-roots" rc-path dup exists? [
- utf8 file-lines [ add-vocab-root ] each
+ utf8 file-lines harvest [ add-vocab-root ] each
] [ drop ] if
] when ;
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax kernel ;
IN: json.reader
HELP: json>
{ $values { "string" "a string in JSON format" } { "object" "a deserialized object" } }
{ $description "Deserializes the JSON formatted string into a Factor object. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
+HELP: read-jsons
+{ $values { "objects" "a vector of deserialized objects" } }
+{ $description "Reads JSON formatted strings into a vector of Factor object until the end of the stream is reached. JSON objects are converted to Factor hashtables. All other JSON objects convert to their obvious Factor equivalents." } ;
+
ARTICLE: "json.reader" "JSON reader"
"The " { $vocab-link "json.reader" } " vocabulary defines a word for parsing strings in JSON format."
-{ $subsections json> } ;
+{ $subsections json> read-jsons } ;
ABOUT: "json.reader"
USING: assocs arrays json.reader kernel strings tools.test
-hashtables json ;
+hashtables json io.streams.string ;
IN: json.reader.tests
{ f } [ "false" json> ] unit-test
{ 0 } [ "0 " json> ] unit-test
{ 0 } [ " 0 " json> ] unit-test
+{ V{ H{ { "a" "b" } } H{ { "c" "d" } } } }
+[ """{"a": "b"} {"c": "d"}""" [ read-jsons ] with-string-reader ] unit-test
+
! empty objects are allowed as values in objects
{ H{ { "foo" H{ } } } } [ "{ \"foo\" : {}}" json> ] unit-test
{ CHAR: { [ 2 [ V{ } clone over push ] times ] }
{ CHAR: : [ v-pick-push ] }
{ CHAR: } [ (close-hash) ] }
- { CHAR: \u000020 [ ] }
+ { CHAR: \s [ ] }
{ CHAR: \t [ ] }
{ CHAR: \r [ ] }
{ CHAR: \n [ ] }
} case
] when* ;
-: (json-parser>) ( string -- object )
- [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
-
PRIVATE>
+: read-jsons ( -- objects )
+ V{ } clone [ read1 dup ] [ scan ] while drop ;
+
: json> ( string -- object )
- (json-parser>) ;
+ [ read-jsons first ] with-string-reader ;
FUNCTION: size_t strlen ( c-string alien ) ;
+FUNCTION: int system ( c-string command ) ;
+
DESTRUCTOR: free
DESTRUCTOR: (free)
{ minimize-button 0 }
{ maximize-button 0 }
{ resize-handles $ WS_EX_WINDOWEDGE }
- { small-title-bar $ WS_EX_TOOLWINDOW }
+ { small-title-bar $[ WS_EX_TOOLWINDOW WS_EX_TOPMOST bitor ] }
{ normal-title-bar $ WS_EX_APPWINDOW }
}
} cleave ;
: exit-fullscreen ( world -- )
- dup handle>> hWnd>>
+ [ handle>> hWnd>> ] [ world>style ] bi
{
- [ GWL_STYLE rot world>style SetWindowLong win32-error=0/f ]
+ [ [ GWL_STYLE ] dip SetWindowLong win32-error=0/f ]
[
+ drop
f
over hwnd>RECT get-RECT-dimensions
flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
- [ SW_RESTORE ShowWindow win32-error=0/f ]
- } cleave ;
+ [ drop SW_RESTORE ShowWindow win32-error=0/f ]
+ } 2cleave ;
M: windows-ui-backend (set-fullscreen) ( ? world -- )
[ enter-fullscreen ] [ exit-fullscreen ] if ;
M: windows-ui-backend (fullscreen?) ( world -- ? )
- [ handle>> hWnd>> hwnd>RECT ]
- [ handle>> hWnd>> fullscreen-RECT ] bi
+ handle>> hWnd>>
+ [ hwnd>RECT ] [ fullscreen-RECT ] bi
[ get-RECT-dimensions 2array 2nip ] bi@ = ;
windows-ui-backend ui-backend set-global
-! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data ascii assocs classes.struct
-combinators combinators.short-circuit command-line environment
-io.encodings.ascii io.encodings.string io.encodings.utf8 kernel
-literals locals math namespaces sequences specialized-arrays
-strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
-ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
-ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
-x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
-FROM: unix.ffi => system ;
-SPECIALIZED-ARRAY: uchar
+USING: accessors arrays alien.c-types alien.data alien.syntax ascii
+assocs classes.struct combinators combinators.short-circuit
+command-line environment io.encodings.ascii io.encodings.string
+io.encodings.utf8 kernel literals locals math namespaces
+sequences specialized-arrays strings ui ui.backend ui.clipboards
+ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.gestures ui.pixel-formats ui.pixel-formats.private ui.private
+x11 x11.clipboard x11.constants x11.events x11.glx x11.io
+x11.windows x11.xim x11.xlib ;
+FROM: libc => system ;
+SPECIALIZED-ARRAYS: uchar ulong ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
+: XA_NET_SUPPORTED ( -- atom ) "_NET_SUPPORTED" x-atom ;
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
+: XA_NET_WM_STATE ( -- atom ) "_NET_WM_STATE" x-atom ;
+: XA_NET_WM_STATE_FULLSCREEN ( -- atom ) "_NET_WM_STATE_FULLSCREEN" x-atom ;
+: XA_NET_ACTIVE_WINDOW ( -- atom ) "_NET_ACTIVE_WINDOW" x-atom ;
+
+: supported-net-wm-hints ( -- seq )
+ { Atom int ulong ulong pointer: Atom }
+ [| type format n-atoms bytes-after atoms |
+ dpy get
+ root get
+ XA_NET_SUPPORTED
+ 0
+ ulong c-type-interval nip
+ 0
+ XA_ATOM
+ type
+ format
+ n-atoms
+ bytes-after
+ atoms
+ XGetWindowProperty
+ Success assert=
+ ]
+ [| type format n-atoms bytes-after atoms |
+ atoms n-atoms <direct-ulong-array> >array
+ atoms XFree
+ ]
+ with-out-parameters ;
+
+: net-wm-hint-supported? ( atom -- ? )
+ supported-net-wm-hints member? ;
TUPLE: x11-handle-base glx ;
TUPLE: x11-handle < x11-handle-base window xic ;
user-input ;
: supported-type? ( atom -- ? )
- { "UTF8_STRING" "STRING" "TEXT" }
- [ x-atom = ] with any? ;
+ XA_UTF8_STRING XA_STRING XA_TEXT 3array member? ;
: clipboard-for-atom ( atom -- clipboard )
{
M: world selection-request-event
drop dup target>> {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
- { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
- { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
+ { [ dup XA_TARGETS = ] [ drop dup set-targets-prop send-notify-success ] }
+ { [ dup XA_TIMESTAMP = ] [ drop dup set-timestamp-prop send-notify-success ] }
[ drop send-notify-failure ]
} cond ;
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-: make-fullscreen-msg ( world ? -- msg )
+: make-fullscreen-msg ( window ? -- msg )
XClientMessageEvent <struct>
- ClientMessage >>type
- dpy get >>display
- "_NET_WM_STATE" x-atom >>message_type
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
- swap handle>> window>> >>window
- 32 >>format
- "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+ ClientMessage >>type
+ dpy get >>display
+ XA_NET_WM_STATE >>message_type
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap >>window
+ 32 >>format
+ XA_NET_WM_STATE_FULLSCREEN >>data1 ;
+
+: send-event ( event -- )
+ [
+ dpy get
+ root get
+ 0
+ SubstructureNotifyMask SubstructureRedirectMask bitor
+ ] dip XSendEvent drop ;
M: x11-ui-backend (set-fullscreen) ( world ? -- )
- [ dpy get root get 0 SubstructureNotifyMask ] 2dip
- make-fullscreen-msg XSendEvent drop ;
+ [ handle>> window>> ] dip make-fullscreen-msg send-event ;
M: x11-ui-backend (open-window) ( world -- )
- dup gadget-window
- handle>> window>>
- [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
+ dup gadget-window handle>> window>>
+ [ set-closable ]
+ [ [ dpy get ] dip set-class ]
+ [ map-window ]
+ tri ;
+
+: make-raise-window-msg ( window -- msg )
+ XClientMessageEvent <struct>
+ ClientMessage >>type
+ 1 >>send_event
+ dpy get >>display
+ swap >>window
+ XA_NET_ACTIVE_WINDOW >>message_type
+ 32 >>format ;
+
+: raise-window-new ( window -- )
+ make-raise-window-msg send-event ;
+
+: raise-window-old ( window -- )
+ [ dpy get ] dip
+ [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+ [ XRaiseWindow drop ]
+ 2bi ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
- dpy get swap window>>
- [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
- [ XRaiseWindow drop ]
- 2bi
+ window>>
+ XA_NET_ACTIVE_WINDOW net-wm-hint-supported?
+ [ raise-window-new ] [ raise-window-old ] if
] when* ;
M: x11-handle select-gl-context ( handle -- )
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: int symlink ( c-string path1, c-string path2 ) ;
FUNCTION: int link ( c-string path1, c-string path2 ) ;
-FUNCTION: int system ( c-string command ) ;
FUNCTION: int unlink ( c-string path ) ;
FUNCTION: int utimes ( c-string path, timeval[2] times ) ;
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings classes.struct
io.encodings.utf8 kernel namespaces sequences
! and http://common-lisp.net/~crhodes/clx/demo/clipboard.lisp.
: XA_CLIPBOARD ( -- atom ) "CLIPBOARD" x-atom ;
-
: XA_UTF8_STRING ( -- atom ) "UTF8_STRING" x-atom ;
+: XA_TARGETS ( -- atom ) "TARGETS" x-atom ;
+: XA_TIMESTAMP ( -- atom ) "TIMESTAMP" x-atom ;
+: XA_TEXT ( -- atom ) "TEXT" x-atom ;
TUPLE: x-clipboard atom contents ;
: set-targets-prop ( evt -- )
[ dpy get ] dip [ requestor>> ] [ property>> ] bi
- "TARGETS" x-atom 32 PropModeReplace
- {
- "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP"
- } [ x-atom ] int-array{ } map-as
+ XA_TARGETS 32 PropModeReplace
+ XA_UTF8_STRING XA_STRING XA_TARGETS XA_TIMESTAMP int-array{ } 4sequence
4 XChangeProperty drop ;
: set-timestamp-prop ( evt -- )
[ dpy get ] dip
[ requestor>> ]
- [ property>> "TIMESTAMP" x-atom 32 PropModeReplace ]
+ [ property>> XA_TIMESTAMP 32 PropModeReplace ]
[ time>> <int> ] tri
1 XChangeProperty drop ;
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.struct combinators kernel
-math.order namespaces x11 x11.xlib ;
+USING: accessors arrays classes.struct combinators
+combinators.short-circuit kernel math.order namespaces
+x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
: event-dim ( event -- dim )
[ width>> ] [ height>> ] bi 2array ;
+: XA_WM_PROTOCOLS ( -- atom ) "WM_PROTOCOLS" x-atom ;
+: XA_WM_DELETE_WINDOW ( -- atom ) "WM_DELETE_WINDOW" x-atom ;
+
: close-box? ( event -- ? )
- [ message_type>> "WM_PROTOCOLS" x-atom = ]
- [ data0>> "WM_DELETE_WINDOW" x-atom = ]
- bi and ;
+ {
+ [ message_type>> XA_WM_PROTOCOLS = ]
+ [ data0>> XA_WM_DELETE_WINDOW = ]
+ } 1&& ;
-! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
-namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct literals ;
+namespaces sequences arrays fry classes.struct literals
+x11 x11.xlib x11.constants x11.events
+x11.glx ;
IN: x11.windows
CONSTANT: create-window-mask
dpy get swap XDestroyWindow drop ;
: set-closable ( win -- )
- dpy get swap
"WM_DELETE_WINDOW" x-atom <Atom> 1
+ dpy get swap
XA_WM_DELETE_WINDOW <Atom> 1
XSetWMProtocols drop ;
: map-window ( win -- ) dpy get swap XMapWindow drop ;
"All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;
ARTICLE: "dip-keep-combinators" "Preserving combinators"
-"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values underneath:"
+"Sometimes it is necessary to temporarily hide values on the datastack. The " { $snippet "dip" } " combinators invoke the quotation at the top of the stack, hiding some number of values:"
{ $subsections dip 2dip 3dip 4dip }
-"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack when it completes:"
+"The " { $snippet "keep" } " combinators invoke a quotation and restore some number of values to the top of the stack:"
{ $subsections keep 2keep 3keep } ;
ARTICLE: "curried-dataflow" "Curried dataflow combinators"
-USING: bson.reader bson.writer byte-arrays io.encodings.binary
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests
: turnaround ( value -- value )
- assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+ assoc>bv >byte-array binary [ H{ } clone stream>assoc ] with-byte-reader ;
[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
[ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
+
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } }
]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader ;
IN: bson
-USING: accessors constructors kernel strings uuid ;
-
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators
+combinators.short-circuit constructors kernel linked-assocs
+math math.bitwise random strings uuid ;
IN: bson.constants
: <objid> ( -- objid )
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
-TUPLE: objref ns objid ;
+: <oid> ( -- oid )
+ oid new
+ now timestamp>micros >>a
+ 8 random-bits 16 shift HEX: FF0000 mask
+ 16 random-bits HEX: FFFF mask
+ bitor >>b ;
+
+TUPLE: dbref ref id db ;
+
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
+
+: dbref>assoc ( dbref -- assoc )
+ [ <linked-hash> ] dip over
+ {
+ [ [ ref>> "$ref" ] [ set-at ] bi* ]
+ [ [ id>> "$id" ] [ set-at ] bi* ]
+ [ over db>> [
+ [ db>> "$db" ] [ set-at ] bi*
+ ] [ 2drop ] if ]
+ } 2cleave ; inline
+
+: assoc>dbref ( assoc -- dbref )
+ [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
+ dbref boa ; inline
-CONSTRUCTOR: objref ( ns objid -- objref ) ;
+: dbref-assoc? ( assoc -- ? )
+ { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
TUPLE: mdbregexp { regexp string } { options string } ;
-USING: accessors assocs bson.constants calendar fry io io.binary
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize locals ;
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants calendar combinators
+combinators.short-circuit io io.binary kernel math locals
+namespaces sequences serialize strings vectors byte-arrays ;
-FROM: kernel.private => declare ;
-FROM: io.encodings.private => (read-until) ;
+FROM: io.encodings.binary => binary ;
+FROM: io.streams.byte-array => with-byte-reader ;
+FROM: typed => TYPED: ;
IN: bson.reader
<PRIVATE
TUPLE: element { type integer } name ;
+
TUPLE: state
- { size initial: -1 } exemplar
- result scope element ;
+ { size initial: -1 }
+ { exemplar assoc }
+ result
+ { scope vector }
+ { elements vector } ;
+
+TYPED: (prepare-elements) ( -- elements-vector: vector )
+ V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
: <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-not-eoo < integer T_EOO > ;
-PREDICATE: bson-eoo < integer T_EOO = ;
-
-PREDICATE: bson-string < integer T_String = ;
-PREDICATE: bson-object < integer T_Object = ;
-PREDICATE: bson-oid < integer T_OID = ;
-PREDICATE: bson-array < integer T_Array = ;
-PREDICATE: bson-integer < integer T_Integer = ;
-PREDICATE: bson-double < integer T_Double = ;
-PREDICATE: bson-date < integer T_Date = ;
-PREDICATE: bson-binary < integer T_Binary = ;
-PREDICATE: bson-boolean < integer T_Boolean = ;
-PREDICATE: bson-regexp < integer T_Regexp = ;
-PREDICATE: bson-null < integer T_NULL = ;
-PREDICATE: bson-ref < integer T_DBRef = ;
-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 = ;
-
-GENERIC: element-read ( type -- cont? )
-GENERIC: element-data-read ( type -- object )
-GENERIC: element-binary-read ( length type -- object )
-
-: get-state ( -- state )
+ {
+ [ clone >>exemplar ]
+ [ clone >>result ]
+ [ V{ } clone [ push ] keep >>scope ]
+ } cleave
+ (prepare-elements) >>elements ;
+
+TYPED: get-state ( -- state: state )
state get ; inline
-: read-int32 ( -- int32 )
+TYPED: read-int32 ( -- int32: integer )
4 read signed-le> ; inline
-: read-longlong ( -- longlong )
+TYPED: read-longlong ( -- longlong: integer )
8 read signed-le> ; inline
-: read-double ( -- double )
+TYPED: read-double ( -- double: float )
8 read le> bits>double ; inline
-: read-byte-raw ( -- byte-raw )
+TYPED: read-byte-raw ( -- byte-raw: byte-array )
1 read ; inline
-: read-byte ( -- byte )
+TYPED: read-byte ( -- byte: integer )
read-byte-raw first ; inline
-: read-cstring ( -- string )
- "\0" read-until drop "" like ; inline
+TYPED: read-cstring ( -- string: string )
+ "\0" read-until drop >string ; inline
-: read-sized-string ( length -- string )
- read 1 head-slice* "" like ; inline
+TYPED: read-sized-string ( length: integer -- string: string )
+ read 1 head-slice* >string ; inline
-: read-element-type ( -- type )
- read-byte ; inline
+TYPED: push-element ( type: integer name: string state: state -- )
+ [ element boa ] dip elements>> push ; inline
-: push-element ( type name -- )
- element boa get-state element>> push ; inline
+TYPED: pop-element ( state: state -- element: element )
+ elements>> pop ; inline
-: pop-element ( -- element )
- get-state element>> pop ; inline
+TYPED: peek-scope ( state: state -- ht )
+ scope>> last ; inline
-: peek-scope ( -- ht )
- get-state scope>> last ; inline
+: bson-object-data-read ( -- object )
+ read-int32 drop get-state
+ [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
+
+: bson-binary-read ( -- binary )
+ read-int32 read-byte
+ {
+ { T_Binary_Bytes [ read ] }
+ { T_Binary_Custom [ read bytes>object ] }
+ { T_Binary_Function [ read ] }
+ [ drop read >string ]
+ } case ; inline
+
+TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
+ mdbregexp new
+ read-cstring >>regexp read-cstring >>options ; inline
+
+TYPED: bson-oid-read ( -- oid: oid )
+ read-longlong read-int32 oid boa ; inline
+
+TYPED: element-data-read ( type: integer -- object )
+ {
+ { T_OID [ bson-oid-read ] }
+ { T_String [ read-int32 read-sized-string ] }
+ { T_Integer [ read-int32 ] }
+ { T_Binary [ bson-binary-read ] }
+ { T_Object [ bson-object-data-read ] }
+ { T_Array [ bson-object-data-read ] }
+ { T_Double [ read-double ] }
+ { T_Boolean [ read-byte 1 = ] }
+ { T_Date [ read-longlong millis>timestamp ] }
+ { T_Regexp [ bson-regexp-read ] }
+ { T_NULL [ f ] }
+ } case ; inline
+
+TYPED: bson-array? ( type: integer -- ?: boolean )
+ T_Array = ; inline
+
+TYPED: bson-object? ( type: integer -- ?: boolean )
+ T_Object = ; inline
+
+: check-object ( assoc -- object )
+ dup dbref-assoc? [ assoc>dbref ] when ; inline
+
+TYPED: fix-result ( assoc type: integer -- result )
+ {
+ { T_Array [ values ] }
+ { T_Object [ check-object ] }
+ } case ; inline
+
+TYPED: end-element ( type: integer -- )
+ { [ bson-object? ] [ bson-array? ] } 1||
+ [ get-state pop-element drop ] unless ; inline
+
+TYPED: (>state<) ( -- state: state scope: vector element: element )
+ get-state [ ] [ scope>> ] [ pop-element ] tri ; inline
+
+TYPED: (prepare-result) ( scope: vector element: element -- result )
+ [ pop ] [ type>> ] bi* fix-result ; inline
+
+: bson-eoo-element-read ( -- cont?: boolean )
+ (>state<)
+ [ (prepare-result) ] [ ] [ drop empty? ] 2tri
+ [ 2drop >>result drop f ]
+ [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
+
+TYPED: (prepare-object) ( type: integer -- object )
+ [ element-data-read ] [ end-element ] bi ; inline
+
+:: (read-object) ( type name state -- )
+ state peek-scope :> scope
+ type (prepare-object) name scope set-at ; inline
+
+TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
+ read-cstring get-state
+ [ push-element ]
+ [ (read-object) t ] 3bi ; inline
+
+TYPED: (element-read) ( type: integer -- cont?: boolean )
+ dup T_EOO >
+ [ bson-not-eoo-element-read ]
+ [ drop bson-eoo-element-read ] if ; inline
: read-elements ( -- )
- read-element-type
- element-read
+ read-byte (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 -- )
- pop-element 2drop ;
-
-M:: bson-eoo element-read ( type -- cont? )
- pop-element :> element
- get-state scope>>
- [ pop element type>> fix-result ] [ empty? ] bi
- [ [ get-state ] dip >>result drop f ]
- [ element name>> peek-scope set-at t ] if ;
-
-M:: bson-not-eoo element-read ( type -- cont? )
- peek-scope :> scope
- type read-cstring [ push-element ] 2keep
- [ [ element-data-read ] [ end-element ] bi ]
- [ scope set-at t ] bi* ;
-
-: [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>> last ; inline
-
-M: bson-object element-data-read ( type -- object )
- (object-data-read) ;
-
-M: bson-string element-data-read ( type -- object )
- drop
- read-int32 read-sized-string ;
-
-M: bson-array element-data-read ( type -- object )
- (object-data-read) ;
-
-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-bytes element-binary-read ( size type -- bytes )
- drop read ;
-
-M: bson-binary-custom element-binary-read ( size type -- quot )
- drop read bytes>object ;
-
PRIVATE>
-USE: tools.continuations
-
: stream>assoc ( exemplar -- assoc )
- <state> dup state
- [ read-int32 >>size read-elements ] with-variable
- result>> ;
+ <state> read-int32 >>size
+ [ state [ read-elements ] with-variable ]
+ [ result>> ] bi ;
-BSON reader and writer
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
-! Copyright (C) 2008 Sascha Matzke.
+! Copyright (C) 2010 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 ;
-
-FROM: io.encodings.utf8.private => char>utf8 ;
-FROM: kernel.private => declare ;
-
+USING: accessors arrays assocs bson.constants byte-arrays
+calendar combinators.short-circuit fry hashtables io io.binary
+kernel linked-assocs literals math math.parser namespaces byte-vectors
+quotations sequences serialize strings vectors dlists alien.accessors ;
+FROM: words => word? word ;
+FROM: typed => TYPED: ;
+FROM: combinators => cond ;
IN: bson.writer
<PRIVATE
-SYMBOL: shared-buffer
-
-CONSTANT: CHAR-SIZE 1
-CONSTANT: INT32-SIZE 4
-CONSTANT: INT64-SIZE 8
+CONSTANT: INT32-SIZE { 0 1 2 3 }
+CONSTANT: INT64-SIZE { 0 1 2 3 4 5 6 7 }
-: (buffer) ( -- buffer )
- shared-buffer get
- [ BV{ } clone [ shared-buffer set ] keep ] unless*
- { byte-vector } declare ; inline
-
PRIVATE>
-: reset-buffer ( buffer -- )
- 0 >>length drop ; inline
-
-: ensure-buffer ( -- )
- (buffer) drop ; inline
+TYPED: get-output ( -- stream: byte-vector )
+ output-stream get ; inline
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
- [ (buffer) [ reset-buffer ] keep dup ] dip
- with-output-stream* ; inline
-
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
- [ (buffer) [ length ] keep ] dip
+TYPED: with-length ( quot -- bytes-written: integer start-index: integer )
+ [ get-output [ length ] [ ] bi ] dip
call length swap [ - ] keep ; inline
-: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
+: (with-length-prefix) ( quot: ( .. -- .. ) length-quot: ( bytes-written -- length ) -- )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
- [ call ] dip (buffer) copy ; inline
+ [ call( written -- length ) get-output underlying>> ] dip set-alien-unsigned-4 ; inline
-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE >le ] (with-length-prefix) ; inline
+: with-length-prefix ( quot: ( .. -- .. ) -- )
+ [ ] (with-length-prefix) ; inline
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
+: with-length-prefix-excl ( quot: ( .. -- .. ) -- )
+ [ 4 - ] (with-length-prefix) ; inline
+
+: (>le) ( x n -- )
+ [ nth-byte write1 ] with each ; inline
<PRIVATE
-GENERIC: bson-type? ( obj -- type )
-GENERIC: bson-write ( obj -- )
+TYPED: write-int32 ( int: integer -- ) INT32-SIZE (>le) ; inline
-M: t bson-type? ( boolean -- type ) drop T_Boolean ;
-M: f bson-type? ( boolean -- type ) drop T_Boolean ;
+TYPED: write-double ( real: float -- ) double>bits INT64-SIZE (>le) ; inline
-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: real bson-type? ( real -- type ) drop T_Double ;
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+TYPED: write-cstring ( string: string -- )
+ get-output [ length ] [ ] bi copy 0 write1 ; inline
-M: oid bson-type? ( word -- type ) drop T_OID ;
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
-M: word bson-type? ( word -- 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-int32 ( int -- ) INT32-SIZE >le write ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
-: write-longlong ( object -- ) INT64-SIZE >le write ; inline
+: write-longlong ( object -- ) INT64-SIZE (>le) ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
-
-M: string bson-write ( obj -- )
- '[ _ write-cstring ] with-length-prefix-excl ;
-M: f bson-write ( f -- )
- drop 0 write1 ;
+TYPED: write-header ( name: string object type: integer -- object )
+ write1 [ write-cstring ] dip ; inline
-M: t bson-write ( t -- )
- drop 1 write1 ;
+DEFER: write-pair
-M: integer bson-write ( num -- )
- write-int32 ;
+TYPED: write-byte-array ( binary: byte-array -- )
+ [ length write-int32 ]
+ [ T_Binary_Bytes write1 write ] bi ; inline
-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 write1
- write ;
-
-M: oid bson-write ( oid -- )
- [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: mdbregexp bson-write ( regexp -- )
+TYPED: write-mdbregexp ( regexp: mdbregexp -- )
[ 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 ;
-
-: (serialize-code) ( code -- )
- object>bytes [ length write-int32 ] keep
- T_Binary_Custom write1
- write ;
+ [ options>> write-cstring ] bi ; inline
-M: quotation bson-write ( quotation -- )
- (serialize-code) ;
-
-M: word bson-write ( word -- )
- (serialize-code) ;
+TYPED: write-sequence ( array: sequence -- )
+ '[
+ _ [ number>string swap write-pair ] each-index
+ write-eoo
+ ] with-length-prefix ; inline recursive
+
+TYPED: write-oid ( oid: oid -- )
+ [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
+
+: write-oid-field ( assoc -- )
+ [ MDB_OID_FIELD dup ] dip at
+ [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
+ [ drop ] if* ; inline
+
+: skip-field? ( name value -- name value boolean )
+ over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
+
+UNION: hashtables hashtable linked-assoc ;
+
+TYPED: write-assoc ( assoc: hashtables -- )
+ '[ _ [ write-oid-field ] [
+ [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ ] bi write-eoo
+ ] with-length-prefix ; inline recursive
+
+UNION: code word quotation ;
+
+TYPED: (serialize-code) ( code: code -- )
+ object>bytes
+ [ length write-int32 ]
+ [ T_Binary_Custom write1 write ] bi ; inline
+
+TYPED: write-string ( string: string -- )
+ '[ _ write-cstring ] with-length-prefix-excl ; inline
+
+TYPED: write-boolean ( bool: boolean -- )
+ [ 1 write1 ] [ 0 write1 ] if ; inline
+
+TYPED: write-pair ( name: string obj -- )
+ {
+ {
+ [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
+ [ T_Object write-header write-assoc ]
+ } {
+ [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
+ [ T_Array write-header write-sequence ]
+ } {
+ [ dup byte-array? ]
+ [ T_Binary write-header write-byte-array ]
+ } {
+ [ dup string? ]
+ [ T_String write-header write-string ]
+ } {
+ [ dup oid? ]
+ [ T_OID write-header write-oid ]
+ } {
+ [ dup integer? ]
+ [ T_Integer write-header write-int32 ]
+ } {
+ [ dup boolean? ]
+ [ T_Boolean write-header write-boolean ]
+ } {
+ [ dup real? ]
+ [ T_Double write-header >float write-double ]
+ } {
+ [ dup timestamp? ]
+ [ T_Date write-header timestamp>millis write-longlong ]
+ } {
+ [ dup mdbregexp? ]
+ [ T_Regexp write-header write-mdbregexp ]
+ } {
+ [ dup quotation? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup word? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup dbref? ]
+ [ T_Object write-header dbref>assoc write-assoc ]
+ } {
+ [ dup f = ]
+ [ T_NULL write-header drop ]
+ }
+ } cond ;
PRIVATE>
-: assoc>bv ( assoc -- byte-vector )
- [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector: byte-vector )
+ [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
-: assoc>stream ( assoc -- )
- { assoc } declare bson-write ; inline
+TYPED: assoc>stream ( assoc: hashtables -- )
+ write-assoc ; inline
-: mdb-special-value? ( value -- ? )
+TYPED: mdb-special-value? ( value -- ?: boolean )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ; inline
+ [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
- [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
+ [ execute( -- ) ] each _ execute( quot -- quot ) gc
+ benchmark ] with-result ] each
print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
: run-benchmarks ( -- )
- "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+ "db" "db" get* "host" "127.0.0.1" get* "port" 27017 get* ensure-number <mdb>
[ print-header
! serialization
{ small-doc-prepare medium-doc-prepare
--- /dev/null
+USING: accessors assocs hashtables kernel linked-assocs strings ;
+IN: mongodb.cmd
+
+<PRIVATE
+
+TUPLE: mongodb-cmd
+ { name string }
+ { const? boolean }
+ { admin? boolean }
+ { auth? boolean }
+ { assoc assoc }
+ { norep? boolean } ;
+
+PRIVATE>
+
+CONSTANT: buildinfo-cmd
+ T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
+
+CONSTANT: list-databases-cmd
+ T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
+
+! Options: { "async" t }
+CONSTANT: fsync-cmd
+ T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
+
+! Value: { "clone" from_host }
+CONSTANT: clone-db-cmd
+ T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
+
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
+CONSTANT: copy-db-cmd
+ T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
+
+CONSTANT: shutdown-cmd
+ T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
+
+CONSTANT: reseterror-cmd
+ T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
+
+CONSTANT: getlasterror-cmd
+ T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
+
+CONSTANT: getpreverror-cmd
+ T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
+
+CONSTANT: forceerror-cmd
+ T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
+
+CONSTANT: drop-db-cmd
+ T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
+
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
+CONSTANT: repair-db-cmd
+ T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
+
+! Options: -1 gets the current profile level; 0-2 set the profile level
+CONSTANT: profile-cmd
+ T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
+
+CONSTANT: server-status-cmd
+ T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
+
+CONSTANT: assertinfo-cmd
+ T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
+
+CONSTANT: getoptime-cmd
+ T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
+
+CONSTANT: oplog-cmd
+ T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
+
+! Value: { "deleteIndexes" collection-name }
+! Options: { "index" index_name or "*" }
+CONSTANT: delete-index-cmd
+ T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
+
+! Value: { "create" collection-name }
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
+CONSTANT: create-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
+
+! Value { "drop" collection-name }
+CONSTANT: drop-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
+
+! Value { "count" collection-name }
+! Options: { "query" query-object }
+CONSTANT: count-cmd
+ T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
+
+! Value { "validate" collection-name }
+CONSTANT: validate-cmd
+ T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
+
+! Value { "collstats" collection-name }
+CONSTANT: collstats-cmd
+ T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
+
+! Value: { "distinct" collection-name }
+! Options: { "key" key-name }
+CONSTANT: distinct-cmd
+ T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
+
+! Value: { "filemd5" oid }
+! Options: { "root" bucket-name }
+CONSTANT: filemd5-cmd
+ T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
+
+CONSTANT: getnonce-cmd
+ T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
+
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
+CONSTANT: authenticate-cmd
+ T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
+
+CONSTANT: logout-cmd
+ T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
+
+! Value: { "findandmodify" collection-name }
+! Options: { { "query" selector } { "sort" sort-spec }
+! { "remove" t/f } { "update" modified-object }
+! { "new" t/f } }
+CONSTANT: findandmodify-cmd
+ T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
+
+: make-cmd ( cmd-stub -- cmd-assoc )
+ dup const?>> [ ] [
+ clone [ clone <linked-assoc> ] change-assoc
+ ] if ; inline
+
+: set-cmd-opt ( cmd value key -- cmd )
+ pick assoc>> set-at ; inline
-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
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
-arrays hashtables sequences.deep vectors locals ;
-
+USING: accessors arrays assocs byte-vectors checksums
+checksums.md5 constructors destructors fry hashtables
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.sockets io.streams.duplex kernel locals math math.parser
+mongodb.cmd mongodb.msg namespaces sequences
+splitting ;
IN: mongodb.connection
: md5-checksum ( string -- digest )
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
-TUPLE: mdb-connection instance node handle remote local ;
+TUPLE: mdb-connection instance node handle remote local buffer ;
+
+: connection-buffer ( -- buffer )
+ mdb-connection get buffer>> 0 >>length ; inline
+
+USE: mongodb.operations
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: check-ok ( result -- errmsg ? )
[ [ "errmsg" ] dip at ]
- [ [ "ok" ] dip at >integer 1 = ] bi ; inline
+ [ [ "ok" ] dip at ] bi ; inline
: <mdb-db> ( name nodes -- mdb-db )
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
nodes>> f swap at ;
: with-connection ( connection quot -- * )
- [ mdb-connection set ] prepose with-scope ; inline
+ [ mdb-connection ] dip with-variable ; inline
: mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "system.namespaces" "." glue ; inline
-: cmd-collection ( -- ns )
- mdb-instance name>> "$cmd" "." glue ; inline
+: cmd-collection ( cmd -- ns )
+ admin?>> [ "admin" ] [ mdb-instance name>> ] if
+ "$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "." glue ; inline
'[ _ 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 ;
+ <mdb-query-msg> -1 >>return# send-query-plain
+ objects>> [ f ] [ first ] if-empty ;
+
+: send-cmd ( cmd -- result )
+ [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
<PRIVATE
: get-nonce ( -- nonce )
- cmd-collection H{ { "getnonce" 1 } } send-query-1result
+ getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ;
: auth? ( mdb -- ? )
[ 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 ;
+: build-auth-cmd ( cmd -- cmd )
+ mdb-instance username>> "user" set-cmd-opt
+ get-nonce [ "nonce" set-cmd-opt ] [ ] bi
+ calculate-key-digest "key" set-cmd-opt ; inline
: perform-authentication ( -- )
- cmd-collection build-auth-query send-query-1result
+ authenticate-cmd make-cmd
+ build-auth-cmd send-cmd
check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client>
- [ >>handle ] dip >>local ;
+ [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
-
+
PRIVATE>
:: verify-nodes ( mdb -- )
USING: accessors arrays assocs bson.constants combinators
-combinators.smart constructors destructors formatting fry hashtables
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
-sequences sets splitting strings
-tools.continuations uuid memoize locals ;
-
+combinators.smart constructors destructors fry hashtables io
+io.pools io.sockets kernel linked-assocs locals math
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
+prettyprint prettyprint.custom prettyprint.sections sequences
+sets splitting strings ;
+FROM: ascii => ascii? ;
IN: mongodb.driver
TUPLE: mdb-pool < pool mdb ;
TUPLE: mdb-collection
{ name string }
-{ capped boolean initial: f }
-{ size integer initial: -1 }
-{ max integer initial: -1 } ;
+{ capped boolean }
+{ size integer }
+{ max integer } ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
query>> update-query ;
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
- over cursor>> 0 >
+ over cursor>> 0 >
[ [ update-query ]
[ [ cursor>> ] dip <mdb-cursor> ] 2bi
] [ 2drop f ] if ;
[ make-cursor ] 2tri
swap objects>> ;
-: make-collection-assoc ( collection assoc -- )
- [ [ name>> "create" ] dip set-at ]
- [ [ [ capped>> ] keep ] dip
- '[ _ _
- [ [ drop t "capped" ] dip set-at ]
- [ [ size>> "size" ] dip set-at ]
- [ [ max>> "max" ] dip set-at ] 2tri ] when
- ] 2bi ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
-: with-db ( mdb quot -- * )
+: with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
-
+
+: with-mdb ( mdb quot -- )
+ [ <mdb-pool> ] dip
+ [ mdb-pool swap with-variable ] curry with-disposal ; inline
+
+: with-mdb-connection ( quot -- )
+ [ mdb-pool get ] dip
+ '[ _ with-connection ] with-pooled-connection ; inline
+
: >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
H{ } clone [ set-at ] keep ;
M: string create-collection
<mdb-collection> create-collection ;
-M: mdb-collection create-collection
- [ [ cmd-collection ] dip
- <linked-hash> [ make-collection-assoc ] keep
- <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
- [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+M: mdb-collection create-collection ( collection -- )
+ create-cmd make-cmd over
+ {
+ [ name>> "create" set-cmd-opt ]
+ [ capped>> [ "capped" set-cmd-opt ] when* ]
+ [ max>> [ "max" set-cmd-opt ] when* ]
+ [ size>> [ "size" set-cmd-opt ] when* ]
+ } cleave send-cmd check-ok
+ [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
+ [ throw ] if ;
: load-collection-list ( -- collection-list )
namespaces-collection
<PRIVATE
: ensure-valid-collection-name ( collection -- )
- [ ";$." intersect length 0 > ] keep
- '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+ [
+ [ ";$." intersect length 0 > ] keep
+ '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
+ ] [
+ [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
+ ] bi ; inline
: build-collection-map ( -- assoc )
H{ } clone load-collection-list
dup empty? [ drop f ] [ first ] if ;
: count ( mdb-query-msg -- result )
- [ collection>> "count" H{ } clone [ set-at ] keep ] keep
- query>> [ over [ "query" ] dip set-at ] when*
- [ cmd-collection ] dip <mdb-query-msg> find-one
+ [ count-cmd make-cmd ] dip
+ [ collection>> "count" set-cmd-opt ]
+ [ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error )
- cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
- find-one [ "err" ] dip at ;
+ getlasterror-cmd make-cmd send-cmd
+ [ "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
+ [ validate-cmd make-cmd ] dip
+ "validate" set-cmd-opt send-cmd
+ [ check-ok nip ] keep
'[ "result" _ at print ] [ ] if ;
M: mdb-collection validate.
<mdb-insert-msg> send-message ;
: ensure-index ( index-spec -- )
- <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+ <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
[ [ key>> "key" ] dip set-at ]
[ 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 ;
+ [ delete-index-cmd make-cmd ] 2dip
+ [ "deleteIndexes" set-cmd-opt ]
+ [ "index" set-cmd-opt ] bi* send-cmd drop ;
: <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ;
: update-unsafe ( mdb-update-msg -- )
send-message ;
-
+
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
+ [ findandmodify-cmd make-cmd ] 3dip
+ [ "findandmodify" set-cmd-opt ]
+ [ "query" set-cmd-opt ]
+ [ "update" set-cmd-opt ] tri* ; inline
+
+: run-cmd ( cmd -- result )
+ send-cmd ; inline
+
: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
check-collection drop ;
: drop-collection ( name -- )
- [ cmd-collection ] dip
- "drop" H{ } clone [ set-at ] keep
- <mdb-query-msg> find-one drop ;
+ [ drop-cmd make-cmd ] dip
+ "drop" set-cmd-opt send-cmd drop ;
--- /dev/null
+USING: accessors arrays assocs base64 bson.constants
+byte-arrays byte-vectors calendar combinators
+combinators.short-circuit destructors formatting fry hashtables
+io kernel linked-assocs locals math math.parser mongodb.cmd
+mongodb.connection mongodb.driver mongodb.msg namespaces
+sequences splitting strings ;
+FROM: mongodb.driver => update ;
+IN: mongodb.gridfs
+
+CONSTANT: default-chunk-size 262144
+
+TUPLE: gridfs
+ { bucket string }
+ { files string }
+ { chunks string } ;
+
+
+<PRIVATE
+
+: gridfs> ( -- gridfs )
+ gridfs get ; inline
+
+: files-collection ( -- str ) gridfs> files>> ; inline
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
+
+
+: init-gridfs ( gridfs -- )
+ chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } }
+ <index-spec> ensure-index ; inline
+
+PRIVATE>
+
+: <gridfs> ( bucket -- gridfs )
+ [ ]
+ [ "files" "%s.%s" sprintf ]
+ [ "chunks" "%s.%s" sprintf ] tri
+ gridfs boa [ init-gridfs ] keep ;
+
+: with-gridfs ( gridfs quot -- * )
+ [ gridfs ] dip with-variable ; inline
+
+TUPLE: entry
+ { id oid }
+ { filename string }
+ { content-type string }
+ { length integer }
+ { chunk-size integer }
+ { created timestamp }
+ { aliases array }
+ { metadata hashtable }
+ { md5 string } ;
+
+<PRIVATE
+
+: id>base64 ( id -- str )
+ [ a>> >hex ] [ b>> >hex ] bi
+ 2array "#" join >base64 >string ; inline
+
+: base64>id ( str -- objid )
+ base64> >string "#" split
+ [ first ] [ second ] bi
+ [ hex> ] bi@ oid boa ; inline
+
+PRIVATE>
+
+: <entry> ( name content-type -- entry )
+ entry new
+ swap >>content-type swap >>filename
+ <oid> >>id 0 >>length default-chunk-size >>chunk-size
+ now >>created ; inline
+
+<PRIVATE
+
+TUPLE: chunk
+ { id oid }
+ { fileid oid }
+ { n integer }
+ { data byte-array } ;
+
+: at> ( assoc key -- value/f )
+ swap at ; inline
+
+:: >set-at ( assoc value key -- )
+ value key assoc set-at ; inline
+
+: (update-file) ( entry assoc -- entry )
+ {
+ [ "_id" at> >>id ]
+ [ "filename" at> >>filename ]
+ [ "contentType" at> >>content-type ]
+ [ "length" at> >>length ]
+ [ "chunkSize" at> >>chunk-size ]
+ [ "uploadDate" at> >>created ]
+ [ "aliases" at> >>aliases ]
+ [ "metadata" at> >>metadata ]
+ [ "md5" at> >>md5 ]
+ } cleave ; inline
+
+: assoc>chunk ( assoc -- chunk )
+ [ chunk new ] dip
+ {
+ [ "_id" at> >>id ]
+ [ "files_id" at> >>fileid ]
+ [ "n" at> >>n ]
+ [ "data" at> >>data ]
+ } cleave ;
+
+: assoc>entry ( assoc -- entry )
+ [ entry new ] dip (update-file) ;
+
+: entry>assoc ( entry -- assoc )
+ [ H{ } clone ] dip
+ {
+ [ id>> "_id" >set-at ]
+ [ filename>> "filename" >set-at ]
+ [ content-type>> "contentType" >set-at ]
+ [ length>> "length" >set-at ]
+ [ chunk-size>> "chunkSize" >set-at ]
+ [ created>> "uploadDate" >set-at ]
+ [ aliases>> "aliases" >set-at ]
+ [ metadata>> "metadata" >set-at ]
+ [ md5>> "md5" >set-at ]
+ [ drop ]
+ } 2cleave ; inline
+
+: create-entry ( entry -- entry )
+ [ [ files-collection ] dip entry>assoc save ] [ ] bi ;
+
+TUPLE: state bytes count ;
+
+: <state> ( -- state )
+ 0 0 state boa ; inline
+
+: get-state ( -- n )
+ state get ; inline
+
+: with-state ( quot -- state )
+ [ <state> state ] dip
+ [ get-state ] compose
+ with-variable ; inline
+
+: update-state ( bytes -- )
+ [ get-state ] dip
+ '[ _ + ] change-bytes
+ [ 1 + ] change-count drop ; inline
+
+:: store-chunk ( chunk entry n -- )
+ entry id>> :> id
+ H{ { "files_id" id }
+ { "n" n } { "data" chunk } }
+ [ chunks-collection ] dip save ; inline
+
+:: write-chunks ( stream entry -- length )
+ entry chunk-size>> :> chunk-size
+ [
+ [
+ chunk-size stream stream-read dup [
+ [ entry get-state count>> store-chunk ]
+ [ length update-state ] bi
+ ] when*
+ ] loop
+ ] with-state bytes>> ;
+
+: (entry-selector) ( entry -- selector )
+ id>> "_id" associate ; inline
+
+:: file-md5 ( id -- md5-str )
+ filemd5-cmd make-cmd
+ id "filemd5" set-cmd-opt
+ gridfs> bucket>> "root" set-cmd-opt
+ send-cmd "md5" at> ; inline
+
+: update-entry ( bytes entry -- entry )
+ [ swap >>length dup id>> file-md5 >>md5 ]
+ [ nip [ (entry-selector) ] [ ] bi
+ [ length>> "length" associate "$set" associate
+ [ files-collection ] 2dip <update> update ]
+ [ md5>> "md5" associate "$set" associate
+ [ files-collection ] 2dip <update> update ] 2bi
+ ] 2bi ;
+
+TUPLE: gridfs-input-stream entry chunk n offset cpos ;
+
+: <gridfs-input-stream> ( entry -- stream )
+ [ gridfs-input-stream new ] dip
+ >>entry 0 >>offset 0 >>cpos -1 >>n ;
+
+PRIVATE>
+
+: write-entry ( input-stream entry -- entry )
+ create-entry [ write-chunks ] keep update-entry ;
+
+: get-entry ( id -- entry )
+ [ files-collection ] dip
+ "_id" associate <query> find-one assoc>entry ;
+
+: open-entry ( entry -- input-stream )
+ <gridfs-input-stream> ;
+
+: entry-contents ( entry -- bytearray )
+ <gridfs-input-stream> stream-contents ;
+
+<PRIVATE
+
+: load-chunk ( stream -- chunk/f )
+ [ entry>> id>> "files_id" associate ]
+ [ n>> "n" associate ] bi assoc-union
+ [ chunks-collection ] dip
+ <query> find-one dup [ assoc>chunk ] when ;
+
+: exhausted? ( stream -- boolean )
+ [ offset>> ] [ entry>> length>> ] bi = ; inline
+
+: fresh? ( stream -- boolean )
+ [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
+
+: data-available ( stream -- int/f )
+ [ cpos>> ] [ chunk>> data>> length ] bi
+ 2dup < [ swap - ] [ 2drop f ] if ; inline
+
+: next-chunk ( stream -- available chunk/f )
+ 0 >>cpos [ 1 + ] change-n
+ [ ] [ load-chunk ] bi >>chunk
+ [ data-available ] [ chunk>> ] bi ; inline
+
+: ?chunk ( stream -- available chunk/f )
+ dup fresh? [ next-chunk ] [
+ dup exhausted? [ drop 0 f ] [
+ dup data-available [ swap chunk>> ] [ next-chunk ] if*
+ ] if
+ ] if ; inline
+
+: set-stream ( n stream -- )
+ swap {
+ [ >>offset drop ]
+ [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
+ [ drop dup load-chunk >>chunk drop ]
+ } 2cleave ; inline
+
+:: advance-stream ( n stream -- )
+ stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
+
+: read-part ( n stream chunk -- seq/f )
+ [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
+ [ drop advance-stream ] 3bi ; inline
+
+:: (stream-read-partial) ( n stream -- seq/f )
+ stream ?chunk :> chunk :> available
+ chunk [
+ n available <
+ [ n ] [ available ] if
+ stream chunk read-part
+ ] [ f ] if ; inline
+
+:: (stream-read) ( n stream acc -- )
+ n stream (stream-read-partial)
+ {
+ { [ dup not ] [ drop ] }
+ { [ dup length n = ] [ acc push-all ] }
+ { [ dup length n < ] [
+ [ acc push-all ] [ length ] bi
+ n swap - stream acc (stream-read) ]
+ }
+ } cond ; inline recursive
+
+PRIVATE>
+
+M: gridfs-input-stream stream-element-type drop +byte+ ;
+
+M: gridfs-input-stream stream-read ( n stream -- seq/f )
+ over <byte-vector> [ (stream-read) ] [ ] bi
+ dup empty? [ drop f ] [ >byte-array ] if ;
+
+M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
+ (stream-read-partial) ;
+
+M: gridfs-input-stream stream-tell ( stream -- n )
+ offset>> ;
+
+M: gridfs-input-stream stream-seek ( n seek-type stream -- )
+ swap seek-absolute =
+ [ set-stream ]
+ [ "seek-type not supported" throw ] if ;
+
+M: gridfs-input-stream dispose drop ;
"USING: mongodb.driver ;"
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
- " [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+ " [ \"ageIdx\" [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
" [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
"" }
{ $heading "Highlevel tuple integration" }
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 } ;
+ { 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 assoc }
-explain hint ;
+ { collection string }
+ { skip# integer initial: 0 }
+ { return# integer initial: 0 }
+ { query assoc }
+ { returnfields assoc }
+ { orderby assoc }
+ explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
-{ collection string }
-{ objects sequence } ;
+ { collection string }
+ { objects sequence } ;
TUPLE: mdb-update-msg < mdb-msg
-{ collection string }
-{ upsert? integer initial: 0 }
-{ selector assoc }
-{ object assoc } ;
+ { collection string }
+ { upsert? integer initial: 0 }
+ { selector assoc }
+ { object assoc } ;
TUPLE: mdb-delete-msg < mdb-msg
-{ collection string }
-{ selector assoc } ;
+ { collection string }
+ { selector assoc } ;
TUPLE: mdb-getmore-msg < mdb-msg
-{ collection string }
-{ return# integer initial: 0 }
-{ cursor integer initial: 0 }
-{ query mdb-query-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 } ;
+ { 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 } ;
+ { 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 )
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 ;
+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 ;
+
+FROM: mongodb.connection => connection-buffer ;
+FROM: alien => byte-length ;
+
IN: mongodb.operations
+M: byte-vector byte-length length ;
+
<PRIVATE
PREDICATE: mdb-reply-op < integer OP_Reply = ;
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
: 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-reply-op (read-message) ( msg-stub opcode -- message )
- drop
+ {
+ [ length>> >>length ]
+ [ req-id>> >>req-id ]
+ [ resp-id>> >>resp-id ]
+ [ opcode>> >>opcode ]
+ [ flags>> >>flags ]
+ } cleave ; inline
+
+: reply-read-message ( msg-stub -- message )
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } stream>assoc ] collector [ times ] dip >>objects ;
+ [ H{ } clone stream>assoc ] collector [ times ] dip >>objects ;
+
+: (read-message) ( message opcode -- message )
+ OP_Reply =
+ [ reply-read-message ]
+ [ "unknown message type" throw ] if ; inline
: read-header ( message -- message )
read-int32 >>length
read-int32 >>flags ; inline
: write-header ( message -- )
- [ req-id>> write-int32 ] keep
- [ resp-id>> write-int32 ] keep
- opcode>> write-int32 ; inline
+ [ req-id>> write-int32 ]
+ [ resp-id>> write-int32 ]
+ [ opcode>> write-int32 ] tri ; inline
PRIVATE>
: read-message ( -- message )
- mdb-msg new
- 0 >bytes-read
- read-header
- [ ] [ opcode>> ] bi (read-message) ;
+ [
+ mdb-msg new 0 >bytes-read read-header
+ [ ] [ opcode>> ] bi (read-message)
+ ] with-scope ;
<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
+: (write-message) ( message quot -- )
+ [ connection-buffer dup ] 2dip
+ '[
+ [ _ [ write-header ] [ @ ] bi ] with-length-prefix
+ ] with-output-stream* write flush ; inline
:: build-query-object ( query -- selector )
H{ } clone :> selector
- query { [ 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 ;
+ query {
+ [ 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 ; inline
+
+: write-query-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ skip#>> write-int32 ]
+ [ return#>> write-int32 ]
+ [ build-query-object assoc>stream ]
+ [ returnfields>> [ assoc>stream ] when* ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-insert-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ objects>> [ assoc>stream ] each ] tri
+ ] (write-message) ; inline
+
+: write-update-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ upsert?>> write-int32 ]
+ [ selector>> assoc>stream ]
+ [ object>> assoc>stream ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-delete-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ 0 write-int32 selector>> assoc>stream ] tri
+ ] (write-message) ; inline
+
+: write-getmore-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ return#>> write-int32 ]
+ [ cursor>> write-longlong ]
+ } cleave
+ ] (write-message) ; inline
+
+: write-killcursors-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ cursors#>> write-int32 ]
+ [ cursors>> [ write-longlong ] each ] tri
+ ] (write-message) ; inline
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) ;
-
+: write-message ( message -- )
+ {
+ { [ dup mdb-query-msg? ] [ write-query-message ] }
+ { [ dup mdb-insert-msg? ] [ write-insert-message ] }
+ { [ dup mdb-update-msg? ] [ write-update-message ] }
+ { [ dup mdb-delete-msg? ] [ write-delete-message ] }
+ { [ dup mdb-getmore-msg? ] [ write-getmore-message ] }
+ { [ dup mdb-killcursors-msg? ] [ write-killcursors-message ] }
+ } cond ;
swap set-at ; inline
: write-field? ( tuple key value -- ? )
- pick mdb-persistent? [
+ pick mdb-persistent? [
{ [ [ 2drop ] dip not ]
[ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
- [ tuple-collection name>> ] [ id>> ] bi <objref> ;
+ [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' )
<cond-value> {
: prepare-assoc ( tuple -- assoc mirror tuple assoc )
H{ } clone swap [ <mirror> ] keep pick ; inline
-: ensure-mdb-info ( tuple -- tuple )
- dup id>> [ <objid> >>id ] unless ; inline
-
: with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline
GENERIC: tuple>storable ( tuple -- storable )
+: ensure-oid ( tuple -- tuple )
+ dup id>> [ <oid> >>id ] unless ; inline
+
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) ;
+ ensure-oid (tuple>assoc) ;
M: tuple tuple>assoc ( tuple -- assoc )
(tuple>assoc) ;
: update-tuple ( tuple -- )
[ tuple-collection name>> ]
- [ id-selector ]
+ [ ensure-oid id-selector ]
[ tuple>assoc ] tri
- <update> update ;
+ <update> >upsert update ;
: save-tuple ( tuple -- )
update-tuple ;
projects / factor.git / commitdiff