diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor index 18000105e7..f46702f450 100644 --- a/basis/alien/enums/enums.factor +++ b/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 > "<" ">" surround create-in ] keep @@ -48,8 +49,8 @@ PRIVATE> : define-enum ( word base-type members -- ) [ dup define-enum-constructor ] 2dip - dup define-enum-members - swap typedef ; + [ define-enum-members ] + [ swap typedef ] bi ; PREDICATE: enum-c-type-word < c-type-word "c-type" word-prop enum-c-type? ; diff --git a/basis/furnace/actions/actions-docs.factor b/basis/furnace/actions/actions-docs.factor index 862bdead72..ae9dd9b65c 100644 --- a/basis/furnace/actions/actions-docs.factor +++ b/basis/furnace/actions/actions-docs.factor @@ -9,7 +9,7 @@ HELP: HELP: { $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" } "." } ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index d4cb484a79..bf27278213 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/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 - parser-notes off - "html.templates.fhtml" use-vocab - string-lines parse-template-lines + "quiet" on + parser-notes off + "html.templates.fhtml" use-vocab + string-lines parse-template-lines ] with-file-vocabs ] with-compilation-unit ; @@ -74,6 +74,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - [ path>> utf8 file-contents eval-template ] call( filename -- ) ; + path>> utf8 file-contents eval-template ; INSTANCE: fhtml template diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index 1a74e3fc6d..ed146d98de 100644 --- a/basis/http/http-tests.factor +++ b/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= ; + [ ] [ 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 +[ ] [ + + "resource:basis/http/test/" 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 diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 6b65cd5fe4..294c3d7a0d 100644 --- a/basis/http/server/static/static.factor +++ b/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 ) + "text/html" ; + : enable-fhtml ( responder -- responder ) - [ "text/html" ] - "application/x-factor-server-page" - pick special>> set-at ; + [ serve-fhtml ] "application/x-factor-server-page" pick special>> set-at + "index.fhtml" over add-index ; diff --git a/basis/http/test/index.fhtml b/basis/http/test/index.fhtml new file mode 100644 index 0000000000..72a9c87242 --- /dev/null +++ b/basis/http/test/index.fhtml @@ -0,0 +1 @@ +<% USE: io "OK" write %> diff --git a/basis/mime/types/mime.types b/basis/mime/types/mime.types index b602e9dc68..494228780c 100644 --- a/basis/mime/types/mime.types +++ b/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 diff --git a/extra/dns/authors.txt b/extra/dns/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/dns/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor new file mode 100644 index 0000000000..82f1062e9a --- /dev/null +++ b/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 ] + [ -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 ] + } 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> + 2 read be> ; + +: 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 ; +M: AAAA parse-rdata 2drop 16 read byte-array>ipv6 ; +M: CNAME parse-rdata 2drop parse-name ; +M: MX parse-rdata 2drop parse-mx ; +M: NS parse-rdata 2drop parse-name ; +M: PTR parse-rdata 2drop parse-name ; +M: SOA parse-rdata 2drop parse-soa ; + +: parse-rr ( -- rr ) + rr new + parse-name >>name + 2 read be> >>type + 2 read be> >>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 + 5 seconds over set-timeout [ + [ send ] [ receive drop ] bi + ] with-disposal ; + +: ( -- inet4 ) + dns-servers get random 53 ; + +: dns-query ( query -- message ) + message>byte-array + udp-query parse-message ; + +: dns-A-query ( domain -- message ) A IN dns-query ; +: dns-AAAA-query ( domain -- message ) AAAA IN dns-query ; +: dns-MX-query ( domain -- message ) MX IN dns-query ; +: dns-NS-query ( domain -- message ) NS IN dns-query ; + +: reverse-lookup ( reversed-ip -- message ) + PTR IN 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 ; diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index 17a0494bf7..7dea9389e0 100644 --- a/extra/mongodb/connection/connection.factor +++ b/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 - [ split-host-str f >>remote ] when* - drop ] 2bi ; + [ + [ "ismaster" ] dip at dup string? + [ >integer 1 = ] [ ] if >>master? drop + ] [ + [ "remote" ] dip at + [ split-host-str f >>remote ] when* drop + ] 2bi ; : check-node ( mdb node -- ) [ &dispose ] dip diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 28e6e2c0aa..eebfb10c5c 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -98,10 +98,12 @@ SYNTAX: r/ ( token -- mdbregexp ) [ ] dip [ mdb-pool swap with-variable ] curry with-disposal ; inline -: with-mdb-connection ( quot -- ) - [ mdb-pool get ] dip +: with-mdb-pool ( ..a mdb-pool quot -- ..b ) '[ _ 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 . ; diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor index 3b0392b70d..1568572bfb 100644 --- a/extra/mongodb/tuple/tuple.factor +++ b/extra/mongodb/tuple/tuple.factor @@ -38,6 +38,8 @@ SYNTAX: MDBTUPLE: [ drop-table ] [ ensure-table ] bi ; +DEFER: tuple>query + >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 ; : 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 ; diff --git a/extra/slots/syntax/syntax-docs.factor b/extra/slots/syntax/syntax-docs.factor index 84e6e89dac..6e201eac77 100755 --- a/extra/slots/syntax/syntax-docs.factor +++ b/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:" -{ $subsections POSTPONE: slots{ } ; +"Cleaving slots to an array:" +{ $subsections POSTPONE: slots{ } +"Setting slots from the stack:" +{ $subsections POSTPONE: set-slots[ } +"Setting slots from an array:" +{ $subsections POSTPONE: set-slots{ } ; ABOUT: "slots.syntax" diff --git a/extra/slots/syntax/syntax.factor b/extra/slots/syntax/syntax.factor index 7bfe238fa8..ef572910d8 100755 --- a/extra/slots/syntax/syntax.factor +++ b/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 -sequences slots ; +USING: combinators combinators.smart fry kernel lexer +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! ;