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

db4
Doug Coleman 2008-05-14 07:55:09 -05:00
commit c012a48920
96 changed files with 1081 additions and 951 deletions

View File

@ -160,11 +160,6 @@ bootstrapping? on
"tuple-layout" "classes.tuple.private" create register-builtin "tuple-layout" "classes.tuple.private" create register-builtin
! Catch-all class for providing a default method. ! 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 "object" "kernel" create
[ f f { } intersection-class define-class ] [ f f { } intersection-class define-class ]
[ [ drop t ] "predicate" set-word-prop ] [ [ drop t ] "predicate" set-word-prop ]

View File

@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
: load-components ( -- ) : load-components ( -- )
"include" "exclude" "include" "exclude"
[ get-global " " split [ empty? not ] filter ] bi@ [ get-global " " split harvest ] bi@
diff diff
[ "bootstrap." prepend require ] each ; [ "bootstrap." prepend require ] each ;

View File

@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
: split-struct ( pairs -- seq ) : split-struct ( pairs -- seq )
[ [
[ 8 mod zero? [ t , ] when , ] assoc-each [ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split [ empty? not ] filter ; ] { } make { t } split harvest ;
: flatten-large-struct ( type -- ) : flatten-large-struct ( type -- )
heap-size cell align heap-size cell align

View File

@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
: balanced? ( in out -- ? ) : balanced? ( in out -- ? )
[ dup [ length - ] [ 2drop f ] if ] 2map [ dup [ length - ] [ 2drop f ] if ] 2map
[ ] filter all-equal? ; sift all-equal? ;
TUPLE: unbalanced-branches-error quots in out ; TUPLE: unbalanced-branches-error quots in out ;
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
2dup balanced? [ 2dup balanced? [
over supremum -rot over supremum -rot
[ >r dupd r> unify-inputs ] 2map [ >r dupd r> unify-inputs ] 2map
[ ] filter unify-stacks sift unify-stacks
rot drop rot drop
] [ ] [
unbalanced-branches-error unbalanced-branches-error

View File

@ -718,17 +718,21 @@ $nl
HELP: unless* HELP: unless*
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } } { $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
{ $description "Variant of " { $link if* } " with no true quotation." { $description "Variant of " { $link if* } " with no true quotation." }
$nl { $notes
"The following two lines are equivalent:" "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 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 -- )" } } } { $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." { $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 { $notes
"The following two lines are equivalent:" "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 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." } { $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." }

View File

@ -207,7 +207,7 @@ SYMBOL: in
: add-use ( seq -- ) [ use+ ] each ; : add-use ( seq -- ) [ use+ ] each ;
: set-use ( seq -- ) : set-use ( seq -- )
[ vocab-words ] map [ ] filter >vector use set ; [ vocab-words ] V{ } map-as sift use set ;
: check-vocab-string ( name -- name ) : check-vocab-string ( name -- name )
dup string? dup string?
@ -278,7 +278,7 @@ M: no-word-error summary
dup forward-reference? [ dup forward-reference? [
drop drop
use get use get
[ at ] with map [ ] filter [ at ] with map sift
[ forward-reference? not ] find nip [ forward-reference? not ] find nip
] [ ] [
nip nip

View File

@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
2dup 1+ swap ?nth next set 2dup 1+ swap ?nth next set
swap nth dup split-before dup , split-after swap nth dup split-before dup , split-after
] with each ] with each
] { } make { t } split [ empty? not ] filter ; ] { } make { t } split harvest ;
: break-group? ( seq -- ? ) : break-group? ( seq -- ? )
[ first section-fits? ] [ peek section-fits? not ] bi and ; [ first section-fits? ] [ peek section-fits? not ] bi and ;

View File

@ -445,6 +445,12 @@ PRIVATE>
: remove ( obj seq -- newseq ) : remove ( obj seq -- newseq )
[ = not ] with filter ; [ = not ] with filter ;
: sift ( seq -- newseq )
[ ] filter ;
: harvest ( seq -- newseq )
[ empty? not ] filter ;
: cache-nth ( i seq quot -- elt ) : cache-nth ( i seq quot -- elt )
2over ?nth dup [ 2over ?nth dup [
>r 3drop r> >r 3drop r>

View File

@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
{ [ over string? ] [ >r dupd r> short-slot ] } { [ over string? ] [ >r dupd r> short-slot ] }
{ [ over array? ] [ long-slot ] } { [ over array? ] [ long-slot ] }
} cond } cond
] 2map [ ] filter nip ; ] 2map sift nip ;
: slot-of-reader ( reader specs -- spec/f ) : slot-of-reader ( reader specs -- spec/f )
[ slot-spec-reader eq? ] with find nip ; [ slot-spec-reader eq? ] with find nip ;

View File

@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
: words-named ( str -- seq ) : words-named ( str -- seq )
dictionary get values dictionary get values
[ vocab-words at ] with map [ vocab-words at ] with map
[ ] filter ; sift ;
: child-vocab? ( prefix name -- ? ) : child-vocab? ( prefix name -- ? )
2dup = pick empty? or 2dup = pick empty? or

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 kernel io.files bootstrap.image sequences io namespaces
io.launcher math io.encodings.ascii ; io.launcher math io.encodings.ascii ;
IN: bootstrap.image.upload IN: bootstrap.image.upload

View File

@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
[ <bunny-fixed-pipeline> ] [ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ] [ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array [ <bunny-outlined> ] tri 3array
[ ] filter >>draw-seq sift >>draw-seq
0 >>draw-n 0 >>draw-n
drop ; drop ;

View File

@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ;
IN: bunny.model IN: bunny.model
: numbers ( str -- seq ) : numbers ( str -- seq )
" " split [ string>number ] map [ ] filter ; " " split [ string>number ] map sift ;
: (parse-model) ( vs is -- vs is ) : (parse-model) ( vs is -- vs is )
readln [ readln [

View File

@ -103,7 +103,7 @@ TUPLE: remote-file
: parse-list ( ftp-response -- ftp-response ) : parse-list ( ftp-response -- ftp-response )
dup strings>> dup strings>>
[ " " split [ empty? not ] filter ] map [ " " split harvest ] map
dup length { dup length {
{ 9 [ parse-list-9 ] } { 9 [ parse-list-9 ] }
{ 8 [ parse-list-8 ] } { 8 [ parse-list-8 ] }

View File

@ -7,7 +7,7 @@ IN: hardware-info.linux
: uname ( -- seq ) : uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep 65536 "char" <c-array> [ (uname) io-error ] keep
"\0" split [ empty? not ] filter [ >string ] map "\0" split harvest [ >string ] map
6 "" pad-right ; 6 "" pad-right ;
: sysname ( -- string ) uname first ; : sysname ( -- string ) uname first ;
@ -18,4 +18,4 @@ IN: hardware-info.linux
: domainname ( -- string ) uname 5 swap nth ; : domainname ( -- string ) uname 5 swap nth ;
: kernel-version ( -- seq ) : kernel-version ( -- seq )
release ".-" split [ ] filter 5 "" pad-right ; release ".-" split harvest 5 "" pad-right ;

View File

@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index"
{ $index [ all-errors ] } ; { $index [ all-errors ] } ;
ARTICLE: "type-index" "Type index" ARTICLE: "type-index" "Type index"
{ $index [ builtins get [ ] filter ] } ; { $index [ builtins get sift ] } ;
ARTICLE: "class-index" "Class index" ARTICLE: "class-index" "Class index"
{ $index [ classes ] } ; { $index [ classes ] } ;

View File

@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":vars - list all variables at error time" print ; ":vars - list all variables at error time" print ;
: :help ( -- ) : :help ( -- )
error get delegates [ error-help ] map [ ] filter error get delegates [ error-help ] map sift
{ {
{ [ dup empty? ] [ (:help-none) ] } { [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] } { [ dup length 1 = ] [ first help ] }

View File

@ -77,12 +77,12 @@ IN: html.parser.analyzer
: find-by-attribute-key ( key vector -- vector ) : find-by-attribute-key ( key vector -- vector )
>r >lower r> >r >lower r>
[ tag-attributes at ] with filter [ tag-attributes at ] with filter
[ ] filter ; sift ;
: find-by-attribute-key-value ( value key vector -- vector ) : find-by-attribute-key-value ( value key vector -- vector )
>r >lower r> >r >lower r>
[ tag-attributes at over = ] with filter nip [ tag-attributes at over = ] with filter nip
[ ] filter ; sift ;
: find-first-attribute-key-value ( value key vector -- i/f tag/f ) : find-first-attribute-key-value ( value key vector -- i/f tag/f )
>r >lower r> >r >lower r>

View File

@ -1,9 +1,7 @@
USING: http.client http.client.private http tools.test USING: http.client http.client.private http tools.test
tuple-syntax namespaces ; 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 [ "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.paulgraham.com/foo.txt" download-name ] unit-test
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" 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 TUPLE{ request
protocol: http
method: "GET" method: "GET"
host: "www.apple.com" host: "www.apple.com"
path: "/index.html"
port: 80 port: 80
path: "/index.html"
version: "1.1" version: "1.1"
cookies: V{ } cookies: V{ }
header: H{ { "connection" "close" } } header: H{ { "connection" "close" } }
@ -26,3 +25,21 @@ tuple-syntax namespaces ;
<get-request> <get-request>
] with-scope ] with-scope
] unit-test ] 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"
<get-request>
] with-scope
] unit-test

View File

@ -19,22 +19,8 @@ DEFER: http-request
<PRIVATE <PRIVATE
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )
"?" split1 >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 SYMBOL: redirects
: absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response data -- response data ) : do-redirect ( response data -- response data )
over code>> 300 399 between? [ over code>> 300 399 between? [
drop drop
@ -42,7 +28,7 @@ SYMBOL: redirects
redirects get max-redirects < [ redirects get max-redirects < [
request get request get
swap "location" header dup absolute-url? swap "location" header dup absolute-url?
[ request-with-url ] [ store-path ] if [ request-with-url ] [ request-with-path ] if
"GET" >>method http-request "GET" >>method http-request
] [ ] [
too-many-redirects too-many-redirects

View File

@ -45,6 +45,7 @@ blah
[ [
TUPLE{ request TUPLE{ request
protocol: http
port: 80 port: 80
method: "GET" method: "GET"
path: "/bar" path: "/bar"
@ -84,6 +85,7 @@ Host: www.sex.com
[ [
TUPLE{ request TUPLE{ request
protocol: http
port: 80 port: 80
method: "HEAD" method: "HEAD"
path: "/bar" path: "/bar"
@ -174,6 +176,8 @@ test-db [
main-responder set main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop [ 1237 httpd ] "HTTPD test" spawn drop
yield
] with-scope ] with-scope
] unit-test ] unit-test

View File

@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format math.parser calendar calendar.format
io io.streams.string io.encodings.utf8 io.encodings.string io io.streams.string io.encodings.utf8 io.encodings.string
io.sockets io.sockets io.sockets.secure
unicode.case unicode.categories qualified ; unicode.case unicode.categories qualified ;
@ -15,9 +15,31 @@ EXCLUDE: fry => , ;
IN: http 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 -- ? ) : url-quotable? ( ch -- ? )
#! In a URL, can this character be used without #! 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 ; [ unparse-cookie ] map concat "; " join ;
TUPLE: request TUPLE: request
protocol
host host
port port
method method
@ -229,7 +252,7 @@ cookies ;
: <request> : <request>
request new request new
"1.1" >>version "1.1" >>version
http-port >>port http >>protocol
H{ } clone >>header H{ } clone >>header
H{ } clone >>query H{ } clone >>query
V{ } clone >>cookies V{ } clone >>cookies
@ -242,6 +265,7 @@ cookies ;
pick query>> set-at ; pick query>> set-at ;
: chop-hostname ( str -- str' ) : chop-hostname ( str -- str' )
":" split1 "//" ?head drop nip
CHAR: / over index over length or tail CHAR: / over index over length or tail
dup empty? [ drop "/" ] when ; dup empty? [ drop "/" ] when ;
@ -249,7 +273,9 @@ cookies ;
#! Technically, only proxies are meant to support hostnames #! Technically, only proxies are meant to support hostnames
#! in HTTP requests, but IE sends these sometimes so we #! in HTTP requests, but IE sends these sometimes so we
#! just chop the hostname part. #! 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-method ( request -- request )
" " read-until [ "Bad request: method" throw ] unless " " read-until [ "Bad request: method" throw ] unless
@ -298,10 +324,11 @@ SYMBOL: max-post-request
: parse-host ( string -- host port ) : parse-host ( string -- host port )
"." ?tail drop ":" split1 "." ?tail drop ":" split1
[ string>number ] [ http-port ] if* ; dup [ string>number ] when ;
: extract-host ( request -- request ) : 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 ) : extract-post-data-type ( request -- request )
dup "content-type" header >>post-data-type ; dup "content-type" header >>post-data-type ;
@ -314,7 +341,7 @@ SYMBOL: max-post-request
dup "cookie" header [ parse-cookies >>cookies ] when* ; dup "cookie" header [ parse-cookies >>cookies ] when* ;
: parse-content-type-attributes ( string -- attributes ) : 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 ) : parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ; ";" split1 parse-content-type-attributes "charset" swap at ;
@ -353,12 +380,20 @@ SYMBOL: max-post-request
"application/x-www-form-urlencoded" >>post-data-type "application/x-www-form-urlencoded" >>post-data-type
] if ; ] if ;
GENERIC: protocol-addr ( request protocol -- addr )
M: object protocol-addr
drop [ host>> ] [ port>> ] bi <inet> ;
M: https protocol-addr
call-next-method <ssl> ;
: request-addr ( request -- addr ) : request-addr ( request -- addr )
[ host>> ] [ port>> ] bi <inet> ; dup protocol>> protocol-addr ;
: request-host ( request -- string ) : request-host ( request -- string )
[ host>> ] [ port>> ] bi [ host>> ] [ port>> ] bi dup http http-port =
dup 80 = [ drop ] [ ":" swap number>string 3append ] if ; [ drop ] [ ":" swap number>string 3append ] if ;
: write-request-header ( request -- request ) : write-request-header ( request -- request )
dup header>> >hashtable dup header>> >hashtable
@ -381,13 +416,32 @@ SYMBOL: max-post-request
flush flush
drop ; 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 ) : request-url ( request -- url )
[ [
[ [
dup host>> [ dup host>> [
[ "http://" write host>> url-encode write ] [ protocol>> protocol>string write "://" write ]
[ ":" write port>> number>string write ] [ host>> url-encode write ":" write ]
bi [ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
tri
] [ drop ] if ] [ drop ] if
] ]
[ path>> "/" head? [ "/" write ] unless ] [ path>> "/" head? [ "/" write ] unless ]

View File

@ -6,6 +6,7 @@ IN: http.server.tests
[ [
<request> <request>
http >>protocol
"www.apple.com" >>host "www.apple.com" >>host
"/xxx/bar" >>path "/xxx/bar" >>path
{ { "a" "b" } } >>query { { "a" "b" } } >>query

View File

@ -240,7 +240,7 @@ SYMBOL: exit-continuation
'[ exit-continuation set @ ] callcc1 exit-continuation off ; '[ exit-continuation set @ ] callcc1 exit-continuation off ;
: split-path ( string -- path ) : split-path ( string -- path )
"/" split [ empty? not ] filter ; "/" split harvest ;
: init-request ( -- ) : init-request ( -- )
H{ } clone base-paths set H{ } clone base-paths set

View File

@ -37,8 +37,7 @@ IN: io.encodings.8-bit
2dup swap length <= [ tail ] [ drop ] if ; 2dup swap length <= [ tail ] [ drop ] if ;
: process-contents ( lines -- assoc ) : process-contents ( lines -- assoc )
[ "#" split1 drop ] map [ "#" split1 drop ] map harvest
[ empty? not ] filter
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ; [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
: byte>ch ( assoc -- array ) : byte>ch ( assoc -- array )

View File

@ -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 ; io.files.unique.private math.parser io.files ;
IN: io.files.unique IN: io.files.unique

View File

@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors math accessors concurrency.flags destructors
io io.backend io.timeouts io.pipes io.pipes.private io.encodings 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 IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -199,7 +199,7 @@ M: object run-pipeline-element
[ swap in>> or ] change-stdin [ swap in>> or ] change-stdin
run-detached run-detached
] ]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ] [ [ out>> close-handle ] [ in>> close-handle ] bi* ]
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ] [ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
} 2cleave r> <encoder-duplex> } 2cleave r> <encoder-duplex>
] with-destructors ; ] with-destructors ;

View File

@ -1,37 +1,38 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend kernel quotations sequences USING: continuations io.backend kernel quotations sequences
system alien alien.accessors sequences.private ; system alien alien.accessors accessors sequences.private ;
IN: io.mmap IN: io.mmap
TUPLE: mapped-file length address handle closed? ; TUPLE: mapped-file address handle length closed ;
: check-closed ( mapped-file -- mapped-file ) : check-closed ( mapped-file -- mapped-file )
dup mapped-file-closed? [ dup closed>> [
"Mapped file is closed" throw "Mapped file is closed" throw
] when ; inline ] when ; inline
M: mapped-file length check-closed mapped-file-length ; M: mapped-file length check-closed length>> ;
M: mapped-file nth-unsafe 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 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 INSTANCE: mapped-file sequence
HOOK: (mapped-file) io-backend ( path length -- mmap ) HOOK: (mapped-file) io-backend ( path length -- address handle )
: <mapped-file> ( path length -- mmap ) : <mapped-file> ( 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 -- ) HOOK: close-mapped-file io-backend ( mmap -- )
M: mapped-file dispose ( mmap -- ) M: mapped-file dispose ( mmap -- )
check-closed dup closed>> [ drop ] [
t over set-mapped-file-closed? t >>closed close-mapped-file
close-mapped-file ; ] if ;
: with-mapped-file ( path length quot -- ) : with-mapped-file ( path length quot -- )
>r <mapped-file> r> with-disposal ; inline >r <mapped-file> r> with-disposal ; inline

View File

@ -1,6 +1,6 @@
USING: io io.pipes io.streams.string io.encodings.utf8 USING: io io.pipes io.streams.string io.encodings.utf8
io.streams.duplex io.encodings namespaces continuations io.streams.duplex io.encodings io.timeouts namespaces
tools.test kernel ; continuations tools.test kernel calendar ;
IN: io.pipes.tests IN: io.pipes.tests
[ "Hello" ] [ [ "Hello" ] [
@ -24,3 +24,10 @@ IN: io.pipes.tests
[ input-stream [ utf8 <decoder> ] change readln ] [ input-stream [ utf8 <decoder> ] change readln ]
} run-pipeline } run-pipeline
] unit-test ] unit-test
[
utf8 <pipe> [
5 seconds over set-timeout
stream-readln
] with-disposal
] must-fail

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 io splitting sequences sequences.lib namespaces kernel
destructors math concurrency.combinators accessors destructors math concurrency.combinators accessors
arrays continuations quotations ; arrays continuations quotations ;

View File

@ -1,9 +1,9 @@
USING: io io.buffers io.backend help.markup help.syntax kernel USING: io io.buffers io.backend help.markup help.syntax kernel
byte-arrays sbufs words continuations byte-vectors classes ; byte-arrays sbufs words continuations byte-vectors classes ;
IN: io.nonblocking IN: io.ports
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" 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.nonblocking" } " vocabulary." "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 $nl
"A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:" "A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:"
{ $subsection port } { $subsection port }
@ -23,13 +23,10 @@ $nl
"Per-port native I/O protocol:" "Per-port native I/O protocol:"
{ $subsection init-handle } { $subsection init-handle }
{ $subsection (wait-to-read) } { $subsection (wait-to-read) }
"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." { $subsection (wait-to-write) }
$nl "Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ;
"Dummy ports which should be used to implement networking:"
{ $subsection server-port }
{ $subsection datagram-port } ;
ABOUT: "io.nonblocking" ABOUT: "io.ports"
HELP: port 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." { $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 +78,6 @@ HELP: (wait-to-read)
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ; { $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
HELP: wait-to-read 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 } } { $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." } ; { $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;

View File

@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend
continuations debugger classes byte-arrays namespaces splitting continuations debugger classes byte-arrays namespaces splitting
dlists assocs io.encodings.binary inspector accessors dlists assocs io.encodings.binary inspector accessors
destructors ; destructors ;
IN: io.nonblocking IN: io.ports
SYMBOL: default-buffer-size SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global 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>> ; M: port timeout timeout>> ;
@ -37,26 +37,6 @@ M: handle-destructor dispose ( obj -- )
new new
swap dup init-handle >>handle ; inline swap dup init-handle >>handle ; inline
: <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
TUPLE: input-port < port ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
TUPLE: output-port < port ;
: <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: <ports> ( read-handle write-handle -- input-port output-port )
[
[ <input-port> dup add-error-destructor ]
[ <output-port> dup add-error-destructor ] bi*
] with-destructors ;
: pending-error ( port -- ) : pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ; [ f ] change-error drop [ throw ] when* ;
@ -68,19 +48,21 @@ M: port-closed-error summary
: check-closed ( port -- port ) : check-closed ( port -- port )
dup closed>> [ port-closed-error ] when ; dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- ) TUPLE: buffered-port < port buffer ;
M: object cancel-io drop ; : <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
M: port timed-out cancel-io ; TUPLE: input-port < buffered-port eof ;
: <input-port> ( handle -- input-port )
input-port <buffered-port> ;
HOOK: (wait-to-read) io-backend ( port -- ) HOOK: (wait-to-read) io-backend ( port -- )
: wait-to-read ( count port -- ) : wait-to-read ( port -- )
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ; dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: unless-eof ( port quot -- value ) : unless-eof ( port quot -- value )
>r dup buffer>> buffer-empty? over eof>> and >r dup buffer>> buffer-empty? over eof>> and
@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- )
M: input-port stream-read1 M: input-port stream-read1
check-closed 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 ) : read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep [ wait-to-read ] keep
[ dupd buffer>> buffer-read ] unless-eof nip ; [ 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 -- ) : read-loop ( count port accum -- )
pick over length - dup 0 > [ pick over length - dup 0 > [
pick read-step dup [ pick read-step dup [
@ -117,9 +103,10 @@ M: input-port stream-read
] [ 2nip ] if ] [ 2nip ] if
] [ 2nip ] if ; ] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f ) TUPLE: output-port < buffered-port ;
check-closed
>r 0 max >fixnum r> read-step ; : <output-port> ( handle -- output-port )
output-port <buffered-port> ;
: can-write? ( len buffer -- ? ) : can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ; [ buffer-fill + ] keep buffer-capacity <= ;
@ -143,7 +130,10 @@ M: output-port stream-write
[ buffer>> >buffer ] 2bi [ buffer>> >buffer ] 2bi
] if ; ] 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 -- ) M: output-port stream-flush ( port -- )
check-closed check-closed
@ -154,35 +144,23 @@ GENERIC: close-port ( port -- )
M: output-port close-port M: output-port close-port
[ flush-port ] [ call-next-method ] bi ; [ 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 M: port close-port
dup cancel-io [ cancel-io ] [ handle>> close-handle ] bi ;
dup handle>> close-handle
[ [ buffer-free ] when* f ] change-buffer drop ;
M: port dispose M: port dispose
dup closed>> [ drop ] [ t >>closed close-port ] if ; dup closed>> [ drop ] [ t >>closed close-port ] if ;
TUPLE: server-port < port addr client client-addr encoding ; : <ports> ( read-handle write-handle -- input-port output-port )
[
: <server-port> ( handle addr encoding -- server ) [ <input-port> dup add-error-destructor ]
rot server-port <port> [ <output-port> dup add-error-destructor ] bi*
swap >>encoding ] with-destructors ;
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 ;
: <datagram-port> ( handle addr -- datagram )
swap datagram-port <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= ;

View File

@ -1,4 +1,7 @@
IN: io.server.tests 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 } [ [ ] 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

View File

@ -3,7 +3,7 @@
USING: io io.sockets io.files io.streams.duplex logging USING: io io.sockets io.files io.streams.duplex logging
continuations kernel math math.parser namespaces parser continuations kernel math math.parser namespaces parser
sequences strings prettyprint debugger quotations calendar sequences strings prettyprint debugger quotations calendar
threads concurrency.combinators assocs ; threads concurrency.combinators assocs fry ;
IN: io.server IN: io.server
SYMBOL: servers SYMBOL: servers
@ -12,22 +12,24 @@ SYMBOL: servers
LOG: accepted-connection NOTICE LOG: accepted-connection NOTICE
: with-client ( client addrspec quot -- ) SYMBOL: remote-address
[
swap accepted-connection
with-stream*
] 2curry with-disposal ; inline
\ with-client DEBUG add-error-logging : with-connection ( client remote quot -- )
'[
, [ remote-address set ] [ accepted-connection ] bi
@
] with-stream ; inline
\ with-connection DEBUG add-error-logging
: accept-loop ( server quot -- ) : accept-loop ( server quot -- )
[ [
>r accept r> [ with-client ] 3curry "Client" spawn drop >r accept r> '[ , , , with-connection ] "Client" spawn drop
] 2keep accept-loop ; inline ] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- ) : server-loop ( addrspec encoding quot -- )
>r <server> dup servers get push r> >r <server> dup servers get push r>
[ accept-loop ] curry with-disposal ; inline '[ , accept-loop ] with-disposal ; inline
\ server-loop NOTICE add-error-logging \ server-loop NOTICE add-error-logging
@ -41,9 +43,7 @@ PRIVATE>
: with-server ( seq service encoding quot -- ) : with-server ( seq service encoding quot -- )
V{ } clone servers [ V{ } clone servers [
[ '[ , [ , , server-loop ] with-logging ] parallel-each
[ server-loop ] 2curry with-logging
] 3curry parallel-each
] with-variable ; inline ] with-variable ; inline
: stop-server ( -- ) : stop-server ( -- )
@ -56,7 +56,7 @@ LOG: received-datagram NOTICE
: datagram-loop ( quot datagram -- ) : datagram-loop ( quot datagram -- )
[ [
[ receive dup received-datagram >r swap call r> ] keep [ receive dup received-datagram >r swap call r> ] keep
pick [ send ] [ 3drop ] keep pick [ send ] [ 3drop ] if
] 2keep datagram-loop ; inline ] 2keep datagram-loop ; inline
: spawn-datagrams ( quot addrspec -- ) : spawn-datagrams ( quot addrspec -- )
@ -67,6 +67,4 @@ LOG: received-datagram NOTICE
PRIVATE> PRIVATE>
: with-datagrams ( seq service quot -- ) : with-datagrams ( seq service quot -- )
[ '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
[ swap spawn-datagrams ] curry parallel-each
] curry with-logging ; inline

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax byte-arrays io 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 ; prettyprint sequences ;
IN: io.sockets.headers IN: io.sockets.headers

View File

@ -1 +0,0 @@
Slava Pestov

View File

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

View File

@ -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" <c-object>
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 <uint> r> inet-ntop
swap sockaddr-in-port ntohs (port) <inet4> ;
M: inet6 inet-ntop ( data addrspec -- str )
drop 16 memory>byte-array 2 <groups> [ 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 <array> 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" <c-object>
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) <inet6> ;
: 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" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io io.backend threads USING: help.markup help.syntax io io.backend threads
strings byte-arrays continuations ; strings byte-arrays continuations quotations ;
IN: io.sockets IN: io.sockets
ARTICLE: "network-addressing" "Address specifiers" ARTICLE: "network-addressing" "Address specifiers"
@ -64,7 +64,7 @@ HELP: local
} ; } ;
HELP: inet 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 <inet> } "." } { $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 <inet> } "." }
{ $notes { $notes
"This address specifier is only supported by " { $link <client> } ", 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." "This address specifier is only supported by " { $link <client> } ", 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 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 <inet4> } "." } { $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 <inet4> } "." }
{ $notes { $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." "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 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 <inet6> } "." } { $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 <inet6> } "." }
{ $notes { $notes
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } "New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
{ $examples { $examples
@ -91,13 +91,19 @@ HELP: inet6
} ; } ;
HELP: <client> HELP: <client>
{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } } { $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." } { $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." } { $errors "Throws an error if the connection cannot be established." }
{ $notes "The " { $link with-client } " word is easier to use in most situations." }
{ $examples { $examples
{ $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" } { $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" }
} ; } ;
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: <server> HELP: <server>
{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } } { $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
{ $description { $description
@ -113,6 +119,13 @@ HELP: <server>
"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:" "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" } { $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." "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 <inet4> ascii <server>"
"[ 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." } ; { $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;

View File

@ -1,4 +1,46 @@
IN: io.sockets.tests IN: io.sockets.tests
USING: io.sockets sequences math tools.test ; 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 [ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test

View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.nonblocking io.streams.duplex sequences arrays io.encodings io.ports io.streams.duplex
accessors destructors ; 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 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 [ <c-object> ] [ heap-size <int> ] bi ;
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
TUPLE: local path ; TUPLE: local path ;
: <local> ( path -- addrspec ) : <local> ( path -- addrspec )
@ -14,59 +43,248 @@ TUPLE: inet4 host port ;
C: <inet4> inet4 C: <inet4> 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" <c-object>
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 ;
<PRIVATE
SYMBOL: port-override
: (port) port-override get swap or ;
PRIVATE>
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs (port) <inet4> ;
TUPLE: inet6 host port ; TUPLE: inet6 host port ;
C: <inet6> inet6 C: <inet6> inet6
M: inet6 inet-ntop ( data addrspec -- str )
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
ERROR: invalid-inet6 string reason ;
M: invalid-inet6 summary drop "Invalid IPv6 address" ;
<PRIVATE
: parse-inet6 ( string -- seq )
dup empty? [ drop f ] [
":" split [
hex> [ "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
<byte-array> 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" <c-object>
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) <inet6> ;
: 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 <ports>
2dup [ add-error-destructor ] bi@
dup dup handle>>
] keep wait-to-connect
] with-destructors ;
: <client> ( remote encoding -- stream local )
>r (client) -rot r> <encoder-duplex> swap ;
SYMBOL: local-address
: with-client ( addrspec encoding quot -- )
>r <client> [ 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 )
: <server> ( addrspec encoding -- server )
>r [ (server) ] keep parse-sockaddr
swap server-port <port>
swap >>addr
r> >>encoding ;
GENERIC: (accept) ( server addrspec -- handle remote )
: accept ( server -- client remote )
check-server-port
[ dup addr>> (accept) ] keep
tuck
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
[ addr>> parse-sockaddr ]
2bi* ;
TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram )
: <datagram> ( addr -- datagram )
dup (datagram) datagram-port <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
sift ;
: 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" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
: host-name ( -- string )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
ascii alien>string ;
TUPLE: inet host port ; TUPLE: inet host port ;
C: <inet> inet C: <inet> 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 <ports>
2dup [ add-error-destructor ] bi@
dup dup handle>> wait-to-connect
] with-destructors ;
: <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ;
: with-client ( addrspec encoding quot -- )
>r <client> r> with-stream ; inline
HOOK: (server) io-backend ( addrspec -- handle )
: <server> ( addrspec encoding -- server )
>r [ (server) ] keep r> <server-port> ;
HOOK: (accept) io-backend ( server -- addrspec handle )
: accept ( server -- client addrspec )
[ (accept) dup <ports> ] [ encoding>> ] bi
<encoder-duplex> swap ;
HOOK: <datagram> 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 ) : resolve-client-addr ( inet -- seq )
[ host>> ] [ port>> ] bi f resolve-host ; [ host>> ] [ port>> ] bi f resolve-host ;
M: inet (client) M: inet (client)
resolve-client-addr (client) ; resolve-client-addr (client) ;
ERROR: invalid-inet-server addrspec ;
M: invalid-inet-server summary
drop "Cannot use <server> with <inet>; use <inet4> or <inet6> instead" ;
M: inet (server)
invalid-inet-server ;

View File

@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors
namespaces ; namespaces ;
IN: io.timeouts IN: io.timeouts
! Won't need this with new slot accessors
GENERIC: timeout ( obj -- dt/f ) GENERIC: timeout ( obj -- dt/f )
GENERIC: set-timeout ( dt/f obj -- ) GENERIC: set-timeout ( dt/f obj -- )
@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ;
GENERIC: timed-out ( obj -- ) GENERIC: timed-out ( obj -- )
M: object timed-out drop ;
: queue-timeout ( obj timeout -- alarm ) : queue-timeout ( obj timeout -- alarm )
>r [ timed-out ] curry r> later ; >r [ timed-out ] curry r> later ;

View File

@ -1,69 +1,95 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math 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 vectors io.buffers io.backend io.encodings math.parser
continuations system libc qualified namespaces io.timeouts continuations system libc qualified namespaces io.timeouts
io.encodings.utf8 accessors ; io.encodings.utf8 accessors inspector combinators ;
QUALIFIED: io QUALIFIED: io
IN: io.unix.backend IN: io.unix.backend
! I/O tasks ! I/O tasks
TUPLE: io-task port callbacks ;
GENERIC: handle-fd ( handle -- fd ) GENERIC: handle-fd ( handle -- fd )
M: integer handle-fd ; TUPLE: fd fd closed ;
: io-task-fd port>> handle>> handle-fd ; : <fd> ( n -- fd ) f fd boa ;
: <io-task> ( port continuation/f class -- task ) M: fd dispose
new dup closed>>
swap [ 1vector ] [ V{ } clone ] if* >>callbacks [ drop ] [ t >>closed fd>> close-file ] if ;
swap >>port ; inline
TUPLE: input-task < io-task ; M: fd handle-fd fd>> ;
TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
! I/O multiplexers ! I/O multiplexers
TUPLE: mx fd reads writes ; 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-mx ( class -- obj )
new new
H{ } clone >>reads H{ } clone >>reads
H{ } clone >>writes ; inline H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- ) GENERIC: add-input-callback ( thread fd mx -- )
GENERIC: unregister-io-task ( task 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 -- ) GENERIC: wait-for-events ( ms mx -- )
: fd/container ( task mx -- task fd container ) TUPLE: unix-io-error error port ;
over io-task-container >r dup io-task-fd r> ; inline
: check-io-task ( task mx -- ) : report-error ( error port -- )
fd/container key? nip [ tuck unix-io-error boa >>error drop ;
"Cannot perform multiple reads from the same port" throw
] when ;
M: mx register-io-task ( task mx -- ) : input-available ( fd mx -- )
2dup check-io-task fd/container set-at ; remove-input-callbacks [ resume ] each ;
: add-io-task ( task -- ) : output-available ( fd mx -- )
mx get-global register-io-task ; remove-output-callbacks [ resume ] each ;
: with-port-continuation ( port quot -- port ) TUPLE: io-timeout ;
[ "I/O" suspend drop ] curry with-timeout ; inline
M: mx unregister-io-task ( task mx -- ) M: io-timeout summary drop "I/O operation timed out" ;
fd/container delete-at drop ;
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-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
[
>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 ! Some general stuff
: file-mode OCT: 0666 ; : file-mode OCT: 0666 ;
@ -77,54 +103,19 @@ M: mx unregister-io-task ( task mx -- )
: io-error ( n -- ) 0 < [ (io-error) ] when ; : 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, #! We drop the error code rather than calling io-error,
#! since on OS X 10.3, this operation fails from init-io #! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and #! when running the Factor.app (presumably because fd 0 and
#! 1 are closed). #! 1 are closed).
fd>>
[ F_SETFL O_NONBLOCK fcntl drop ] [ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ; [ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- ) M: fd close-handle ( fd -- ) dispose ;
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 ! Readers
: reader-eof ( reader -- ) : eof ( reader -- )
dup buffer>> buffer-empty? [ t >>eof ] when drop ; dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n ) : (refill) ( port -- n )
@ -132,70 +123,50 @@ M: unix cancel-io ( port -- )
[ buffer>> buffer-end ] [ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ; [ 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 M: fd refill
#! Return f if there is a recoverable error fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
drop {
dup buffer>> buffer-empty? [ { [ dup 0 = ] [ drop eof f ] }
dup (refill) dup 0 >= [ { [ dup 0 > ] [ swap buffer>> n>buffer f ] }
swap buffer>> n>buffer t { [ err_no EINTR = ] [ 2drop +retry+ ] }
] [ { [ err_no EAGAIN = ] [ 2drop +input+ ] }
drop defer-error [ (io-error) ]
] if } cond ;
] [ drop t ] if ;
TUPLE: read-task < input-task ; M: unix (wait-to-read) ( port -- )
dup dup handle>> refill dup
: <read-task> ( port continuation -- task ) read-task <io-task> ; [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
M: read-task do-io-task
port>> dup dup handle>> refill
[ [ reader-eof ] [ drop ] if ] keep ;
M: unix (wait-to-read)
[ <read-task> add-io-task ] with-port-continuation
pending-error ;
! Writers ! Writers
GENERIC: drain ( port handle -- ? ) GENERIC: drain ( port handle -- event/f )
M: integer drain M: fd drain
drop fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
dup {
[ handle>> ] { [ dup 0 >= ] [
[ buffer>> buffer@ ] over buffer>> buffer-consume
[ buffer>> buffer-length ] tri buffer>> buffer-empty? f +output+ ?
write dup 0 >= ] }
[ swap buffer>> buffer-consume f ] { [ err_no EINTR = ] [ 2drop +retry+ ] }
[ drop defer-error ] if ; { [ err_no EAGAIN = ] [ 2drop +output+ ] }
[ (io-error) ]
} cond ;
TUPLE: write-task < output-task ; M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup
: <write-task> ( port continuation -- task ) write-task <io-task> ; [ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
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 <write-task> 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 io-multiplex ( ms/f -- ) M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ; mx get-global wait-for-events ;
M: unix (init-stdio) ( -- ) M: unix (init-stdio) ( -- )
0 <input-port> 0 <fd> <input-port>
1 <output-port> 1 <fd> <output-port>
2 <output-port> ; 2 <fd> <output-port> ;
! mx io-task for embedding an fd-based mx inside another mx ! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ; TUPLE: mx-port < port mx ;
@ -203,16 +174,10 @@ TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port ) : <mx-port> ( mx -- port )
dup fd>> mx-port <port> swap >>mx ; dup fd>> mx-port <port> swap >>mx ;
TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;
M: mx-task do-io-task
port>> mx>> 0 swap wait-for-events f ;
: multiplexer-error ( n -- ) : 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 ) : ?flag ( n mask symbol -- n )
pick rot bitand 0 > [ , ] [ drop ] if ; pick rot bitand 0 > [ , ] [ drop ] if ;

View File

@ -3,16 +3,16 @@
IN: io.unix.bsd IN: io.unix.bsd
USING: namespaces system kernel accessors assocs continuations USING: namespaces system kernel accessors assocs continuations
unix 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 ( -- ) M: bsd init-io ( -- )
<select-mx> mx set-global <select-mx> mx set-global ;
<kqueue-mx> kqueue-mx set-global ! <kqueue-mx> kqueue-mx set-global
kqueue-mx get-global <mx-port> <mx-task> ! kqueue-mx get-global <mx-port> <mx-task>
dup io-task-fd ! dup io-task-fd
[ mx get-global reads>> set-at ] ! [ mx get-global reads>> set-at ]
[ mx get-global writes>> set-at ] 2bi ; ! [ mx get-global writes>> set-at ] 2bi ;
M: bsd (monitor) ( path recursive? mailbox -- ) ! M: bsd (monitor) ( path recursive? mailbox -- )
swap [ "Recursive kqueue monitors not supported" throw ] when ! swap [ "Recursive kqueue monitors not supported" throw ] when
<vnode-monitor> ; ! <vnode-monitor> ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 bit-arrays sequences assocs unix unix.linux.epoll math
namespaces structs ; namespaces structs ;
IN: io.unix.epoll IN: io.unix.epoll

View File

@ -1,44 +1,44 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar math.bitfields byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system io.encodings.binary accessors sequences strings system
io.files.private ; io.files.private destructors ;
IN: io.unix.files IN: io.unix.files
M: unix cwd ( -- path ) M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd MAXPATHLEN [ <byte-array> ] keep getcwd
[ (io-error) ] unless* ; [ (io-error) ] unless* ;
M: unix cd ( path -- ) M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
chdir io-error ;
: read-flags O_RDONLY ; inline : read-flags O_RDONLY ; inline
: open-read ( path -- fd ) : open-read ( path -- fd ) O_RDONLY file-mode open-file ;
O_RDONLY file-mode open dup io-error ;
M: unix (file-reader) ( path -- stream ) M: unix (file-reader) ( path -- stream )
open-read <input-port> ; open-read <fd> <input-port> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd ) : open-write ( path -- fd )
write-flags file-mode open dup io-error ; write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream ) M: unix (file-writer) ( path -- stream )
open-write <output-port> ; open-write <fd> <output-port> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
: open-append ( path -- fd ) : open-append ( path -- fd )
append-flags file-mode open dup io-error [
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] 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 ) M: unix (file-appender) ( path -- stream )
open-append <output-port> ; open-append <fd> <output-port> ;
: touch-mode ( -- n ) : touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
@ -46,14 +46,13 @@ M: unix (file-appender) ( path -- stream )
M: unix touch-file ( path -- ) M: unix touch-file ( path -- )
normalize-path normalize-path
dup exists? [ touch ] [ dup exists? [ touch ] [
touch-mode file-mode open close touch-mode file-mode open-file close-file
] if ; ] if ;
M: unix move-file ( from to -- ) M: unix move-file ( from to -- )
[ normalize-path ] bi@ rename io-error ; [ normalize-path ] bi@ rename io-error ;
M: unix delete-file ( path -- ) M: unix delete-file ( path -- ) normalize-path unlink-file ;
normalize-path unlink io-error ;
M: unix make-directory ( path -- ) M: unix make-directory ( path -- )
normalize-path OCT: 777 mkdir io-error ; normalize-path OCT: 777 mkdir io-error ;
@ -106,6 +105,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ; normalize-path symlink io-error ;
M: unix read-link ( path -- path' ) M: unix read-link ( path -- path' )
normalize-path normalize-path read-symbolic-link ;
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
dup io-error head-slice >string ;

View File

@ -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 ; unix io.files.unique.backend system ;
IN: io.unix.files.unique IN: io.unix.files.unique
@ -6,6 +6,6 @@ IN: io.unix.files.unique
{ O_RDWR O_CREAT O_EXCL } flags ; { O_RDWR O_CREAT O_EXCL } flags ;
M: unix (make-unique-file) ( path -- ) 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" ; M: unix temporary-path ( -- path ) "/tmp" ;

View File

@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces
locals accessors combinators threads vectors hashtables locals accessors combinators threads vectors hashtables
sequences assocs continuations sets sequences assocs continuations sets
unix unix.time unix.kqueue unix.process 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 ; io.monitors ;
IN: io.unix.kqueue IN: io.unix.kqueue

View File

@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ;
] times ] times
"append-test" temp-file utf8 file-contents "append-test" temp-file utf8 file-contents
] unit-test ] unit-test
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test

View File

@ -3,7 +3,7 @@
USING: kernel namespaces math system sequences debugger USING: kernel namespaces math system sequences debugger
continuations arrays assocs combinators alien.c-types strings continuations arrays assocs combinators alien.c-types strings
threads accessors 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.files.private io.unix.files io.unix.backend
io.unix.launcher.parser io.unix.launcher.parser
unix unix.process ; unix unix.process ;
@ -31,7 +31,7 @@ USE: unix
] when* ; ] when* ;
: redirect-fd ( oldfd fd -- ) : redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ; 2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
: reset-fd ( fd -- ) : reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of #! We drop the error code because on *BSD, fcntl of
@ -44,7 +44,7 @@ USE: unix
: redirect-file ( obj mode fd -- ) : redirect-file ( obj mode fd -- )
>r >r normalize-path r> file-mode >r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ; open-file r> redirect-fd ;
: redirect-file-append ( obj mode fd -- ) : redirect-file-append ( obj mode fd -- )
>r drop path>> normalize-path open-append r> redirect-fd ; >r drop path>> normalize-path open-append r> redirect-fd ;
@ -58,7 +58,7 @@ USE: unix
{ [ pick string? ] [ redirect-file ] } { [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] } { [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] } { [ 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 ] [ >r >r underlying-handle r> r> redirect ]
} cond ; } cond ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.backend io.monitors io.monitors.recursive 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 io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types math math.bitfields sets alien alien.strings alien.c-types
@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- )
] if ; ] if ;
: inotify-read-loop ( port -- ) : inotify-read-loop ( port -- )
dup wait-to-read1 dup wait-to-read
0 over buffer>> parse-file-notifications 0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset 0 over buffer>> buffer-reset
inotify-read-loop ; inotify-read-loop ;

View File

@ -1,22 +1,25 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien io io.files kernel math system unix io.unix.backend USING: alien io io.files kernel math math.bitfields system unix
io.mmap ; io.unix.backend io.ports io.mmap destructors locals accessors ;
IN: io.unix.mmap IN: io.unix.mmap
: open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ; : 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 [ 0 mmap ] keep [
over MAP_FAILED = [ close (io-error) ] when ; 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 swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor { PROT_READ PROT_WRITE } flags
r> mmap-open f mapped-file boa ; { MAP_FILE MAP_SHARED } flags
r> mmap-open ;
M: unix close-mapped-file ( mmap -- ) M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep [ [ address>> ] [ length>> ] bi munmap io-error ]
[ mapped-file-length munmap ] keep [ handle>> close-file ]
mapped-file-handle close bi ;
io-error ;

View File

@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: system alien.c-types kernel unix math sequences 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 IN: io.unix.pipes
QUALIFIED: io.pipes QUALIFIED: io.pipes
M: unix io.pipes:(pipe) ( -- pair ) M: unix io.pipes:(pipe) ( -- pair )
2 "int" <c-array> 2 "int" <c-array>
dup pipe io-error dup pipe io-error
2 c-int-array> first2 2 c-int-array> first2 [ <fd> ] bi@
[ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ; [ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 bit-arrays sequences assocs unix math namespaces structs
accessors math.order ; accessors math.order locals ;
IN: io.unix.select IN: io.unix.select
TUPLE: select-mx < mx read-fdset write-fdset ; TUPLE: select-mx < mx read-fdset write-fdset ;
@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
: clear-nth ( n seq -- ? ) : clear-nth ( n seq -- ? )
[ nth ] [ f -rot set-nth ] 2bi ; [ nth ] [ f -rot set-nth ] 2bi ;
: check-fd ( fd task fdset mx -- ) :: check-fd ( fd fdset mx quot -- )
roll munge rot clear-nth fd munge fdset clear-nth [ fd mx quot call ] when ; inline
[ swap perform-io-task ] [ 2drop ] if ;
: check-fdset ( tasks fdset mx -- ) : check-fdset ( fds fdset mx quot -- )
[ check-fd ] 2curry assoc-each ; [ check-fd ] 3curry each ; inline
: init-fdset ( tasks fdset -- ) : init-fdset ( fds fdset -- )
[ >r drop t swap munge r> set-nth ] curry assoc-each ; [ >r t swap munge r> set-nth ] curry each ;
: read-fdset/tasks : read-fdset/tasks
[ reads>> ] [ read-fdset>> ] bi ; [ reads>> keys ] [ read-fdset>> ] bi ;
: write-fdset/tasks : write-fdset/tasks
[ writes>> ] [ write-fdset>> ] bi ; [ writes>> keys ] [ write-fdset>> ] bi ;
: max-fd ( assoc -- n ) : max-fd ( assoc -- n )
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ; 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 ) : init-fdsets ( mx -- nfds read write except )
[ num-fds ] [ num-fds ]
[ read-fdset/tasks tuck init-fdset ] [ read-fdset/tasks [ init-fdset ] keep ]
[ write-fdset/tasks tuck init-fdset ] tri [ write-fdset/tasks [ init-fdset ] keep ] tri
f ; f ;
M: select-mx wait-for-events ( ms mx -- ) M:: select-mx wait-for-events ( ms mx -- )
swap >r dup init-fdsets r> dup [ make-timeval ] when mx
select multiplexer-error [ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ]
dup read-fdset/tasks pick check-fdset [ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
dup write-fdset/tasks rot check-fdset ; [ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
tri ;

View File

@ -4,94 +4,138 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math
math.order combinators init alien alien.c-types alien.strings libc math.order combinators init alien alien.c-types alien.strings libc
continuations destructors continuations destructors
openssl openssl.libcrypto openssl.libssl 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 io.encodings.ascii io.buffers io.sockets io.sockets.secure
unix ; unix system ;
IN: io.unix.sockets.secure IN: io.unix.sockets.secure
! todo: SSL_pending, rehandshake ! todo: SSL_pending, rehandshake
! do we call write twice, wth 0 bytes at the end?
! check-certificate at some point ! check-certificate at some point
! test on windows ! 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? [ ERR_get_error dup zero? [
drop drop
{ {
{ -1 [ err_no strerror ] } { -1 [ (io-error) ] }
{ 0 [ "Premature EOF" ] } { 0 [ "Premature EOF" throw ] }
} case } case
] [ ] [
nip (ssl-error-string) nip (ssl-error)
] if swap report-error ; ] if ;
: check-response ( port r -- port r n ) : check-response ( port r -- port r n )
over handle>> handle>> over SSL_get_error ; inline over handle>> handle>> over SSL_get_error ; inline
! Input ports ! Input ports
: report-ssl-error ( port r -- ) : check-read-response ( port r -- event )
drop ssl-error-string swap report-error ;
: check-read-response ( port r -- ? )
check-response check-response
{ {
{ SSL_ERROR_NONE [ swap buffer>> n>buffer t ] } { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
{ SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] } { SSL_ERROR_ZERO_RETURN [ drop eof f ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] } { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error t ] } { SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] } { SSL_ERROR_SSL [ (ssl-error) ] }
} case ; } case ;
M: ssl-handle refill M: ssl-handle refill
drop handle>> ! ssl
dup buffer>> buffer-empty? [ over buffer>>
dup [ buffer-end ] ! buf
[ handle>> handle>> ] ! ssl [ buffer-capacity ] bi ! len
[ buffer>> buffer-end ] ! buf SSL_read
[ buffer>> buffer-capacity ] tri ! len check-read-response ;
SSL_read
check-read-response
] [ drop t ] if ;
! Output ports ! Output ports
: check-write-response ( port r -- ? ) : check-write-response ( port r -- event )
check-response check-response
{ {
{ SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } { SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SYSCALL [ syscall-error t ] } { SSL_ERROR_SSL [ (ssl-error) ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] }
} case ; } case ;
M: ssl-handle drain M: ssl-handle drain
drop handle>> ! ssl
dup over buffer>>
[ handle>> handle>> ] ! ssl [ buffer@ ] ! buf
[ buffer>> buffer@ ] ! buf [ buffer-length ] bi ! len
[ buffer>> buffer-length ] tri ! len
SSL_write SSL_write
check-write-response ; check-write-response ;
! Client sockets ! Client sockets
M: ssl ((client)) ( addrspec -- handle ) : <ssl-socket> ( fd -- ssl )
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ; [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep <ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
: check-connect-response ( port r -- ? ) M: ssl ((client)) ( addrspec -- handle )
addrspec>> ((client)) <ssl-socket> ;
M: ssl parse-sockaddr addrspec>> parse-sockaddr <ssl> ;
: check-connect-response ( port r -- event )
check-response check-response
{ {
{ SSL_ERROR_NONE [ 2drop t ] } { SSL_ERROR_NONE [ 2drop f ] }
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
{ SSL_ERROR_SYSCALL [ syscall-error t ] } { SSL_ERROR_SYSCALL [ syscall-error ] }
{ SSL_ERROR_SSL [ report-ssl-error t ] } { SSL_ERROR_SSL [ (ssl-error) ] }
} case ; } case ;
: do-ssl-connect ( port ssl-handle -- )
2dup SSL_connect check-connect-response dup
[ >r over r> wait-for-port do-ssl-connect ] [ 3drop ] if ;
M: ssl-handle (wait-to-connect) M: ssl-handle (wait-to-connect)
handle>> ! ssl addrspec>>
SSL_connect [ >r file>> r> (wait-to-connect) ]
check-connect-response ; [ 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
<ssl-socket> 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 ;

View File

@ -1,104 +1,86 @@
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov. ! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings generic kernel math USING: alien alien.c-types alien.strings generic kernel math
namespaces threads sequences byte-arrays io.nonblocking namespaces threads sequences byte-arrays io.ports
io.binary io.unix.backend io.streams.duplex io.sockets.impl io.binary io.unix.backend io.streams.duplex
io.backend io.nonblocking io.files io.files.private io.backend io.ports io.files io.files.private
io.encodings.utf8 math.parser continuations libc combinators 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 => read write close ;
EXCLUDE: io.sockets => accept ; EXCLUDE: io.sockets => accept ;
IN: io.unix.sockets IN: io.unix.sockets
: socket-fd ( domain type -- socket ) : socket-fd ( domain type -- fd )
0 socket 0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
dup io-error
dup close-later
dup init-handle ;
: sockopt ( fd level opt -- ) : set-socket-option ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ; >r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
M: unix addrinfo-error ( n -- ) M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ; dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain ! Client sockets - TCP and Unix domain
: init-client-socket ( fd -- ) : init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ; SOL_SOCKET SO_OOBINLINE set-socket-option ;
TUPLE: connect-task < output-task ; : get-socket-name ( fd addrspec -- sockaddr )
>r handle-fd r> empty-sockaddr/size
[ getsockname io-error ] 2keep drop ;
: <connect-task> ( port continuation -- task ) : get-peer-name ( fd addrspec -- sockaddr )
connect-task <io-task> ; >r handle-fd r> empty-sockaddr/size
[ getpeername io-error ] 2keep drop ;
GENERIC: (wait-to-connect) ( port handle -- ? ) M: fd (wait-to-connect)
>r >r +output+ wait-for-port r> r> get-socket-name ;
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
[ <connect-task> add-io-task ] with-port-continuation
pending-error ;
M: object ((client)) ( addrspec -- fd ) M: object ((client)) ( addrspec -- fd )
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi [ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
[ 2drop ] [ connect ] 3bi >r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
zero? err_no EINPROGRESS = or
[ dup init-client-socket ] [ (io-error) ] if ; [ dup init-client-socket ] [ (io-error) ] if ;
! Server sockets - TCP and Unix domain ! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- ) : init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ; SOL_SOCKET SO_REUSEADDR set-socket-option ;
TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
[ handle>> ] [ addr>> sockaddr-type ] bi
dup <c-object> [ swap heap-size <int> 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 -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
: server-socket-fd ( addrspec type -- fd ) : server-socket-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd >r dup protocol-family r> socket-fd
dup init-server-socket dup init-server-socket
dup rot make-sockaddr/size bind dup handle-fd rot make-sockaddr/size bind io-error ;
zero? [ dup close (io-error) ] unless ;
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 handle-fd 10 listen io-error
dup
] keep
get-socket-name
] with-destructors ; ] with-destructors ;
M: unix (accept) ( server -- addrspec handle ) : do-accept ( server addrspec -- fd remote )
#! Wait for a client connection. [ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
check-server-port [ accept ] 2keep drop ; inline
[ wait-to-accept ]
[ pending-error ] M: object (accept) ( server addrspec -- fd remote )
[ [ client-addr>> ] [ client>> ] bi ] tri ; 2dup do-accept
{
{ [ over 0 >= ] [ { [ drop ] [ drop ] [ <fd> ] [ ] } spread ] }
{ [ err_no EINTR = ] [ 2drop (accept) ] }
{ [ err_no EAGAIN = ] [
2drop
[ drop +input+ wait-for-port ]
[ (accept) ]
2bi
] }
[ (io-error) ]
} cond ;
! Datagram sockets - UDP and Unix domain ! Datagram sockets - UDP and Unix domain
M: unix <datagram> M: unix (datagram)
[ [ SOCK_DGRAM server-socket-fd ] with-destructors ;
[ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
] with-destructors ;
SYMBOL: receive-buffer SYMBOL: receive-buffer
@ -106,76 +88,45 @@ SYMBOL: receive-buffer
packet-size <byte-array> receive-buffer set-global packet-size <byte-array> receive-buffer set-global
: setup-receive ( port -- s buffer len flags from fromlen ) :: do-receive ( port -- packet sockaddr )
dup port-handle port addr>> empty-sockaddr/size [| sockaddr len |
swap datagram-port-addr sockaddr-type port handle>> handle-fd ! s
dup <c-object> swap heap-size <int> receive-buffer get-global ! buf
>r >r receive-buffer get-global packet-size 0 r> r> ; 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 ) M: unix (receive) ( datagram -- packet sockaddr )
over >r recvfrom r> dup do-receive dup [ rot drop ] [
over -1 = [ 2drop [ +input+ wait-for-port ] [ (receive) ] bi
2drop f f
] [
receive-buffer get-global
rot head
] if ; ] if ;
TUPLE: receive-task < input-task ; :: do-send ( packet sockaddr len socket datagram -- )
socket handle-fd 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 ;
: <receive-task> ( stream continuation -- task ) M: unix (send) ( packet addrspec datagram -- )
receive-task <io-task> ; [ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
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 -- )
[ <receive-task> 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 ;
: <send-task> ( packet sockaddr len stream continuation -- task )
send-task <io-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 -- )
[ <send-task> 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 ;
! Unix domain sockets
M: local protocol-family drop PF_UNIX ; M: local protocol-family drop PF_UNIX ;
M: local sockaddr-type drop "sockaddr-un" c-type ; M: local sockaddr-type drop "sockaddr-un" c-type ;

View File

@ -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.backend windows.winsock windows.kernel32 windows
io.streams.duplex io namespaces alien.syntax system combinators io.streams.duplex io namespaces alien.syntax system combinators
io.buffers io.encodings io.encodings.utf8 combinators.lib ; io.buffers io.encodings io.encodings.utf8 combinators.lib ;

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types combinators io io.backend io.buffers 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 prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend system ; windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files IN: windows.ce.files

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types combinators io io.backend io.buffers 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 math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend threads.private windows windows.kernel32 io.windows.ce.backend
byte-arrays system ; byte-arrays system ;
@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle )
M: wince (accept) ( server -- client ) M: wince (accept) ( server -- client )
[ [
dup check-server-port
[ [
dup port-handle win32-file-handle dup port-handle win32-file-handle
swap server-port-addr sockaddr-type heap-size swap server-port-addr sockaddr-type heap-size

View File

@ -3,7 +3,7 @@
USING: alien.c-types io.backend io.files io.windows kernel math USING: alien.c-types io.backend io.files io.windows kernel math
windows windows.kernel32 windows.time calendar combinators windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system 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 IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+ SYMBOLS: +read-only+ +hidden+ +system+

View File

@ -1,5 +1,5 @@
USING: kernel system io.files.unique.backend 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 IN: io.windows.files.unique
M: windows (make-unique-file) ( path -- ) M: windows (make-unique-file) ( path -- )

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io 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 windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators splitting system threads init strings combinators

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types alien.syntax arrays continuations 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 kernel libc math namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system ; windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap IN: io.windows.mmap

View File

@ -1,5 +1,5 @@
USING: alien alien.c-types arrays assocs combinators 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 io.windows libc kernel math namespaces sequences
threads classes.tuple.lib windows windows.errors threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii windows.kernel32 strings splitting io.files qualified ascii

View File

@ -1,5 +1,5 @@
USING: continuations destructors io.buffers io.files io.backend 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 kernel libc math threads windows windows.kernel32 system
alien.c-types alien.arrays alien.strings sequences combinators alien.c-types alien.arrays alien.strings sequences combinators
combinators.lib sequences.lib ascii splitting alien strings combinators.lib sequences.lib ascii splitting alien strings

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations destructors io 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 math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings sequences windows.errors assocs splitting system strings
io.windows.launcher io.windows.nt.pipes io.backend io.files io.windows.launcher io.windows.nt.pipes io.backend io.files

View File

@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system sorting arrays combinators math.bitfields strings system
accessors threads splitting accessors threads splitting
io.backend io.windows io.windows.nt.backend io.windows.nt.files 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 ; windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors IN: io.windows.nt.monitors

View File

@ -3,7 +3,7 @@
USING: alien alien.c-types arrays destructors io io.windows libc USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math.bitfields windows.kernel32 windows namespaces windows.types math.bitfields windows.kernel32 windows namespaces
kernel sequences windows.errors assocs math.parser system random 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 IN: io.windows.nt.pipes
! This code is based on ! This code is based on

View File

@ -1,6 +1,6 @@
USING: alien alien.accessors alien.c-types byte-arrays USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.nonblocking io.timeouts io.sockets continuations destructors io.ports io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows io.sockets io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences io.windows.nt.backend windows.winsock kernel libc math sequences
threads classes.tuple.lib system accessors ; threads classes.tuple.lib system accessors ;
IN: io.windows.nt.sockets IN: io.windows.nt.sockets
@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port
M: winnt (accept) ( server -- addrspec handle ) M: winnt (accept) ( server -- addrspec handle )
[ [
[ [
check-server-port
\ AcceptEx-args new \ AcceptEx-args new
[ init-accept ] keep [ init-accept ] keep
[ ((accept)) ] keep [ ((accept)) ] keep
@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle )
f <win32-socket> f <win32-socket>
] with-destructors ; ] with-destructors ;
M: winnt <datagram> ( addrspec -- datagram ) M: winnt (datagram) ( addrspec -- handle )
[ [
[ SOCK_DGRAM server-fd
SOCK_DGRAM server-fd dup add-completion
dup add-completion f <win32-socket>
f <win32-socket>
] keep <datagram-port>
] with-destructors ; ] with-destructors ;
TUPLE: WSARecvFrom-args port TUPLE: WSARecvFrom-args port

View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary io.buffers io.files io.ports io.sockets io.binary
io.sockets.impl windows.errors strings io.sockets windows.errors strings
kernel math namespaces sequences windows windows.kernel32 kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ; continuations math.bitfields system accessors ;

View File

@ -148,7 +148,7 @@ DEFER: (d)
: nth-basis-elt ( generators n -- elt ) : nth-basis-elt ( generators n -- elt )
over length [ over length [
3dup bit? [ nth ] [ 2drop f ] if 3dup bit? [ nth ] [ 2drop f ] if
] map [ ] filter 2nip ; ] map sift 2nip ;
: basis ( generators -- seq ) : basis ( generators -- seq )
natural-sort dup length 2^ [ nth-basis-elt ] with map ; natural-sort dup length 2^ [ nth-basis-elt ] with map ;

View File

@ -26,14 +26,14 @@ DEFER: funcall
unclip convert-form swap convert-body [ , % funcall ] bake ; unclip convert-form swap convert-body [ , % funcall ] bake ;
<PRIVATE <PRIVATE
: localize-body ( vars body -- newbody ) : localize-body ( assoc body -- assoc newbody )
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ] [ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
[ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if [ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
] with map ; ] map ;
: localize-lambda ( body vars -- newbody newvars ) : localize-lambda ( body vars -- newbody newvars )
dup make-locals dup push-locals [ swap localize-body <s-exp> convert-form ] dipd make-locals dup push-locals swap
pop-locals swap ; [ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
PRIVATE> PRIVATE>

View File

@ -8,6 +8,14 @@ IN: lisp.parser.tests
"1234" "atom" \ lisp-expr rule parse parse-result-ast "1234" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] 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 } [
"123.98" "atom" \ lisp-expr rule parse parse-result-ast "123.98" "atom" \ lisp-expr rule parse parse-result-ast
] unit-test ] unit-test

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
combinators.lib ; combinators.lib math ;
IN: lisp.parser IN: lisp.parser
@ -18,9 +18,11 @@ RPAREN = ")"
dquote = '"' dquote = '"'
squote = "'" squote = "'"
digit = [0-9] digit = [0-9]
integer = (digit)+ => [[ string>number ]] integer = ("-")? (digit)+ => [[ first2 append string>number ]]
float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]] float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]]
rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
number = float number = float
| rational
| integer | integer
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<" id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@" | " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"

View File

@ -37,7 +37,7 @@ SYMBOL: log-files
write bl write ": " write print ; write bl write ": " write print ;
: write-message ( msg word-name level -- ) : write-message ( msg word-name level -- )
rot [ empty? not ] filter { rot harvest {
{ [ dup empty? ] [ 3drop ] } { [ dup empty? ] [ 3drop ] }
{ [ dup length 1 = ] [ first -rot f (write-message) ] } { [ dup length 1 = ] [ first -rot f (write-message) ] }
[ [

View File

@ -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: 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 ) ; FUNCTION: void SSL_free ( ssl-pointer ssl ) ;

View File

@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
continuations destructors debugger inspector continuations destructors debugger inspector
locals unicode.case locals unicode.case
openssl.libcrypto openssl.libssl openssl.libcrypto openssl.libssl
io.nonblocking io.files io.encodings.ascii io.sockets.secure ; io.backend io.ports io.files io.encodings.ascii io.sockets.secure ;
IN: openssl IN: openssl
! This code is based on http://www.rtfm.com/openssl-examples/ ! 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 ) : ssl-error-string ( -- string )
ERR_get_error ERR_clear_error f ERR_error_string ; ERR_get_error ERR_clear_error f ERR_error_string ;
: (ssl-error) ( -- * )
ssl-error-string throw ;
: ssl-error ( obj -- ) : ssl-error ( obj -- )
{ f 0 } member? [ ssl-error-string throw ] when ; { f 0 } member? [ (ssl-error) ] when ;
: init-ssl ( -- ) : init-ssl ( -- )
SSL_library_init ssl-error SSL_library_init ssl-error
@ -117,7 +120,7 @@ M: openssl-context dispose
dup handle>> [ SSL_CTX_free ] when* f >>handle dup handle>> [ SSL_CTX_free ] when* f >>handle
drop ; drop ;
TUPLE: ssl-handle file handle disposed ; TUPLE: ssl-handle file handle connected disposed ;
ERROR: no-ssl-context ; ERROR: no-ssl-context ;
@ -129,20 +132,19 @@ M: no-ssl-context summary
: <ssl-handle> ( fd -- ssl ) : <ssl-handle> ( fd -- ssl )
current-ssl-context handle>> SSL_new dup ssl-error current-ssl-context handle>> SSL_new dup ssl-error
f ssl-handle boa ; f f ssl-handle boa ;
: <ssl-socket> ( fd -- ssl ) M: ssl-handle init-handle file>> init-handle ;
[ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
<ssl-handle>
[ handle>> swap dup SSL_set_bio ] keep ;
M: ssl-handle init-handle drop ; HOOK: ssl-shutdown io-backend ( handle -- )
M: ssl-handle close-handle M: ssl-handle close-handle
dup disposed>> [ drop ] [ dup disposed>> [ drop ] [
[ t >>disposed drop ] t >>disposed
[ ssl-shutdown ]
[ handle>> SSL_free ]
[ file>> close-handle ] [ file>> close-handle ]
[ handle>> SSL_free ] tri tri
] if ; ] if ;
ERROR: certificate-verify-error result ; ERROR: certificate-verify-error result ;

View File

@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser )
: search ( string parser -- seq ) : search ( string parser -- seq )
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [ any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
parse-result-ast [ ] filter parse-result-ast sift
] [ ] [
drop { } drop { }
] if ; ] if ;
: (replace) ( string parser -- seq ) : (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 ( string parser -- result )
[ (replace) [ tree-write ] each ] with-string-writer ; [ (replace) [ tree-write ] each ] with-string-writer ;

View File

@ -23,7 +23,7 @@ IN: qualified
] curry map zip ; ] curry map zip ;
: partial-vocab-ignoring ( words name -- assoc ) : 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: : EXCLUDE:
#! Syntax: EXCLUDE: vocab => words ... ; #! Syntax: EXCLUDE: vocab => words ... ;
@ -32,12 +32,12 @@ IN: qualified
: FROM: : FROM:
#! Syntax: FROM: vocab => words... ; #! Syntax: FROM: vocab => words... ;
scan expect=> scan dup load-vocab drop expect=>
";" parse-tokens swap partial-vocab use get push ; parsing ";" parse-tokens swap partial-vocab use get push ; parsing
: RENAME: : RENAME:
#! Syntax: RENAME: word vocab => newname #! 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=> expect=>
scan associate use get push ; parsing scan associate use get push ; parsing

View File

@ -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 namespaces random io.encodings.binary init
accessors system ; accessors system ;
IN: random.unix IN: random.unix

View File

@ -216,7 +216,7 @@ USE: continuations
>r dup length swap r> >r dup length swap r>
[ = [ ] [ drop f ] if ] curry [ = [ ] [ drop f ] if ] curry
2map 2map
[ ] filter ; sift ;
<PRIVATE <PRIVATE
: (attempt-each-integer) ( i n quot -- result ) : (attempt-each-integer) ( i n quot -- result )

View File

@ -133,7 +133,7 @@ IN: tools.deploy.shaker
[ [
io.backend:io-backend , io.backend:io-backend ,
"default-buffer-size" "io.nonblocking" lookup , "default-buffer-size" "io.ports" lookup ,
] { } make ] { } make
{ "alarms" "io" "tools" } strip-vocab-globals % { "alarms" "io" "tools" } strip-vocab-globals %

View File

@ -106,7 +106,7 @@ C: <vocab-author> vocab-author
: vocab-xref ( vocab quot -- vocabs ) : vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words r> map >r dup vocab-name swap words r> map
[ [ word? ] filter [ word-vocabulary ] map ] map>set [ [ word? ] filter [ word-vocabulary ] map ] map>set
remove [ ] filter [ vocab ] map ; inline remove sift [ vocab ] map ; inline
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;

View File

@ -8,7 +8,7 @@ TUPLE: track sizes ;
: normalized-sizes ( track -- seq ) : normalized-sizes ( track -- seq )
track-sizes track-sizes
[ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ; [ sift sum ] keep [ dup [ over / ] when ] map nip ;
: <track> ( orientation -- track ) : <track> ( orientation -- track )
<pack> V{ } clone <pack> V{ } clone

View File

@ -17,7 +17,7 @@ IN: ui.tools.tests
[ ] [ "w" get com-scroll-down ] unit-test [ ] [ "w" get com-scroll-down ] unit-test
[ t ] [ [ t ] [
"w" get workspace-book gadget-children "w" get workspace-book gadget-children
[ tool-scroller ] map [ ] filter [ scroller? ] all? [ tool-scroller ] map sift [ scroller? ] all?
] unit-test ] unit-test
[ ] [ "w" get hide-popup ] unit-test [ ] [ "w" get hide-popup ] unit-test
[ ] [ <gadget> "w" get show-popup ] unit-test [ ] [ <gadget> "w" get show-popup ] unit-test

View File

@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
[ blank? ] right-trim ; [ blank? ] right-trim ;
: process-other-extend ( lines -- set ) : process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map [ "#" split1 drop ";" split1 drop trim-blank ] map harvest
[ empty? not ] filter
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
concat unique ; concat unique ;

View File

@ -89,7 +89,7 @@ IN: unicode.data
] assoc-map >hashtable ; ] assoc-map >hashtable ;
: multihex ( hexstring -- string ) : multihex ( hexstring -- string )
" " split [ hex> ] map [ ] filter ; " " split [ hex> ] map sift ;
TUPLE: code-point lower title upper ; TUPLE: code-point lower title upper ;

View File

@ -10,7 +10,7 @@ SYMBOL: interned
: parse-script ( stream -- assoc ) : parse-script ( stream -- assoc )
! assoc is code point/range => name ! assoc is code point/range => name
lines [ "#" split1 drop ] map [ empty? not ] filter [ lines [ "#" split1 drop ] map harvest [
";" split1 [ [ blank? ] trim ] bi@ ";" split1 [ [ blank? ] trim ] bi@
] H{ } map>assoc ; ] H{ } map>assoc ;

View File

@ -1,7 +1,6 @@
USING: kernel alien alien.c-types USING: kernel alien alien.c-types
io.sockets io.sockets
io.sockets.impl
unix unix
unix.linux.sockios unix.linux.sockios
unix.linux.if ; unix.linux.if ;

View File

@ -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 ; unix unix.linux.sockios ;
: route ( dst gateway genmask flags -- ) : route ( dst gateway genmask flags -- )

View File

@ -1,12 +1,20 @@
USING: kernel alien.c-types alien.strings sequences math unix USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
vectors kernel namespaces continuations threads assocs vectors vectors kernel namespaces continuations threads assocs vectors
io.unix.backend io.encodings.utf8 ; io.unix.backend io.encodings.utf8 ;
IN: unix.process IN: unix.process
! Low-level Unix process launching utilities. These are used ! Low-level Unix process launching utilities. These are used
! to implement io.launcher on Unix. User code should use ! to implement io.launcher on Unix. User code should use
! io.launcher instead. ! io.launcher instead.
FUNCTION: pid_t fork ( ) ;
: fork-process ( -- pid ) [ fork ] unix-system-call ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: >argv ( seq -- alien ) : >argv ( seq -- alien )
[ utf8 malloc-string ] map f suffix >c-void*-array ; [ utf8 malloc-string ] map f suffix >c-void*-array ;
@ -29,10 +37,65 @@ IN: unix.process
>r [ first ] [ ] bi r> exec-with-env ; >r [ first ] [ ] bi r> exec-with-env ;
: with-fork ( child parent -- ) : with-fork ( child parent -- )
fork dup io-error dup zero? -roll swap curry if ; inline fork-process dup zero? -roll swap curry if ; inline
: wait-for-pid ( pid -- status ) : SIGKILL 9 ; inline
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ; : 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 -- ) : set-priority ( n -- )
0 0 rot setpriority io-error ; 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 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel libc structs sequences USING: alien alien.c-types alien.syntax kernel libc structs sequences
continuations continuations byte-arrays strings
math namespaces system combinators vocabs.loader qualified math namespaces system combinators vocabs.loader qualified
accessors inference macros fry arrays.lib accessors inference macros locals shuffle arrays.lib
unix.types ; unix.types ;
IN: unix IN: unix
@ -50,32 +50,40 @@ LIBRARY: factor
FUNCTION: void clear_err_no ( ) ; FUNCTION: void clear_err_no ( ) ;
FUNCTION: int 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 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 accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( char* path ) ; FUNCTION: int chdir ( char* path ) ;
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ; FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
FUNCTION: int chroot ( char* path ) ; FUNCTION: int chroot ( char* path ) ;
FUNCTION: void close ( int fd ) ;
FUNCTION: int close ( int fd ) ;
: close-file ( fd -- ) [ close ] unix-system-call drop ;
FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int dup2 ( int oldd, int newd ) ; FUNCTION: int dup2 ( int oldd, int newd ) ;
! FUNCTION: int dup ( int oldd ) ; ! FUNCTION: int dup ( int oldd ) ;
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
: _exit ( status -- * ) : _exit ( status -- * )
#! We throw to give this a terminating stack effect. #! We throw to give this a terminating stack effect.
"int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
@ -83,7 +91,6 @@ FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ; FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
FUNCTION: int flock ( int fd, int operation ) ; FUNCTION: int flock ( int fd, int operation ) ;
FUNCTION: pid_t fork ( ) ;
FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ;
FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: char* gai_strerror ( int ecode ) ;
@ -100,6 +107,7 @@ FUNCTION: int getpwnam_r ( char* login, passwd* pwd, char* buffer, size_t bufsiz
FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ; FUNCTION: int getgroups ( int gidsetlen, gid_t* gidset ) ;
FUNCTION: int gethostname ( char* name, int len ) ; FUNCTION: int gethostname ( char* name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_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: uid_t getuid ;
FUNCTION: uint htonl ( uint n ) ; FUNCTION: uint htonl ( uint n ) ;
FUNCTION: ushort htons ( ushort n ) ; FUNCTION: ushort htons ( ushort n ) ;
@ -135,7 +143,17 @@ FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ; FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ; FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ; FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ; FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
: PATH_MAX 1024 ; inline
: read-symbolic-link ( path -- path )
PATH_MAX <byte-array> dup >r
PATH_MAX
[ readlink ] unix-system-call
r> swap head-slice >string ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ; FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ; FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
FUNCTION: int rename ( char* from, char* to ) ; FUNCTION: int rename ( char* from, char* to ) ;
@ -151,69 +169,15 @@ 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 setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
FUNCTION: int setuid ( uid_t uid ) ; FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ; FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
FUNCTION: int symlink ( char* path1, char* path2 ) ; FUNCTION: int symlink ( char* path1, char* path2 ) ;
FUNCTION: int system ( char* command ) ; FUNCTION: int system ( char* command ) ;
FUNCTION: int unlink ( char* path ) ; FUNCTION: int unlink ( char* path ) ;
: unlink-file ( path -- ) [ unlink ] unix-system-call drop ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ;
: SIGKILL 9 ; inline
: SIGTERM 15 ; inline
FUNCTION: int kill ( pid_t pid, int sig ) ;
: PATH_MAX 1024 ; inline
: 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 ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{ {

View File

@ -45,8 +45,7 @@ unless
<com-function-definition> ; <com-function-definition> ;
: parse-com-functions ( -- functions ) : parse-com-functions ( -- functions )
";" parse-tokens { ")" } split ";" parse-tokens { ")" } split harvest
[ empty? not ] filter
[ (parse-com-function) ] map ; [ (parse-com-function) ] map ;
: (iid-word) ( definition -- word ) : (iid-word) ( definition -- word )

View File

@ -8,7 +8,7 @@ IN: wrap
SYMBOL: width SYMBOL: width
: line-chunks ( string -- words-lines ) : line-chunks ( string -- words-lines )
"\n" split [ " \t" split [ empty? not ] filter ] map ; "\n" split [ " \t" split harvest ] map ;
: (split-chunk) ( words -- ) : (split-chunk) ( words -- )
-1 over [ length + 1+ dup width get > ] find drop nip -1 over [ length + 1+ dup width get > ] find drop nip