Joe Groff 2009-05-01 13:01:04 -05:00
commit c8739f5430
125 changed files with 3076 additions and 172 deletions

1
Makefile Normal file → Executable file
View File

@ -10,7 +10,6 @@ VERSION = 0.92
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall -Werror
FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG

View File

@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
] when* ;
: init-alarms ( -- )
alarms global [ cancel-alarms <min-heap> ] change-at
alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;

2
basis/alien/libraries/libraries-docs.factor Normal file → Executable file
View File

@ -15,7 +15,7 @@ HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
{ $values { "name" "a string" } { "library" "a hashtable" } }
{ $values { "name" "a string" } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }

View File

@ -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

View File

@ -7,7 +7,7 @@ compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
global [ dupd ?set-at ] change-at ;
[ dupd ?set-at ] change-global ;
SYMBOL: sent-messages

View File

@ -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:"

View File

@ -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 ( -- )

View File

@ -4,4 +4,11 @@ USING: tools.test combinators generic.single sequences kernel ;
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
! VM type check error
[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
: call-test ( q -- ) call( -- ) ;
[ ] [ [ ] call-test ] unit-test
[ ] [ f [ drop ] curry call-test ] unit-test
[ ] [ [ ] [ ] compose call-test ] unit-test
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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>
] [

View File

@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
\ event-stream-counter counter ;
[
event-stream-callbacks global
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
event-stream-callbacks
[ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id )

View File

@ -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? [

View File

@ -1,6 +1,6 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline generic.standard delegate.protocols
accessors eval multiline generic.single delegate.protocols
delegate.private assocs see ;
IN: delegate.tests

View File

@ -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

View File

@ -1,6 +1,7 @@
USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
urls.encoding byte-arrays strings assocs sequences destructors ;
urls.encoding byte-arrays strings assocs sequences destructors
http.client.post-data.private ;
IN: http.client
HELP: download-failed
@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
{ $subsection with-http-get }
{ $subsection with-http-request } ;
ARTICLE: "http.client.post-data" "HTTP client submission data"
ARTICLE: "http.client.post-data" "HTTP client post data"
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
{ $code
"\"my-large-post-request.txt\" ascii <file-reader>"
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
} ;
}
"An internal word used to convert objects to " { $link post-data } " instances:"
{ $subsection >post-data } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"

View File

@ -0,0 +1,6 @@
IN: http.client.post-data
USING: http http.client.post-data.private help.markup help.syntax kernel ;
HELP: >post-data
{ $values { "object" object } { "post-data" { $maybe post-data } } }
{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;

22
basis/io/styles/styles-docs.factor Normal file → Executable file
View File

@ -1,17 +1,17 @@
USING: help.markup help.syntax io.streams.plain io strings
hashtables kernel quotations colors ;
hashtables kernel quotations colors assocs ;
IN: io.styles
HELP: stream-format
{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
@ -21,7 +21,7 @@ $nl
$io-error ;
HELP: stream-write-table
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -29,13 +29,13 @@ $nl
$io-error ;
HELP: make-cell-stream
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
@ -43,19 +43,19 @@ $nl
$io-error ;
HELP: format
{ $values { "str" string } { "style" "a hashtable" } }
{ $values { "str" string } { "style" assoc } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@ -85,7 +85,7 @@ HELP: write-cell
$io-error ;
HELP: with-style
{ $values { "style" "a hashtable" } { "quot" quotation } }
{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;

3
basis/macros/macros-docs.factor Normal file → Executable file
View File

@ -49,6 +49,7 @@ $nl
{ $subsection POSTPONE: MACRO: }
"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
{ $subsection define-transform }
"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
{ $see-also "generalizations" "fry" } ;
ABOUT: "macros"

View File

@ -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

36
basis/refs/refs-docs.factor Normal file → Executable file
View File

@ -1,14 +1,18 @@
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: boxes help.markup help.syntax kernel math namespaces ;
USING: boxes help.markup help.syntax kernel math namespaces assocs ;
IN: refs
ARTICLE: "refs" "References"
"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
{ $subsection get-ref }
{ $subsection set-ref }
{ $subsection set-ref* }
{ $subsection delete-ref }
"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol."
{ $subsection "refs-protocol" }
{ $subsection "refs-impls" }
{ $subsection "refs-utils" }
"References are used by the " { $link "ui-inspector" } "." ;
ABOUT: "refs"
ARTICLE: "refs-impls" "Reference implementations"
"References to objects:"
{ $subsection obj-ref }
{ $subsection <obj-ref> }
@ -27,20 +31,24 @@ ARTICLE: "refs" "References"
{ $subsection slot-ref }
{ $subsection <slot-ref> }
"Using boxes as references:"
{ $subsection "box-refs" }
"References are used by the UI inspector." ;
{ $subsection "box-refs" } ;
ABOUT: "refs"
ARTICLE: "refs-utils" "Reference utilities"
{ $subsection ref-on }
{ $subsection ref-off }
{ $subsection ref-inc }
{ $subsection ref-dec }
{ $subsection set-ref* } ;
ARTICLE: "refs-protocol" "Reference Protocol"
ARTICLE: "refs-protocol" "Reference protocol"
"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
{ $subsection get-ref }
{ $subsection set-ref }
"References may also implement:"
{ $subsection delete-ref } ;
ARTICLE: "box-refs" "Using Boxes as References"
"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
ARTICLE: "box-refs" "Boxes as references"
{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
HELP: ref
{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
@ -89,14 +97,14 @@ HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
HELP: <key-ref>
{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } }
{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } }
{ $description "Creates a reference to a key stored in an assoc." } ;
HELP: value-ref
{ $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;
HELP: <value-ref>
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
{ get-ref set-ref delete-ref set-ref* } related-words

View File

@ -19,7 +19,7 @@ IN: stack-checker.call-effect
TUPLE: inline-cache value ;
: cache-hit? ( word/quot ic -- ? )
[ value>> ] [ value>> eq? ] bi and ; inline
[ value>> eq? ] [ value>> ] bi and ; inline
SINGLETON: +unknown+

7
basis/stack-checker/errors/errors-docs.factor Normal file → Executable file
View File

@ -84,8 +84,11 @@ HELP: inconsistent-recursive-call-error
} ;
ARTICLE: "inference-errors" "Stack checker errors"
"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
$nl
"These " { $link "inference" } " failure conditions are reported in one of two ways:"
{ $list
{ { $link "tools.inference" } " throws them as errors" }
{ "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
}
"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
{ $subsection literal-expected }
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"

View File

@ -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* ;

View File

@ -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 ;

View File

@ -1,6 +1,4 @@
IN: tools.disassembler.tests
USING: math classes.tuple prettyprint.custom
tools.disassembler tools.test strings ;
USING: kernel fry vocabs tools.disassembler tools.test sequences ;
[ ] [ \ + disassemble ] unit-test
[ ] [ M\ string pprint* disassemble ] unit-test
"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each

View File

@ -3,7 +3,7 @@
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
math.parser system make fry arrays ;
math.parser system make fry arrays libc destructors ;
IN: tools.disassembler.udis
<<
@ -47,11 +47,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ;
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
: <ud> ( -- ud )
"ud" <c-object>
"ud" malloc-object &free
dup ud_init
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- )
[ [ <ud> ] dip call ] with-destructors ; inline
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
@ -82,10 +85,12 @@ SINGLETON: udis-disassembler
] { } make ;
M: udis-disassembler disassemble* ( from to -- buffer )
[ <ud> ] 2dip {
'[
_ _
[ drop ud_set_pc ]
[ buf/len ud_set_input_buffer ]
[ 2drop (disassemble) format-disassembly ]
} 3cleave ;
3tri
] with-ud ;
udis-disassembler disassembler-backend set-global

View File

@ -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

1
basis/tuple-arrays/summary.txt Executable file
View File

@ -0,0 +1 @@
Efficient arrays of tuples with value semantics for elements

1
basis/tuple-arrays/tags.txt Executable file
View File

@ -0,0 +1 @@
collections

View File

@ -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

View File

@ -46,14 +46,16 @@ mouse-index
{ takes-focus? initial: t }
focused? ;
: <table> ( rows renderer -- table )
table new-line-gadget
: new-table ( rows renderer class -- table )
new-line-gadget
swap >>renderer
swap >>model
f <model> >>selected-value
sans-serif-font >>font
focus-border-color >>focus-border-color
transparent >>column-line-color ;
transparent >>column-line-color ; inline
: <table> ( rows renderer -- table ) table new-table ;
<PRIVATE

View File

@ -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
[

View File

@ -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 ;

View File

@ -7,7 +7,7 @@ IN: ui.tools.common
SYMBOL: tool-dims
tool-dims global [ H{ } clone or ] change-at
tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ;

View File

@ -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? ;

View File

@ -28,7 +28,7 @@ SYMBOL: windows
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
windows global [ [ first = not ] with filter ] change-at ;
windows [ [ first = not ] with filter ] change-global ;
: raised-window ( world -- )
windows get-global

View File

@ -842,7 +842,7 @@ SYMBOLS:
[ define-constants ] "windows.dinput.constants" add-init-hook
: uninitialize ( variable quot -- )
[ global ] dip '[ _ when* f ] change-at ; inline
'[ _ when* f ] change-global ; inline
: free-dinput-constants ( -- )
{

View File

@ -205,7 +205,7 @@ find_architecture() {
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
}
c_find_word_size() {

2
core/combinators/combinators-docs.factor Normal file → Executable file
View File

@ -290,7 +290,6 @@ $nl
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
{ $subsection call-effect }
{ $subsection execute-effect }
{ $subsection "call-unsafe" }
"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
{ $subsection "call-unsafe" }
{ $see-also "effects" "inference" } ;
@ -306,6 +305,7 @@ ARTICLE: "combinators" "Combinators"
{ $subsection "combinators.smart" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
{ $subsection "combinators-quot" }
{ $subsection "generalizations" }
{ $see-also "quotations" } ;
ABOUT: "combinators"

0
core/combinators/combinators-tests.factor Normal file → Executable file
View File

View File

@ -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

View File

@ -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 ;

2
core/hashtables/hashtables-docs.factor Normal file → Executable file
View File

@ -116,7 +116,7 @@ HELP: ?set-at
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
HELP: >hashtable
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $values { "assoc" assoc } { "hashtable" hashtable } }
{ $description "Constructs a hashtable from any assoc." } ;
HELP: rehash

View File

@ -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

View File

@ -1,7 +1,7 @@
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
make math sequences system threads tools.test generic.standard ;
make math sequences system threads tools.test generic.single ;
IN: io.files.tests
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test

20
core/namespaces/namespaces-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
sequences words namespaces.private quotations vectors
math.parser math words.symbol ;
math.parser math words.symbol assocs ;
IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators"
@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values"
{ $subsection off }
{ $subsection inc }
{ $subsection dec }
{ $subsection change } ;
{ $subsection change }
{ $subsection change-global } ;
ARTICLE: "namespaces-global" "Global variables"
{ $subsection namespace }
@ -73,6 +74,11 @@ HELP: change
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
{ $side-effects "variable" } ;
HELP: change-global
{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." }
{ $side-effects "variable" } ;
HELP: +@
{ $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } }
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
@ -113,19 +119,19 @@ HELP: with-variable
} ;
HELP: make-assoc
{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } }
{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
HELP: bind
{ $values { "ns" "a hashtable" } { "quot" quotation } }
{ $values { "ns" assoc } { "quot" quotation } }
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;
HELP: namespace
{ $values { "namespace" "an assoc" } }
{ $values { "namespace" assoc } }
{ $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ;
HELP: global
{ $values { "g" "an assoc" } }
{ $values { "g" assoc } }
{ $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ;
HELP: get-global
@ -150,7 +156,7 @@ HELP: set-namestack
{ $description "Replaces the name stack with a copy of the given vector." } ;
HELP: >n
{ $values { "namespace" "an assoc" } }
{ $values { "namespace" assoc } }
{ $description "Pushes a namespace on the name stack." } ;
HELP: ndrop

View File

@ -24,12 +24,13 @@ PRIVATE>
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
: change-global ( variable quot -- ) [ global ] dip change-at ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline

View File

@ -1,4 +1,4 @@
USING: kernel help.markup help.syntax sequences quotations ;
USING: kernel help.markup help.syntax sequences quotations assocs ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
@ -42,7 +42,7 @@ HELP: adjoin
{ $side-effects "seq" } ;
HELP: conjoin
{ $values { "elt" object } { "assoc" "an assoc" } }
{ $values { "elt" object } { "assoc" assoc } }
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
{ $examples
{ $example
@ -54,7 +54,7 @@ HELP: conjoin
{ $side-effects "assoc" } ;
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }

View File

@ -1,5 +1,5 @@
IN: slots.tests
USING: math accessors slots strings generic.standard kernel
USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ;

View File

@ -58,7 +58,7 @@ unit-test
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with
! Make sure 24-bit strings work
"hello world" "s" set

View File

@ -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 ;

6
extra/bson/bson.factor Normal file
View File

@ -0,0 +1,6 @@
USING: vocabs.loader ;
IN: bson
"bson.reader" require
"bson.writer" require

View File

@ -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

View File

@ -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 ;

View File

@ -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|| ;

View File

@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math
parser crypto.hmac tools.test ;
IN: crypto.hmac.tests
[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
[
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
] [
16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
[
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
]
[
16 HEX: aa <string>
50 HEX: dd <repetition> sequence>md5-hmac >string
] unit-test
[
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
] [
16 11 <string> "Hi There" sequence>sha1-hmac >string
] unit-test
[
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
] [
"Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string
] unit-test
[
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
] [
16 HEX: aa <string>
50 HEX: dd <repetition> sequence>sha1-hmac >string
] unit-test

View File

@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;
IN: crypto.hmac
<PRIVATE
: sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
@ -24,6 +26,7 @@ IN: crypto.hmac
[ bitxor ] 2map ;
MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
[ opad seq-bitxor ] keep
ipad seq-bitxor ;
PRIVATE>
: stream>sha1-hmac ( K stream -- hmac )
[ init-hmac sha1-hmac ] with-input-stream ;
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
: byte-array>sha1-hmac ( K string -- hmac )
: sequence>sha1-hmac ( K sequence -- hmac )
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
: byte-array>md5-hmac ( K string -- hmac )
: sequence>md5-hmac ( K sequence -- hmac )
binary <byte-reader> stream>md5-hmac ;

View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-unicode? f }
{ deploy-threads? t }
{ deploy-math? t }
{ deploy-name "drills" }
{ deploy-ui? t }
{ deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
}

View File

@ -0,0 +1,36 @@
USING: accessors arrays cocoa.dialogs combinators continuations
fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings system ;
IN: drills.deployed
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
[ [ second ] card ]
[ '[ |<< it get _ model-changed ] "No" op ]
[ '[ |<< [ it get [
_ value>> swap remove
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
] change-model ] with-return ] "Yes" op ]
} cleave
2array { 1 0 } <track> swap [ 0.5 track-add ] each
3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
: drill ( -- ) [
open-panel [
[ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
"Got it?" open-window
] [ 0 exit ] if*
] with-ui ;
MAIN: drill

View File

@ -0,0 +1 @@
unportable

View File

@ -3,40 +3,34 @@ fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks ui.gestures
ui.gadgets.corners ;
ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
wrap.strings ;
IN: drills
SYMBOLS: it startLength ;
: big ( gadget -- gadget ) { "sans-serif" plain 30 } >>font ;
: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
[ [ [ second ] [ drop [ "malformed input" throw ] "Malformed Input" alert ] recover ] card ]
[ '[ |<< [ it get [
_ value>> swap remove
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
] change-model ] with-return ] "Yes" op ]
[ '[ |<< it get _ model-changed ] "No" op ] } cleave
[ [ second ] card ]
[ '[ |<< it get _ model-changed ] "No" op ]
[ '[ |<< [ it get [
_ value>> swap remove
[ [ it get go-back ] "Drill Complete" alert return ] when-empty
] change-model ] with-return ] "Yes" op ]
} cleave
2array { 1 0 } <track> swap [ 0.5 track-add ] each
3array <book*> 3 3 <frame> { 450 175 } >>pref-dim swap @center grid-add
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> @bottom grid-add ;
3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
: drill ( -- ) [
: drill ( -- ) [
open-panel [
[ utf8 file-lines [ "\t" split
[ " " split 4 group [ " " join ] map ] map ] map ] map concat dup [ [ first ] [ second ] bi swap 2array ] map append
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
"Got it?" open-window
[ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
[ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
"Got it?" open-window
] when*
] with-ui ;
MAIN: drill
! FIXME: command-line opening
! TODO: Menu bar
! TODO: Pious hot-buttons
MAIN: drill

View File

@ -22,7 +22,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+dinput+ set-global ;
: delete-dinput ( -- )
+dinput+ global [ com-release f ] change-at ;
+dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
+dinput+ get swap f <void*>
@ -172,10 +172,8 @@ TUPLE: window-rect < rect window-loc ;
[ +device-change-window+ set-global ] bi ;
: close-device-change-window ( -- )
+device-change-handle+ global
[ UnregisterDeviceNotification drop f ] change-at
+device-change-window+ global
[ DestroyWindow win32-error=0/f f ] change-at ;
+device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
+device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
: add-wm-devicechange ( -- )
[ 4dup handle-wm-devicechange DefWindowProc ]
@ -185,14 +183,11 @@ TUPLE: window-rect < rect window-loc ;
WM_DEVICECHANGE wm-handlers get-global delete-at ;
: release-controllers ( -- )
+controller-devices+ global [
[ drop com-release ] assoc-each f
] change-at
+controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
f +controller-guids+ set-global ;
: release-keyboard ( -- )
+keyboard-device+ global
[ com-release f ] change-at
+keyboard-device+ [ com-release f ] change-global
f +keyboard-state+ set-global ;
M: dinput-game-input-backend (open-game-input)

View File

@ -239,7 +239,7 @@ M: iokit-game-input-backend (reset-game-input)
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
+hid-manager+ global [
+hid-manager+ [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
@ -247,7 +247,7 @@ M: iokit-game-input-backend (close-game-input)
[ 0 IOHIDManagerClose drop ]
[ CFRelease ] tri
f
] change-at
] change-global
f +keyboard-state+ set-global
f +controller-states+ set-global
] when ;

View File

@ -0,0 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-unicode? t }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-name "Merger" }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-word-defs? f }
}

View File

@ -0,0 +1,30 @@
USING: accessors arrays fry io.directories kernel models sequences sets ui
ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
math.rectangles cocoa.dialogs ;
IN: merger
: main ( -- ) [
vertical <track>
{ "From:" "To:" } f <model> f <model> 2array
[
[
"…" [
open-panel [ first
[ <label> 1array >>children drop ]
[ swap set-control-value ] 2bi ] [ drop ] if*
] <border-button> swap >>model swap <labeled-gadget>
1 track-add
] 2each
] keep
dup first2
'[ _ [ value>> ] all? [ parent>> "processing..." <label> [
<zero-rect> show-glass
_ value>> [
"." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
] with-directory
] keep hide-glass
] [ drop ] if ]
"merge" swap <border-button> 0.4 track-add { 300 220 } >>pref-dim "Merging" open-window
] with-ui ;
MAIN: main

2
extra/merger/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable

View File

@ -0,0 +1 @@
Sam Anklesaria

View File

@ -0,0 +1,4 @@
USING: modules.rpc-server vocabs ;
IN: modules.remote-loading mem-service
: get-vocab ( vocabstr -- vocab ) vocab ;

View File

@ -0,0 +1 @@
required for listeners allowing remote loading of modules

View File

@ -0,0 +1 @@
Sam Anklesaria

View File

@ -0,0 +1,37 @@
USING: accessors assocs continuations effects io
io.encodings.binary io.servers.connection kernel
memoize namespaces parser sets sequences serialize
threads vocabs vocabs.parser words ;
IN: modules.rpc-server
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
: do-rpc ( args word -- bytes )
[ execute ] curry with-datastack object>bytes ; inline
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
swap at "executer" get execute( args word -- bytes ) write flush ;
: (serve) ( -- ) deserialize dup serving-vocabs get-global index
[ process ] [ drop ] if ;
: start-serving-vocabs ( -- ) [
<threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
start-server ] in-thread ;
: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
current-vocab serving-vocabs get-global adjoin
"get-words" create-in
in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
(( -- words )) define-inline ;
SYNTAX: service \ do-rpc "executer" set (service) ;
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
load-vocab-hook [
[ dup words>> values
\ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
append ] change-global

View File

@ -0,0 +1 @@
remote procedure call server

View File

@ -0,0 +1 @@
Sam Anklesaria

View File

@ -0,0 +1,9 @@
USING: help.syntax help.markup ;
IN: modules.rpc
ARTICLE: { "modules" "protocol" } "RPC Protocol"
{ $list
"Send vocab as string"
"Send arglist"
"Send word as string"
"Receive result list"
} ;

View File

@ -0,0 +1,26 @@
USING: accessors compiler.units combinators fry generalizations io
io.encodings.binary io.sockets kernel namespaces
parser sequences serialize vocabs vocabs.parser words ;
IN: modules.rpc
DEFER: get-words
: remote-quot ( addrspec vocabspec effect str -- quot )
'[ _ 5000 <inet> binary
[
_ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
] with-client
] ;
: define-remote ( addrspec vocabspec effect str -- ) [
[ remote-quot ] 2keep create-in -rot define-declared word make-inline
] with-compilation-unit ;
: with-in ( vocab quot -- vocab ) over
[ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
: remote-vocab ( addrspec vocabspec -- vocab )
dup "-remote" append [
[ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
[ rot first2 swap define-remote ] 2curry each
] with-in ;

View File

@ -0,0 +1 @@
remote procedure call client

View File

@ -0,0 +1 @@
Sam Anklesaria

View File

@ -0,0 +1 @@
module pushing in remote-loading listeners

View File

@ -0,0 +1,5 @@
USING: assocs modules.rpc-server vocabs
modules.remote-loading words ;
IN: modules.uploads service
: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;

View File

@ -0,0 +1 @@
Sam Anklesaria

View File

@ -0,0 +1 @@
improved module import syntax

View File

@ -0,0 +1 @@
unportable

View File

@ -0,0 +1,3 @@
USING: modules.rpc-server io.servers.connection ;
IN: modules.test-server service
: rpc-hello ( -- str ) "hello world" stop-this-server ;

View File

@ -0,0 +1,4 @@
USING: modules.using ;
IN: modules.using.tests
USING: tools.test localhost::modules.test-server ;
[ "hello world" ] [ rpc-hello ] unit-test

View File

@ -0,0 +1,14 @@
USING: modules.using modules.rpc-server help.syntax help.markup strings ;
IN: modules
HELP: service
{ $syntax "IN: module service" }
{ $description "Starts a server for requests for remote procedure calls." } ;
ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
HELP: USING:
{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;

View File

@ -0,0 +1,36 @@
USING: assocs kernel modules.remote-loading modules.rpc
namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
strings ;
IN: modules.using
: >qualified ( vocab prefix -- assoc )
[ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
: >partial-vocab ( words assoc -- assoc )
[ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
EBNF: modulize
tokenpart = (!(':').)+ => [[ >string ]]
s = ':' => [[ drop ignore ]]
rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
remote = tokenpart s tokenpart => [[ first2 remote-load ]]
plain = tokenpart => [[ load-vocab ]]
module = rpc | remote | plain
;EBNF
ON-BNF: USING:
tokenizer = <foreign factor>
sym = !(";"|"}"|"=>").
modspec = sym => [[ modulize ]]
qualified = modspec sym => [[ first2 >qualified ]]
unqualified = modspec => [[ vocab-words ]]
words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
short = modspec => [[ use+ ignore ]]
wordSpec = long | short
using = wordSpec+ ";" => [[ drop ignore ]]
;ON-BNF

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Sascha Matzke

View File

@ -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"

View File

@ -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 ;

View File

@ -0,0 +1 @@
A driver for the MongoDB document-oriented database (http://www.mongodb.org)

View File

@ -0,0 +1 @@
database

View File

@ -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

View File

@ -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

View File

@ -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) ;

Some files were not shown because too many files have changed in this diff Show More