Merge branch 'master' of git://factorcode.org/git/factor

basis/alien/enums/enums.factor

@@ -1,6 +1,7 @@
 ! (c)2010 Joe Groff, Erik Charlebois bsd license
 USING: accessors alien.c-types arrays combinators delegate fry
-generic.parser kernel macros math parser sequences words words.symbol ;
+generic.parser kernel macros math parser sequences words words.symbol
+classes.singleton assocs ;
 IN: alien.enums
 
 <PRIVATE
@@ -34,11 +35,11 @@ M: enum-c-type c-type-setter
 : define-enum-value ( class value -- )
     "enum-value" set-word-prop ;
 
-: define-enum-members ( member-names -- )
+: define-enum-members ( members -- )
     [
-        [ first define-symbol ]
+        [ drop define-singleton-class ]
-        [ first2 define-enum-value ] bi
+        [ define-enum-value ] 2bi
-    ] each ;
+    ] assoc-each ;
 
 : define-enum-constructor ( word -- )
     [ name>> "<" ">" surround create-in ] keep
@@ -48,8 +49,8 @@ PRIVATE>
 
 : define-enum ( word base-type members -- )
     [ dup define-enum-constructor ] 2dip
-    dup define-enum-members
+    [ define-enum-members ]
-    <enum-c-type> swap typedef ;
+    [ <enum-c-type> swap typedef ] bi ;
     
 PREDICATE: enum-c-type-word < c-type-word
     "c-type" word-prop enum-c-type? ;

basis/furnace/actions/actions-docs.factor

@@ -9,7 +9,7 @@ HELP: <action>
 
 HELP: <chloe-content>
 { $values
-     { "path" "a pathname string" }
+     { "pair" "a pair with shape " { $snippet "{ class string }" } }
      { "response" response }
 }
 { $description "Creates an HTTP response which serves a Chloe template. See " { $link "html.templates.chloe" } "." } ;

basis/html/templates/fhtml/fhtml.factor

@@ -1,5 +1,5 @@
 ! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2009 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations sequences kernel namespaces debugger
 combinators math quotations generic strings splitting accessors
@@ -26,7 +26,7 @@ M: template-lexer skip-word
 DEFER: <% delimiter
 
 : check-<% ( lexer -- col )
-    "<%" over line-text>> rot column>> start* ;
+    "<%" swap [ line-text>> ] [ column>> ] bi start* ;
 
 : found-<% ( accum lexer col -- accum )
     [
@@ -59,10 +59,10 @@ SYNTAX: %> lexer get parse-%> ;
 : parse-template ( string -- quot )
     [
         [
-        "quiet" on
+            "quiet" on
-        parser-notes off
+            parser-notes off
-        "html.templates.fhtml" use-vocab
+            "html.templates.fhtml" use-vocab
-        string-lines parse-template-lines
+            string-lines parse-template-lines
         ] with-file-vocabs
     ] with-compilation-unit ;
 
@@ -74,6 +74,6 @@ TUPLE: fhtml path ;
 C: <fhtml> fhtml
 
 M: fhtml call-template* ( filename -- )
-    [ path>> utf8 file-contents eval-template ] call( filename -- ) ;
+    path>> utf8 file-contents eval-template ;
 
 INSTANCE: fhtml template

basis/http/http-tests.factor

@@ -235,6 +235,13 @@ test-db [
         servers>> random addr>> port>>
     ] with-scope "port" set ;
 
+: add-port ( url -- url' )
+    >url clone "port" get >>port ;
+
+: stop-test-httpd ( -- )
+    "http://localhost/quit" add-port http-get nip
+    "Goodbye" assert= ;
+
 [ ] [
     <dispatcher>
         add-quit-action
@@ -248,9 +255,6 @@ test-db [
     test-httpd
 ] unit-test
 
-: add-port ( url -- url' )
-    >url clone "port" get >>port ;
-
 [ t ] [
     "vocab:http/test/foo.html" ascii file-contents
     "http://localhost/nested/foo.html" add-port http-get nip =
@@ -279,7 +283,7 @@ test-db [
 
 
 [ ] [
-    [ "http://localhost/quit" add-port http-get 2drop ] ignore-errors
+    [ stop-test-httpd ] ignore-errors
 ] unit-test
 
 ! Dispatcher bugs
@@ -402,7 +406,7 @@ SYMBOL: a
     "vocab:http/test/foo.html" ascii file-contents =
 ] unit-test
 
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+[ ] [ stop-test-httpd ] unit-test
 
 ! Check behavior of 307 redirect (reported by Chris Double)
 [ ] [
@@ -429,4 +433,16 @@ SYMBOL: a
     ] with-directory
 ] must-fail
 
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+[ ] [ stop-test-httpd ] unit-test
+
+! Check that index.fhtml works
+[ ] [
+    <dispatcher>
+        "resource:basis/http/test/" <static> enable-fhtml >>default
+        add-quit-action
+    test-httpd
+] unit-test
+
+[ "OK\n\n" ] [ "http://localhost/" add-port http-get nip ] unit-test
+
+[ ] [ stop-test-httpd ] unit-test

basis/http/server/static/static.factor

@@ -7,9 +7,10 @@ io.files.info io.directories io.pathnames io.encodings.binary
 fry xml.entities destructors urls html xml.syntax
 html.templates.fhtml http http.server http.server.responses
 http.server.redirection xml.writer ;
+FROM: sets => adjoin ;
 IN: http.server.static
 
-TUPLE: file-responder root hook special allow-listings ;
+TUPLE: file-responder root hook special index-names allow-listings ;
 
 : modified-since ( request -- date )
     "if-modified-since" header ";" split1 drop
@@ -23,7 +24,8 @@ TUPLE: file-responder root hook special allow-listings ;
     file-responder new
         swap >>hook
         swap >>root
-        H{ } clone >>special ;
+        H{ } clone >>special
+        V{ "index.html" } >>index-names ;
 
 : (serve-static) ( path mime-type -- response )
     [
@@ -75,7 +77,9 @@ TUPLE: file-responder root hook special allow-listings ;
     ] if ;
 
 : find-index ( filename -- path )
-    "index.html" append-path dup exists? [ drop f ] unless ;
+    file-responder get index-names>>
+    [ append-path dup exists? [ drop f ] unless ] with map-find
+    drop ;
 
 : serve-directory ( filename -- response )
     url get path>> "/" tail? [
@@ -97,8 +101,12 @@ M: file-responder call-responder* ( path responder -- response )
     ".." over member?
     [ drop <400> ] [ "/" join serve-object ] if ;
 
-! file responder integration
+: add-index ( name responder -- )
+    index-names>> adjoin ;
+
+: serve-fhtml ( path -- response )
+    <fhtml> "text/html" <content> ;
+
 : enable-fhtml ( responder -- responder )
-    [ <fhtml> "text/html" <content> ]
+    [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at
-    "application/x-factor-server-page"
+    "index.fhtml" over add-index ;
-    pick special>> set-at ;

basis/http/test/index.fhtml

@@ -0,0 +1 @@
+<% USE: io "OK" write %>

basis/mime/types/mime.types

@@ -726,6 +726,7 @@ audio/mpa
 audio/mpa-robust
 audio/mpeg					mpga mp2 mp2a mp3 m2a m3a
 audio/mpeg4-generic
+audio/ogg                                       oga
 audio/parityfec
 audio/pcma
 audio/pcmu
@@ -954,6 +955,7 @@ video/mpeg					mpeg mpg mpe m1v m2v
 video/mpeg4-generic
 video/mpv
 video/nv
+video/ogg                                       ogv
 video/parityfec
 video/pointer
 video/quicktime					qt mov
@@ -976,6 +978,7 @@ video/vnd.sealed.mpeg4
 video/vnd.sealed.swf
 video/vnd.sealedmedia.softseal.mov
 video/vnd.vivo					viv
+video/webm                                      webm
 video/x-dv			dv dif
 video/x-fli					fli
 video/x-ms-asf					asf asx

extra/dns/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/dns/dns.factor

@@ -0,0 +1,408 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.enums alien.syntax arrays assocs
+byte-arrays calendar combinators combinators.smart constructors
+destructors fry grouping io io.binary io.buffers
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.files io.ports io.sockets io.streams.byte-array io.timeouts
+kernel make math math.bitwise math.parser math.ranges
+math.statistics memoize namespaces random sequences
+slots.syntax splitting strings system unicode.categories
+vectors nested-comments io.sockets.private ;
+IN: dns
+
+GENERIC: stream-peek1 ( stream -- byte/f )
+
+M: input-port stream-peek1
+    dup check-disposed dup wait-to-read
+    [ drop f ] [ buffer>> buffer-peek ] if ; inline
+
+M: byte-reader stream-peek1
+    [ i>> ] [ underlying>> ] bi ?nth ;
+
+: peek1 ( -- byte ) input-stream get stream-peek1 ;
+
+: with-temporary-input-seek ( n seek-type quot -- )
+    tell-input [
+        [ seek-input ] dip call
+    ] dip seek-absolute seek-input ; inline
+
+ENUM: dns-type
+{ A 1 } { NS 2 } { MD 3 } { MF 4 }
+{ CNAME 5 } { SOA 6 } { MB 7 } { MG 8 }
+{ MR 9 } { NULL 10 } { WKS 11 } { PTR 12 }
+{ HINFO 13 } { MINFO 14 } { MX 15 } { TXT 16 }
+{ RP 17 } { AFSDB 18 } { SIG 24 } { KEY 25 }
+{ AAAA 28 } { LOC 29 } { SVR 33 } { NAPTR 35 }
+{ KX 36 } { CERT 37 } { DNAME 39 } { OPT 41 }
+{ APL 42 } { DS 43 } { SSHFP 44 } { IPSECKEY 45 }
+{ RRSIG 46 } { NSEC 47 } { DNSKEY 48 } { DHCID 49 }
+{ NSEC3 50 } { NSEC3PARAM 51 } { HIP 55 } { SPF 99 }
+{ TKEY 249 } { TSIG 250 } { IXFR 251 }
+{ TA 32768 } { DLV 32769 } ;
+
+ENUM: dns-class { IN 1 } { CS 2 } { CH 3 } { HS 4 } ;
+
+ENUM: dns-opcode QUERY IQUERY STATUS ;
+
+ENUM: dns-rcode NO-ERROR FORMAT-ERROR SERVER-FAILURE
+NAME-ERROR NOT-IMPLEMENTED REFUSED ;
+
+SYMBOL: dns-servers
+
+: add-dns-server ( string -- )
+    dns-servers get push ;
+
+: remove-dns-server ( string -- )
+    dns-servers get remove! drop ;
+
+: clear-dns-servers ( -- )
+    V{ } clone dns-servers set-global ;
+
+! Google DNS servers
+CONSTANT: initial-dns-servers { "8.8.8.8" "8.8.4.4" }
+
+: load-resolve.conf ( -- seq )
+    "/etc/resolv.conf" utf8 file-lines
+    [ [ blank? ] trim ] map
+    [ "#" head? not ] filter
+    [ [ " " split1 swap ] dip push-at ] sequence>hashtable "nameserver" swap at ;
+
+dns-servers [ initial-dns-servers >vector ] initialize
+
+: >dotted ( domain -- domain' )
+    dup "." tail? [ "." append ] unless ;
+
+: dotted> ( string -- string' )
+    "." ?tail drop ;
+
+TUPLE: query name type class ;
+CONSTRUCTOR: query ( name type class -- obj )
+    [ >dotted ] change-name ;
+
+TUPLE: rr name type class ttl rdata ;
+
+TUPLE: hinfo cpu os ;
+
+TUPLE: mx preference exchange ;
+
+TUPLE: soa mname rname serial refresh retry expire minimum ;
+
+TUPLE: a name ;
+CONSTRUCTOR: a ( name -- obj ) ;
+
+TUPLE: aaaa name ;
+CONSTRUCTOR: aaaa ( name -- obj ) ;
+
+TUPLE: cname name ;
+CONSTRUCTOR: cname ( name -- obj ) ;
+
+TUPLE: ptr name ;
+CONSTRUCTOR: ptr ( name -- obj ) ;
+
+TUPLE: ns name ;
+CONSTRUCTOR: ns ( name -- obj ) ;
+
+TUPLE: message id qr opcode aa tc rd ra z rcode
+query answer-section authority-section additional-section ;
+
+CONSTRUCTOR: message ( query -- obj )
+    16 2^ random >>id
+    0 >>qr
+    QUERY >>opcode
+    0 >>aa
+    0 >>tc
+    1 >>rd
+    0 >>ra
+    0 >>z
+    NO-ERROR >>rcode
+    [ dup sequence? [ 1array ] unless ] change-query
+    { } >>answer-section
+    { } >>authority-section
+    { } >>additional-section ;
+
+: message>header ( message -- n )
+    [
+        {
+            [ qr>> 15 shift ]
+            [ opcode>> enum>number 11 shift ]
+            [ aa>> 10 shift ]
+            [ tc>> 9 shift ]
+            [ rd>> 8 shift ]
+            [ ra>> 7 shift ]
+            [ z>> 4 shift ]
+            [ rcode>> enum>number 0 shift ]
+        } cleave
+    ] sum-outputs ;
+
+: header>message-parts ( n -- qr opcode aa tc rd ra z rcode )
+    {
+        [ -15 shift BIN: 1 bitand ]
+        [ -11 shift BIN: 111 bitand <dns-opcode> ]
+        [ -10 shift BIN: 1 bitand ]
+        [ -9 shift BIN: 1 bitand ]
+        [ -8 shift BIN: 1 bitand ]
+        [ -7 shift BIN: 1 bitand ]
+        [ -4 shift BIN: 111 bitand ]
+        [ BIN: 1111 bitand <dns-rcode> ]
+    } cleave ;
+
+: byte-array>ipv4 ( byte-array -- string )
+    [ number>string ] { } map-as "." join ;
+
+: byte-array>ipv6 ( byte-array -- string )
+    2 group [ be> >hex ] { } map-as ":" join ;
+
+: ipv4>byte-array ( string -- byte-array )
+    "." split [ string>number ] B{ } map-as ;
+
+: ipv6>byte-array ( string -- byte-array )
+    T{ inet6 } inet-pton ;
+
+: expand-ipv6 ( ipv6 -- ipv6' ) ipv6>byte-array byte-array>ipv6 ;
+
+: reverse-ipv4 ( string -- string )
+    ipv4>byte-array reverse byte-array>ipv4 ;
+
+CONSTANT: ipv4-arpa-suffix ".in-addr.arpa"
+
+: ipv4>arpa ( string -- string )
+    reverse-ipv4 ipv4-arpa-suffix append ;
+
+CONSTANT: ipv6-arpa-suffix ".ip6.arpa"
+
+: ipv6>arpa ( string -- string )
+    ipv6>byte-array [ [ -4 shift 4 bits ] [ 4 bits ] bi 2array ] { } map-as
+    B{ } concat-as reverse
+    [ >hex ] { } map-as "." join ipv6-arpa-suffix append ;
+
+: trim-ipv4-arpa ( string -- string' )
+    dotted> ipv4-arpa-suffix ?tail drop ;
+
+: trim-ipv6-arpa ( string -- string' )
+    dotted> ipv6-arpa-suffix ?tail drop ;
+ 
+: arpa>ipv4 ( string -- ip ) trim-ipv4-arpa reverse-ipv4 ;
+
+: arpa>ipv6 ( string -- ip )
+    trim-ipv6-arpa "." split 2 group reverse
+    [
+        first2 swap [ hex> ] bi@ [ 4 shift ] [ ] bi* bitor
+    ] B{ } map-as byte-array>ipv6 ;
+
+: parse-length-bytes ( -- seq ) read1 read utf8 decode ;
+
+: (parse-name) ( -- )
+    peek1 [
+        read1 drop
+    ] [
+        HEX: C0 mask? [
+            2 read be> HEX: 3fff bitand
+            seek-absolute [ parse-length-bytes , (parse-name) ] with-temporary-input-seek
+        ] [
+            parse-length-bytes , (parse-name)
+        ] if
+    ] if-zero ;
+
+: parse-name ( -- seq )
+    [ (parse-name) ] { } make "." join ;
+
+: parse-query ( -- query )
+    parse-name
+    2 read be> <dns-type>
+    2 read be> <dns-class> <query> ;
+
+: parse-soa ( -- soa )
+    soa new
+        parse-name >>mname
+        parse-name >>rname
+        4 read be> >>serial
+        4 read be> >>refresh
+        4 read be> >>retry
+        4 read be> >>expire
+        4 read be> >>minimum ;
+
+: parse-mx ( -- mx )
+    mx new
+        2 read be> >>preference
+        parse-name >>exchange ;
+
+GENERIC: parse-rdata ( n type -- obj )
+
+M: object parse-rdata drop read ;
+M: A parse-rdata 2drop 4 read byte-array>ipv4 <a> ;
+M: AAAA parse-rdata 2drop 16 read byte-array>ipv6 <aaaa> ;
+M: CNAME parse-rdata 2drop parse-name <cname> ;
+M: MX parse-rdata 2drop parse-mx ;
+M: NS parse-rdata 2drop parse-name <ns> ;
+M: PTR parse-rdata 2drop parse-name <ptr> ;
+M: SOA parse-rdata 2drop parse-soa ;
+
+: parse-rr ( -- rr )
+    rr new
+        parse-name >>name
+        2 read be> <dns-type> >>type
+        2 read be> <dns-class> >>class
+        4 read be> >>ttl
+        2 read be> over type>> parse-rdata >>rdata ;
+
+: parse-message ( ba -- message )
+    [ message new ] dip
+    binary [
+        2 read be> >>id
+        2 read be> header>message-parts set-slots[ qr opcode aa tc rd ra z rcode ]
+        2 read be> >>query
+        2 read be> >>answer-section
+        2 read be> >>authority-section
+        2 read be> >>additional-section
+        [ [ parse-query ] replicate ] change-query
+        [ [ parse-rr ] replicate ] change-answer-section
+        [ [ parse-rr ] replicate ] change-authority-section
+        [ [ parse-rr ] replicate ] change-additional-section
+    ] with-byte-reader ;
+
+: >n/label ( string -- ba )
+    [ length 1array ] [ utf8 encode ] bi B{ } append-as ;
+
+: >name ( dn -- ba ) "." split [ >n/label ] map concat ;
+
+: query>byte-array ( query -- ba )
+    [
+        {
+            [ name>> >name ]
+            [ type>> enum>number 2 >be ]
+            [ class>> enum>number 2 >be ]
+        } cleave
+    ] output>array concat ;
+
+GENERIC: rdata>byte-array ( rdata type -- obj )
+
+M: A rdata>byte-array drop ipv4>byte-array ;
+
+M: CNAME rdata>byte-array drop >name ;
+
+M: HINFO rdata>byte-array
+    drop
+    [ cpu>> >name ]
+    [ os>> >name ] bi append ;
+
+M: MX rdata>byte-array
+    drop 
+    [ preference>> 2 >be ]
+    [ exchange>> >name ] bi append ;
+
+M: NS rdata>byte-array drop >name ;
+
+M: PTR rdata>byte-array drop >name ;
+
+M: SOA rdata>byte-array
+    drop
+    [
+        {
+            [ mname>> >name ]
+            [ rname>> >name ]
+            [ serial>> 4 >be ]
+            [ refresh>> 4 >be ]
+            [ retry>> 4 >be ]
+            [ expire>> 4 >be ]
+            [ minimum>> 4 >be ]
+        } cleave
+    ] output>array concat ;
+
+: rr>byte-array ( rr -- ba )
+    [
+        {
+            [ name>> >name ]
+            [ type>> enum>number 2 >be ]
+            [ class>> enum>number 2 >be ]
+            [ ttl>> 4 >be ]
+            [
+                [ rdata>> ] [ type>> ] bi rdata>byte-array
+                [ length 2 >be ] [ ] bi append
+            ]
+        } cleave
+    ] output>array concat ;
+
+: message>byte-array ( message -- ba )
+    [
+        {
+            [ id>> 2 >be ]
+            [ message>header 2 >be ]
+            [ query>> length 2 >be ]
+            [ answer-section>> length 2 >be ]
+            [ authority-section>> length 2 >be ]
+            [ additional-section>> length 2 >be ]
+            [ query>> [ query>byte-array ] map concat ]
+            [ answer-section>> [ rr>byte-array ] map concat ]
+            [ authority-section>> [ rr>byte-array ] map concat ]
+            [ additional-section>> [ rr>byte-array ] map concat ]
+        } cleave
+    ] output>array concat ;
+
+: udp-query ( bytes server -- bytes' )
+    f 0 <inet4> <datagram>
+    5 seconds over set-timeout [
+        [ send ] [ receive drop ] bi
+    ] with-disposal ;
+
+: <dns-inet4> ( -- inet4 )
+    dns-servers get random 53 <inet4> ;
+
+: dns-query ( query -- message )
+    <message> message>byte-array
+    <dns-inet4> udp-query parse-message ;
+
+: dns-A-query ( domain -- message ) A IN <query> dns-query ;
+: dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
+: dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
+: dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
+
+: reverse-lookup ( reversed-ip -- message )
+    PTR IN <query> dns-query ;
+
+: reverse-ipv4-lookup ( ip -- message )
+    ipv4>arpa reverse-lookup ;
+
+: reverse-ipv6-lookup ( ip -- message )
+    ipv6>arpa reverse-lookup ;
+
+: message>names ( message -- names )
+    answer-section>> [ rdata>> name>> ] map ;
+
+: message>mxs ( message -- assoc )
+    answer-section>> [ rdata>> [ preference>> ] [ exchange>> ] bi 2array ] map ;
+
+: messages>names ( messages -- names ) 
+    [ message>names ] map concat ;
+
+: forward-confirmed-reverse-dns-ipv4? ( ipv4-string -- ? )
+    dup reverse-ipv4-lookup message>names
+    [ dns-A-query ] map messages>names member? ;
+
+: forward-confirmed-reverse-dns-ipv6? ( ipv6-string -- ? )
+    expand-ipv6
+    dup reverse-ipv6-lookup message>names
+    [ dns-AAAA-query ] map messages>names member? ;
+
+: message>query-name ( message -- string )
+    query>> first name>> dotted> ;
+
+: a-line. ( host ip -- )
+    [ write " has address " write ] [ print ] bi* ;
+
+: a-message. ( message -- )
+    [ message>query-name ] [ message>names ] bi
+    [ a-line. ] with each ;
+
+: mx-line. ( host pair -- )
+    [ write " mail is handled by " write ]
+    [ first2 [ number>string write bl ] [ print ] bi* ] bi* ;
+
+: mx-message. ( message -- )
+    [ message>query-name ] [ message>mxs ] bi
+    [ mx-line. ] with each ;
+
+: host ( domain -- )
+    [ dns-A-query a-message. ]
+    [ dns-AAAA-query a-message. ]
+    [ dns-MX-query mx-message. ] tri ;

extra/mongodb/connection/connection.factor

@@ -2,7 +2,7 @@ USING: accessors arrays assocs byte-vectors checksums
 checksums.md5 constructors continuations destructors fry
 hashtables io.encodings.binary io.encodings.string
 io.encodings.utf8 io.sockets io.streams.duplex kernel locals
-math math.parser mongodb.cmd mongodb.msg
+math math.parser mongodb.cmd mongodb.msg strings
 namespaces sequences splitting ;
 IN: mongodb.connection
 
@@ -112,10 +112,13 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
    ":" split [ first ] [ second string>number ] bi ; inline
 
 : eval-ismaster-result ( node result -- )
-   [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
+   [
-   [ [ "remote" ] dip at
+        [ "ismaster" ] dip at dup string?
-     [ split-host-str <inet> f <mdb-node> >>remote ] when*
+        [ >integer 1 = ] [ ] if >>master? drop
-     drop ] 2bi ;
+   ] [
+        [ "remote" ] dip at
+        [ split-host-str <inet> f <mdb-node> >>remote ] when* drop
+    ] 2bi ;
 
 : check-node ( mdb node --  )
    [ <mdb-connection> &dispose ] dip

extra/mongodb/driver/driver.factor

@@ -98,10 +98,12 @@ SYNTAX: r/ ( token -- mdbregexp )
     [ <mdb-pool> ] dip
     [ mdb-pool swap with-variable ] curry with-disposal ; inline
 
-: with-mdb-connection ( quot -- )
+: with-mdb-pool ( ..a mdb-pool quot -- ..b )
-    [ mdb-pool get ] dip 
     '[ _ with-connection ] with-pooled-connection ; inline
 
+: with-mdb-connection ( quot -- )
+    [ mdb-pool get ] dip with-mdb-pool ; inline
+
 : >id-selector ( assoc -- selector )
     [ MDB_OID_FIELD swap at ] keep
     H{ } clone [ set-at ] keep ;
@@ -225,6 +227,15 @@ M: mdb-query-msg find
 M: mdb-cursor find
     get-more ;
 
+: each-chunk ( selector quot: ( seq -- ) -- )
+    swap find
+    [ pick call( seq -- ) ] when*
+    [ swap each-chunk ] [ drop ] if* ;
+
+: find-all ( selector -- seq )
+    [ V{ } clone ] dip
+    over '[ _ push-all ] each-chunk >array ;
+
 : explain. ( mdb-query-msg -- )
     t >>explain find nip . ;
 

extra/mongodb/tuple/tuple.factor

@@ -38,6 +38,8 @@ SYNTAX: MDBTUPLE:
     [ drop-table ] 
     [ ensure-table ] bi ;
 
+DEFER: tuple>query
+
 <PRIVATE
 
 GENERIC: id-selector ( object -- selector )
@@ -52,6 +54,10 @@ M: mdb-persistent id-selector
    swap '[ [ _ ] 2dip
            [ id-selector ] dip
            <update> >upsert update ] assoc-each ; inline
+
+: prepare-tuple-query ( tuple/query -- query )
+    dup mdb-query-msg? [ tuple>query ] unless ;
+
 PRIVATE>
  
 : save-tuple-deep ( tuple -- )
@@ -83,12 +89,16 @@ PRIVATE>
    tuple>selector <query> ;
 
 : select-tuple ( tuple/query -- tuple/f )
-   dup mdb-query-msg? [ tuple>query ] unless
+   prepare-tuple-query
    find-one [ assoc>tuple ] [ f ] if* ;
 
 : select-tuples ( tuple/query -- cursor tuples/f )
-   dup mdb-query-msg? [ tuple>query ] unless
+   prepare-tuple-query
    find [ assoc>tuple ] map ;
 
+: select-all-tuples ( tuple/query -- tuples )
+   prepare-tuple-query
+   find-all [ assoc>tuple ] map ;
+
 : count-tuples ( tuple/query -- n )
    dup mdb-query-msg? [ tuple>query ] unless count ;

extra/slots/syntax/syntax-docs.factor

@@ -22,11 +22,33 @@ HELP: slots{
            "{ 3 5 }"
 } ;
 
+HELP: set-slots{
+{ $description "Sets slot values in a tuple from an array." }
+{ $example "USING: prettyprint slots.syntax kernel ;"
+           "IN: slots.syntax.example"
+           "TUPLE: rectangle width height ;"
+           "rectangle new { 3 5 } set-slots{ width height } ."
+           "T{ rectangle { width 3 } { height 5 } }"
+} ;
+
+HELP: set-slots[
+{ $description "Sets slot values in a tuple from the stack." }
+{ $example "USING: prettyprint slots.syntax kernel ;"
+           "IN: slots.syntax.example"
+           "TUPLE: rectangle width height ;"
+           "rectangle new 3 5 set-slots[ width height ] ."
+           "T{ rectangle { width 3 } { height 5 } }"
+} ;
+
 ARTICLE: "slots.syntax" "Slots syntax sugar"
-"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for taking a sequence of slots from a tuple." $nl
+"The " { $vocab-link "slots.syntax" } " vocabulary provides an alternative syntax for getting and setting multiple values of a tuple." $nl
 "Syntax sugar for cleaving slots to the stack:"
 { $subsections POSTPONE: slots[ }
-"Syntax sugar for cleaving slots to an array:"
+"Cleaving slots to an array:"
-{ $subsections POSTPONE: slots{ } ;
+{ $subsections POSTPONE: slots{ }
+"Setting slots from the stack:"
+{ $subsections POSTPONE: set-slots[ }
+"Setting slots from an array:"
+{ $subsections POSTPONE: set-slots{ } ;
 
 ABOUT: "slots.syntax"

extra/slots/syntax/syntax.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators combinators.smart fry lexer quotations
+USING: combinators combinators.smart fry kernel lexer
-sequences slots  ;
+quotations sequences sequences.generalizations slots words ;
 IN: slots.syntax
 
 SYNTAX: slots[
@@ -11,3 +11,15 @@ SYNTAX: slots[
 SYNTAX: slots{
     "}" [ reader-word 1quotation ] map-tokens
     '[ [ _ cleave ] output>array ] append! ;
+
+: writer-word* ( name -- word )
+    ">>" prepend "accessors" lookup ;
+
+SYNTAX: set-slots[
+    "]" [ writer-word* 1quotation ] map-tokens
+    '[ _ spread ] append! ;
+
+SYNTAX: set-slots{
+    "}" [ writer-word* 1quotation ] map-tokens
+    [ length ] [ ] bi
+    '[ _ firstn _ spread ] append! ;