From 62c7aabf35ce3f6d85b3f8c4493f6e5ed618cf06 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 18:24:46 -0500 Subject: [PATCH 01/18] Major I/O cleanup --- extra/io/files/unique/unique-docs.factor | 2 +- extra/io/launcher/launcher.factor | 2 +- extra/io/pipes/pipes-tests.factor | 11 +- extra/io/pipes/pipes.factor | 2 +- extra/io/{nonblocking => ports}/authors.txt | 0 .../ports-docs.factor} | 12 +- .../nonblocking.factor => ports/ports.factor} | 104 +++--- extra/io/{nonblocking => ports}/summary.txt | 0 extra/io/server/server-tests.factor | 1 + extra/io/server/server.factor | 16 +- extra/io/sockets/headers/headers.factor | 2 +- extra/io/sockets/impl/authors.txt | 1 - extra/io/sockets/impl/impl-tests.factor | 45 --- extra/io/sockets/impl/impl.factor | 134 -------- extra/io/sockets/sockets-docs.factor | 23 +- extra/io/sockets/sockets-tests.factor | 42 +++ extra/io/sockets/sockets.factor | 310 +++++++++++++++--- extra/io/timeouts/timeouts.factor | 3 - extra/io/unix/backend/backend.factor | 217 +++++------- extra/io/unix/bsd/bsd.factor | 20 +- extra/io/unix/epoll/epoll.factor | 2 +- extra/io/unix/files/files.factor | 2 +- extra/io/unix/files/unique/unique.factor | 2 +- extra/io/unix/kqueue/kqueue.factor | 2 +- extra/io/unix/launcher/launcher.factor | 2 +- extra/io/unix/linux/monitors/monitors.factor | 4 +- extra/io/unix/pipes/pipes.factor | 2 +- extra/io/unix/select/select.factor | 36 +- extra/io/unix/sockets/secure/secure.factor | 87 +++-- extra/io/unix/sockets/sockets.factor | 185 ++++------- extra/io/windows/ce/backend/backend.factor | 2 +- extra/io/windows/ce/files/files.factor | 2 +- extra/io/windows/ce/sockets/sockets.factor | 3 +- extra/io/windows/files/files.factor | 2 +- extra/io/windows/files/unique/unique.factor | 2 +- extra/io/windows/launcher/launcher.factor | 2 +- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 2 +- extra/io/windows/nt/files/files.factor | 2 +- extra/io/windows/nt/launcher/launcher.factor | 2 +- extra/io/windows/nt/monitors/monitors.factor | 2 +- extra/io/windows/nt/pipes/pipes.factor | 2 +- extra/io/windows/nt/sockets/sockets.factor | 15 +- extra/io/windows/windows.factor | 4 +- extra/openssl/openssl.factor | 7 +- extra/random/unix/unix.factor | 2 +- extra/tools/deploy/shaker/shaker.factor | 2 +- extra/unix/linux/ifreq/ifreq.factor | 1 - extra/unix/linux/route/route.factor | 2 +- 49 files changed, 650 insertions(+), 679 deletions(-) rename extra/io/{nonblocking => ports}/authors.txt (100%) rename extra/io/{nonblocking/nonblocking-docs.factor => ports/ports-docs.factor} (90%) rename extra/io/{nonblocking/nonblocking.factor => ports/ports.factor} (72%) rename extra/io/{nonblocking => ports}/summary.txt (100%) delete mode 100755 extra/io/sockets/impl/authors.txt delete mode 100644 extra/io/sockets/impl/impl-tests.factor delete mode 100755 extra/io/sockets/impl/impl.factor diff --git a/extra/io/files/unique/unique-docs.factor b/extra/io/files/unique/unique-docs.factor index 01b8e131cc..bb4e9ef01f 100644 --- a/extra/io/files/unique/unique-docs.factor +++ b/extra/io/files/unique/unique-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io io.nonblocking kernel math +USING: help.markup help.syntax io io.ports kernel math io.files.unique.private math.parser io.files ; IN: io.files.unique diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index e28742537d..0bfac74416 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads continuations math accessors concurrency.flags destructors io io.backend io.timeouts io.pipes io.pipes.private io.encodings -io.streams.duplex io.nonblocking ; +io.streams.duplex io.ports ; IN: io.launcher TUPLE: process < identity-tuple diff --git a/extra/io/pipes/pipes-tests.factor b/extra/io/pipes/pipes-tests.factor index c1b37f6efc..4fb9d57748 100755 --- a/extra/io/pipes/pipes-tests.factor +++ b/extra/io/pipes/pipes-tests.factor @@ -1,6 +1,6 @@ USING: io io.pipes io.streams.string io.encodings.utf8 -io.streams.duplex io.encodings namespaces continuations -tools.test kernel ; +io.streams.duplex io.encodings io.timeouts namespaces +continuations tools.test kernel calendar ; IN: io.pipes.tests [ "Hello" ] [ @@ -24,3 +24,10 @@ IN: io.pipes.tests [ input-stream [ utf8 ] change readln ] } run-pipeline ] unit-test + +[ + utf8 [ + 5 seconds over set-timeout + stream-readln + ] with-disposal +] must-fail diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index cae7ef8158..a3315d02ca 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.encodings io.backend io.nonblocking io.streams.duplex +USING: io.encodings io.backend io.ports io.streams.duplex io splitting sequences sequences.lib namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; diff --git a/extra/io/nonblocking/authors.txt b/extra/io/ports/authors.txt similarity index 100% rename from extra/io/nonblocking/authors.txt rename to extra/io/ports/authors.txt diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/ports/ports-docs.factor similarity index 90% rename from extra/io/nonblocking/nonblocking-docs.factor rename to extra/io/ports/ports-docs.factor index 7a489d8606..e94df99a84 100755 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -1,9 +1,9 @@ USING: io io.buffers io.backend help.markup help.syntax kernel byte-arrays sbufs words continuations byte-vectors classes ; -IN: io.nonblocking +IN: io.ports -ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" -"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary." +ARTICLE: "io.ports" "Non-blocking I/O implementation" +"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary." $nl "A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:" { $subsection port } @@ -29,7 +29,7 @@ $nl { $subsection server-port } { $subsection datagram-port } ; -ABOUT: "io.nonblocking" +ABOUT: "io.ports" HELP: port { $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." @@ -81,10 +81,6 @@ HELP: (wait-to-read) { $contract "Suspends the current thread until the port's buffer has data available for reading." } ; HELP: wait-to-read -{ $values { "count" "a non-negative integer" } { "port" input-port } } -{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; - -HELP: wait-to-read1 { $values { "port" input-port } } { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ; diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/ports/ports.factor similarity index 72% rename from extra/io/nonblocking/nonblocking.factor rename to extra/io/ports/ports.factor index 74133e5abb..16e089a4a6 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/ports/ports.factor @@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend continuations debugger classes byte-arrays namespaces splitting dlists assocs io.encodings.binary inspector accessors destructors ; -IN: io.nonblocking +IN: io.ports SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global -TUPLE: port handle buffer error timeout closed eof ; +TUPLE: port handle error timeout closed ; M: port timeout timeout>> ; @@ -37,26 +37,6 @@ M: handle-destructor dispose ( obj -- ) new swap dup init-handle >>handle ; inline -: ( handle class -- port ) - - default-buffer-size get >>buffer ; inline - -TUPLE: input-port < port ; - -: ( handle -- input-port ) - input-port ; - -TUPLE: output-port < port ; - -: ( handle -- output-port ) - output-port ; - -: ( read-handle write-handle -- input-port output-port ) - [ - [ dup add-error-destructor ] - [ dup add-error-destructor ] bi* - ] with-destructors ; - : pending-error ( port -- ) [ f ] change-error drop [ throw ] when* ; @@ -68,19 +48,21 @@ M: port-closed-error summary : check-closed ( port -- port ) dup closed>> [ port-closed-error ] when ; -HOOK: cancel-io io-backend ( port -- ) +TUPLE: buffered-port < port buffer ; -M: object cancel-io drop ; +: ( handle class -- port ) + + default-buffer-size get >>buffer ; inline -M: port timed-out cancel-io ; +TUPLE: input-port < buffered-port eof ; + +: ( handle -- input-port ) + input-port ; HOOK: (wait-to-read) io-backend ( port -- ) -: wait-to-read ( count port -- ) - tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; - -: wait-to-read1 ( port -- ) - 1 swap wait-to-read ; +: wait-to-read ( port -- ) + dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ; : unless-eof ( port quot -- value ) >r dup buffer>> buffer-empty? over eof>> and @@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- ) M: input-port stream-read1 check-closed - dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ; + dup wait-to-read [ buffer>> buffer-pop ] unless-eof ; : read-step ( count port -- byte-array/f ) - [ wait-to-read ] 2keep + [ wait-to-read ] keep [ dupd buffer>> buffer-read ] unless-eof nip ; +M: input-port stream-read-partial ( max stream -- byte-array/f ) + check-closed + >r 0 max >integer r> read-step ; + : read-loop ( count port accum -- ) pick over length - dup 0 > [ pick read-step dup [ @@ -117,9 +103,10 @@ M: input-port stream-read ] [ 2nip ] if ] [ 2nip ] if ; -M: input-port stream-read-partial ( max stream -- byte-array/f ) - check-closed - >r 0 max >fixnum r> read-step ; +TUPLE: output-port < buffered-port ; + +: ( handle -- output-port ) + output-port ; : can-write? ( len buffer -- ? ) [ buffer-fill + ] keep buffer-capacity <= ; @@ -143,7 +130,10 @@ M: output-port stream-write [ buffer>> >buffer ] 2bi ] if ; -HOOK: flush-port io-backend ( port -- ) +HOOK: (wait-to-write) io-backend ( port -- ) + +: flush-port ( port -- ) + dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: output-port stream-flush ( port -- ) check-closed @@ -154,35 +144,23 @@ GENERIC: close-port ( port -- ) M: output-port close-port [ flush-port ] [ call-next-method ] bi ; +M: buffered-port close-port + [ call-next-method ] + [ [ [ buffer-free ] when* f ] change-buffer drop ] + bi ; + +HOOK: cancel-io io-backend ( port -- ) + +M: port timed-out cancel-io ; + M: port close-port - dup cancel-io - dup handle>> close-handle - [ [ buffer-free ] when* f ] change-buffer drop ; + [ cancel-io ] [ handle>> close-handle ] bi ; M: port dispose dup closed>> [ drop ] [ t >>closed close-port ] if ; -TUPLE: server-port < port addr client client-addr encoding ; - -: ( handle addr encoding -- server ) - rot server-port - swap >>encoding - swap >>addr ; - -: check-server-port ( port -- port ) - dup server-port? [ "Not a server port" throw ] unless ; inline - -TUPLE: datagram-port < port addr packet packet-addr ; - -: ( handle addr -- datagram ) - swap datagram-port - swap >>addr ; - -: check-datagram-port ( port -- port ) - check-closed - dup datagram-port? [ "Not a datagram port" throw ] unless ; inline - -: check-datagram-send ( packet addrspec port -- packet addrspec port ) - check-datagram-port - 2dup addr>> [ class ] bi@ assert= - pick class byte-array assert= ; +: ( read-handle write-handle -- input-port output-port ) + [ + [ dup add-error-destructor ] + [ dup add-error-destructor ] bi* + ] with-destructors ; diff --git a/extra/io/nonblocking/summary.txt b/extra/io/ports/summary.txt similarity index 100% rename from extra/io/nonblocking/summary.txt rename to extra/io/ports/summary.txt diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index e1297a9839..f3ee309380 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -2,3 +2,4 @@ IN: io.server.tests USING: tools.test io.server io.server.private ; { 2 0 } [ [ ] server-loop ] must-infer-as +{ 2 0 } [ [ ] with-connection ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 1d626a9e15..2bddb78206 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -12,17 +12,19 @@ SYMBOL: servers LOG: accepted-connection NOTICE -: with-client ( client addrspec quot -- ) - [ - swap accepted-connection - with-stream* - ] 2curry with-disposal ; inline +SYMBOL: remote-address -\ with-client DEBUG add-error-logging +: with-connection ( client addrspec quot -- ) + [ + >r [ remote-address set ] [ accepted-connection ] bi + r> call + ] 2curry with-stream ; inline + +\ with-connection DEBUG add-error-logging : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 3curry "Client" spawn drop + >r accept r> [ with-connection ] 3curry "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index 2547fee5ae..7ae9265220 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math math.parser +io.sockets kernel structs math math.parser prettyprint sequences ; IN: io.sockets.headers diff --git a/extra/io/sockets/impl/authors.txt b/extra/io/sockets/impl/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/io/sockets/impl/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/io/sockets/impl/impl-tests.factor b/extra/io/sockets/impl/impl-tests.factor deleted file mode 100644 index 6b930a994e..0000000000 --- a/extra/io/sockets/impl/impl-tests.factor +++ /dev/null @@ -1,45 +0,0 @@ -USING: io.sockets.impl io.sockets kernel tools.test ; -IN: io.sockets.impl.tests - -[ B{ 1 2 3 4 } ] -[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test - -[ "1.2.3.4" ] -[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test - -[ "255.255.255.255" ] -[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test - -[ B{ 255 255 255 255 } ] -[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] -[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test - -[ "1:2:3:4:5:6:7:8" ] -[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "::" T{ inet6 } inet-pton ] unit-test - -[ "0:0:0:0:0:0:0:0" ] -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] -[ "1::" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] -[ "::1" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] -[ "1::2" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] -[ "1::2:3" T{ inet6 } inet-pton ] unit-test - -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] -[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test - -[ "1:2:0:0:0:0:3:4" ] -[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test - diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor deleted file mode 100755 index fa82080259..0000000000 --- a/extra/io/sockets/impl/impl.factor +++ /dev/null @@ -1,134 +0,0 @@ -! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: arrays byte-arrays io.backend io.binary io.sockets -io.encodings.ascii kernel math math.parser sequences splitting -system alien.c-types alien.strings alien combinators namespaces -parser ; -IN: io.sockets.impl - -<< { - { [ os windows? ] [ "windows.winsock" ] } - { [ os unix? ] [ "unix" ] } -} cond use+ >> - -GENERIC: protocol-family ( addrspec -- af ) - -GENERIC: sockaddr-type ( addrspec -- type ) - -GENERIC: make-sockaddr ( addrspec -- sockaddr ) - -: make-sockaddr/size ( addrspec -- sockaddr size ) - dup make-sockaddr swap sockaddr-type heap-size ; - -GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) - -HOOK: addrinfo-error io-backend ( n -- ) - -! IPV4 and IPV6 -GENERIC: address-size ( addrspec -- n ) - -GENERIC: inet-ntop ( data addrspec -- str ) - -GENERIC: inet-pton ( str addrspec -- data ) - - -M: inet4 inet-ntop ( data addrspec -- str ) - drop 4 memory>byte-array [ number>string ] { } map-as "." join ; - -M: inet4 inet-pton ( str addrspec -- data ) - drop "." split [ string>number ] B{ } map-as ; - -M: inet4 address-size drop 4 ; - -M: inet4 protocol-family drop PF_INET ; - -M: inet4 sockaddr-type drop "sockaddr-in" c-type ; - -M: inet4 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in" - AF_INET over set-sockaddr-in-family - over inet4-port htons over set-sockaddr-in-port - over inet4-host - "0.0.0.0" or - rot inet-pton *uint over set-sockaddr-in-addr ; - -SYMBOL: port-override - -: (port) port-override get swap or ; - -M: inet4 parse-sockaddr - >r dup sockaddr-in-addr r> inet-ntop - swap sockaddr-in-port ntohs (port) ; - -M: inet6 inet-ntop ( data addrspec -- str ) - drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; - -M: inet6 inet-pton ( str addrspec -- data ) - drop "::" split1 - [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@ - 2dup [ length ] bi@ + 8 swap - 0 swap 3append - [ 2 >be ] map concat >byte-array ; - -M: inet6 address-size drop 16 ; - -M: inet6 protocol-family drop PF_INET6 ; - -M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; - -M: inet6 make-sockaddr ( inet -- sockaddr ) - "sockaddr-in6" - AF_INET6 over set-sockaddr-in6-family - over inet6-port htons over set-sockaddr-in6-port - over inet6-host "::" or - rot inet-pton over set-sockaddr-in6-addr ; - -M: inet6 parse-sockaddr - >r dup sockaddr-in6-addr r> inet-ntop - swap sockaddr-in6-port ntohs (port) ; - -: addrspec-of-family ( af -- addrspec ) - { - { [ dup AF_INET = ] [ T{ inet4 } ] } - { [ dup AF_INET6 = ] [ T{ inet6 } ] } - { [ dup AF_UNIX = ] [ T{ local } ] } - [ f ] - } cond nip ; - -M: f parse-sockaddr nip ; - -: addrinfo>addrspec ( addrinfo -- addrspec ) - [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi - parse-sockaddr ; - -: parse-addrinfo-list ( addrinfo -- seq ) - [ addrinfo-next ] follow - [ addrinfo>addrspec ] map - [ ] filter ; - -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) - #! If the port is a number, we resolve for 'http' then - #! change it later. This is a workaround for a FreeBSD - #! getaddrinfo() limitation -- on Windows, Linux and Mac, - #! we can convert a number to a string and pass that as the - #! service name, but on FreeBSD this gives us an unknown - #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; - -M: object resolve-host ( host serv passive? -- seq ) - [ - prepare-resolve-host - "addrinfo" - [ set-addrinfo-flags ] keep - PF_UNSPEC over set-addrinfo-family - IPPROTO_TCP over set-addrinfo-protocol - f [ getaddrinfo addrinfo-error ] keep *void* - [ parse-addrinfo-list ] keep - freeaddrinfo - ] with-scope ; - -M: object host-name ( -- name ) - 256 dup dup length gethostname - zero? [ "gethostname failed" throw ] unless - ascii alien>string ; diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index ee3cb3aa7b..2061a123de 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -64,7 +64,7 @@ HELP: local } ; HELP: inet -{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link } "." } { $notes "This address specifier is only supported by " { $link } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name." } @@ -74,7 +74,7 @@ HELP: inet } ; HELP: inet4 -{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet4-host } " and " { $link inet4-port } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." } @@ -83,7 +83,7 @@ HELP: inet4 } ; HELP: inet6 -{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } +{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } { $examples @@ -91,13 +91,19 @@ HELP: inet6 } ; HELP: -{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } -{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." } +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } } +{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." } { $errors "Throws an error if the connection cannot be established." } +{ $notes "The " { $link with-client } " word is easier to use in most situations." } { $examples { $code "\"www.apple.com\" \"http\" utf8 " } } ; +HELP: with-client +{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } } +{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." } +{ $errors "Throws an error if the connection cannot be established." } ; + HELP: { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $description @@ -113,6 +119,13 @@ HELP: "To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" { $code "\"localhost\" 1234 t resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this." + $nl + "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" + { $unchecked-example + "f 0 ascii " + "[ addr>> . ] [ dispose ] bi" + "T{ inet4 f \"0.0.0.0\" 58901 }" + } } { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 1810b8587b..b4dd910004 100644 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -1,4 +1,46 @@ IN: io.sockets.tests USING: io.sockets sequences math tools.test ; +[ B{ 1 2 3 4 } ] +[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test + +[ "1.2.3.4" ] +[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test + +[ "255.255.255.255" ] +[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test + +[ B{ 255 255 255 255 } ] +[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ] +[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test + +[ "1:2:3:4:5:6:7:8" ] +[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "::" T{ inet6 } inet-pton ] unit-test + +[ "0:0:0:0:0:0:0:0" ] +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ] +[ "1::" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ] +[ "::1" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ] +[ "1::2" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ] +[ "1::2:3" T{ inet6 } inet-pton ] unit-test + +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ] +[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test + +[ "1:2:0:0:0:0:3:4" ] +[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test + [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 7b0f55cab7..971ad95e5e 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -1,10 +1,39 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. +! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman, +! Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: generic kernel io.backend namespaces continuations -sequences arrays io.encodings io.nonblocking io.streams.duplex -accessors destructors ; +sequences arrays io.encodings io.ports io.streams.duplex +io.encodings.ascii alien.strings io.binary accessors destructors +classes debugger byte-arrays system combinators parser +alien.c-types math.parser splitting math assocs inspector ; IN: io.sockets +<< { + { [ os windows? ] [ "windows.winsock" ] } + { [ os unix? ] [ "unix" ] } +} cond use+ >> + +! Addressing +GENERIC: protocol-family ( addrspec -- af ) + +GENERIC: sockaddr-type ( addrspec -- type ) + +GENERIC: make-sockaddr ( addrspec -- sockaddr ) + +GENERIC: address-size ( addrspec -- n ) + +GENERIC: inet-ntop ( data addrspec -- str ) + +GENERIC: inet-pton ( str addrspec -- data ) + +: make-sockaddr/size ( addrspec -- sockaddr size ) + dup make-sockaddr swap sockaddr-type heap-size ; + +: empty-sockaddr/size ( addrspec -- sockaddr len ) + sockaddr-type [ ] [ heap-size ] bi ; + +GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) + TUPLE: local path ; : ( path -- addrspec ) @@ -14,59 +43,248 @@ TUPLE: inet4 host port ; C: inet4 +M: inet4 inet-ntop ( data addrspec -- str ) + drop 4 memory>byte-array [ number>string ] { } map-as "." join ; + +ERROR: invalid-inet4 string reason ; + +M: invalid-inet4 summary drop "Invalid IPv4 address" ; + +M: inet4 inet-pton ( str addrspec -- data ) + drop + [ + "." split dup length 4 = [ + "Must have four components" throw + ] unless + [ + string>number + [ "Dotted component not a number" throw ] unless* + ] B{ } map-as + ] [ invalid-inet4 ] recover ; + +M: inet4 address-size drop 4 ; + +M: inet4 protocol-family drop PF_INET ; + +M: inet4 sockaddr-type drop "sockaddr-in" c-type ; + +M: inet4 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in" + AF_INET over set-sockaddr-in-family + over inet4-port htons over set-sockaddr-in-port + over inet4-host + "0.0.0.0" or + rot inet-pton *uint over set-sockaddr-in-addr ; + + + +M: inet4 parse-sockaddr + >r dup sockaddr-in-addr r> inet-ntop + swap sockaddr-in-port ntohs (port) ; + TUPLE: inet6 host port ; C: inet6 +M: inet6 inet-ntop ( data addrspec -- str ) + drop 16 memory>byte-array 2 [ be> >hex ] map ":" join ; + +ERROR: invalid-inet6 string reason ; + +M: invalid-inet6 summary drop "Invalid IPv6 address" ; + + [ "Component not a number" throw ] unless* + ] B{ } map-as + ] if ; + +: pad-inet6 ( string1 string2 -- seq ) + 2dup [ length ] bi@ + 8 swap - + dup 0 < [ "More than 8 components" throw ] when + swap 3append ; + +: inet6-bytes ( seq -- bytes ) + [ 2 >be ] { } map-as concat >byte-array ; + +PRIVATE> + +M: inet6 inet-pton ( str addrspec -- data ) + drop + [ + "::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes + ] [ invalid-inet6 ] recover ; + +M: inet6 address-size drop 16 ; + +M: inet6 protocol-family drop PF_INET6 ; + +M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; + +M: inet6 make-sockaddr ( inet -- sockaddr ) + "sockaddr-in6" + AF_INET6 over set-sockaddr-in6-family + over inet6-port htons over set-sockaddr-in6-port + over inet6-host "::" or + rot inet-pton over set-sockaddr-in6-addr ; + +M: inet6 parse-sockaddr + >r dup sockaddr-in6-addr r> inet-ntop + swap sockaddr-in6-port ntohs (port) ; + +: addrspec-of-family ( af -- addrspec ) + { + { AF_INET [ T{ inet4 } ] } + { AF_INET6 [ T{ inet6 } ] } + { AF_UNIX [ T{ local } ] } + [ drop f ] + } case ; + +M: f parse-sockaddr nip ; + +GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr ) + +: wait-to-connect ( client-out handle remote -- local ) + [ (wait-to-connect) ] keep parse-sockaddr ; + +GENERIC: ((client)) ( remote -- handle ) + +GENERIC: (client) ( remote -- client-in client-out local ) + +M: array (client) [ (client) 3array ] attempt-all first3 ; + +M: object (client) ( remote -- client-in client-out local ) + [ + [ + ((client)) + dup + 2dup [ add-error-destructor ] bi@ + dup dup handle>> + ] keep wait-to-connect + ] with-destructors ; + +: ( remote encoding -- stream local ) + >r (client) -rot r> swap ; + +SYMBOL: local-address + +: with-client ( addrspec encoding quot -- ) + >r [ local-address set ] curry + r> compose with-stream ; inline + +TUPLE: server-port < port addr encoding ; + +: check-server-port ( port -- port ) + check-closed + dup server-port? [ "Not a server port" throw ] unless ; inline + +GENERIC: (server) ( addrspec -- handle sockaddr ) + +: ( addrspec encoding -- server ) + >r [ (server) ] keep parse-sockaddr + swap server-port + swap >>addr + r> >>encoding ; + +HOOK: (accept) io-backend ( server -- handle sockaddr ) + +: accept ( server -- client addrspec ) + check-server-port + [ (accept) ] keep + tuck + [ [ dup ] [ encoding>> ] bi* ] + [ addr>> parse-sockaddr ] + 2bi* ; + +TUPLE: datagram-port < port addr ; + +HOOK: (datagram) io-backend ( addr -- datagram ) + +: ( addr -- datagram ) + dup (datagram) datagram-port swap >>addr ; + +: check-datagram-port ( port -- port ) + check-closed + dup datagram-port? [ "Not a datagram port" throw ] unless ; inline + +HOOK: (receive) io-backend ( datagram -- packet addrspec ) + +: receive ( datagram -- packet sockaddr ) + check-datagram-port + [ (receive) ] [ addr>> ] bi parse-sockaddr ; + +: check-datagram-send ( packet addrspec port -- packet addrspec port ) + check-datagram-port + 2dup addr>> [ class ] bi@ assert= + pick class byte-array assert= ; + +HOOK: (send) io-backend ( packet addrspec datagram -- ) + +: send ( packet addrspec datagram -- ) + check-datagram-send (send) ; + +: addrinfo>addrspec ( addrinfo -- addrspec ) + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi + parse-sockaddr ; + +: parse-addrinfo-list ( addrinfo -- seq ) + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + [ ] filter ; + +: prepare-resolve-host ( host serv passive? -- host' serv' flags ) + #! If the port is a number, we resolve for 'http' then + #! change it later. This is a workaround for a FreeBSD + #! getaddrinfo() limitation -- on Windows, Linux and Mac, + #! we can convert a number to a string and pass that as the + #! service name, but on FreeBSD this gives us an unknown + #! service error. + >r + dup integer? [ port-override set "http" ] when + r> AI_PASSIVE 0 ? ; + +HOOK: addrinfo-error io-backend ( n -- ) + +: resolve-host ( host serv passive? -- seq ) + [ + prepare-resolve-host + "addrinfo" + [ set-addrinfo-flags ] keep + PF_UNSPEC over set-addrinfo-family + IPPROTO_TCP over set-addrinfo-protocol + f [ getaddrinfo addrinfo-error ] keep *void* + [ parse-addrinfo-list ] keep + freeaddrinfo + ] with-scope ; + +: host-name ( -- string ) + 256 dup dup length gethostname + zero? [ "gethostname failed" throw ] unless + ascii alien>string ; + TUPLE: inet host port ; C: inet -GENERIC: wait-to-connect ( client-out handle -- ) - -GENERIC: ((client)) ( addrspec -- handle ) - -GENERIC: (client) ( addrspec -- client-in client-out ) - -M: array (client) [ (client) 2array ] attempt-all first2 ; - -M: object (client) - [ - ((client)) - dup - 2dup [ add-error-destructor ] bi@ - dup dup handle>> wait-to-connect - ] with-destructors ; - -: ( addrspec encoding -- stream ) - >r (client) r> ; - -: with-client ( addrspec encoding quot -- ) - >r r> with-stream ; inline - -HOOK: (server) io-backend ( addrspec -- handle ) - -: ( addrspec encoding -- server ) - >r [ (server) ] keep r> ; - -HOOK: (accept) io-backend ( server -- addrspec handle ) - -: accept ( server -- client addrspec ) - [ (accept) dup ] [ encoding>> ] bi - swap ; - -HOOK: io-backend ( addrspec -- datagram ) - -HOOK: receive io-backend ( datagram -- packet addrspec ) - -HOOK: send io-backend ( packet addrspec datagram -- ) - -HOOK: resolve-host io-backend ( host serv passive? -- seq ) - -HOOK: host-name io-backend ( -- string ) - : resolve-client-addr ( inet -- seq ) [ host>> ] [ port>> ] bi f resolve-host ; M: inet (client) resolve-client-addr (client) ; + +ERROR: invalid-inet-server addrspec ; + +M: invalid-inet-server summary + drop "Cannot use with ; use or instead" ; + +M: inet (server) + invalid-inet-server ; diff --git a/extra/io/timeouts/timeouts.factor b/extra/io/timeouts/timeouts.factor index f9ffd5e98f..816bfd1b19 100755 --- a/extra/io/timeouts/timeouts.factor +++ b/extra/io/timeouts/timeouts.factor @@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors namespaces ; IN: io.timeouts -! Won't need this with new slot accessors GENERIC: timeout ( obj -- dt/f ) GENERIC: set-timeout ( dt/f obj -- ) @@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ; GENERIC: timed-out ( obj -- ) -M: object timed-out drop ; - : queue-timeout ( obj timeout -- alarm ) >r [ timed-out ] curry r> later ; diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 652d4e77b3..5a21e8da68 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -1,69 +1,85 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien generic assocs kernel kernel.private math -io.nonblocking sequences strings structs sbufs threads unix +io.ports sequences strings structs sbufs threads unix vectors io.buffers io.backend io.encodings math.parser continuations system libc qualified namespaces io.timeouts -io.encodings.utf8 accessors ; +io.encodings.utf8 accessors inspector combinators ; QUALIFIED: io IN: io.unix.backend ! I/O tasks -TUPLE: io-task port callbacks ; - GENERIC: handle-fd ( handle -- fd ) M: integer handle-fd ; -: io-task-fd port>> handle>> handle-fd ; - -: ( port continuation/f class -- task ) - new - swap [ 1vector ] [ V{ } clone ] if* >>callbacks - swap >>port ; inline - -TUPLE: input-task < io-task ; - -TUPLE: output-task < io-task ; - -GENERIC: do-io-task ( task -- ? ) -GENERIC: io-task-container ( mx task -- hashtable ) - ! I/O multiplexers TUPLE: mx fd reads writes ; -M: input-task io-task-container drop reads>> ; - -M: output-task io-task-container drop writes>> ; - : new-mx ( class -- obj ) new H{ } clone >>reads H{ } clone >>writes ; inline -GENERIC: register-io-task ( task mx -- ) -GENERIC: unregister-io-task ( task mx -- ) +GENERIC: add-input-callback ( thread fd mx -- ) + +: add-callback ( thread fd assoc -- ) + [ ?push ] change-at ; + +M: mx add-input-callback reads>> add-callback ; + +GENERIC: add-output-callback ( thread fd mx -- ) + +M: mx add-output-callback writes>> add-callback ; + +GENERIC: remove-input-callbacks ( fd mx -- callbacks ) + +M: mx remove-input-callbacks reads>> delete-at* drop ; + +GENERIC: remove-output-callbacks ( fd mx -- callbacks ) + +M: mx remove-output-callbacks writes>> delete-at* drop ; + GENERIC: wait-for-events ( ms mx -- ) -: fd/container ( task mx -- task fd container ) - over io-task-container >r dup io-task-fd r> ; inline +TUPLE: unix-io-error error port ; -: check-io-task ( task mx -- ) - fd/container key? nip [ - "Cannot perform multiple reads from the same port" throw - ] when ; +: report-error ( error port -- ) + tuck unix-io-error boa >>error drop ; -M: mx register-io-task ( task mx -- ) - 2dup check-io-task fd/container set-at ; +: input-available ( fd mx -- ) + remove-input-callbacks [ resume ] each ; -: add-io-task ( task -- ) - mx get-global register-io-task ; +: output-available ( fd mx -- ) + remove-output-callbacks [ resume ] each ; -: with-port-continuation ( port quot -- port ) - [ "I/O" suspend drop ] curry with-timeout ; inline +TUPLE: io-timeout ; -M: mx unregister-io-task ( task mx -- ) - fd/container delete-at drop ; +M: io-timeout summary drop "I/O operation timed out" ; + +M: unix cancel-io ( port -- ) + io-timeout new over report-error + handle>> handle-fd mx get-global + [ input-available ] [ output-available ] 2bi ; + +SYMBOL: +retry+ ! just try the operation again without blocking +SYMBOL: +input+ +SYMBOL: +output+ + +: wait-for-port ( port event -- ) + dup +retry+ eq? [ 2drop ] [ + [ + [ + >r + swap handle>> handle-fd + mx get-global + r> { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] curry "I/O" suspend drop + ] curry with-timeout pending-error + ] if ; ! Some general stuff : file-mode OCT: 0666 ; @@ -88,43 +104,8 @@ M: integer init-handle ( fd -- ) M: integer close-handle ( fd -- ) close ; -TUPLE: unix-io-error error port ; - -: report-error ( error port -- ) - tuck unix-io-error boa >>error drop ; - -: ignorable-error? ( n -- ? ) - [ EAGAIN number= ] [ EINTR number= ] bi or ; - -: defer-error ( port -- ? ) - #! Return t if it is an unrecoverable error. - err_no dup ignorable-error? - [ 2drop f ] [ strerror swap report-error t ] if ; - -: pop-callbacks ( mx task -- ) - dup rot unregister-io-task - io-task-callbacks [ resume ] each ; - -: perform-io-task ( mx task -- ) - dup do-io-task [ pop-callbacks ] [ 2drop ] if ; - -: handle-timeout ( port mx assoc -- ) - >r swap port-handle r> delete-at* [ - "I/O operation cancelled" over port>> report-error - pop-callbacks - ] [ - 2drop - ] if ; - -: cancel-io-tasks ( port mx -- ) - [ dup reads>> handle-timeout ] - [ dup writes>> handle-timeout ] 2bi ; - -M: unix cancel-io ( port -- ) - mx get-global cancel-io-tasks ; - ! Readers -: reader-eof ( reader -- ) +: eof ( reader -- ) dup buffer>> buffer-empty? [ t >>eof ] when drop ; : (refill) ( port -- n ) @@ -132,62 +113,42 @@ M: unix cancel-io ( port -- ) [ buffer>> buffer-end ] [ buffer>> buffer-capacity ] tri read ; -GENERIC: refill ( port handle -- ? ) +! Returns an event to wait for which will ensure completion of +! this request +GENERIC: refill ( port handle -- event/f ) M: integer refill - #! Return f if there is a recoverable error - drop - dup buffer>> buffer-empty? [ - dup (refill) dup 0 >= [ - swap buffer>> n>buffer t - ] [ - drop defer-error - ] if - ] [ drop t ] if ; + over buffer>> [ buffer-end ] [ buffer-capacity ] bi read + { + { [ dup 0 = ] [ drop eof f ] } + { [ dup 0 > ] [ swap buffer>> n>buffer f ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +input+ ] } + [ (io-error) ] + } cond ; -TUPLE: read-task < input-task ; - -: ( port continuation -- task ) read-task ; - -M: read-task do-io-task - port>> dup dup handle>> refill - [ [ reader-eof ] [ drop ] if ] keep ; - -M: unix (wait-to-read) - [ add-io-task ] with-port-continuation - pending-error ; +M: unix (wait-to-read) ( port -- ) + dup dup handle>> refill dup + [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; ! Writers -GENERIC: drain ( port handle -- ? ) +GENERIC: drain ( port handle -- event/f ) M: integer drain - drop - dup - [ handle>> ] - [ buffer>> buffer@ ] - [ buffer>> buffer-length ] tri - write dup 0 >= - [ swap buffer>> buffer-consume f ] - [ drop defer-error ] if ; + over buffer>> [ buffer@ ] [ buffer-length ] bi write + { + { [ dup 0 >= ] [ + over buffer>> buffer-consume + buffer>> buffer-empty? f +output+ ? + ] } + { [ err_no EINTR = ] [ 2drop +retry+ ] } + { [ err_no EAGAIN = ] [ 2drop +output+ ] } + [ (io-error) ] + } cond ; -TUPLE: write-task < output-task ; - -: ( port continuation -- task ) write-task ; - -M: write-task do-io-task - io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or - [ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ; - -: add-write-io-task ( port continuation -- ) - over handle>> mx get-global writes>> at* - [ io-task-callbacks push drop ] - [ drop add-io-task ] if ; - -: (wait-to-write) ( port -- ) - [ add-write-io-task ] with-port-continuation drop ; - -M: unix flush-port ( port -- ) - dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ; +M: unix (wait-to-write) ( port -- ) + dup dup handle>> drain dup + [ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; @@ -203,16 +164,10 @@ TUPLE: mx-port < port mx ; : ( mx -- port ) dup fd>> mx-port swap >>mx ; -TUPLE: mx-task < io-task ; - -: ( port -- task ) - f mx-task ; - -M: mx-task do-io-task - port>> mx>> 0 swap wait-for-events f ; - : multiplexer-error ( n -- ) - 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; + 0 < [ + err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless + ] when ; : ?flag ( n mask symbol -- n ) pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index d74c355642..c8219a9f63 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -3,16 +3,16 @@ IN: io.unix.bsd USING: namespaces system kernel accessors assocs continuations unix -io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; +io.backend io.unix.backend io.unix.select io.monitors ; M: bsd init-io ( -- ) - mx set-global - kqueue-mx set-global - kqueue-mx get-global - dup io-task-fd - [ mx get-global reads>> set-at ] - [ mx get-global writes>> set-at ] 2bi ; + mx set-global ; +! kqueue-mx set-global +! kqueue-mx get-global +! dup io-task-fd +! [ mx get-global reads>> set-at ] +! [ mx get-global writes>> set-at ] 2bi ; -M: bsd (monitor) ( path recursive? mailbox -- ) - swap [ "Recursive kqueue monitors not supported" throw ] when - ; +! M: bsd (monitor) ( path recursive? mailbox -- ) +! swap [ "Recursive kqueue monitors not supported" throw ] when +! ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index f34a4c7009..406a7fcb50 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix unix.linux.epoll math namespaces structs ; IN: io.unix.epoll diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 835b14e66d..121cd6dec3 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend io.nonblocking io.unix.backend io.files io +USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 035e6398ee..54ced6e5ce 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -1,4 +1,4 @@ -USING: kernel io.nonblocking io.unix.backend math.bitfields +USING: kernel io.ports io.unix.backend math.bitfields unix io.files.unique.backend system ; IN: io.unix.files.unique diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index ad5240e548..8888d0182f 100755 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces locals accessors combinators threads vectors hashtables sequences assocs continuations sets unix unix.time unix.kqueue unix.process -io.nonblocking io.unix.backend io.launcher io.unix.launcher +io.ports io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 043b2bd73e..d8a0c3cfe9 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -3,7 +3,7 @@ USING: kernel namespaces math system sequences debugger continuations arrays assocs combinators alien.c-types strings threads accessors -io io.backend io.launcher io.nonblocking io.files +io io.backend io.launcher io.ports io.files io.files.private io.unix.files io.unix.backend io.unix.launcher.parser unix unix.process ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 31dbe42e64..43733e8481 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io.backend io.monitors io.monitors.recursive -io.files io.buffers io.monitors io.nonblocking io.timeouts +io.files io.buffers io.monitors io.ports io.timeouts io.unix.backend io.unix.select io.encodings.utf8 unix.linux.inotify assocs namespaces threads continuations init math math.bitfields sets alien alien.strings alien.c-types @@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- ) ] if ; : inotify-read-loop ( port -- ) - dup wait-to-read1 + dup wait-to-read 0 over buffer>> parse-file-notifications 0 over buffer>> buffer-reset inotify-read-loop ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index 4fc5acf634..dd7ed4a94a 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: system alien.c-types kernel unix math sequences -qualified io.unix.backend io.nonblocking ; +qualified io.unix.backend io.ports ; IN: io.unix.pipes QUALIFIED: io.pipes diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 58b8371d89..fea5f4e9ae 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend +USING: alien.c-types kernel io.ports io.unix.backend bit-arrays sequences assocs unix math namespaces structs -accessors math.order ; +accessors math.order locals ; IN: io.unix.select TUPLE: select-mx < mx read-fdset write-fdset ; @@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; -: check-fd ( fd task fdset mx -- ) - roll munge rot clear-nth - [ swap perform-io-task ] [ 2drop ] if ; +:: check-fd ( fd fdset mx quot -- ) + fd munge fdset clear-nth [ fd mx quot call ] when ; inline -: check-fdset ( tasks fdset mx -- ) - [ check-fd ] 2curry assoc-each ; +: check-fdset ( fds fdset mx quot -- ) + [ check-fd ] 3curry each ; inline -: init-fdset ( tasks fdset -- ) - [ >r drop t swap munge r> set-nth ] curry assoc-each ; +: init-fdset ( fds fdset -- ) + [ >r t swap munge r> set-nth ] curry each ; : read-fdset/tasks - [ reads>> ] [ read-fdset>> ] bi ; + [ reads>> keys ] [ read-fdset>> ] bi ; : write-fdset/tasks - [ writes>> ] [ write-fdset>> ] bi ; + [ writes>> keys ] [ write-fdset>> ] bi ; : max-fd ( assoc -- n ) dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; @@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks tuck init-fdset ] - [ write-fdset/tasks tuck init-fdset ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; -M: select-mx wait-for-events ( ms mx -- ) - swap >r dup init-fdsets r> dup [ make-timeval ] when - select multiplexer-error - dup read-fdset/tasks pick check-fdset - dup write-fdset/tasks rot check-fdset ; +M:: select-mx wait-for-events ( ms mx -- ) + mx + [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ] + [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ] + [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ] + tri ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index e8bcd0e0f0..bb8364d58e 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -4,7 +4,7 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math math.order combinators init alien alien.c-types alien.strings libc continuations destructors openssl openssl.libcrypto openssl.libssl -io.files io.nonblocking io.unix.backend io.unix.sockets +io.files io.ports io.unix.backend io.unix.sockets io.encodings.ascii io.buffers io.sockets io.sockets.secure unix ; IN: io.unix.sockets.secure @@ -16,64 +16,56 @@ IN: io.unix.sockets.secure M: ssl-handle handle-fd file>> ; -: syscall-error ( port r -- ) +: syscall-error ( port r -- * ) ERR_get_error dup zero? [ drop { - { -1 [ err_no strerror ] } - { 0 [ "Premature EOF" ] } + { -1 [ (io-error) ] } + { 0 [ "Premature EOF" throw ] } } case ] [ - nip (ssl-error-string) - ] if swap report-error ; + nip (ssl-error) + ] if ; : check-response ( port r -- port r n ) over handle>> handle>> over SSL_get_error ; inline ! Input ports -: report-ssl-error ( port r -- ) - drop ssl-error-string swap report-error ; - -: check-read-response ( port r -- ? ) +: check-read-response ( port r -- event ) check-response { - { SSL_ERROR_NONE [ swap buffer>> n>buffer t ] } - { SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] } - { SSL_ERROR_WANT_READ [ 2drop f ] } - { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } + { SSL_ERROR_ZERO_RETURN [ drop eof f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; M: ssl-handle refill - drop - dup buffer>> buffer-empty? [ - dup - [ handle>> handle>> ] ! ssl - [ buffer>> buffer-end ] ! buf - [ buffer>> buffer-capacity ] tri ! len - SSL_read - check-read-response - ] [ drop t ] if ; + handle>> ! ssl + over buffer>> + [ buffer-end ] ! buf + [ buffer-capacity ] bi ! len + SSL_read + check-read-response ; ! Output ports -: check-write-response ( port r -- ? ) +: check-write-response ( port r -- event ) check-response { { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - ! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX - { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX - { SSL_ERROR_WANT_WRITE [ 2drop f ] } - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; M: ssl-handle drain - drop - dup - [ handle>> handle>> ] ! ssl - [ buffer>> buffer@ ] ! buf - [ buffer>> buffer-length ] tri ! len + handle>> ! ssl + over buffer>> + [ buffer@ ] ! buf + [ buffer-length ] bi ! len SSL_write check-write-response ; @@ -81,17 +73,20 @@ M: ssl-handle drain M: ssl ((client)) ( addrspec -- handle ) [ addrspec>> ((client)) ] with-destructors ; -: check-connect-response ( port r -- ? ) +: check-connect-response ( port r -- event ) check-response { - { SSL_ERROR_NONE [ 2drop t ] } - { SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX - { SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX - { SSL_ERROR_SYSCALL [ syscall-error t ] } - { SSL_ERROR_SSL [ report-ssl-error t ] } + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } } case ; -M: ssl-handle (wait-to-connect) - handle>> ! ssl - SSL_connect - check-connect-response ; +: do-ssl-connect ( port ssl -- ) + 2dup SSL_connect check-connect-response dup + [ nip wait-for-port ] [ 3drop ] if ; + +M: ssl-handle wait-to-connect + [ file>> wait-to-connect ] + [ handle>> do-ssl-connect ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index fee4821f50..01c0736663 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.strings generic kernel math -namespaces threads sequences byte-arrays io.nonblocking -io.binary io.unix.backend io.streams.duplex io.sockets.impl -io.backend io.nonblocking io.files io.files.private +namespaces threads sequences byte-arrays io.ports +io.binary io.unix.backend io.streams.duplex +io.backend io.ports io.files io.files.private io.encodings.utf8 math.parser continuations libc combinators -system accessors qualified destructors unix ; +system accessors qualified destructors unix locals ; EXCLUDE: io => read write close ; EXCLUDE: io.sockets => accept ; @@ -28,23 +28,11 @@ M: unix addrinfo-error ( n -- ) : init-client-socket ( fd -- ) SOL_SOCKET SO_OOBINLINE sockopt ; -TUPLE: connect-task < output-task ; - -: ( port continuation -- task ) - connect-task ; - -GENERIC: (wait-to-connect) ( port handle -- ? ) +: get-socket-name ( fd addrspec -- sockaddr ) + empty-sockaddr/size [ getsockname io-error ] 2keep drop ; M: integer (wait-to-connect) - f 0 write 0 < [ defer-error ] [ drop t ] if ; - -M: connect-task do-io-task - port>> dup handle>> (wait-to-connect) ; - -M: object wait-to-connect ( client-out fd -- ) - drop - [ add-io-task ] with-port-continuation - pending-error ; + >r >r +output+ wait-for-port r> r> get-socket-name ; M: object ((client)) ( addrspec -- fd ) [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi @@ -56,49 +44,41 @@ M: object ((client)) ( addrspec -- fd ) : init-server-socket ( fd -- ) SOL_SOCKET SO_REUSEADDR sockopt ; -TUPLE: accept-task < input-task ; - -: ( port continuation -- task ) - accept-task ; - -: accept-sockaddr ( port -- fd sockaddr ) - [ handle>> ] [ addr>> sockaddr-type ] bi - dup [ swap heap-size accept ] keep ; inline - -: do-accept ( port fd sockaddr -- ) - swapd over addr>> parse-sockaddr >>client-addr (>>client) ; - -M: accept-task do-io-task - io-task-port dup accept-sockaddr - over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; - -: wait-to-accept ( server -- ) - [ add-io-task ] with-port-continuation drop ; - : server-socket-fd ( addrspec type -- fd ) >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr/size bind - zero? [ dup close (io-error) ] unless ; + dup rot make-sockaddr/size bind io-error ; -M: unix (server) ( addrspec -- handle ) +M: object (server) ( addrspec -- handle sockaddr ) [ - SOCK_STREAM server-socket-fd - dup 10 listen io-error + [ + SOCK_STREAM server-socket-fd + dup 10 listen io-error + dup + ] keep + get-socket-name ] with-destructors ; -M: unix (accept) ( server -- addrspec handle ) - #! Wait for a client connection. - check-server-port - [ wait-to-accept ] - [ pending-error ] - [ [ client-addr>> ] [ client>> ] bi ] tri ; +: do-accept ( server -- fd sockaddr ) + [ handle>> ] [ addr>> empty-sockaddr/size ] bi + [ accept ] 2keep drop ; inline + +M: unix (accept) ( server -- fd sockaddr ) + dup do-accept + { + { [ over 0 >= ] [ rot drop ] } + { [ err_no EINTR = ] [ 2drop do-accept ] } + { [ err_no EAGAIN = ] [ + 2drop + [ +input+ wait-for-port ] + [ do-accept ] bi + ] } + [ (io-error) ] + } cond ; ! Datagram sockets - UDP and Unix domain -M: unix - [ - [ SOCK_DGRAM server-socket-fd ] keep - ] with-destructors ; +M: unix (datagram) + [ SOCK_DGRAM server-socket-fd ] with-destructors ; SYMBOL: receive-buffer @@ -106,76 +86,45 @@ SYMBOL: receive-buffer packet-size receive-buffer set-global -: setup-receive ( port -- s buffer len flags from fromlen ) - dup port-handle - swap datagram-port-addr sockaddr-type - dup swap heap-size - >r >r receive-buffer get-global packet-size 0 r> r> ; +:: do-receive ( port -- packet sockaddr ) + port addr>> empty-sockaddr/size [| sockaddr len | + port handle>> ! s + receive-buffer get-global ! buf + packet-size ! nbytes + 0 ! flags + sockaddr ! from + len ! fromlen + recvfrom dup 0 >= [ + receive-buffer get-global swap head sockaddr + ] [ + drop f f + ] if + ] call ; -: do-receive ( s buffer len flags from fromlen -- sockaddr data ) - over >r recvfrom r> - over -1 = [ - 2drop f f - ] [ - receive-buffer get-global - rot head +M: unix (receive) ( datagram -- packet sockaddr ) + dup do-receive dup [ rot drop ] [ + 2drop [ +input+ wait-for-port ] [ (receive) ] bi ] if ; -TUPLE: receive-task < input-task ; +:: do-send ( packet sockaddr len socket datagram -- ) + socket packet dup length 0 sockaddr len sendto + 0 < [ + err_no EINTR = [ + packet sockaddr len socket datagram do-send + ] [ + err_no EAGAIN = [ + datagram +output+ wait-for-port + packet sockaddr len socket datagram do-send + ] [ + (io-error) + ] if + ] if + ] when ; -: ( stream continuation -- task ) - receive-task ; - -M: receive-task do-io-task - io-task-port - dup setup-receive do-receive dup [ - pick set-datagram-port-packet - over datagram-port-addr parse-sockaddr - swap set-datagram-port-packet-addr - t - ] [ - 2drop defer-error - ] if ; - -: wait-receive ( stream -- ) - [ add-io-task ] with-port-continuation drop ; - -M: unix receive ( datagram -- packet addrspec ) - check-datagram-port - [ wait-receive ] - [ pending-error ] - [ [ packet>> ] [ packet-addr>> ] bi ] tri ; - -: do-send ( socket data sockaddr len -- n ) - >r >r dup length 0 r> r> sendto ; - -TUPLE: send-task < output-task packet sockaddr len ; - -: ( packet sockaddr len stream continuation -- task ) - send-task [ - { - set-send-task-packet - set-send-task-sockaddr - set-send-task-len - } set-slots - ] keep ; - -M: send-task do-io-task - [ io-task-port port-handle ] keep - [ send-task-packet ] keep - [ send-task-sockaddr ] keep - [ send-task-len do-send ] keep - swap 0 < [ io-task-port defer-error ] [ drop t ] if ; - -: wait-send ( packet sockaddr len stream -- ) - [ add-io-task ] with-port-continuation - 2drop 2drop ; - -M: unix send ( packet addrspec datagram -- ) - check-datagram-send - [ >r make-sockaddr/size r> wait-send ] keep - pending-error ; +M: unix (send) ( packet addrspec datagram -- ) + [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ; +! Unix domain sockets M: local protocol-family drop PF_UNIX ; M: local sockaddr-type drop "sockaddr-un" c-type ; diff --git a/extra/io/windows/ce/backend/backend.factor b/extra/io/windows/ce/backend/backend.factor index 46564f2aec..7209a68ebf 100755 --- a/extra/io/windows/ce/backend/backend.factor +++ b/extra/io/windows/ce/backend/backend.factor @@ -1,4 +1,4 @@ -USING: io.nonblocking io.windows threads.private kernel +USING: io.ports io.windows threads.private kernel io.backend windows.winsock windows.kernel32 windows io.streams.duplex io namespaces alien.syntax system combinators io.buffers io.encodings io.encodings.utf8 combinators.lib ; diff --git a/extra/io/windows/ce/files/files.factor b/extra/io/windows/ce/files/files.factor index 8f7390aa7c..83d456832b 100755 --- a/extra/io/windows/ce/files/files.factor +++ b/extra/io/windows/ce/files/files.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.files io.nonblocking io.windows kernel libc math namespaces +io.files io.ports io.windows kernel libc math namespaces prettyprint sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend system ; IN: windows.ce.files diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 45c10ea258..b3117dcde1 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types combinators io io.backend io.buffers -io.nonblocking io.sockets io.sockets.impl io.windows kernel libc +io.ports io.sockets io.windows kernel libc math namespaces prettyprint qualified sequences strings threads threads.private windows windows.kernel32 io.windows.ce.backend byte-arrays system ; @@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle ) M: wince (accept) ( server -- client ) [ - dup check-server-port [ dup port-handle win32-file-handle swap server-port-addr sockaddr-type heap-size diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8a15a57f83..d83c789d36 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -3,7 +3,7 @@ USING: alien.c-types io.backend io.files io.windows kernel math windows windows.kernel32 windows.time calendar combinators math.functions sequences namespaces words symbols system -combinators.lib io.nonblocking destructors math.bitfields.lib ; +combinators.lib io.ports destructors math.bitfields.lib ; IN: io.windows.files SYMBOLS: +read-only+ +hidden+ +system+ diff --git a/extra/io/windows/files/unique/unique.factor b/extra/io/windows/files/unique/unique.factor index 0449980286..2c166373e7 100644 --- a/extra/io/windows/files/unique/unique.factor +++ b/extra/io/windows/files/unique/unique.factor @@ -1,5 +1,5 @@ USING: kernel system io.files.unique.backend -windows.kernel32 io.windows io.nonblocking windows ; +windows.kernel32 io.windows io.ports windows ; IN: io.windows.files.unique M: windows (make-unique-file) ( path -- ) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index a5d7338cd6..28e7e241e5 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations io -io.windows io.windows.nt.pipes libc io.nonblocking +io.windows io.windows.nt.pipes libc io.ports windows.types math windows.kernel32 namespaces io.launcher kernel sequences windows.errors splitting system threads init strings combinators diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index dc29405b12..b401ed5556 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types alien.syntax arrays continuations -destructors generic io.mmap io.nonblocking io.windows +destructors generic io.mmap io.ports io.windows kernel libc math namespaces quotations sequences windows windows.advapi32 windows.kernel32 io.backend system ; IN: io.windows.mmap diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index fe7f1ecc61..99364f832d 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types arrays assocs combinators -continuations destructors io io.backend io.nonblocking +continuations destructors io io.backend io.ports io.windows libc kernel math namespaces sequences threads classes.tuple.lib windows windows.errors windows.kernel32 strings splitting io.files qualified ascii diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 12fad1a2d0..2b3021a3f1 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,5 +1,5 @@ USING: continuations destructors io.buffers io.files io.backend -io.timeouts io.nonblocking io.windows io.windows.nt.backend +io.timeouts io.ports io.windows io.windows.nt.backend kernel libc math threads windows windows.kernel32 system alien.c-types alien.arrays alien.strings sequences combinators combinators.lib sequences.lib ascii splitting alien strings diff --git a/extra/io/windows/nt/launcher/launcher.factor b/extra/io/windows/nt/launcher/launcher.factor index 39edd931b1..c18523e68d 100755 --- a/extra/io/windows/nt/launcher/launcher.factor +++ b/extra/io/windows/nt/launcher/launcher.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays continuations destructors io -io.windows libc io.nonblocking io.pipes windows.types +io.windows libc io.ports io.pipes windows.types math windows.kernel32 windows namespaces io.launcher kernel sequences windows.errors assocs splitting system strings io.windows.launcher io.windows.nt.pipes io.backend io.files diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor index 37784c673c..ee8c6c60e1 100755 --- a/extra/io/windows/nt/monitors/monitors.factor +++ b/extra/io/windows/nt/monitors/monitors.factor @@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables sorting arrays combinators math.bitfields strings system accessors threads splitting io.backend io.windows io.windows.nt.backend io.windows.nt.files -io.monitors io.nonblocking io.buffers io.files io.timeouts io +io.monitors io.ports io.buffers io.files io.timeouts io windows windows.kernel32 windows.types ; IN: io.windows.nt.monitors diff --git a/extra/io/windows/nt/pipes/pipes.factor b/extra/io/windows/nt/pipes/pipes.factor index aa565b52e8..8a0fa05b74 100755 --- a/extra/io/windows/nt/pipes/pipes.factor +++ b/extra/io/windows/nt/pipes/pipes.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types arrays destructors io io.windows libc windows.types math.bitfields windows.kernel32 windows namespaces kernel sequences windows.errors assocs math.parser system random -combinators accessors io.pipes io.nonblocking ; +combinators accessors io.pipes io.ports ; IN: io.windows.nt.pipes ! This code is based on diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 89e1ea3277..5baa0a31e5 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,6 +1,6 @@ USING: alien alien.accessors alien.c-types byte-arrays -continuations destructors io.nonblocking io.timeouts io.sockets -io.sockets.impl io namespaces io.streams.duplex io.windows +continuations destructors io.ports io.timeouts io.sockets +io.sockets io namespaces io.streams.duplex io.windows io.windows.nt.backend windows.winsock kernel libc math sequences threads classes.tuple.lib system accessors ; IN: io.windows.nt.sockets @@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port M: winnt (accept) ( server -- addrspec handle ) [ [ - check-server-port \ AcceptEx-args new [ init-accept ] keep [ ((accept)) ] keep @@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle ) f ] with-destructors ; -M: winnt ( addrspec -- datagram ) +M: winnt (datagram) ( addrspec -- handle ) [ - [ - SOCK_DGRAM server-fd - dup add-completion - f - ] keep + SOCK_DGRAM server-fd + dup add-completion + f ] with-destructors ; TUPLE: WSARecvFrom-args port diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 6f793bc939..5c0a1c8ecf 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend -io.buffers io.files io.nonblocking io.sockets io.binary -io.sockets.impl windows.errors strings +io.buffers io.files io.ports io.sockets io.binary +io.sockets windows.errors strings kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting continuations math.bitfields system accessors ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 3b58a606a0..41e413c966 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc continuations destructors debugger inspector locals unicode.case openssl.libcrypto openssl.libssl -io.nonblocking io.files io.encodings.ascii io.sockets.secure ; +io.ports io.files io.encodings.ascii io.sockets.secure ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ @@ -25,8 +25,11 @@ M: TLSv1 ssl-method drop TLSv1_method ; : ssl-error-string ( -- string ) ERR_get_error ERR_clear_error f ERR_error_string ; +: (ssl-error) ( -- * ) + ssl-error-string throw ; + : ssl-error ( obj -- ) - { f 0 } member? [ ssl-error-string throw ] when ; + { f 0 } member? [ (ssl-error) ] when ; : init-ssl ( -- ) SSL_library_init ssl-error diff --git a/extra/random/unix/unix.factor b/extra/random/unix/unix.factor index 7fda7c5d1d..e534691ecd 100644 --- a/extra/random/unix/unix.factor +++ b/extra/random/unix/unix.factor @@ -1,4 +1,4 @@ -USING: alien.c-types io io.files io.nonblocking kernel +USING: alien.c-types io io.files io.ports kernel namespaces random io.encodings.binary init accessors system ; IN: random.unix diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 1374254612..4f0d6ac036 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -133,7 +133,7 @@ IN: tools.deploy.shaker [ io.backend:io-backend , - "default-buffer-size" "io.nonblocking" lookup , + "default-buffer-size" "io.ports" lookup , ] { } make { "alarms" "io" "tools" } strip-vocab-globals % diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor index d688153bd0..5dc1c0fde2 100755 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -1,7 +1,6 @@ USING: kernel alien alien.c-types io.sockets - io.sockets.impl unix unix.linux.sockios unix.linux.if ; diff --git a/extra/unix/linux/route/route.factor b/extra/unix/linux/route/route.factor index c4eeadb69e..4d9bbfae99 100644 --- a/extra/unix/linux/route/route.factor +++ b/extra/unix/linux/route/route.factor @@ -42,7 +42,7 @@ C-STRUCT: struct-rtentry ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: kernel alien.c-types io.sockets io.sockets.impl +USING: kernel alien.c-types io.sockets unix unix.linux.sockios ; : route ( dst gateway genmask flags -- ) From 318f0875a1beb50ebbccde58214e22b897d159b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 20:04:57 -0500 Subject: [PATCH 02/18] I/O fixes --- extra/http/http-tests.factor | 2 ++ extra/io/server/server-tests.factor | 4 +++- extra/io/server/server.factor | 26 +++++++++------------- extra/io/sockets/sockets.factor | 4 ++-- extra/io/unix/sockets/secure/secure.factor | 4 ++-- extra/io/unix/sockets/sockets.factor | 11 +++++---- extra/unix/unix.factor | 1 + 7 files changed, 28 insertions(+), 24 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 21eb241b84..a3b9676aac 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -174,6 +174,8 @@ test-db [ main-responder set [ 1237 httpd ] "HTTPD test" spawn drop + + yield ] with-scope ] unit-test diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index f3ee309380..86cfe35bc1 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,5 +1,7 @@ IN: io.server.tests -USING: tools.test io.server io.server.private ; +USING: tools.test io.server io.server.private kernel ; { 2 0 } [ [ ] server-loop ] must-infer-as { 2 0 } [ [ ] with-connection ] must-infer-as +{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as +{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 2bddb78206..23066114e4 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -3,7 +3,7 @@ USING: io io.sockets io.files io.streams.duplex logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar -threads concurrency.combinators assocs ; +threads concurrency.combinators assocs fry ; IN: io.server SYMBOL: servers @@ -14,22 +14,22 @@ LOG: accepted-connection NOTICE SYMBOL: remote-address -: with-connection ( client addrspec quot -- ) - [ - >r [ remote-address set ] [ accepted-connection ] bi - r> call - ] 2curry with-stream ; inline +: with-connection ( client remote quot -- ) + '[ + , [ remote-address set ] [ accepted-connection ] bi + @ + ] with-stream ; inline \ with-connection DEBUG add-error-logging : accept-loop ( server quot -- ) [ - >r accept r> [ with-connection ] 3curry "Client" spawn drop + >r accept r> '[ , , , with-connection ] "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) >r dup servers get push r> - [ accept-loop ] curry with-disposal ; inline + '[ , accept-loop ] with-disposal ; inline \ server-loop NOTICE add-error-logging @@ -43,9 +43,7 @@ PRIVATE> : with-server ( seq service encoding quot -- ) V{ } clone servers [ - [ - [ server-loop ] 2curry with-logging - ] 3curry parallel-each + '[ , [ , , server-loop ] with-logging ] parallel-each ] with-variable ; inline : stop-server ( -- ) @@ -58,7 +56,7 @@ LOG: received-datagram NOTICE : datagram-loop ( quot datagram -- ) [ [ receive dup received-datagram >r swap call r> ] keep - pick [ send ] [ 3drop ] keep + pick [ send ] [ 3drop ] if ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) @@ -69,6 +67,4 @@ LOG: received-datagram NOTICE PRIVATE> : with-datagrams ( seq service quot -- ) - [ - [ swap spawn-datagrams ] curry parallel-each - ] curry with-logging ; inline + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 971ad95e5e..0975f83c46 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -195,9 +195,9 @@ GENERIC: (server) ( addrspec -- handle sockaddr ) swap >>addr r> >>encoding ; -HOOK: (accept) io-backend ( server -- handle sockaddr ) +HOOK: (accept) io-backend ( server -- handle remote ) -: accept ( server -- client addrspec ) +: accept ( server -- client remote ) check-server-port [ (accept) ] keep tuck diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index bb8364d58e..675cd9a396 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -87,6 +87,6 @@ M: ssl ((client)) ( addrspec -- handle ) 2dup SSL_connect check-connect-response dup [ nip wait-for-port ] [ 3drop ] if ; -M: ssl-handle wait-to-connect - [ file>> wait-to-connect ] +M: ssl-handle (wait-to-connect) + [ file>> (wait-to-connect) ] [ handle>> do-ssl-connect ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 01c0736663..a04d008a21 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -31,6 +31,9 @@ M: unix addrinfo-error ( n -- ) : get-socket-name ( fd addrspec -- sockaddr ) empty-sockaddr/size [ getsockname io-error ] 2keep drop ; +: get-peer-name ( fd addrspec -- sockaddr ) + empty-sockaddr/size [ getpeername io-error ] 2keep drop ; + M: integer (wait-to-connect) >r >r +output+ wait-for-port r> r> get-socket-name ; @@ -59,19 +62,19 @@ M: object (server) ( addrspec -- handle sockaddr ) get-socket-name ] with-destructors ; -: do-accept ( server -- fd sockaddr ) +: do-accept ( server -- fd remote ) [ handle>> ] [ addr>> empty-sockaddr/size ] bi [ accept ] 2keep drop ; inline -M: unix (accept) ( server -- fd sockaddr ) +M: unix (accept) ( server -- fd remote ) dup do-accept { { [ over 0 >= ] [ rot drop ] } - { [ err_no EINTR = ] [ 2drop do-accept ] } + { [ err_no EINTR = ] [ 2drop (accept) ] } { [ err_no EAGAIN = ] [ 2drop [ +input+ wait-for-port ] - [ do-accept ] bi + [ (accept) ] bi ] } [ (io-error) ] } cond ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 71e8dba8e6..745cac0cd1 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -100,6 +100,7 @@ FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsiz FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ; +FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ; FUNCTION: uid_t getuid ; FUNCTION: uint htonl ( uint n ) ; FUNCTION: ushort htons ( ushort n ) ; From 47f1c31261e3fb411279aa31d2f3049f919fabcb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 23:36:15 -0500 Subject: [PATCH 03/18] More Unix I/O work --- extra/io/ports/ports-docs.factor | 7 ++----- extra/io/unix/sockets/secure/secure.factor | 11 ++++++++--- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor index e94df99a84..265b74e87a 100755 --- a/extra/io/ports/ports-docs.factor +++ b/extra/io/ports/ports-docs.factor @@ -23,11 +23,8 @@ $nl "Per-port native I/O protocol:" { $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." -$nl -"Dummy ports which should be used to implement networking:" -{ $subsection server-port } -{ $subsection datagram-port } ; +{ $subsection (wait-to-write) } +"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ; ABOUT: "io.ports" diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 675cd9a396..7e4e8955ae 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -73,6 +73,8 @@ M: ssl-handle drain M: ssl ((client)) ( addrspec -- handle ) [ addrspec>> ((client)) ] with-destructors ; +M: ssl parse-sockaddr addrspec>> parse-sockaddr ; + : check-connect-response ( port r -- event ) check-response { @@ -83,10 +85,13 @@ M: ssl ((client)) ( addrspec -- handle ) { SSL_ERROR_SSL [ (ssl-error) ] } } case ; -: do-ssl-connect ( port ssl -- ) +: do-ssl-connect ( port ssl addrspec -- ) + drop 2dup SSL_connect check-connect-response dup [ nip wait-for-port ] [ 3drop ] if ; M: ssl-handle (wait-to-connect) - [ file>> (wait-to-connect) ] - [ handle>> do-ssl-connect ] 2bi ; + addrspec>> + [ >r file>> r> (wait-to-connect) ] + [ >r handle>> r> do-ssl-connect ] + 3bi ; From c7c1882b084d810d23d7d4abc04469b3205332b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 23:36:27 -0500 Subject: [PATCH 04/18] qualified would fail if vocab wasn't loaded --- extra/qualified/qualified.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/qualified/qualified.factor b/extra/qualified/qualified.factor index e48714bc44..3ce6d30819 100644 --- a/extra/qualified/qualified.factor +++ b/extra/qualified/qualified.factor @@ -23,7 +23,7 @@ IN: qualified ] curry map zip ; : partial-vocab-ignoring ( words name -- assoc ) - [ vocab-words keys swap diff ] keep partial-vocab ; + [ load-vocab vocab-words keys swap diff ] keep partial-vocab ; : EXCLUDE: #! Syntax: EXCLUDE: vocab => words ... ; @@ -32,12 +32,12 @@ IN: qualified : FROM: #! Syntax: FROM: vocab => words... ; - scan expect=> + scan dup load-vocab drop expect=> ";" parse-tokens swap partial-vocab use get push ; parsing : RENAME: #! Syntax: RENAME: word vocab => newname - scan scan lookup [ "No such word" throw ] unless* + scan scan dup load-vocab drop lookup [ "No such word" throw ] unless* expect=> scan associate use get push ; parsing From cf94f718966d08247ad659b5991746c8faca8cda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 23:36:45 -0500 Subject: [PATCH 05/18] Working on I/O --- extra/io/encodings/8-bit/8-bit.factor | 3 +-- extra/io/sockets/sockets-docs.factor | 2 +- extra/io/sockets/sockets.factor | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 88414efd16..a8cd1fea91 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -37,8 +37,7 @@ IN: io.encodings.8-bit 2dup swap length <= [ tail ] [ drop ] if ; : process-contents ( lines -- assoc ) - [ "#" split1 drop ] map - [ empty? not ] filter + [ "#" split1 drop ] map harvest [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; : byte>ch ( assoc -- array ) diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 2061a123de..db07caa330 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays continuations ; +strings byte-arrays continuations quotations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 0975f83c46..167f013d32 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -239,7 +239,7 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) : parse-addrinfo-list ( addrinfo -- seq ) [ addrinfo-next ] follow [ addrinfo>addrspec ] map - [ ] filter ; + sift ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then From c60baf123260f4199f534a55de2c4a80be4e0ba8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 23:36:55 -0500 Subject: [PATCH 06/18] sift and harvest words added --- core/bootstrap/primitives.factor | 5 -- core/bootstrap/stage2.factor | 2 +- core/cpu/x86/64/64.factor | 2 +- core/inference/backend/backend.factor | 4 +- core/parser/parser.factor | 4 +- core/prettyprint/sections/sections.factor | 2 +- core/sequences/sequences.factor | 6 ++ core/slots/deprecated/deprecated.factor | 2 +- core/vocabs/vocabs.factor | 2 +- extra/bunny/bunny.factor | 2 +- extra/bunny/model/model.factor | 2 +- extra/ftp/client/client.factor | 2 +- extra/hardware-info/linux/linux.factor | 4 +- extra/help/handbook/handbook.factor | 2 +- extra/help/help.factor | 2 +- extra/html/parser/analyzer/analyzer.factor | 4 +- extra/http/client/client-tests.factor | 25 +++++-- extra/http/client/client.factor | 16 +---- extra/http/http.factor | 82 ++++++++++++++++++---- extra/http/server/server.factor | 2 +- extra/koszul/koszul.factor | 2 +- extra/logging/server/server.factor | 2 +- extra/peg/search/search.factor | 4 +- extra/sequences/lib/lib.factor | 2 +- extra/tools/vocabs/browser/browser.factor | 2 +- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/tools/tools-tests.factor | 2 +- extra/unicode/breaks/breaks.factor | 3 +- extra/unicode/data/data.factor | 2 +- extra/unicode/script/script.factor | 2 +- extra/windows/com/syntax/syntax.factor | 3 +- extra/wrap/wrap.factor | 2 +- 32 files changed, 128 insertions(+), 72 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4aebef3e0d..6fc8ca7685 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -160,11 +160,6 @@ bootstrapping? on "tuple-layout" "classes.tuple.private" create register-builtin ! Catch-all class for providing a default method. -! "object" "kernel" create -! [ f builtins get [ ] filter f union-class define-class ] -! [ [ drop t ] "predicate" set-word-prop ] -! bi - "object" "kernel" create [ f f { } intersection-class define-class ] [ [ drop t ] "predicate" set-word-prop ] diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 2e087ff5bd..f94cc0ed37 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -23,7 +23,7 @@ SYMBOL: bootstrap-time : load-components ( -- ) "include" "exclude" - [ get-global " " split [ empty? not ] filter ] bi@ + [ get-global " " split harvest ] bi@ diff [ "bootstrap." prepend require ] each ; diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 9c44a6a656..ebaa6056ff 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : split-struct ( pairs -- seq ) [ [ 8 mod zero? [ t , ] when , ] assoc-each - ] { } make { t } split [ empty? not ] filter ; + ] { } make { t } split harvest ; : flatten-large-struct ( type -- ) heap-size cell align diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 5896429ccf..c49e7fda8a 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ; : balanced? ( in out -- ? ) [ dup [ length - ] [ 2drop f ] if ] 2map - [ ] filter all-equal? ; + sift all-equal? ; TUPLE: unbalanced-branches-error quots in out ; @@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ; 2dup balanced? [ over supremum -rot [ >r dupd r> unify-inputs ] 2map - [ ] filter unify-stacks + sift unify-stacks rot drop ] [ unbalanced-branches-error diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 76c831cf13..f08ba8fbc2 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -207,7 +207,7 @@ SYMBOL: in : add-use ( seq -- ) [ use+ ] each ; : set-use ( seq -- ) - [ vocab-words ] map [ ] filter >vector use set ; + [ vocab-words ] V{ } map-as sift use set ; : check-vocab-string ( name -- name ) dup string? @@ -278,7 +278,7 @@ M: no-word-error summary dup forward-reference? [ drop use get - [ at ] with map [ ] filter + [ at ] with map sift [ forward-reference? not ] find nip ] [ nip diff --git a/core/prettyprint/sections/sections.factor b/core/prettyprint/sections/sections.factor index 11fa4da28e..73d3620107 100644 --- a/core/prettyprint/sections/sections.factor +++ b/core/prettyprint/sections/sections.factor @@ -309,7 +309,7 @@ M: f section-end-group? drop f ; 2dup 1+ swap ?nth next set swap nth dup split-before dup , split-after ] with each - ] { } make { t } split [ empty? not ] filter ; + ] { } make { t } split harvest ; : break-group? ( seq -- ? ) [ first section-fits? ] [ peek section-fits? not ] bi and ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 8d0e3eec18..cbddfa7d28 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -445,6 +445,12 @@ PRIVATE> : remove ( obj seq -- newseq ) [ = not ] with filter ; +: sift ( seq -- newseq ) + [ ] filter ; + +: harvest ( seq -- newseq ) + [ empty? not ] filter ; + : cache-nth ( i seq quot -- elt ) 2over ?nth dup [ >r 3drop r> diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor index 90f468a185..3e2f899774 100755 --- a/core/slots/deprecated/deprecated.factor +++ b/core/slots/deprecated/deprecated.factor @@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; { [ over string? ] [ >r dupd r> short-slot ] } { [ over array? ] [ long-slot ] } } cond - ] 2map [ ] filter nip ; + ] 2map sift nip ; : slot-of-reader ( reader specs -- spec/f ) [ slot-spec-reader eq? ] with find nip ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index edd82b2596..57951e8642 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- ) : words-named ( str -- seq ) dictionary get values [ vocab-words at ] with map - [ ] filter ; + sift ; : child-vocab? ( prefix name -- ? ) 2dup = pick empty? or diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index d546f9ea41..6ebd598dc6 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- ) [ ] [ ] [ ] tri 3array - [ ] filter >>draw-seq + sift >>draw-seq 0 >>draw-n drop ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 239603755d..95b5fe401d 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ; IN: bunny.model : numbers ( str -- seq ) - " " split [ string>number ] map [ ] filter ; + " " split [ string>number ] map sift ; : (parse-model) ( vs is -- vs is ) readln [ diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 13cb21d7e4..88b83b7d66 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -130,7 +130,7 @@ TUPLE: remote-file : parse-list ( ftp-response -- ftp-response ) dup strings>> - [ " " split [ empty? not ] filter ] map + [ " " split harvest ] map dup length { { 9 [ parse-list-9 ] } { 8 [ parse-list-8 ] } diff --git a/extra/hardware-info/linux/linux.factor b/extra/hardware-info/linux/linux.factor index 5d9ca6eaa7..89f42b4384 100644 --- a/extra/hardware-info/linux/linux.factor +++ b/extra/hardware-info/linux/linux.factor @@ -7,7 +7,7 @@ IN: hardware-info.linux : uname ( -- seq ) 65536 "char" [ (uname) io-error ] keep - "\0" split [ empty? not ] filter [ >string ] map + "\0" split harvest [ >string ] map 6 "" pad-right ; : sysname ( -- string ) uname first ; @@ -18,4 +18,4 @@ IN: hardware-info.linux : domainname ( -- string ) uname 5 swap nth ; : kernel-version ( -- seq ) - release ".-" split [ ] filter 5 "" pad-right ; + release ".-" split harvest 5 "" pad-right ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index a8271a0e3b..dd4106239d 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; ARTICLE: "type-index" "Type index" -{ $index [ builtins get [ ] filter ] } ; +{ $index [ builtins get sift ] } ; ARTICLE: "class-index" "Class index" { $index [ classes ] } ; diff --git a/extra/help/help.factor b/extra/help/help.factor index 2d56251392..75a14e645b 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ":vars - list all variables at error time" print ; : :help ( -- ) - error get delegates [ error-help ] map [ ] filter + error get delegates [ error-help ] map sift { { [ dup empty? ] [ (:help-none) ] } { [ dup length 1 = ] [ first help ] } diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e9906f3f2a..9a3ff8c7a7 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -77,12 +77,12 @@ IN: html.parser.analyzer : find-by-attribute-key ( key vector -- vector ) >r >lower r> [ tag-attributes at ] with filter - [ ] filter ; + sift ; : find-by-attribute-key-value ( value key vector -- vector ) >r >lower r> [ tag-attributes at over = ] with filter nip - [ ] filter ; + sift ; : find-first-attribute-key-value ( value key vector -- i/f tag/f ) >r >lower r> diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor index 1d947b99e5..9ad805b81b 100755 --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -1,9 +1,7 @@ USING: http.client http.client.private http tools.test tuple-syntax namespaces ; -[ "localhost" 80 ] [ "localhost" parse-host ] unit-test +[ "localhost" f ] [ "localhost" parse-host ] unit-test [ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test -[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test -[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test [ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test [ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test @@ -12,10 +10,11 @@ tuple-syntax namespaces ; [ TUPLE{ request + protocol: http method: "GET" host: "www.apple.com" - path: "/index.html" port: 80 + path: "/index.html" version: "1.1" cookies: V{ } header: H{ { "connection" "close" } } @@ -26,3 +25,21 @@ tuple-syntax namespaces ; ] with-scope ] unit-test + +[ + TUPLE{ request + protocol: https + method: "GET" + host: "www.amazon.com" + port: 443 + path: "/index.html" + version: "1.1" + cookies: V{ } + header: H{ { "connection" "close" } } + } +] [ + [ + "https://www.amazon.com/index.html" + + ] with-scope +] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 17882277a3..cec1bb931a 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -19,22 +19,8 @@ DEFER: http-request r >>path r> dup [ query>assoc ] when >>query ; - -: request-with-url ( request url -- request ) - parse-url >r >r store-path r> >>host r> >>port ; - SYMBOL: redirects -: absolute-url? ( url -- ? ) - [ "http://" head? ] [ "https://" head? ] bi or ; - : do-redirect ( response data -- response data ) over code>> 300 399 between? [ drop @@ -42,7 +28,7 @@ SYMBOL: redirects redirects get max-redirects < [ request get swap "location" header dup absolute-url? - [ request-with-url ] [ store-path ] if + [ request-with-url ] [ request-with-path ] if "GET" >>method http-request ] [ too-many-redirects diff --git a/extra/http/http.factor b/extra/http/http.factor index 968d4d88ca..bbbebda53a 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format io io.streams.string io.encodings.utf8 io.encodings.string -io.sockets +io.sockets io.sockets.secure unicode.case unicode.categories qualified ; @@ -15,9 +15,31 @@ EXCLUDE: fry => , ; IN: http -: http-port 80 ; inline +SINGLETON: http -: https-port 443 ; inline +SINGLETON: https + +GENERIC: http-port ( protocol -- port ) + +M: http http-port drop 80 ; + +M: https http-port drop 443 ; + +GENERIC: protocol>string ( protocol -- string ) + +M: http protocol>string drop "http" ; + +M: https protocol>string drop "https" ; + +: string>protocol ( string -- protocol ) + { + { "http" [ http ] } + { "https" [ https ] } + [ "Unknown protocol: " swap append throw ] + } case ; + +: absolute-url? ( url -- ? ) + [ "http://" head? ] [ "https://" head? ] bi or ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -212,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ; [ unparse-cookie ] map concat "; " join ; TUPLE: request +protocol host port method @@ -229,7 +252,7 @@ cookies ; : request new "1.1" >>version - http-port >>port + http >>protocol H{ } clone >>header H{ } clone >>query V{ } clone >>cookies @@ -242,6 +265,7 @@ cookies ; pick query>> set-at ; : chop-hostname ( str -- str' ) + ":" split1 nip CHAR: / over index over length or tail dup empty? [ drop "/" ] when ; @@ -249,7 +273,9 @@ cookies ; #! Technically, only proxies are meant to support hostnames #! in HTTP requests, but IE sends these sometimes so we #! just chop the hostname part. - url-decode "http://" ?head [ chop-hostname ] when ; + url-decode + dup { "http://" "https://" } [ head? ] with contains? + [ chop-hostname ] when ; : read-method ( request -- request ) " " read-until [ "Bad request: method" throw ] unless @@ -298,10 +324,11 @@ SYMBOL: max-post-request : parse-host ( string -- host port ) "." ?tail drop ":" split1 - [ string>number ] [ http-port ] if* ; + dup [ string>number ] when ; : extract-host ( request -- request ) - dup "host" header parse-host >r >>host r> >>port ; + dup [ "host" header parse-host ] keep protocol>> http-port or + [ >>host ] [ >>port ] bi* ; : extract-post-data-type ( request -- request ) dup "content-type" header >>post-data-type ; @@ -314,7 +341,7 @@ SYMBOL: max-post-request dup "cookie" header [ parse-cookies >>cookies ] when* ; : parse-content-type-attributes ( string -- attributes ) - " " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ; + " " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; @@ -353,12 +380,20 @@ SYMBOL: max-post-request "application/x-www-form-urlencoded" >>post-data-type ] if ; +GENERIC: protocol-addr ( request protocol -- addr ) + +M: object protocol-addr + drop [ host>> ] [ port>> ] bi ; + +M: https protocol-addr + call-next-method ; + : request-addr ( request -- addr ) - [ host>> ] [ port>> ] bi ; + dup protocol>> protocol-addr ; : request-host ( request -- string ) - [ host>> ] [ port>> ] bi - dup 80 = [ drop ] [ ":" swap number>string 3append ] if ; + [ host>> ] [ port>> ] bi dup http http-port = + [ drop ] [ ":" swap number>string 3append ] if ; : write-request-header ( request -- request ) dup header>> >hashtable @@ -381,13 +416,32 @@ SYMBOL: max-post-request flush drop ; +: request-with-path ( request path -- request ) + [ "/" prepend ] [ "/" ] if* + "?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ; + +: request-with-url ( request url -- request ) + ":" split1 + [ string>protocol >>protocol ] + [ + "//" ?head [ "Invalid URL" throw ] unless + "/" split1 + [ + parse-host [ >>host ] [ >>port ] bi* + dup protocol>> http-port '[ , or ] change-port + ] + [ request-with-path ] + bi* + ] bi* ; + : request-url ( request -- url ) [ [ dup host>> [ - [ "http://" write host>> url-encode write ] - [ ":" write port>> number>string write ] - bi + [ protocol>> protocol>string write "://" write ] + [ host>> url-encode write ":" write ] + [ port>> number>string write ] + tri ] [ drop ] if ] [ path>> "/" head? [ "/" write ] unless ] diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 70c1e9a1f5..4e561220f9 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -240,7 +240,7 @@ SYMBOL: exit-continuation '[ exit-continuation set @ ] callcc1 exit-continuation off ; : split-path ( string -- path ) - "/" split [ empty? not ] filter ; + "/" split harvest ; : init-request ( -- ) H{ } clone base-paths set diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index aecae1cf88..4194ff6609 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -148,7 +148,7 @@ DEFER: (d) : nth-basis-elt ( generators n -- elt ) over length [ 3dup bit? [ nth ] [ 2drop f ] if - ] map [ ] filter 2nip ; + ] map sift 2nip ; : basis ( generators -- seq ) natural-sort dup length 2^ [ nth-basis-elt ] with map ; diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index 3bc8637f90..a832b10a18 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -37,7 +37,7 @@ SYMBOL: log-files write bl write ": " write print ; : write-message ( msg word-name level -- ) - rot [ empty? not ] filter { + rot harvest { { [ dup empty? ] [ 3drop ] } { [ dup length 1 = ] [ first -rot f (write-message) ] } [ diff --git a/extra/peg/search/search.factor b/extra/peg/search/search.factor index 3da676dcb2..7ab7e83d12 100755 --- a/extra/peg/search/search.factor +++ b/extra/peg/search/search.factor @@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser ) : search ( string parser -- seq ) any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ - parse-result-ast [ ] filter + parse-result-ast sift ] [ drop { } ] if ; : (replace) ( string parser -- seq ) - any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ; + any-char-parser 2array choice repeat0 parse parse-result-ast sift ; : replace ( string parser -- result ) [ (replace) [ tree-write ] each ] with-string-writer ; diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 0dc5601cd0..b703bb55a0 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -216,7 +216,7 @@ USE: continuations >r dup length swap r> [ = [ ] [ drop f ] if ] curry 2map - [ ] filter ; + sift ; vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] filter [ word-vocabulary ] map ] map>set - remove [ ] filter [ vocab ] map ; inline + remove sift [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index 56a0fbc3ee..cf97bedb8d 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -8,7 +8,7 @@ TUPLE: track sizes ; : normalized-sizes ( track -- seq ) track-sizes - [ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ; + [ sift sum ] keep [ dup [ over / ] when ] map nip ; : ( orientation -- track ) V{ } clone diff --git a/extra/ui/tools/tools-tests.factor b/extra/ui/tools/tools-tests.factor index 6d22083096..47b0d51705 100755 --- a/extra/ui/tools/tools-tests.factor +++ b/extra/ui/tools/tools-tests.factor @@ -17,7 +17,7 @@ IN: ui.tools.tests [ ] [ "w" get com-scroll-down ] unit-test [ t ] [ "w" get workspace-book gadget-children - [ tool-scroller ] map [ ] filter [ scroller? ] all? + [ tool-scroller ] map sift [ scroller? ] all? ] unit-test [ ] [ "w" get hide-popup ] unit-test [ ] [ "w" get show-popup ] unit-test diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index dfac27f7a4..53f81ccbf9 100755 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; [ blank? ] right-trim ; : process-other-extend ( lines -- set ) - [ "#" split1 drop ";" split1 drop trim-blank ] map - [ empty? not ] filter + [ "#" split1 drop ";" split1 drop trim-blank ] map harvest [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map concat unique ; diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 52706647a9..b411e4e209 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -89,7 +89,7 @@ IN: unicode.data ] assoc-map >hashtable ; : multihex ( hexstring -- string ) - " " split [ hex> ] map [ ] filter ; + " " split [ hex> ] map sift ; TUPLE: code-point lower title upper ; diff --git a/extra/unicode/script/script.factor b/extra/unicode/script/script.factor index 846f797f71..2d07ba2caa 100755 --- a/extra/unicode/script/script.factor +++ b/extra/unicode/script/script.factor @@ -10,7 +10,7 @@ SYMBOL: interned : parse-script ( stream -- assoc ) ! assoc is code point/range => name - lines [ "#" split1 drop ] map [ empty? not ] filter [ + lines [ "#" split1 drop ] map harvest [ ";" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ; diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index b3c803be2d..b63a5c3337 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -45,8 +45,7 @@ unless ; : parse-com-functions ( -- functions ) - ";" parse-tokens { ")" } split - [ empty? not ] filter + ";" parse-tokens { ")" } split harvest [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 9b1eeede96..29a8bbf10f 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -8,7 +8,7 @@ IN: wrap SYMBOL: width : line-chunks ( string -- words-lines ) - "\n" split [ " \t" split [ empty? not ] filter ] map ; + "\n" split [ " \t" split harvest ] map ; : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip From 58e4106a27a5425b4e5b8dcb950ced06b698111a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 13 May 2008 23:51:04 -0500 Subject: [PATCH 07/18] Use destructors in io.unix.mmap --- extra/io/unix/mmap/mmap.factor | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 216f98ee58..b6f0afb16e 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,22 +1,25 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien io io.files kernel math system unix io.unix.backend -io.mmap ; +io.mmap destructors ; IN: io.unix.mmap : open-r/w ( path -- fd ) O_RDWR file-mode open-file ; : mmap-open ( length prot flags path -- alien fd ) - >r f -roll r> open-r/w [ 0 mmap ] keep - over MAP_FAILED = [ close-file (io-error) ] when ; + [ + >r f -roll r> open-r/w dup close-later + [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep + ] with-destructors ; M: unix (mapped-file) ( path length -- obj ) swap >r - dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor + dup + PROT_READ PROT_WRITE bitor + MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file boa ; M: unix close-mapped-file ( mmap -- ) - [ mapped-file-address ] keep - [ mapped-file-length munmap ] keep - mapped-file-handle close-file - io-error ; + [ [ address>> ] [ length>> ] bi munmap io-error ] + [ handle>> close-file ] + bi ; From 0388568f5e5e029eac422c204ee9c51d2b76ad39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 00:44:27 -0500 Subject: [PATCH 08/18] Cleanup --- extra/io/mmap/mmap.factor | 23 ++++++++++++----------- extra/io/unix/mmap/mmap.factor | 18 +++++++++--------- extra/unix/unix.factor | 34 ++++++++++++++++++++-------------- 3 files changed, 41 insertions(+), 34 deletions(-) diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index a07443783c..2f637a4f81 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,37 +1,38 @@ ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien alien.accessors sequences.private ; +system alien alien.accessors accessors sequences.private ; IN: io.mmap -TUPLE: mapped-file length address handle closed? ; +TUPLE: mapped-file address handle length closed ; : check-closed ( mapped-file -- mapped-file ) - dup mapped-file-closed? [ + dup closed>> [ "Mapped file is closed" throw ] when ; inline -M: mapped-file length check-closed mapped-file-length ; +M: mapped-file length check-closed length>> ; M: mapped-file nth-unsafe - check-closed mapped-file-address swap alien-unsigned-1 ; + check-closed address>> swap alien-unsigned-1 ; M: mapped-file set-nth-unsafe - check-closed mapped-file-address swap set-alien-unsigned-1 ; + check-closed address>> swap set-alien-unsigned-1 ; INSTANCE: mapped-file sequence -HOOK: (mapped-file) io-backend ( path length -- mmap ) +HOOK: (mapped-file) io-backend ( path length -- address handle ) : ( path length -- mmap ) - >r normalize-path r> (mapped-file) ; + [ >r normalize-path r> (mapped-file) ] keep + f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) M: mapped-file dispose ( mmap -- ) - check-closed - t over set-mapped-file-closed? - close-mapped-file ; + dup closed>> [ drop ] [ + t >>closed close-mapped-file + ] if ; : with-mapped-file ( path length quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index b6f0afb16e..3798f422d8 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -1,23 +1,23 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien io io.files kernel math system unix io.unix.backend -io.mmap destructors ; +USING: alien io io.files kernel math math.bitfields system unix +io.unix.backend io.ports io.mmap destructors locals accessors ; IN: io.unix.mmap : open-r/w ( path -- fd ) O_RDWR file-mode open-file ; -: mmap-open ( length prot flags path -- alien fd ) +:: mmap-open ( length prot flags path -- alien fd ) [ - >r f -roll r> open-r/w dup close-later + f length prot flags + path open-r/w dup close-later [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; -M: unix (mapped-file) ( path length -- obj ) +M: unix (mapped-file) swap >r - dup - PROT_READ PROT_WRITE bitor - MAP_FILE MAP_SHARED bitor - r> mmap-open f mapped-file boa ; + { PROT_READ PROT_WRITE } flags + { MAP_FILE MAP_SHARED } flags + r> mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 2ac0a3bfa0..5608f229f0 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc structs sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified - accessors inference macros fry arrays.lib + accessors inference macros locals shuffle arrays.lib unix.types ; IN: unix @@ -50,20 +50,27 @@ LIBRARY: factor FUNCTION: void clear_err_no ( ) ; FUNCTION: int err_no ( ) ; -ERROR: unix-system-call-error word args message ; - -DEFER: strerror - -MACRO: unix-system-call ( quot -- ) - [ ] [ infer in>> ] [ first ] tri - '[ - [ @ dup 0 < [ dup throw ] [ ] if ] - [ drop , narray , swap err_no strerror unix-system-call-error ] - recover - ] ; - LIBRARY: libc +ERROR: unix-system-call-error args message word ; + +FUNCTION: char* strerror ( int errno ) ; + +MACRO:: unix-system-call ( quot -- ) + [let | n [ quot infer in>> ] + word [ quot first ] | + [ + n ndup quot call dup 0 < [ + drop + n narray + err_no strerror + word unix-system-call-error + ] [ + n nnip + ] if + ] + ] ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; @@ -162,7 +169,6 @@ FUNCTION: int setreuid ( uid_t ruid, uid_t euid ) ; FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ; FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ; -FUNCTION: char* strerror ( int errno ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int system ( char* command ) ; From a444db0c1f6c698c6e08a4516cbf8db69bf1bdb5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 00:45:43 -0500 Subject: [PATCH 09/18] Move some words to unix.process --- extra/unix/process/process.factor | 61 +++++++++++++++++++++++++++++-- extra/unix/unix.factor | 55 ---------------------------- 2 files changed, 58 insertions(+), 58 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 48fac04a1c..644276ef7d 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -39,8 +39,63 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ; : with-fork ( child parent -- ) fork-process dup zero? -roll swap curry if ; inline -: wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; + +: PRIO_PROCESS 0 ; inline +: PRIO_PGRP 1 ; inline +: PRIO_USER 2 ; inline + +: PRIO_MIN -20 ; inline +: PRIO_MAX 20 ; inline + +! which/who = 0 for current process +FUNCTION: int getpriority ( int which, int who ) ; +FUNCTION: int setpriority ( int which, int who, int prio ) ; : set-priority ( n -- ) - 0 0 rot setpriority io-error ; \ No newline at end of file + 0 0 rot setpriority io-error ; + +! Flags for waitpid + +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline + +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline + +! Examining status + +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline + +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline + +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline + +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline + +: WCOREFLAG ( -- value ) + HEX: 80 ; inline + +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline + +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline + +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline + +FUNCTION: pid_t wait ( int* status ) ; +FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; + +: wait-for-pid ( pid -- status ) + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 5608f229f0..9a7d405546 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -178,61 +178,6 @@ FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; -: SIGKILL 9 ; inline -: SIGTERM 15 ; inline - -FUNCTION: int kill ( pid_t pid, int sig ) ; - -: PRIO_PROCESS 0 ; inline -: PRIO_PGRP 1 ; inline -: PRIO_USER 2 ; inline - -: PRIO_MIN -20 ; inline -: PRIO_MAX 20 ; inline - -! which/who = 0 for current process -FUNCTION: int getpriority ( int which, int who ) ; -FUNCTION: int setpriority ( int which, int who, int prio ) ; - -! Flags for waitpid - -: WNOHANG 1 ; inline -: WUNTRACED 2 ; inline - -: WSTOPPED 2 ; inline -: WEXITED 4 ; inline -: WCONTINUED 8 ; inline -: WNOWAIT HEX: 1000000 ; inline - -! Examining status - -: WTERMSIG ( status -- value ) - HEX: 7f bitand ; inline - -: WIFEXITED ( status -- ? ) - WTERMSIG zero? ; inline - -: WEXITSTATUS ( status -- value ) - HEX: ff00 bitand -8 shift ; inline - -: WIFSIGNALED ( status -- ? ) - HEX: 7f bitand 1+ -1 shift 0 > ; inline - -: WCOREFLAG ( -- value ) - HEX: 80 ; inline - -: WCOREDUMP ( status -- ? ) - WCOREFLAG bitand zero? not ; inline - -: WIFSTOPPED ( status -- ? ) - HEX: ff bitand HEX: 7f = ; inline - -: WSTOPSIG ( status -- value ) - WEXITSTATUS ; inline - -FUNCTION: pid_t wait ( int* status ) ; -FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; - FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { From 509cf872a8df1bc8a0b7fef8aea83927751eca1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 01:14:52 -0500 Subject: [PATCH 10/18] Update docs --- core/kernel/kernel-docs.factor | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d142255535..e4100557e1 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -718,17 +718,21 @@ $nl HELP: unless* { $values { "cond" "a generalized boolean" } { "false" "a quotation " } } -{ $description "Variant of " { $link if* } " with no true quotation." -$nl +{ $description "Variant of " { $link if* } " with no true quotation." } +{ $notes "The following two lines are equivalent:" -{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ; +{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } +"The following two lines are equivalent, where " { $snippet "L" } " is a literal:" +{ $code "[ L ] unless*" "L or" } } ; HELP: ?if { $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } } -{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." -$nl +{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." } +{ $notes "The following two lines are equivalent:" -{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ; +{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } +"The following two lines are equivalent:" +{ $code "[ ] [ ] ?if" "swap or" } } ; HELP: die { $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } From 70a28abeabc14ff9f219c73852fa6e4fdb607a4e Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 14 May 2008 02:19:21 -0400 Subject: [PATCH 11/18] Adding support of rational numbers to parser --- extra/lisp/parser/parser-tests.factor | 8 ++++++++ extra/lisp/parser/parser.factor | 8 +++++--- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor index 9e6b54ab0c..98a6d2a6ba 100644 --- a/extra/lisp/parser/parser-tests.factor +++ b/extra/lisp/parser/parser-tests.factor @@ -8,6 +8,14 @@ IN: lisp.parser.tests "1234" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test +{ -42 } [ + "-42" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + +{ 37/52 } [ + "37/52" "atom" \ lisp-expr rule parse parse-result-ast +] unit-test + { 123.98 } [ "123.98" "atom" \ lisp-expr rule parse parse-result-ast ] unit-test diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 65ad01aa6f..32886f9367 100644 --- a/extra/lisp/parser/parser.factor +++ b/extra/lisp/parser/parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings -combinators.lib ; +combinators.lib math ; IN: lisp.parser @@ -18,9 +18,11 @@ RPAREN = ")" dquote = '"' squote = "'" digit = [0-9] -integer = (digit)+ => [[ string>number ]] -float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]] +integer = ("-")? (digit)+ => [[ first2 append string>number ]] +float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]] +rational = integer "/" (digit)+ => [[ first3 nip string>number / ]] number = float + | rational | integer id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" From 2f4ef55ae5f270d2368fd21885906f46d6fb154b Mon Sep 17 00:00:00 2001 From: James Cash Date: Wed, 14 May 2008 02:19:52 -0400 Subject: [PATCH 12/18] Finally got tests passing - lambdas work now --- extra/lisp/lisp.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor index 52faf59c17..8582021d6d 100644 --- a/extra/lisp/lisp.factor +++ b/extra/lisp/lisp.factor @@ -26,14 +26,14 @@ DEFER: funcall unclip convert-form swap convert-body [ , % funcall ] bake ; > swap member? [ name>> make-local ] [ ] if ] - [ dup s-exp? [ body>> localize-body ] [ nip ] if ] if - ] with map ; +: localize-body ( assoc body -- assoc newbody ) + [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ] + [ dup s-exp? [ body>> localize-body ] when ] if + ] map ; : localize-lambda ( body vars -- newbody newvars ) - dup make-locals dup push-locals [ swap localize-body convert-form ] dipd - pop-locals swap ; + make-locals dup push-locals swap + [ swap localize-body convert-form swap pop-locals ] dip swap ; PRIVATE> From 8f96e40c1c7aef050fd23e4650a496f955746ad6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 03:55:33 -0500 Subject: [PATCH 13/18] Working on SSL server sockets --- extra/io/launcher/launcher.factor | 2 +- extra/io/sockets/sockets.factor | 4 +- extra/io/unix/backend/backend.factor | 53 +++++++++------ extra/io/unix/files/files.factor | 19 +++--- extra/io/unix/launcher/launcher-tests.factor | 2 + extra/io/unix/launcher/launcher.factor | 2 +- extra/io/unix/pipes/pipes.factor | 2 +- extra/io/unix/sockets/secure/secure.factor | 68 ++++++++++++++++---- extra/io/unix/sockets/sockets.factor | 49 +++++++------- extra/openssl/libssl/libssl.factor | 2 +- extra/openssl/openssl.factor | 19 +++--- 11 files changed, 140 insertions(+), 82 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 0bfac74416..54c97bdb0e 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -199,7 +199,7 @@ M: object run-pipeline-element [ swap in>> or ] change-stdin run-detached ] - [ [ in>> close-handle ] [ out>> close-handle ] bi* ] + [ [ out>> close-handle ] [ in>> close-handle ] bi* ] [ [ in>> ] [ out>> ] bi* ] } 2cleave r> ] with-destructors ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 167f013d32..1075858346 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -195,11 +195,11 @@ GENERIC: (server) ( addrspec -- handle sockaddr ) swap >>addr r> >>encoding ; -HOOK: (accept) io-backend ( server -- handle remote ) +GENERIC: (accept) ( server addrspec -- handle remote ) : accept ( server -- client remote ) check-server-port - [ (accept) ] keep + [ dup addr>> (accept) ] keep tuck [ [ dup ] [ encoding>> ] bi* ] [ addr>> parse-sockaddr ] diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 537f00bfc9..207fdc3cbc 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -11,7 +11,15 @@ IN: io.unix.backend ! I/O tasks GENERIC: handle-fd ( handle -- fd ) -M: integer handle-fd ; +TUPLE: fd fd closed ; + +: ( n -- fd ) f fd boa ; + +M: fd dispose + dup closed>> + [ drop ] [ t >>closed fd>> close-file ] if ; + +M: fd handle-fd fd>> ; ! I/O multiplexers TUPLE: mx fd reads writes ; @@ -66,21 +74,23 @@ SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ -: wait-for-port ( port event -- ) +: wait-for-fd ( handle event -- ) dup +retry+ eq? [ 2drop ] [ [ - [ - >r - swap handle>> handle-fd - mx get-global - r> { - { +input+ [ add-input-callback ] } - { +output+ [ add-output-callback ] } - } case - ] curry "I/O" suspend drop - ] curry with-timeout pending-error + >r + swap handle-fd + mx get-global + r> { + { +input+ [ add-input-callback ] } + { +output+ [ add-output-callback ] } + } case + ] curry "I/O" suspend 2drop ] if ; +: wait-for-port ( port event -- ) + [ >r dup handle>> r> wait-for-fd ] curry + with-timeout pending-error ; + ! Some general stuff : file-mode OCT: 0666 ; @@ -93,15 +103,16 @@ SYMBOL: +output+ : io-error ( n -- ) 0 < [ (io-error) ] when ; -M: integer init-handle ( fd -- ) +M: fd init-handle ( fd -- ) #! We drop the error code rather than calling io-error, #! since on OS X 10.3, this operation fails from init-io #! when running the Factor.app (presumably because fd 0 and #! 1 are closed). + fd>> [ F_SETFL O_NONBLOCK fcntl drop ] [ F_SETFD FD_CLOEXEC fcntl drop ] bi ; -M: integer close-handle ( fd -- ) close-file ; +M: fd close-handle ( fd -- ) dispose ; ! Readers : eof ( reader -- ) @@ -116,8 +127,8 @@ M: integer close-handle ( fd -- ) close-file ; ! this request GENERIC: refill ( port handle -- event/f ) -M: integer refill - over buffer>> [ buffer-end ] [ buffer-capacity ] bi read +M: fd refill + fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { { [ dup 0 = ] [ drop eof f ] } { [ dup 0 > ] [ swap buffer>> n>buffer f ] } @@ -133,8 +144,8 @@ M: unix (wait-to-read) ( port -- ) ! Writers GENERIC: drain ( port handle -- event/f ) -M: integer drain - over buffer>> [ buffer@ ] [ buffer-length ] bi write +M: fd drain + fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write { { [ dup 0 >= ] [ over buffer>> buffer-consume @@ -153,9 +164,9 @@ M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; M: unix (init-stdio) ( -- ) - 0 - 1 - 2 ; + 0 + 1 + 2 ; ! mx io-task for embedding an fd-based mx inside another mx TUPLE: mx-port < port mx ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 9b0057c166..27dcc01889 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -4,12 +4,12 @@ USING: io.backend io.ports io.unix.backend io.files io unix unix.stat unix.time kernel math continuations math.bitfields byte-arrays alien combinators calendar io.encodings.binary accessors sequences strings system -io.files.private ; +io.files.private destructors ; IN: io.unix.files M: unix cwd ( -- path ) - MAXPATHLEN [ ] [ ] bi getcwd + MAXPATHLEN [ ] keep getcwd [ (io-error) ] unless* ; M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; @@ -19,23 +19,26 @@ M: unix cd ( path -- ) [ chdir ] unix-system-call drop ; : open-read ( path -- fd ) O_RDONLY file-mode open-file ; M: unix (file-reader) ( path -- stream ) - open-read ; + open-read ; : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline -: open-write ( path -- fd ) write-flags file-mode open-file ; +: open-write ( path -- fd ) + write-flags file-mode open-file ; M: unix (file-writer) ( path -- stream ) - open-write ; + open-write ; : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) - append-flags file-mode open-file - [ dup 0 SEEK_END lseek io-error ] [ ] [ close-file ] cleanup ; + [ + append-flags file-mode open-file dup close-later + dup 0 SEEK_END lseek io-error + ] with-destructors ; M: unix (file-appender) ( path -- stream ) - open-append ; + open-append ; : touch-mode ( -- n ) { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 177c5775dc..49bfc34164 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ; ] times "append-test" temp-file utf8 file-contents ] unit-test + +[ ] [ "ls" utf8 contents drop ] unit-test diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 405f26d4bc..3b9c8fc7af 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -58,7 +58,7 @@ USE: unix { [ pick string? ] [ redirect-file ] } { [ pick appender? ] [ redirect-file-append ] } { [ pick +closed+ eq? ] [ redirect-closed ] } - { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] } + { [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] } [ >r >r underlying-handle r> r> redirect ] } cond ; diff --git a/extra/io/unix/pipes/pipes.factor b/extra/io/unix/pipes/pipes.factor index dd7ed4a94a..db2c917520 100644 --- a/extra/io/unix/pipes/pipes.factor +++ b/extra/io/unix/pipes/pipes.factor @@ -8,5 +8,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 "int" dup pipe io-error - 2 c-int-array> first2 + 2 c-int-array> first2 [ ] bi@ [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 7e4e8955ae..14cd9fdb6f 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -6,17 +6,16 @@ continuations destructors openssl openssl.libcrypto openssl.libssl io.files io.ports io.unix.backend io.unix.sockets io.encodings.ascii io.buffers io.sockets io.sockets.secure -unix ; +unix system ; IN: io.unix.sockets.secure ! todo: SSL_pending, rehandshake -! do we call write twice, wth 0 bytes at the end? ! check-certificate at some point ! test on windows -M: ssl-handle handle-fd file>> ; +M: ssl-handle handle-fd file>> handle-fd ; -: syscall-error ( port r -- * ) +: syscall-error ( r -- * ) ERR_get_error dup zero? [ drop { @@ -70,10 +69,14 @@ M: ssl-handle drain check-write-response ; ! Client sockets -M: ssl ((client)) ( addrspec -- handle ) - [ addrspec>> ((client)) ] with-destructors ; +: ( fd -- ssl ) + [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep + [ handle>> swap dup SSL_set_bio ] keep ; -M: ssl parse-sockaddr addrspec>> parse-sockaddr ; +M: ssl ((client)) ( addrspec -- handle ) + addrspec>> ((client)) ; + +M: ssl parse-sockaddr addrspec>> parse-sockaddr ; : check-connect-response ( port r -- event ) check-response @@ -85,13 +88,54 @@ M: ssl parse-sockaddr addrspec>> parse-sockaddr ; { SSL_ERROR_SSL [ (ssl-error) ] } } case ; -: do-ssl-connect ( port ssl addrspec -- ) - drop +: do-ssl-connect ( port ssl-handle -- ) 2dup SSL_connect check-connect-response dup - [ nip wait-for-port ] [ 3drop ] if ; + [ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ; M: ssl-handle (wait-to-connect) addrspec>> [ >r file>> r> (wait-to-connect) ] - [ >r handle>> r> do-ssl-connect ] - 3bi ; + [ drop handle>> do-ssl-connect ] + [ drop t >>connected 2drop ] + 3tri ; + +M: ssl (server) addrspec>> (server) ; + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ; + +M: ssl (accept) + [ + addrspec>> + (accept) >r + dup close-later + dup close-later + dup do-ssl-accept + r> + ] with-destructors ; + +: check-shutdown-response ( handle r -- event ) + >r handle>> r> SSL_get_error + { + { SSL_ERROR_WANT_READ [ +input+ ] } + { SSL_ERROR_WANT_WRITE [ +output+ ] } + { SSL_ERROR_SYSCALL [ -1 syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: unix ssl-shutdown + dup connected>> [ + dup dup handle>> SSL_shutdown check-shutdown-response + dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if + ] [ drop ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index a04d008a21..127f50d1aa 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -12,69 +12,68 @@ EXCLUDE: io.sockets => accept ; IN: io.unix.sockets -: socket-fd ( domain type -- socket ) - 0 socket - dup io-error - dup close-later - dup init-handle ; +: socket-fd ( domain type -- fd ) + 0 socket dup io-error [ close-later ] [ init-handle ] [ ] tri ; -: sockopt ( fd level opt -- ) - 1 "int" heap-size setsockopt io-error ; +: set-socket-option ( fd level opt -- ) + >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain : init-client-socket ( fd -- ) - SOL_SOCKET SO_OOBINLINE sockopt ; + SOL_SOCKET SO_OOBINLINE set-socket-option ; : get-socket-name ( fd addrspec -- sockaddr ) - empty-sockaddr/size [ getsockname io-error ] 2keep drop ; + >r handle-fd r> empty-sockaddr/size + [ getsockname io-error ] 2keep drop ; : get-peer-name ( fd addrspec -- sockaddr ) - empty-sockaddr/size [ getpeername io-error ] 2keep drop ; + >r handle-fd r> empty-sockaddr/size + [ getpeername io-error ] 2keep drop ; -M: integer (wait-to-connect) +M: fd (wait-to-connect) >r >r +output+ wait-for-port r> r> get-socket-name ; M: object ((client)) ( addrspec -- fd ) [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi - [ 2drop ] [ connect ] 3bi - zero? err_no EINPROGRESS = or + >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket ] [ (io-error) ] if ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) - SOL_SOCKET SO_REUSEADDR sockopt ; + SOL_SOCKET SO_REUSEADDR set-socket-option ; : server-socket-fd ( addrspec type -- fd ) >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr/size bind io-error ; + dup handle-fd rot make-sockaddr/size bind io-error ; M: object (server) ( addrspec -- handle sockaddr ) [ [ SOCK_STREAM server-socket-fd - dup 10 listen io-error + dup handle-fd 10 listen io-error dup ] keep get-socket-name ] with-destructors ; -: do-accept ( server -- fd remote ) - [ handle>> ] [ addr>> empty-sockaddr/size ] bi +: do-accept ( server addrspec -- fd remote ) + [ handle>> handle-fd ] [ empty-sockaddr/size ] bi* [ accept ] 2keep drop ; inline -M: unix (accept) ( server -- fd remote ) - dup do-accept +M: object (accept) ( server addrspec -- fd remote ) + 2dup do-accept { - { [ over 0 >= ] [ rot drop ] } + { [ over 0 >= ] [ { [ drop ] [ drop ] [ ] [ ] } spread ] } { [ err_no EINTR = ] [ 2drop (accept) ] } { [ err_no EAGAIN = ] [ 2drop - [ +input+ wait-for-port ] - [ (accept) ] bi + [ drop +input+ wait-for-port ] + [ (accept) ] + 2bi ] } [ (io-error) ] } cond ; @@ -91,7 +90,7 @@ packet-size receive-buffer set-global :: do-receive ( port -- packet sockaddr ) port addr>> empty-sockaddr/size [| sockaddr len | - port handle>> ! s + port handle>> handle-fd ! s receive-buffer get-global ! buf packet-size ! nbytes 0 ! flags @@ -110,7 +109,7 @@ M: unix (receive) ( datagram -- packet sockaddr ) ] if ; :: do-send ( packet sockaddr len socket datagram -- ) - socket packet dup length 0 sockaddr len sendto + socket handle-fd packet dup length 0 sockaddr len sendto 0 < [ err_no EINTR = [ packet sockaddr len socket datagram do-send diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor index d1c53c4b23..5330a815a3 100755 --- a/extra/openssl/libssl/libssl.factor +++ b/extra/openssl/libssl/libssl.factor @@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ; FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ; -FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ; +FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ; diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 41e413c966..6eb2d0dbda 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc continuations destructors debugger inspector locals unicode.case openssl.libcrypto openssl.libssl -io.ports io.files io.encodings.ascii io.sockets.secure ; +io.backend io.ports io.files io.encodings.ascii io.sockets.secure ; IN: openssl ! This code is based on http://www.rtfm.com/openssl-examples/ @@ -120,7 +120,7 @@ M: openssl-context dispose dup handle>> [ SSL_CTX_free ] when* f >>handle drop ; -TUPLE: ssl-handle file handle disposed ; +TUPLE: ssl-handle file handle connected disposed ; ERROR: no-ssl-context ; @@ -132,20 +132,19 @@ M: no-ssl-context summary : ( fd -- ssl ) current-ssl-context handle>> SSL_new dup ssl-error - f ssl-handle boa ; + f f ssl-handle boa ; -: ( fd -- ssl ) - [ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep - - [ handle>> swap dup SSL_set_bio ] keep ; +M: ssl-handle init-handle file>> init-handle ; -M: ssl-handle init-handle drop ; +HOOK: ssl-shutdown io-backend ( handle -- ) M: ssl-handle close-handle dup disposed>> [ drop ] [ - [ t >>disposed drop ] + t >>disposed + [ ssl-shutdown ] + [ handle>> SSL_free ] [ file>> close-handle ] - [ handle>> SSL_free ] tri + tri ] if ; ERROR: certificate-verify-error result ; From a190375c0256803188febc2e14d5e4cd1295bd1f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 14 May 2008 06:08:57 -0500 Subject: [PATCH 14/18] Fixes --- extra/bootstrap/image/upload/upload.factor | 2 +- extra/http/http-tests.factor | 2 ++ extra/http/http.factor | 4 ++-- extra/http/server/server-tests.factor | 1 + extra/io/unix/files/unique/unique.factor | 2 +- 5 files changed, 7 insertions(+), 4 deletions(-) diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor index e78c3541d4..29c9d5b072 100755 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: http.client checksums checksums.openssl splitting assocs +USING: checksums checksums.openssl splitting assocs kernel io.files bootstrap.image sequences io namespaces io.launcher math io.encodings.ascii ; IN: bootstrap.image.upload diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index a3b9676aac..daac4d6dd9 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -45,6 +45,7 @@ blah [ TUPLE{ request + protocol: http port: 80 method: "GET" path: "/bar" @@ -84,6 +85,7 @@ Host: www.sex.com [ TUPLE{ request + protocol: http port: 80 method: "HEAD" path: "/bar" diff --git a/extra/http/http.factor b/extra/http/http.factor index bbbebda53a..6efbd42fd2 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -265,7 +265,7 @@ cookies ; pick query>> set-at ; : chop-hostname ( str -- str' ) - ":" split1 nip + ":" split1 "//" ?head drop nip CHAR: / over index over length or tail dup empty? [ drop "/" ] when ; @@ -440,7 +440,7 @@ M: https protocol-addr dup host>> [ [ protocol>> protocol>string write "://" write ] [ host>> url-encode write ":" write ] - [ port>> number>string write ] + [ [ port>> ] [ protocol>> http-port or ] bi number>string write ] tri ] [ drop ] if ] diff --git a/extra/http/server/server-tests.factor b/extra/http/server/server-tests.factor index a5dffbc58b..af27eda527 100755 --- a/extra/http/server/server-tests.factor +++ b/extra/http/server/server-tests.factor @@ -6,6 +6,7 @@ IN: http.server.tests [ + http >>protocol "www.apple.com" >>host "/xxx/bar" >>path { { "a" "b" } } >>query diff --git a/extra/io/unix/files/unique/unique.factor b/extra/io/unix/files/unique/unique.factor index 54ced6e5ce..dca2f51958 100644 --- a/extra/io/unix/files/unique/unique.factor +++ b/extra/io/unix/files/unique/unique.factor @@ -6,6 +6,6 @@ IN: io.unix.files.unique { O_RDWR O_CREAT O_EXCL } flags ; M: unix (make-unique-file) ( path -- ) - open-unique-flags file-mode open dup io-error close ; + open-unique-flags file-mode open-file close-file ; M: unix temporary-path ( -- path ) "/tmp" ; From ab070a6839e8735c38e0caa0f5a9b8f0b3632b32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 07:54:13 -0500 Subject: [PATCH 15/18] intermediate work on ftp, gotta pull.. --- extra/ftp/client/client.factor | 11 +-- extra/ftp/ftp.factor | 37 ++++++++++- extra/ftp/server/server.factor | 118 ++++++++++++++++++++++++--------- 3 files changed, 123 insertions(+), 43 deletions(-) diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor index 44ff488a93..8ec7366266 100644 --- a/extra/ftp/client/client.factor +++ b/extra/ftp/client/client.factor @@ -27,7 +27,6 @@ IN: ftp.client : ftp-command ( string -- ftp-response ) ftp-send read-response ; - : ftp-user ( ftp-client -- ftp-response ) user>> "USER " prepend ftp-command ; @@ -56,21 +55,13 @@ IN: ftp.client strings>> first "|" split 2 tail* first string>number ; -: ch>attribute ( ch -- symbol ) - { - { CHAR: d [ +directory+ ] } - { CHAR: l [ +symbolic-link+ ] } - { CHAR: - [ +regular-file+ ] } - [ drop +unknown+ ] - } case ; - TUPLE: remote-file type permissions links owner group size month day time year name ; : ( -- remote-file ) remote-file new ; : parse-permissions ( remote-file str -- remote-file ) - [ first ch>attribute >>type ] [ rest >>permissions ] bi ; + [ first ch>type >>type ] [ rest >>permissions ] bi ; : parse-list-9 ( lines -- seq ) [ diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor index 05291d3d5f..ccdbcd76ea 100644 --- a/extra/ftp/ftp.factor +++ b/extra/ftp/ftp.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors io kernel math.parser sequences ; +USING: accessors arrays assocs combinators io io.files kernel +math.parser sequences strings ; IN: ftp SINGLETON: active @@ -15,6 +16,11 @@ TUPLE: ftp-client host port user password mode state ; "anonymous" >>user "ftp@my.org" >>password ; +: reset-ftp-client ( ftp-client -- ) + f >>user + f >>password + drop ; + TUPLE: ftp-response n strings parsed ; : ( -- ftp-response ) @@ -25,3 +31,32 @@ TUPLE: ftp-response n strings parsed ; over strings>> push ; : ftp-send ( string -- ) write "\r\n" write flush ; + +: ftp-ipv4 1 ; inline +: ftp-ipv6 2 ; inline + + +: ch>type ( ch -- type ) + { + { CHAR: d [ +directory+ ] } + { CHAR: l [ +symbolic-link+ ] } + { CHAR: - [ +regular-file+ ] } + [ drop +unknown+ ] + } case ; + +: type>ch ( type -- string ) + { + { +directory+ [ CHAR: d ] } + { +symbolic-link+ [ CHAR: l ] } + { +regular-file+ [ CHAR: - ] } + [ drop CHAR: - ] + } case ; + +: file-info>string ( file-info name -- string ) + >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ] + [ size>> number>string 15 CHAR: \s pad-left ] bi r> + 3array " " join ; + +: directory-list ( -- seq ) + "" directory keys + [ [ link-info ] keep file-info>string ] map ; diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor index 1b9201fb7b..37c806f1b9 100644 --- a/extra/ftp/server/server.factor +++ b/extra/ftp/server/server.factor @@ -1,27 +1,30 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators io io.encodings.8-bit io.files io.server io.sockets kernel math.parser namespaces sequences ftp io.unix.launcher.parser -unicode.case ; +unicode.case splitting assocs ; IN: ftp.server SYMBOL: client +SYMBOL: stream -TUPLE: ftp-client-command string tokenized ; +TUPLE: ftp-command raw tokenized ; -: ( -- obj ) - ftp-client-command new ; +: ( -- obj ) + ftp-command new ; -: read-client-command ( -- ftp-client-command ) - readln - [ >>string ] [ tokenize-command >>tokenized ] bi ; +: read-command ( -- ftp-command ) + readln + [ >>raw ] [ tokenize-command >>tokenized ] bi ; + +: (send-response) ( n string separator -- ) + rot number>string write write ftp-send ; : send-response ( ftp-response -- ) [ n>> ] [ strings>> ] bi - 2dup - but-last-slice [ - [ number>string write "-" write ] [ ftp-send ] bi* - ] with each - first [ number>string write bl ] [ ftp-send ] bi* ; + [ but-last-slice [ "-" (send-response) ] with each ] + [ first " " (send-response) ] 2bi ; : server-response ( n string -- ) @@ -35,72 +38,123 @@ TUPLE: ftp-client-command string tokenized ; : send-PASS-request ( -- ) 331 "Please specify the password." server-response ; -: parse-USER ( ftp-client-command -- ) +: anonymous-only ( -- ) + 530 "This FTP server is anonymous only." server-response ; + +: parse-USER ( ftp-command -- ) tokenized>> second client get swap >>user drop ; : send-login-response ( -- ) ! client get 230 "Login successful" server-response ; -: parse-PASS ( ftp-client-command -- ) +: parse-PASS ( ftp-command -- ) tokenized>> second client get swap >>password drop ; -: send-quit-response ( ftp-client-command -- ) +: send-quit-response ( ftp-command -- ) drop 221 "Goodbye." server-response ; -: unimplemented-command ( ftp-client-command -- ) - 500 "Unimplemented command: " rot string>> append server-response ; +: ftp-error ( string -- ) + 500 "Unrecognized command: " rot append server-response ; + +: send-type-error ( -- ) + "TYPE is binary only" ftp-error ; + +: send-type-success ( string -- ) + 200 "Switching to " rot " mode" 3append server-response ; + +: parse-TYPE ( obj -- ) + tokenized>> second >upper { + { "IMAGE" [ "Binary" send-type-success ] } + { "I" [ "Binary" send-type-success ] } + [ drop send-type-error ] + } case ; + +: pwd-response ( -- ) + 257 current-directory get "\"" swap "\"" 3append server-response ; + +! : random-local-inet ( -- spec ) + ! remote-address get class new 0 >>port ; + +! : handle-LIST ( -- ) + ! random-local-inet ascii ; + +: handle-STOR ( obj -- ) + ; + +! EPRT |2|::1|62138| +! : handle-EPRT ( obj -- ) + ! tokenized>> second "|" split harvest ; + +! : handle-EPSV ( obj -- ) + ! 229 "Entering Extended Passive Mode (|||" + ! random-local-inet ! get port number>string + ! "|)" 3append server-response ; + +! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186 +: handle-LPRT ( obj -- ) + tokenized>> "," split ; + +: start-directory ( -- ) + 150 "Here comes the directory listing." server-response ; + +: finish-directory ( -- ) + 226 "Directory send OK." server-response ; + +: send-directory-list ( stream -- ) + [ directory-list write ] with-output-stream ; + +: unrecognized-command ( obj -- ) raw>> ftp-error ; : handle-client-loop ( -- ) - readln - [ >>string ] + readln + [ >>raw ] [ tokenize-command >>tokenized ] bi dup tokenized>> first >upper { { "USER" [ parse-USER send-PASS-request t ] } { "PASS" [ parse-PASS send-login-response t ] } - ! { "ACCT" [ ] } + { "ACCT" [ drop "ACCT unimplemented" ftp-error t ] } ! { "CWD" [ ] } ! { "CDUP" [ ] } ! { "SMNT" [ ] } - ! { "REIN" [ ] } + ! { "REIN" [ drop client get reset-ftp-client t ] } { "QUIT" [ send-quit-response f ] } ! { "PORT" [ ] } ! { "PASV" [ ] } ! { "MODE" [ ] } - ! { "TYPE" [ ] } + { "TYPE" [ parse-TYPE t ] } ! { "STRU" [ ] } ! { "ALLO" [ ] } ! { "REST" [ ] } - ! { "STOR" [ ] } + ! { "STOR" [ handle-STOR t ] } ! { "STOU" [ ] } ! { "RETR" [ ] } - ! { "LIST" [ ] } + ! { "LIST" [ drop handle-LIST t ] } ! { "NLST" [ ] } - ! { "LIST" [ ] } ! { "APPE" [ ] } ! { "RNFR" [ ] } ! { "RNTO" [ ] } ! { "DELE" [ ] } ! { "RMD" [ ] } ! { "MKD" [ ] } - ! { "PWD" [ ] } + { "PWD" [ drop pwd-response t ] } ! { "ABOR" [ ] } - ! { "SYST" [ ] } + ! { "SYST" [ drop ] } ! { "STAT" [ ] } ! { "HELP" [ ] } ! { "SITE" [ ] } ! { "NOOP" [ ] } - ! { "EPRT" [ ] } - ! { "LPRT" [ ] } - ! { "EPSV" [ ] } - ! { "LPSV" [ ] } - [ drop unimplemented-command t ] + ! { "EPRT" [ handle-eprt ] } + ! { "LPRT" [ handle-lprt ] } + ! { "EPSV" [ drop handle-epsv t ] } + ! { "LPSV" [ drop handle-lpsv t ] } + [ drop unrecognized-command t ] } case [ handle-client-loop ] when ; : handle-client ( -- ) From dd9e8a2245ae7d04e28eb0bd699cbf5229de932c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 07:54:40 -0500 Subject: [PATCH 16/18] expose some more fields from windows file info --- extra/io/windows/files/files.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 8a15a57f83..1fd60fe1a5 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -68,6 +68,11 @@ SYMBOLS: +read-only+ +hidden+ +system+ ! [ BY_HANDLE_FILE_INFORMATION-ftCreationTime FILETIME>timestamp ] [ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ] ! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ] + ! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ] + ! [ + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] + ! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit + ! ] } cleave \ file-info boa ; From c6ab75e3f53338fd513b0374683dcd4458ebe036 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 14 May 2008 15:43:34 -0500 Subject: [PATCH 17/18] move remote-address to public --- extra/io/server/server.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 23066114e4..e15e8c0039 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -8,12 +8,12 @@ IN: io.server SYMBOL: servers +SYMBOL: remote-address + Date: Wed, 14 May 2008 19:03:07 -0500 Subject: [PATCH 18/18] Destructor changes --- core/boxes/boxes.factor | 18 +++++----- .../distributed/distributed-tests.factor | 2 +- extra/db/pooling/pooling.factor | 2 +- extra/db/postgresql/lib/lib.factor | 12 +++---- extra/destructors/destructors-docs.factor | 22 +++++------- extra/destructors/destructors-tests.factor | 4 +-- extra/destructors/destructors.factor | 23 ++++++------ extra/http/server/auth/login/login.factor | 2 +- extra/http/server/sessions/sessions.factor | 2 +- extra/io/launcher/launcher.factor | 6 ++-- extra/io/pipes/pipes.factor | 13 +++---- extra/io/ports/ports.factor | 12 +++---- extra/io/sockets/sockets.factor | 13 +++---- extra/io/unix/files/files.factor | 2 +- extra/io/unix/mmap/mmap.factor | 2 +- extra/io/unix/sockets/secure/secure.factor | 4 +-- extra/io/unix/sockets/sockets.factor | 36 ++++++++++++------- extra/io/windows/windows.factor | 2 +- extra/openssl/openssl.factor | 3 +- extra/random/windows/windows.factor | 5 ++- extra/smtp/smtp.factor | 18 +++++----- 21 files changed, 102 insertions(+), 101 deletions(-) diff --git a/core/boxes/boxes.factor b/core/boxes/boxes.factor index b56a46b6b3..42b329b84b 100755 --- a/core/boxes/boxes.factor +++ b/core/boxes/boxes.factor @@ -1,24 +1,26 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel accessors ; IN: boxes TUPLE: box value full? ; : ( -- box ) box new ; +ERROR: box-full box ; + : >box ( value box -- ) - dup box-full? [ "Box already has a value" throw ] when - t over set-box-full? - set-box-value ; + dup full?>> + [ box-full ] [ t >>full? (>>value) ] if ; + +ERROR: box-empty box ; : box> ( box -- value ) - dup box-full? [ "Box empty" throw ] unless - dup box-value f pick set-box-value - f rot set-box-full? ; + dup full?>> + [ [ f ] change-value f >>full? drop ] [ box-empty ] if ; : ?box ( box -- value/f ? ) - dup box-full? [ box> t ] [ drop f f ] if ; + dup full?>> [ box> t ] [ drop f f ] if ; : if-box? ( box quot -- ) >r ?box r> [ drop ] if ; inline diff --git a/extra/concurrency/distributed/distributed-tests.factor b/extra/concurrency/distributed/distributed-tests.factor index e2abd6deb9..840c5efa36 100755 --- a/extra/concurrency/distributed/distributed-tests.factor +++ b/extra/concurrency/distributed/distributed-tests.factor @@ -13,7 +13,7 @@ concurrency.messaging continuations ; [ ] [ test-node dup 1array swap (start-node) ] unit-test -[ ] [ yield ] unit-test +[ ] [ 1000 sleep ] unit-test [ ] [ [ diff --git a/extra/db/pooling/pooling.factor b/extra/db/pooling/pooling.factor index 83820294d6..1be05d5d72 100644 --- a/extra/db/pooling/pooling.factor +++ b/extra/db/pooling/pooling.factor @@ -40,4 +40,4 @@ M: return-connection dispose [ db>> ] [ pool>> ] bi return-connection ; : return-connection-later ( db pool -- ) - \ return-connection boa add-always-destructor ; + \ return-connection boa &dispose drop ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 8b0026b6e5..cd079690e3 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -67,12 +67,10 @@ M: postgresql-result-null summary ( obj -- str ) in-params>> [ type>> type>oid ] map >c-uint-array ; : malloc-byte-array/length - [ malloc-byte-array dup free-always ] [ length ] bi ; + [ malloc-byte-array &free ] [ length ] bi ; : default-param-value - number>string* dup [ - utf8 malloc-string dup free-always - ] when 0 ; + number>string* dup [ utf8 malloc-string &free ] when 0 ; : param-values ( statement -- seq seq2 ) [ bind-params>> ] [ in-params>> ] bi @@ -128,8 +126,8 @@ C: postgresql-malloc-destructor M: postgresql-malloc-destructor dispose ( obj -- ) alien>> PQfreemem ; -: postgresql-free-always ( alien -- ) - add-always-destructor ; +: &postgresql-free ( alien -- alien ) + &dispose ; inline : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength @@ -142,7 +140,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) PQunescapeBytea dup zero? [ postgresql-result-error-message throw ] [ - dup postgresql-free-always + &postgresql-free ] if ] keep *uint memory>byte-array diff --git a/extra/destructors/destructors-docs.factor b/extra/destructors/destructors-docs.factor index e9f6002efa..28f8858597 100755 --- a/extra/destructors/destructors-docs.factor +++ b/extra/destructors/destructors-docs.factor @@ -1,20 +1,16 @@ USING: help.markup help.syntax libc kernel continuations ; IN: destructors -HELP: free-always -{ $values { "alien" "alien returned by malloc" } } -{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " ends." } -{ $see-also free-later } ; - -HELP: free-later -{ $values { "alien" "alien returned by malloc" } } -{ $description "Adds a destructor that will " { $link free } " the alien. The free will happen whenever the quotation passed to " { $link with-destructors } " errors or else the object will persist and manual cleanup is required later." } -{ $see-also free-always } ; - HELP: with-destructors { $values { "quot" "a quotation" } } -{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } -{ $notes "Destructors are not allowed to throw exceptions. No exceptions." } +{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." } +{ $notes + "Destructors generalize " { $link with-disposal } ". The following two lines are equivalent:" + { $code + "[ X ] with-disposal" + "[ &dispose X ] with-destructors" + } +} { $examples - { $code "[ 10 malloc free-always ] with-destructors" } + { $code "[ 10 malloc &free ] with-destructors" } } ; diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 59c325c490..18f50bf760 100755 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -13,10 +13,10 @@ M: dummy-destructor dispose ( obj -- ) dummy-destructor-obj t swap set-dummy-obj-destroyed? ; : destroy-always - add-always-destructor ; + &dispose drop ; : destroy-later - add-error-destructor ; + |dispose drop ; [ t ] [ [ diff --git a/extra/destructors/destructors.factor b/extra/destructors/destructors.factor index 3d5e19520f..86f8fa1f48 100755 --- a/extra/destructors/destructors.factor +++ b/extra/destructors/destructors.factor @@ -4,14 +4,11 @@ USING: accessors continuations io.backend libc kernel namespaces sequences system vectors ; IN: destructors -SYMBOL: error-destructors + dispose-each ; @@ -19,6 +16,12 @@ SYMBOL: always-destructors : do-error-destructors ( -- ) error-destructors get dispose-each ; +PRIVATE> + +: &dispose dup always-destructors get push ; inline + +: |dispose dup error-destructors get push ; inline + : with-destructors ( quot -- ) [ V{ } clone always-destructors set @@ -44,8 +47,8 @@ C: memory-destructor M: memory-destructor dispose ( obj -- ) alien>> free ; -: free-always ( alien -- ) - add-always-destructor ; +: &free ( alien -- alien ) + &dispose ; inline -: free-later ( alien -- ) - add-error-destructor ; +: |free ( alien -- alien ) + |dispose ; inline diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor index 9f1fe6fe77..bb77532a22 100755 --- a/extra/http/server/auth/login/login.factor +++ b/extra/http/server/auth/login/login.factor @@ -58,7 +58,7 @@ M: user-saver dispose user>> dup changed?>> [ users update-user ] [ drop ] if ; : save-user-after ( user -- ) - add-always-destructor ; + &dispose drop ; : login-template ( name -- template ) "resource:extra/http/server/auth/login/" swap ".xml" diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor index fe32327c24..a7e1a141c4 100755 --- a/extra/http/server/sessions/sessions.factor +++ b/extra/http/server/sessions/sessions.factor @@ -102,7 +102,7 @@ M: session-saver dispose ] [ drop ] if ; : save-session-after ( session -- ) - add-always-destructor ; + &dispose drop ; : existing-session ( path session -- response ) [ session set ] [ save-session-after ] bi diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 54c97bdb0e..90eea091d5 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -158,7 +158,7 @@ M: object run-pipeline-element : ( process encoding -- process stream ) [ >r (pipe) { - [ add-error-destructor ] + [ |dispose drop ] [ swap >process [ swap out>> or ] change-stdout @@ -175,7 +175,7 @@ M: object run-pipeline-element : ( process encoding -- process stream ) [ >r (pipe) { - [ add-error-destructor ] + [ |dispose drop ] [ swap >process [ swap in>> or ] change-stdout @@ -192,7 +192,7 @@ M: object run-pipeline-element : ( process encoding -- process stream ) [ >r (pipe) (pipe) { - [ [ add-error-destructor ] bi@ ] + [ [ |dispose drop ] bi@ ] [ rot >process [ swap out>> or ] change-stdout diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index a3315d02ca..ef6b200f64 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -15,18 +15,15 @@ HOOK: (pipe) io-backend ( -- pipe ) : ( encoding -- stream ) [ - >r (pipe) - [ add-error-destructor ] - [ in>> ] - [ out>> ] - tri + >r (pipe) |dispose + [ in>> ] [ out>> ] bi r> ] with-destructors ; dup add-always-destructor ] [ input-stream get ] if* ; -: ?writer [ dup add-always-destructor ] [ output-stream get ] if* ; +: ?reader [ &dispose ] [ input-stream get ] if* ; +: ?writer [ &dispose ] [ output-stream get ] if* ; GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) @@ -38,7 +35,7 @@ M: callable run-pipeline-element : ( n -- pipes ) [ - [ (pipe) dup add-error-destructor ] replicate + [ (pipe) |dispose ] replicate T{ pipe } [ prefix ] [ suffix ] bi 2 ] with-destructors ; diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor index 16e089a4a6..2b1d62aaeb 100755 --- a/extra/io/ports/ports.factor +++ b/extra/io/ports/ports.factor @@ -27,11 +27,11 @@ C: handle-destructor M: handle-destructor dispose ( obj -- ) handle>> close-handle ; -: close-always ( handle -- ) - add-always-destructor ; +: &close-handle ( handle -- handle ) + &dispose ; inline -: close-later ( handle -- ) - add-error-destructor ; +: |close-handle ( handle -- handle ) + |dispose ; inline : ( handle class -- port ) new @@ -161,6 +161,6 @@ M: port dispose : ( read-handle write-handle -- input-port output-port ) [ - [ dup add-error-destructor ] - [ dup add-error-destructor ] bi* + [ |dispose ] + [ |dispose ] bi* ] with-destructors ; diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 1075858346..ac58a54bb8 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -151,10 +151,9 @@ M: inet6 parse-sockaddr M: f parse-sockaddr nip ; -GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr ) +GENERIC# get-local-address 1 ( handle remote -- sockaddr ) -: wait-to-connect ( client-out handle remote -- local ) - [ (wait-to-connect) ] keep parse-sockaddr ; +GENERIC: establish-connection ( client-out remote -- ) GENERIC: ((client)) ( remote -- handle ) @@ -164,12 +163,8 @@ M: array (client) [ (client) 3array ] attempt-all first3 ; M: object (client) ( remote -- client-in client-out local ) [ - [ - ((client)) - dup - 2dup [ add-error-destructor ] bi@ - dup dup handle>> - ] keep wait-to-connect + [ ((client)) dup 2dup [ |dispose drop ] bi@ ] keep + [ establish-connection ] [ drop ] [ get-local-address ] 2tri ] with-destructors ; : ( remote encoding -- stream local ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 27dcc01889..33cc25d60c 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -33,7 +33,7 @@ M: unix (file-writer) ( path -- stream ) : open-append ( path -- fd ) [ - append-flags file-mode open-file dup close-later + append-flags file-mode open-file |close-handle dup 0 SEEK_END lseek io-error ] with-destructors ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor index 3798f422d8..8a98e4795f 100755 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -9,7 +9,7 @@ IN: io.unix.mmap :: mmap-open ( length prot flags path -- alien fd ) [ f length prot flags - path open-r/w dup close-later + path open-r/w |close-handle [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor index 14cd9fdb6f..1d240057b0 100644 --- a/extra/io/unix/sockets/secure/secure.factor +++ b/extra/io/unix/sockets/secure/secure.factor @@ -119,8 +119,8 @@ M: ssl (accept) [ addrspec>> (accept) >r - dup close-later - dup close-later + |close-handle + |close-handle dup do-ssl-accept r> ] with-destructors ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 127f50d1aa..7973ca5164 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -13,7 +13,7 @@ EXCLUDE: io.sockets => accept ; IN: io.unix.sockets : socket-fd ( domain type -- fd ) - 0 socket dup io-error [ close-later ] [ init-handle ] [ ] tri ; + 0 socket dup io-error |close-handle dup init-handle ; : set-socket-option ( fd level opt -- ) >r >r handle-fd r> r> 1 "int" heap-size setsockopt io-error ; @@ -22,24 +22,34 @@ M: unix addrinfo-error ( n -- ) dup zero? [ drop ] [ gai_strerror throw ] if ; ! Client sockets - TCP and Unix domain -: init-client-socket ( fd -- ) - SOL_SOCKET SO_OOBINLINE set-socket-option ; - -: get-socket-name ( fd addrspec -- sockaddr ) +M: fd get-local-address ( handle remote -- sockaddr ) >r handle-fd r> empty-sockaddr/size [ getsockname io-error ] 2keep drop ; -: get-peer-name ( fd addrspec -- sockaddr ) - >r handle-fd r> empty-sockaddr/size - [ getpeername io-error ] 2keep drop ; +: init-client-socket ( fd -- ) + SOL_SOCKET SO_OOBINLINE set-socket-option ; -M: fd (wait-to-connect) - >r >r +output+ wait-for-port r> r> get-socket-name ; +: wait-to-connect ( port -- ) + dup handle>> handle-fd f 0 write + { + { [ 0 = ] [ drop f ] } + { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ err_no EINTR = ] [ wait-to-connect ] } + [ (io-error) ] + } cond ; + +M: object establish-connection ( client-out remote -- ) + [ drop ] [ [ handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi + { + { [ 0 = ] [ ] } + { [ err_no EINPROGRESS = ] [ + [ +output+ wait-for-port ] [ check-connection ] [ ] tri + ] } + [ (io-error) ] + } cond ; M: object ((client)) ( addrspec -- fd ) - [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi - >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or - [ dup init-client-socket ] [ (io-error) ] if ; + protocol-family SOCK_STREAM socket-fd dup init-client-socket ; ! Server sockets - TCP and Unix domain : init-server-socket ( fd -- ) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 5c0a1c8ecf..4f34153b31 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -185,7 +185,7 @@ M: socket-destructor dispose ( obj -- ) alien>> destruct-socket ; : close-socket-later ( handle -- ) - add-error-destructor ; + |dispose drop ; : server-fd ( addrspec type -- fd ) >r dup protocol-family r> open-socket diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor index 6eb2d0dbda..1cffd24cd5 100755 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -103,8 +103,7 @@ M: openssl ( config -- context ) maybe-init-ssl [ dup method>> ssl-method SSL_CTX_new - dup ssl-error V{ } clone openssl-context boa - dup add-error-destructor + dup ssl-error V{ } clone openssl-context boa |dispose { [ load-certificate-chain ] [ set-default-password ] diff --git a/extra/random/windows/windows.factor b/extra/random/windows/windows.factor index 6f47d3e6bf..f376903ecf 100644 --- a/extra/random/windows/windows.factor +++ b/extra/random/windows/windows.factor @@ -36,9 +36,8 @@ M: windows-crypto-context dispose ( tuple -- ) M: windows-rng random-bytes* ( n tuple -- bytes ) [ [ provider>> ] [ type>> ] bi - windows-crypto-context - dup add-always-destructor handle>> - swap dup + windows-crypto-context &dispose + handle>> swap dup [ CryptGenRandom win32-error=0/f ] keep ] with-destructors ; diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 8fdc0e07a4..f4f2496cc6 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -110,14 +110,16 @@ M: email clone : (send) ( email -- ) [ - helo get-ok - dup from>> mail-from get-ok - dup to>> [ rcpt-to get-ok ] each - data get-ok - dup headers>> write-headers - crlf - body>> send-body get-ok - quit get-ok + [ + helo get-ok + dup from>> mail-from get-ok + dup to>> [ rcpt-to get-ok ] each + data get-ok + dup headers>> write-headers + crlf + body>> send-body get-ok + quit get-ok USING: continuations debugger ; + ] [ global [ error. :c ] bind ] recover ] with-smtp-connection ; : extract-email ( recepient -- email )