Merge branch 'master' of git://factorcode.org/git/factor
commit
c012a48920
|
@ -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 ]
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 [
|
||||||
|
|
|
@ -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 ] }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ] } ;
|
||||||
|
|
|
@ -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 ] }
|
||||||
|
|
|
@ -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>
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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." } ;
|
||||||
|
|
|
@ -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= ;
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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 ;
|
|
|
@ -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." } ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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> ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
|
|
@ -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" ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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+
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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>
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
|
||||||
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||||
|
|
|
@ -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) ] }
|
||||||
[
|
[
|
||||||
|
|
|
@ -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 ) ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 %
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 -- )
|
||||||
|
|
|
@ -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 ;
|
|
@ -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 ) ;
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue