Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
c012a48920
core
bootstrap
cpu/x86/64
inference/backend
kernel
parser
prettyprint/sections
sequences
slots/deprecated
vocabs
extra
bootstrap/image/upload
bunny
ftp/client
hardware-info/linux
help
handbook
html/parser/analyzer
io
encodings/8-bit
files/unique
launcher
mmap
timeouts
unix
backend
bsd
epoll
files
kqueue
linux/monitors
mmap
pipes
select
sockets
windows
ce
files
launcher
mmap
nt
backend
files
launcher
monitors
pipes
sockets
koszul
logging/server
openssl
peg/search
qualified
random/unix
sequences/lib
tools
deploy/shaker
vocabs/browser
ui
gadgets/tracks
tools
unicode
unix
windows/com/syntax
wrap
|
|
@ -160,11 +160,6 @@ bootstrapping? on
|
|||
"tuple-layout" "classes.tuple.private" create register-builtin
|
||||
|
||||
! Catch-all class for providing a default method.
|
||||
! "object" "kernel" create
|
||||
! [ f builtins get [ ] filter f union-class define-class ]
|
||||
! [ [ drop t ] "predicate" set-word-prop ]
|
||||
! bi
|
||||
|
||||
"object" "kernel" create
|
||||
[ f f { } intersection-class define-class ]
|
||||
[ [ drop t ] "predicate" set-word-prop ]
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ SYMBOL: bootstrap-time
|
|||
|
||||
: load-components ( -- )
|
||||
"include" "exclude"
|
||||
[ get-global " " split [ empty? not ] filter ] bi@
|
||||
[ get-global " " split harvest ] bi@
|
||||
diff
|
||||
[ "bootstrap." prepend require ] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -184,7 +184,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >>
|
|||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split [ empty? not ] filter ;
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-large-struct ( type -- )
|
||||
heap-size cell align
|
||||
|
|
|
|||
|
|
@ -261,7 +261,7 @@ TUPLE: cannot-unify-specials ;
|
|||
|
||||
: balanced? ( in out -- ? )
|
||||
[ dup [ length - ] [ 2drop f ] if ] 2map
|
||||
[ ] filter all-equal? ;
|
||||
sift all-equal? ;
|
||||
|
||||
TUPLE: unbalanced-branches-error quots in out ;
|
||||
|
||||
|
|
@ -281,7 +281,7 @@ TUPLE: unbalanced-branches-error quots in out ;
|
|||
2dup balanced? [
|
||||
over supremum -rot
|
||||
[ >r dupd r> unify-inputs ] 2map
|
||||
[ ] filter unify-stacks
|
||||
sift unify-stacks
|
||||
rot drop
|
||||
] [
|
||||
unbalanced-branches-error
|
||||
|
|
|
|||
|
|
@ -718,17 +718,21 @@ $nl
|
|||
|
||||
HELP: unless*
|
||||
{ $values { "cond" "a generalized boolean" } { "false" "a quotation " } }
|
||||
{ $description "Variant of " { $link if* } " with no true quotation."
|
||||
$nl
|
||||
{ $description "Variant of " { $link if* } " with no true quotation." }
|
||||
{ $notes
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" } } ;
|
||||
{ $code "X [ Y ] unless*" "X dup [ ] [ drop Y ] if" }
|
||||
"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
|
||||
{ $code "[ L ] unless*" "L or" } } ;
|
||||
|
||||
HELP: ?if
|
||||
{ $values { "default" object } { "cond" "a generalized boolean" } { "true" "a quotation with stack effect " { $snippet "( cond -- )" } } { "false" "a quotation with stack effect " { $snippet "( default -- )" } } }
|
||||
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack."
|
||||
$nl
|
||||
{ $description "If the condition is " { $link f } ", the " { $snippet "false" } " quotation is called with the " { $snippet "default" } " value on the stack. Otherwise, the " { $snippet "true" } " quotation is called with the condition on the stack." }
|
||||
{ $notes
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
|
||||
{ $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" }
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "[ ] [ ] ?if" "swap or" } } ;
|
||||
|
||||
HELP: die
|
||||
{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
|
||||
|
|
|
|||
|
|
@ -207,7 +207,7 @@ SYMBOL: in
|
|||
: add-use ( seq -- ) [ use+ ] each ;
|
||||
|
||||
: set-use ( seq -- )
|
||||
[ vocab-words ] map [ ] filter >vector use set ;
|
||||
[ vocab-words ] V{ } map-as sift use set ;
|
||||
|
||||
: check-vocab-string ( name -- name )
|
||||
dup string?
|
||||
|
|
@ -278,7 +278,7 @@ M: no-word-error summary
|
|||
dup forward-reference? [
|
||||
drop
|
||||
use get
|
||||
[ at ] with map [ ] filter
|
||||
[ at ] with map sift
|
||||
[ forward-reference? not ] find nip
|
||||
] [
|
||||
nip
|
||||
|
|
|
|||
|
|
@ -309,7 +309,7 @@ M: f section-end-group? drop f ;
|
|||
2dup 1+ swap ?nth next set
|
||||
swap nth dup split-before dup , split-after
|
||||
] with each
|
||||
] { } make { t } split [ empty? not ] filter ;
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: break-group? ( seq -- ? )
|
||||
[ first section-fits? ] [ peek section-fits? not ] bi and ;
|
||||
|
|
|
|||
|
|
@ -445,6 +445,12 @@ PRIVATE>
|
|||
: remove ( obj seq -- newseq )
|
||||
[ = not ] with filter ;
|
||||
|
||||
: sift ( seq -- newseq )
|
||||
[ ] filter ;
|
||||
|
||||
: harvest ( seq -- newseq )
|
||||
[ empty? not ] filter ;
|
||||
|
||||
: cache-nth ( i seq quot -- elt )
|
||||
2over ?nth dup [
|
||||
>r 3drop r>
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
|||
{ [ over string? ] [ >r dupd r> short-slot ] }
|
||||
{ [ over array? ] [ long-slot ] }
|
||||
} cond
|
||||
] 2map [ ] filter nip ;
|
||||
] 2map sift nip ;
|
||||
|
||||
: slot-of-reader ( reader specs -- spec/f )
|
||||
[ slot-spec-reader eq? ] with find nip ;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ SYMBOL: load-vocab-hook ! ( name -- )
|
|||
: words-named ( str -- seq )
|
||||
dictionary get values
|
||||
[ vocab-words at ] with map
|
||||
[ ] filter ;
|
||||
sift ;
|
||||
|
||||
: child-vocab? ( prefix name -- ? )
|
||||
2dup = pick empty? or
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: http.client checksums checksums.openssl splitting assocs
|
||||
USING: checksums checksums.openssl splitting assocs
|
||||
kernel io.files bootstrap.image sequences io namespaces
|
||||
io.launcher math io.encodings.ascii ;
|
||||
IN: bootstrap.image.upload
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ M: bunny-gadget graft* ( gadget -- )
|
|||
[ <bunny-fixed-pipeline> ]
|
||||
[ <bunny-cel-shaded> ]
|
||||
[ <bunny-outlined> ] tri 3array
|
||||
[ ] filter >>draw-seq
|
||||
sift >>draw-seq
|
||||
0 >>draw-n
|
||||
drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ float-arrays continuations namespaces sequences.lib accessors ;
|
|||
IN: bunny.model
|
||||
|
||||
: numbers ( str -- seq )
|
||||
" " split [ string>number ] map [ ] filter ;
|
||||
" " split [ string>number ] map sift ;
|
||||
|
||||
: (parse-model) ( vs is -- vs is )
|
||||
readln [
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ TUPLE: remote-file
|
|||
|
||||
: parse-list ( ftp-response -- ftp-response )
|
||||
dup strings>>
|
||||
[ " " split [ empty? not ] filter ] map
|
||||
[ " " split harvest ] map
|
||||
dup length {
|
||||
{ 9 [ parse-list-9 ] }
|
||||
{ 8 [ parse-list-8 ] }
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: hardware-info.linux
|
|||
|
||||
: uname ( -- seq )
|
||||
65536 "char" <c-array> [ (uname) io-error ] keep
|
||||
"\0" split [ empty? not ] filter [ >string ] map
|
||||
"\0" split harvest [ >string ] map
|
||||
6 "" pad-right ;
|
||||
|
||||
: sysname ( -- string ) uname first ;
|
||||
|
|
@ -18,4 +18,4 @@ IN: hardware-info.linux
|
|||
: domainname ( -- string ) uname 5 swap nth ;
|
||||
|
||||
: kernel-version ( -- seq )
|
||||
release ".-" split [ ] filter 5 "" pad-right ;
|
||||
release ".-" split harvest 5 "" pad-right ;
|
||||
|
|
|
|||
|
|
@ -238,7 +238,7 @@ ARTICLE: "error-index" "Error index"
|
|||
{ $index [ all-errors ] } ;
|
||||
|
||||
ARTICLE: "type-index" "Type index"
|
||||
{ $index [ builtins get [ ] filter ] } ;
|
||||
{ $index [ builtins get sift ] } ;
|
||||
|
||||
ARTICLE: "class-index" "Class index"
|
||||
{ $index [ classes ] } ;
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
":vars - list all variables at error time" print ;
|
||||
|
||||
: :help ( -- )
|
||||
error get delegates [ error-help ] map [ ] filter
|
||||
error get delegates [ error-help ] map sift
|
||||
{
|
||||
{ [ dup empty? ] [ (:help-none) ] }
|
||||
{ [ dup length 1 = ] [ first help ] }
|
||||
|
|
|
|||
|
|
@ -77,12 +77,12 @@ IN: html.parser.analyzer
|
|||
: find-by-attribute-key ( key vector -- vector )
|
||||
>r >lower r>
|
||||
[ tag-attributes at ] with filter
|
||||
[ ] filter ;
|
||||
sift ;
|
||||
|
||||
: find-by-attribute-key-value ( value key vector -- vector )
|
||||
>r >lower r>
|
||||
[ tag-attributes at over = ] with filter nip
|
||||
[ ] filter ;
|
||||
sift ;
|
||||
|
||||
: find-first-attribute-key-value ( value key vector -- i/f tag/f )
|
||||
>r >lower r>
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
USING: http.client http.client.private http tools.test
|
||||
tuple-syntax namespaces ;
|
||||
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
|
||||
[ "localhost" f ] [ "localhost" parse-host ] unit-test
|
||||
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
||||
[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
|
||||
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
|
||||
|
||||
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
|
||||
[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
|
||||
|
|
@ -12,10 +10,11 @@ tuple-syntax namespaces ;
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: http
|
||||
method: "GET"
|
||||
host: "www.apple.com"
|
||||
path: "/index.html"
|
||||
port: 80
|
||||
path: "/index.html"
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
header: H{ { "connection" "close" } }
|
||||
|
|
@ -26,3 +25,21 @@ tuple-syntax namespaces ;
|
|||
<get-request>
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: https
|
||||
method: "GET"
|
||||
host: "www.amazon.com"
|
||||
port: 443
|
||||
path: "/index.html"
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
header: H{ { "connection" "close" } }
|
||||
}
|
||||
] [
|
||||
[
|
||||
"https://www.amazon.com/index.html"
|
||||
<get-request>
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -19,22 +19,8 @@ DEFER: http-request
|
|||
|
||||
<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
|
||||
|
||||
: absolute-url? ( url -- ? )
|
||||
[ "http://" head? ] [ "https://" head? ] bi or ;
|
||||
|
||||
: do-redirect ( response data -- response data )
|
||||
over code>> 300 399 between? [
|
||||
drop
|
||||
|
|
@ -42,7 +28,7 @@ SYMBOL: redirects
|
|||
redirects get max-redirects < [
|
||||
request get
|
||||
swap "location" header dup absolute-url?
|
||||
[ request-with-url ] [ store-path ] if
|
||||
[ request-with-url ] [ request-with-path ] if
|
||||
"GET" >>method http-request
|
||||
] [
|
||||
too-many-redirects
|
||||
|
|
|
|||
|
|
@ -45,6 +45,7 @@ blah
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: http
|
||||
port: 80
|
||||
method: "GET"
|
||||
path: "/bar"
|
||||
|
|
@ -84,6 +85,7 @@ Host: www.sex.com
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
protocol: http
|
||||
port: 80
|
||||
method: "HEAD"
|
||||
path: "/bar"
|
||||
|
|
@ -174,6 +176,8 @@ test-db [
|
|||
main-responder set
|
||||
|
||||
[ 1237 httpd ] "HTTPD test" spawn drop
|
||||
|
||||
yield
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ strings vectors hashtables quotations arrays byte-arrays
|
|||
math.parser calendar calendar.format
|
||||
|
||||
io io.streams.string io.encodings.utf8 io.encodings.string
|
||||
io.sockets
|
||||
io.sockets io.sockets.secure
|
||||
|
||||
unicode.case unicode.categories qualified ;
|
||||
|
||||
|
|
@ -15,9 +15,31 @@ EXCLUDE: fry => , ;
|
|||
|
||||
IN: http
|
||||
|
||||
: http-port 80 ; inline
|
||||
SINGLETON: http
|
||||
|
||||
: https-port 443 ; inline
|
||||
SINGLETON: https
|
||||
|
||||
GENERIC: http-port ( protocol -- port )
|
||||
|
||||
M: http http-port drop 80 ;
|
||||
|
||||
M: https http-port drop 443 ;
|
||||
|
||||
GENERIC: protocol>string ( protocol -- string )
|
||||
|
||||
M: http protocol>string drop "http" ;
|
||||
|
||||
M: https protocol>string drop "https" ;
|
||||
|
||||
: string>protocol ( string -- protocol )
|
||||
{
|
||||
{ "http" [ http ] }
|
||||
{ "https" [ https ] }
|
||||
[ "Unknown protocol: " swap append throw ]
|
||||
} case ;
|
||||
|
||||
: absolute-url? ( url -- ? )
|
||||
[ "http://" head? ] [ "https://" head? ] bi or ;
|
||||
|
||||
: url-quotable? ( ch -- ? )
|
||||
#! In a URL, can this character be used without
|
||||
|
|
@ -212,6 +234,7 @@ TUPLE: cookie name value path domain expires max-age http-only ;
|
|||
[ unparse-cookie ] map concat "; " join ;
|
||||
|
||||
TUPLE: request
|
||||
protocol
|
||||
host
|
||||
port
|
||||
method
|
||||
|
|
@ -229,7 +252,7 @@ cookies ;
|
|||
: <request>
|
||||
request new
|
||||
"1.1" >>version
|
||||
http-port >>port
|
||||
http >>protocol
|
||||
H{ } clone >>header
|
||||
H{ } clone >>query
|
||||
V{ } clone >>cookies
|
||||
|
|
@ -242,6 +265,7 @@ cookies ;
|
|||
pick query>> set-at ;
|
||||
|
||||
: chop-hostname ( str -- str' )
|
||||
":" split1 "//" ?head drop nip
|
||||
CHAR: / over index over length or tail
|
||||
dup empty? [ drop "/" ] when ;
|
||||
|
||||
|
|
@ -249,7 +273,9 @@ cookies ;
|
|||
#! Technically, only proxies are meant to support hostnames
|
||||
#! in HTTP requests, but IE sends these sometimes so we
|
||||
#! just chop the hostname part.
|
||||
url-decode "http://" ?head [ chop-hostname ] when ;
|
||||
url-decode
|
||||
dup { "http://" "https://" } [ head? ] with contains?
|
||||
[ chop-hostname ] when ;
|
||||
|
||||
: read-method ( request -- request )
|
||||
" " read-until [ "Bad request: method" throw ] unless
|
||||
|
|
@ -298,10 +324,11 @@ SYMBOL: max-post-request
|
|||
|
||||
: parse-host ( string -- host port )
|
||||
"." ?tail drop ":" split1
|
||||
[ string>number ] [ http-port ] if* ;
|
||||
dup [ string>number ] when ;
|
||||
|
||||
: extract-host ( request -- request )
|
||||
dup "host" header parse-host >r >>host r> >>port ;
|
||||
dup [ "host" header parse-host ] keep protocol>> http-port or
|
||||
[ >>host ] [ >>port ] bi* ;
|
||||
|
||||
: extract-post-data-type ( request -- request )
|
||||
dup "content-type" header >>post-data-type ;
|
||||
|
|
@ -314,7 +341,7 @@ SYMBOL: max-post-request
|
|||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
: parse-content-type-attributes ( string -- attributes )
|
||||
" " split [ empty? not ] filter [ "=" split1 >r >lower r> ] { } map>assoc ;
|
||||
" " split harvest [ "=" split1 >r >lower r> ] { } map>assoc ;
|
||||
|
||||
: parse-content-type ( content-type -- type encoding )
|
||||
";" split1 parse-content-type-attributes "charset" swap at ;
|
||||
|
|
@ -353,12 +380,20 @@ SYMBOL: max-post-request
|
|||
"application/x-www-form-urlencoded" >>post-data-type
|
||||
] if ;
|
||||
|
||||
GENERIC: protocol-addr ( request protocol -- addr )
|
||||
|
||||
M: object protocol-addr
|
||||
drop [ host>> ] [ port>> ] bi <inet> ;
|
||||
|
||||
M: https protocol-addr
|
||||
call-next-method <ssl> ;
|
||||
|
||||
: request-addr ( request -- addr )
|
||||
[ host>> ] [ port>> ] bi <inet> ;
|
||||
dup protocol>> protocol-addr ;
|
||||
|
||||
: request-host ( request -- string )
|
||||
[ host>> ] [ port>> ] bi
|
||||
dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
|
||||
[ host>> ] [ port>> ] bi dup http http-port =
|
||||
[ drop ] [ ":" swap number>string 3append ] if ;
|
||||
|
||||
: write-request-header ( request -- request )
|
||||
dup header>> >hashtable
|
||||
|
|
@ -381,13 +416,32 @@ SYMBOL: max-post-request
|
|||
flush
|
||||
drop ;
|
||||
|
||||
: request-with-path ( request path -- request )
|
||||
[ "/" prepend ] [ "/" ] if*
|
||||
"?" split1 [ >>path ] [ dup [ query>assoc ] when >>query ] bi* ;
|
||||
|
||||
: request-with-url ( request url -- request )
|
||||
":" split1
|
||||
[ string>protocol >>protocol ]
|
||||
[
|
||||
"//" ?head [ "Invalid URL" throw ] unless
|
||||
"/" split1
|
||||
[
|
||||
parse-host [ >>host ] [ >>port ] bi*
|
||||
dup protocol>> http-port '[ , or ] change-port
|
||||
]
|
||||
[ request-with-path ]
|
||||
bi*
|
||||
] bi* ;
|
||||
|
||||
: request-url ( request -- url )
|
||||
[
|
||||
[
|
||||
dup host>> [
|
||||
[ "http://" write host>> url-encode write ]
|
||||
[ ":" write port>> number>string write ]
|
||||
bi
|
||||
[ protocol>> protocol>string write "://" write ]
|
||||
[ host>> url-encode write ":" write ]
|
||||
[ [ port>> ] [ protocol>> http-port or ] bi number>string write ]
|
||||
tri
|
||||
] [ drop ] if
|
||||
]
|
||||
[ path>> "/" head? [ "/" write ] unless ]
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: http.server.tests
|
|||
|
||||
[
|
||||
<request>
|
||||
http >>protocol
|
||||
"www.apple.com" >>host
|
||||
"/xxx/bar" >>path
|
||||
{ { "a" "b" } } >>query
|
||||
|
|
|
|||
|
|
@ -240,7 +240,7 @@ SYMBOL: exit-continuation
|
|||
'[ exit-continuation set @ ] callcc1 exit-continuation off ;
|
||||
|
||||
: split-path ( string -- path )
|
||||
"/" split [ empty? not ] filter ;
|
||||
"/" split harvest ;
|
||||
|
||||
: init-request ( -- )
|
||||
H{ } clone base-paths set
|
||||
|
|
|
|||
|
|
@ -37,8 +37,7 @@ IN: io.encodings.8-bit
|
|||
2dup swap length <= [ tail ] [ drop ] if ;
|
||||
|
||||
: process-contents ( lines -- assoc )
|
||||
[ "#" split1 drop ] map
|
||||
[ empty? not ] filter
|
||||
[ "#" split1 drop ] map harvest
|
||||
[ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
|
||||
|
||||
: byte>ch ( assoc -- array )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io io.nonblocking kernel math
|
||||
USING: help.markup help.syntax io io.ports kernel math
|
||||
io.files.unique.private math.parser io.files ;
|
||||
IN: io.files.unique
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
|
|||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors
|
||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.streams.duplex io.nonblocking ;
|
||||
io.streams.duplex io.ports ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
|
@ -199,7 +199,7 @@ M: object run-pipeline-element
|
|||
[ swap in>> or ] change-stdin
|
||||
run-detached
|
||||
]
|
||||
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
|
||||
[ [ out>> close-handle ] [ in>> close-handle ] bi* ]
|
||||
[ [ in>> <input-port> ] [ out>> <output-port> ] bi* ]
|
||||
} 2cleave r> <encoder-duplex>
|
||||
] with-destructors ;
|
||||
|
|
|
|||
|
|
@ -1,37 +1,38 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations io.backend kernel quotations sequences
|
||||
system alien alien.accessors sequences.private ;
|
||||
system alien alien.accessors accessors sequences.private ;
|
||||
IN: io.mmap
|
||||
|
||||
TUPLE: mapped-file length address handle closed? ;
|
||||
TUPLE: mapped-file address handle length closed ;
|
||||
|
||||
: check-closed ( mapped-file -- mapped-file )
|
||||
dup mapped-file-closed? [
|
||||
dup closed>> [
|
||||
"Mapped file is closed" throw
|
||||
] when ; inline
|
||||
|
||||
M: mapped-file length check-closed mapped-file-length ;
|
||||
M: mapped-file length check-closed length>> ;
|
||||
|
||||
M: mapped-file nth-unsafe
|
||||
check-closed mapped-file-address swap alien-unsigned-1 ;
|
||||
check-closed address>> swap alien-unsigned-1 ;
|
||||
|
||||
M: mapped-file set-nth-unsafe
|
||||
check-closed mapped-file-address swap set-alien-unsigned-1 ;
|
||||
check-closed address>> swap set-alien-unsigned-1 ;
|
||||
|
||||
INSTANCE: mapped-file sequence
|
||||
|
||||
HOOK: (mapped-file) io-backend ( path length -- mmap )
|
||||
HOOK: (mapped-file) io-backend ( path length -- address handle )
|
||||
|
||||
: <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 -- )
|
||||
|
||||
M: mapped-file dispose ( mmap -- )
|
||||
check-closed
|
||||
t over set-mapped-file-closed?
|
||||
close-mapped-file ;
|
||||
dup closed>> [ drop ] [
|
||||
t >>closed close-mapped-file
|
||||
] if ;
|
||||
|
||||
: with-mapped-file ( path length quot -- )
|
||||
>r <mapped-file> r> with-disposal ; inline
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: io io.pipes io.streams.string io.encodings.utf8
|
||||
io.streams.duplex io.encodings namespaces continuations
|
||||
tools.test kernel ;
|
||||
io.streams.duplex io.encodings io.timeouts namespaces
|
||||
continuations tools.test kernel calendar ;
|
||||
IN: io.pipes.tests
|
||||
|
||||
[ "Hello" ] [
|
||||
|
|
@ -24,3 +24,10 @@ IN: io.pipes.tests
|
|||
[ input-stream [ utf8 <decoder> ] change readln ]
|
||||
} run-pipeline
|
||||
] unit-test
|
||||
|
||||
[
|
||||
utf8 <pipe> [
|
||||
5 seconds over set-timeout
|
||||
stream-readln
|
||||
] with-disposal
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings io.backend io.nonblocking io.streams.duplex
|
||||
USING: io.encodings io.backend io.ports io.streams.duplex
|
||||
io splitting sequences sequences.lib namespaces kernel
|
||||
destructors math concurrency.combinators accessors
|
||||
arrays continuations quotations ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
byte-arrays sbufs words continuations byte-vectors classes ;
|
||||
IN: io.nonblocking
|
||||
IN: io.ports
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary."
|
||||
ARTICLE: "io.ports" "Non-blocking I/O implementation"
|
||||
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary."
|
||||
$nl
|
||||
"A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:"
|
||||
{ $subsection port }
|
||||
|
|
@ -23,13 +23,10 @@ $nl
|
|||
"Per-port native I/O protocol:"
|
||||
{ $subsection init-handle }
|
||||
{ $subsection (wait-to-read) }
|
||||
"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words."
|
||||
$nl
|
||||
"Dummy ports which should be used to implement networking:"
|
||||
{ $subsection server-port }
|
||||
{ $subsection datagram-port } ;
|
||||
{ $subsection (wait-to-write) }
|
||||
"Additionally, the I/O backend must provide an implementation of the " { $link dispose } " generic word." ;
|
||||
|
||||
ABOUT: "io.nonblocking"
|
||||
ABOUT: "io.ports"
|
||||
|
||||
HELP: port
|
||||
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output."
|
||||
|
|
@ -81,10 +78,6 @@ HELP: (wait-to-read)
|
|||
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
|
||||
|
||||
HELP: wait-to-read
|
||||
{ $values { "count" "a non-negative integer" } { "port" input-port } }
|
||||
{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
|
||||
|
||||
HELP: wait-to-read1
|
||||
{ $values { "port" input-port } }
|
||||
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
|
||||
|
||||
|
|
@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend
|
|||
continuations debugger classes byte-arrays namespaces splitting
|
||||
dlists assocs io.encodings.binary inspector accessors
|
||||
destructors ;
|
||||
IN: io.nonblocking
|
||||
IN: io.ports
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
TUPLE: port handle buffer error timeout closed eof ;
|
||||
TUPLE: port handle error timeout closed ;
|
||||
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
|
|
@ -37,26 +37,6 @@ M: handle-destructor dispose ( obj -- )
|
|||
new
|
||||
swap dup init-handle >>handle ; inline
|
||||
|
||||
: <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 -- )
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
|
|
@ -68,19 +48,21 @@ M: port-closed-error summary
|
|||
: check-closed ( port -- port )
|
||||
dup closed>> [ port-closed-error ] when ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
TUPLE: buffered-port < port buffer ;
|
||||
|
||||
M: object cancel-io drop ;
|
||||
: <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 -- )
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: wait-to-read1 ( port -- )
|
||||
1 swap wait-to-read ;
|
||||
: wait-to-read ( port -- )
|
||||
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: unless-eof ( port quot -- value )
|
||||
>r dup buffer>> buffer-empty? over eof>> and
|
||||
|
|
@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- )
|
|||
|
||||
M: input-port stream-read1
|
||||
check-closed
|
||||
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
|
||||
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ;
|
||||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ wait-to-read ] keep
|
||||
[ dupd buffer>> buffer-read ] unless-eof nip ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >integer r> read-step ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
pick read-step dup [
|
||||
|
|
@ -117,9 +103,10 @@ M: input-port stream-read
|
|||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
TUPLE: output-port < buffered-port ;
|
||||
|
||||
: <output-port> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
|
@ -143,7 +130,10 @@ M: output-port stream-write
|
|||
[ buffer>> >buffer ] 2bi
|
||||
] if ;
|
||||
|
||||
HOOK: flush-port io-backend ( port -- )
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
: flush-port ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
check-closed
|
||||
|
|
@ -154,35 +144,23 @@ GENERIC: close-port ( port -- )
|
|||
M: output-port close-port
|
||||
[ flush-port ] [ call-next-method ] bi ;
|
||||
|
||||
M: buffered-port close-port
|
||||
[ call-next-method ]
|
||||
[ [ [ buffer-free ] when* f ] change-buffer drop ]
|
||||
bi ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
M: port timed-out cancel-io ;
|
||||
|
||||
M: port close-port
|
||||
dup cancel-io
|
||||
dup handle>> close-handle
|
||||
[ [ buffer-free ] when* f ] change-buffer drop ;
|
||||
[ cancel-io ] [ handle>> close-handle ] bi ;
|
||||
|
||||
M: port dispose
|
||||
dup closed>> [ drop ] [ t >>closed close-port ] if ;
|
||||
|
||||
TUPLE: server-port < port addr client client-addr encoding ;
|
||||
|
||||
: <server-port> ( handle addr encoding -- server )
|
||||
rot server-port <port>
|
||||
swap >>encoding
|
||||
swap >>addr ;
|
||||
|
||||
: check-server-port ( port -- port )
|
||||
dup server-port? [ "Not a server port" throw ] unless ; inline
|
||||
|
||||
TUPLE: datagram-port < port addr packet packet-addr ;
|
||||
|
||||
: <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= ;
|
||||
: <ports> ( read-handle write-handle -- input-port output-port )
|
||||
[
|
||||
[ <input-port> dup add-error-destructor ]
|
||||
[ <output-port> dup add-error-destructor ] bi*
|
||||
] with-destructors ;
|
||||
|
|
@ -1,4 +1,7 @@
|
|||
IN: io.server.tests
|
||||
USING: tools.test io.server io.server.private ;
|
||||
USING: tools.test io.server io.server.private kernel ;
|
||||
|
||||
{ 2 0 } [ [ ] server-loop ] must-infer-as
|
||||
{ 2 0 } [ [ ] with-connection ] must-infer-as
|
||||
{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as
|
||||
{ 2 0 } [ [ ] with-datagrams ] must-infer-as
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: io io.sockets io.files io.streams.duplex logging
|
||||
continuations kernel math math.parser namespaces parser
|
||||
sequences strings prettyprint debugger quotations calendar
|
||||
threads concurrency.combinators assocs ;
|
||||
threads concurrency.combinators assocs fry ;
|
||||
IN: io.server
|
||||
|
||||
SYMBOL: servers
|
||||
|
|
@ -12,22 +12,24 @@ SYMBOL: servers
|
|||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-client ( client addrspec quot -- )
|
||||
[
|
||||
swap accepted-connection
|
||||
with-stream*
|
||||
] 2curry with-disposal ; inline
|
||||
SYMBOL: remote-address
|
||||
|
||||
\ with-client DEBUG add-error-logging
|
||||
: with-connection ( client remote quot -- )
|
||||
'[
|
||||
, [ remote-address set ] [ accepted-connection ] bi
|
||||
@
|
||||
] with-stream ; inline
|
||||
|
||||
\ with-connection DEBUG add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[
|
||||
>r accept r> [ with-client ] 3curry "Client" spawn drop
|
||||
>r accept r> '[ , , , with-connection ] "Client" spawn drop
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( addrspec encoding quot -- )
|
||||
>r <server> dup servers get push r>
|
||||
[ accept-loop ] curry with-disposal ; inline
|
||||
'[ , accept-loop ] with-disposal ; inline
|
||||
|
||||
\ server-loop NOTICE add-error-logging
|
||||
|
||||
|
|
@ -41,9 +43,7 @@ PRIVATE>
|
|||
|
||||
: with-server ( seq service encoding quot -- )
|
||||
V{ } clone servers [
|
||||
[
|
||||
[ server-loop ] 2curry with-logging
|
||||
] 3curry parallel-each
|
||||
'[ , [ , , server-loop ] with-logging ] parallel-each
|
||||
] with-variable ; inline
|
||||
|
||||
: stop-server ( -- )
|
||||
|
|
@ -56,7 +56,7 @@ LOG: received-datagram NOTICE
|
|||
: datagram-loop ( quot datagram -- )
|
||||
[
|
||||
[ receive dup received-datagram >r swap call r> ] keep
|
||||
pick [ send ] [ 3drop ] keep
|
||||
pick [ send ] [ 3drop ] if
|
||||
] 2keep datagram-loop ; inline
|
||||
|
||||
: spawn-datagrams ( quot addrspec -- )
|
||||
|
|
@ -67,6 +67,4 @@ LOG: received-datagram NOTICE
|
|||
PRIVATE>
|
||||
|
||||
: with-datagrams ( seq service quot -- )
|
||||
[
|
||||
[ swap spawn-datagrams ] curry parallel-each
|
||||
] curry with-logging ; inline
|
||||
'[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax byte-arrays io
|
||||
io.sockets.impl kernel structs math math.parser
|
||||
io.sockets kernel structs math math.parser
|
||||
prettyprint sequences ;
|
||||
IN: io.sockets.headers
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
strings byte-arrays continuations ;
|
||||
strings byte-arrays continuations quotations ;
|
||||
IN: io.sockets
|
||||
|
||||
ARTICLE: "network-addressing" "Address specifiers"
|
||||
|
|
@ -64,7 +64,7 @@ HELP: local
|
|||
} ;
|
||||
|
||||
HELP: inet
|
||||
{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link <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
|
||||
"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
|
||||
{ $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
|
||||
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible."
|
||||
}
|
||||
|
|
@ -83,7 +83,7 @@ HELP: inet4
|
|||
} ;
|
||||
|
||||
HELP: inet6
|
||||
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <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
|
||||
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
|
||||
{ $examples
|
||||
|
|
@ -91,13 +91,19 @@ HELP: inet6
|
|||
} ;
|
||||
|
||||
HELP: <client>
|
||||
{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } }
|
||||
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." }
|
||||
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
|
||||
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." }
|
||||
{ $errors "Throws an error if the connection cannot be established." }
|
||||
{ $notes "The " { $link with-client } " word is easier to use in most situations." }
|
||||
{ $examples
|
||||
{ $code "\"www.apple.com\" \"http\" <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>
|
||||
{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
|
||||
{ $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:"
|
||||
{ $code "\"localhost\" 1234 t resolve-host" }
|
||||
"Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this."
|
||||
$nl
|
||||
"To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:"
|
||||
{ $unchecked-example
|
||||
"f 0 <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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,46 @@
|
|||
IN: io.sockets.tests
|
||||
USING: io.sockets sequences math tools.test ;
|
||||
|
||||
[ B{ 1 2 3 4 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ "1.2.3.4" ]
|
||||
[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ "255.255.255.255" ]
|
||||
[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 255 255 255 255 } ]
|
||||
[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ]
|
||||
[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "1:2:3:4:5:6:7:8" ]
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "0:0:0:0:0:0:0:0" ]
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "1::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
|
||||
[ "::1" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
|
||||
[ "1::2" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ]
|
||||
[ "1::2:3" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ]
|
||||
[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "1:2:0:0:0:0:3:4" ]
|
||||
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,39 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman,
|
||||
! Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel io.backend namespaces continuations
|
||||
sequences arrays io.encodings io.nonblocking io.streams.duplex
|
||||
accessors destructors ;
|
||||
sequences arrays io.encodings io.ports io.streams.duplex
|
||||
io.encodings.ascii alien.strings io.binary accessors destructors
|
||||
classes debugger byte-arrays system combinators parser
|
||||
alien.c-types math.parser splitting math assocs inspector ;
|
||||
IN: io.sockets
|
||||
|
||||
<< {
|
||||
{ [ os windows? ] [ "windows.winsock" ] }
|
||||
{ [ os unix? ] [ "unix" ] }
|
||||
} cond use+ >>
|
||||
|
||||
! Addressing
|
||||
GENERIC: protocol-family ( addrspec -- af )
|
||||
|
||||
GENERIC: sockaddr-type ( addrspec -- type )
|
||||
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr )
|
||||
|
||||
GENERIC: address-size ( addrspec -- n )
|
||||
|
||||
GENERIC: inet-ntop ( data addrspec -- str )
|
||||
|
||||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
|
||||
: empty-sockaddr/size ( addrspec -- sockaddr len )
|
||||
sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
TUPLE: local path ;
|
||||
|
||||
: <local> ( path -- addrspec )
|
||||
|
|
@ -14,59 +43,248 @@ TUPLE: inet4 host port ;
|
|||
|
||||
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 ;
|
||||
|
||||
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 ;
|
||||
|
||||
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 )
|
||||
[ host>> ] [ port>> ] bi f resolve-host ;
|
||||
|
||||
M: inet (client)
|
||||
resolve-client-addr (client) ;
|
||||
|
||||
ERROR: invalid-inet-server addrspec ;
|
||||
|
||||
M: invalid-inet-server summary
|
||||
drop "Cannot use <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 ;
|
||||
IN: io.timeouts
|
||||
|
||||
! Won't need this with new slot accessors
|
||||
GENERIC: timeout ( obj -- dt/f )
|
||||
GENERIC: set-timeout ( dt/f obj -- )
|
||||
|
||||
|
|
@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ;
|
|||
|
||||
GENERIC: timed-out ( obj -- )
|
||||
|
||||
M: object timed-out drop ;
|
||||
|
||||
: queue-timeout ( obj timeout -- alarm )
|
||||
>r [ timed-out ] curry r> later ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,69 +1,95 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien generic assocs kernel kernel.private math
|
||||
io.nonblocking sequences strings structs sbufs threads unix
|
||||
io.ports sequences strings structs sbufs threads unix
|
||||
vectors io.buffers io.backend io.encodings math.parser
|
||||
continuations system libc qualified namespaces io.timeouts
|
||||
io.encodings.utf8 accessors ;
|
||||
io.encodings.utf8 accessors inspector combinators ;
|
||||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
! I/O tasks
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
GENERIC: handle-fd ( handle -- fd )
|
||||
|
||||
M: integer handle-fd ;
|
||||
TUPLE: fd fd closed ;
|
||||
|
||||
: io-task-fd port>> handle>> handle-fd ;
|
||||
: <fd> ( n -- fd ) f fd boa ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
new
|
||||
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
|
||||
swap >>port ; inline
|
||||
M: fd dispose
|
||||
dup closed>>
|
||||
[ drop ] [ t >>closed fd>> close-file ] if ;
|
||||
|
||||
TUPLE: input-task < io-task ;
|
||||
|
||||
TUPLE: output-task < io-task ;
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
M: fd handle-fd fd>> ;
|
||||
|
||||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
||||
M: input-task io-task-container drop reads>> ;
|
||||
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: new-mx ( class -- obj )
|
||||
new
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
GENERIC: add-input-callback ( thread fd mx -- )
|
||||
|
||||
: add-callback ( thread fd assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
||||
M: mx add-input-callback reads>> add-callback ;
|
||||
|
||||
GENERIC: add-output-callback ( thread fd mx -- )
|
||||
|
||||
M: mx add-output-callback writes>> add-callback ;
|
||||
|
||||
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
||||
|
||||
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
||||
|
||||
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
||||
|
||||
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
||||
|
||||
GENERIC: wait-for-events ( ms mx -- )
|
||||
|
||||
: fd/container ( task mx -- task fd container )
|
||||
over io-task-container >r dup io-task-fd r> ; inline
|
||||
TUPLE: unix-io-error error port ;
|
||||
|
||||
: check-io-task ( task mx -- )
|
||||
fd/container key? nip [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when ;
|
||||
: report-error ( error port -- )
|
||||
tuck unix-io-error boa >>error drop ;
|
||||
|
||||
M: mx register-io-task ( task mx -- )
|
||||
2dup check-io-task fd/container set-at ;
|
||||
: input-available ( fd mx -- )
|
||||
remove-input-callbacks [ resume ] each ;
|
||||
|
||||
: add-io-task ( task -- )
|
||||
mx get-global register-io-task ;
|
||||
: output-available ( fd mx -- )
|
||||
remove-output-callbacks [ resume ] each ;
|
||||
|
||||
: with-port-continuation ( port quot -- port )
|
||||
[ "I/O" suspend drop ] curry with-timeout ; inline
|
||||
TUPLE: io-timeout ;
|
||||
|
||||
M: mx unregister-io-task ( task mx -- )
|
||||
fd/container delete-at drop ;
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
M: unix cancel-io ( port -- )
|
||||
io-timeout new over report-error
|
||||
handle>> handle-fd mx get-global
|
||||
[ input-available ] [ output-available ] 2bi ;
|
||||
|
||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
|
||||
: wait-for-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
|
||||
: file-mode OCT: 0666 ;
|
||||
|
|
@ -77,54 +103,19 @@ M: mx unregister-io-task ( task mx -- )
|
|||
|
||||
: io-error ( n -- ) 0 < [ (io-error) ] when ;
|
||||
|
||||
M: integer init-handle ( fd -- )
|
||||
M: fd init-handle ( fd -- )
|
||||
#! We drop the error code rather than calling io-error,
|
||||
#! since on OS X 10.3, this operation fails from init-io
|
||||
#! when running the Factor.app (presumably because fd 0 and
|
||||
#! 1 are closed).
|
||||
fd>>
|
||||
[ F_SETFL O_NONBLOCK fcntl drop ]
|
||||
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
|
||||
|
||||
M: integer close-handle ( fd -- )
|
||||
close ;
|
||||
|
||||
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 ;
|
||||
M: fd close-handle ( fd -- ) dispose ;
|
||||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
: eof ( reader -- )
|
||||
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
|
|
@ -132,70 +123,50 @@ M: unix cancel-io ( port -- )
|
|||
[ buffer>> buffer-end ]
|
||||
[ buffer>> buffer-capacity ] tri read ;
|
||||
|
||||
GENERIC: refill ( port handle -- ? )
|
||||
! Returns an event to wait for which will ensure completion of
|
||||
! this request
|
||||
GENERIC: refill ( port handle -- event/f )
|
||||
|
||||
M: integer refill
|
||||
#! Return f if there is a recoverable error
|
||||
drop
|
||||
dup buffer>> buffer-empty? [
|
||||
dup (refill) dup 0 >= [
|
||||
swap buffer>> n>buffer t
|
||||
] [
|
||||
drop defer-error
|
||||
] if
|
||||
] [ drop t ] if ;
|
||||
M: fd refill
|
||||
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
|
||||
{
|
||||
{ [ dup 0 = ] [ drop eof f ] }
|
||||
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: read-task < input-task ;
|
||||
|
||||
: <read-task> ( port continuation -- task ) read-task <io-task> ;
|
||||
|
||||
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 ;
|
||||
M: unix (wait-to-read) ( port -- )
|
||||
dup dup handle>> refill dup
|
||||
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
|
||||
|
||||
! Writers
|
||||
GENERIC: drain ( port handle -- ? )
|
||||
GENERIC: drain ( port handle -- event/f )
|
||||
|
||||
M: integer drain
|
||||
drop
|
||||
dup
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer@ ]
|
||||
[ buffer>> buffer-length ] tri
|
||||
write dup 0 >=
|
||||
[ swap buffer>> buffer-consume f ]
|
||||
[ drop defer-error ] if ;
|
||||
M: fd drain
|
||||
fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
|
||||
{
|
||||
{ [ dup 0 >= ] [
|
||||
over buffer>> buffer-consume
|
||||
buffer>> buffer-empty? f +output+ ?
|
||||
] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: write-task < output-task ;
|
||||
|
||||
: <write-task> ( port continuation -- task ) write-task <io-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over handle>> mx get-global writes>> at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ drop <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 (wait-to-write) ( port -- )
|
||||
dup dup handle>> drain dup
|
||||
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
||||
M: unix (init-stdio) ( -- )
|
||||
0 <input-port>
|
||||
1 <output-port>
|
||||
2 <output-port> ;
|
||||
0 <fd> <input-port>
|
||||
1 <fd> <output-port>
|
||||
2 <fd> <output-port> ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
|
@ -203,16 +174,10 @@ TUPLE: mx-port < port mx ;
|
|||
: <mx-port> ( mx -- port )
|
||||
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 -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
0 < [
|
||||
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
|
||||
] when ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -3,16 +3,16 @@
|
|||
IN: io.unix.bsd
|
||||
USING: namespaces system kernel accessors assocs continuations
|
||||
unix
|
||||
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
|
||||
io.backend io.unix.backend io.unix.select io.monitors ;
|
||||
|
||||
M: bsd init-io ( -- )
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task>
|
||||
dup io-task-fd
|
||||
[ mx get-global reads>> set-at ]
|
||||
[ mx get-global writes>> set-at ] 2bi ;
|
||||
<select-mx> mx set-global ;
|
||||
! <kqueue-mx> kqueue-mx set-global
|
||||
! kqueue-mx get-global <mx-port> <mx-task>
|
||||
! dup io-task-fd
|
||||
! [ mx get-global reads>> set-at ]
|
||||
! [ mx get-global writes>> set-at ] 2bi ;
|
||||
|
||||
M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
<vnode-monitor> ;
|
||||
! M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
! <vnode-monitor> ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
USING: alien.c-types kernel io.ports io.unix.backend
|
||||
bit-arrays sequences assocs unix unix.linux.epoll math
|
||||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
|
|
|||
|
|
@ -1,44 +1,44 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
USING: io.backend io.ports io.unix.backend io.files io
|
||||
unix unix.stat unix.time kernel math continuations
|
||||
math.bitfields byte-arrays alien combinators calendar
|
||||
io.encodings.binary accessors sequences strings system
|
||||
io.files.private ;
|
||||
io.files.private destructors ;
|
||||
|
||||
IN: io.unix.files
|
||||
|
||||
M: unix cwd ( -- path )
|
||||
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
|
||||
MAXPATHLEN [ <byte-array> ] keep getcwd
|
||||
[ (io-error) ] unless* ;
|
||||
|
||||
M: unix cd ( path -- )
|
||||
chdir io-error ;
|
||||
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
|
||||
|
||||
: read-flags O_RDONLY ; inline
|
||||
|
||||
: open-read ( path -- fd )
|
||||
O_RDONLY file-mode open dup io-error ;
|
||||
: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
|
||||
|
||||
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
|
||||
|
||||
: open-write ( path -- fd )
|
||||
write-flags file-mode open dup io-error ;
|
||||
write-flags file-mode open-file ;
|
||||
|
||||
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
|
||||
|
||||
: 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 )
|
||||
open-append <output-port> ;
|
||||
open-append <fd> <output-port> ;
|
||||
|
||||
: touch-mode ( -- n )
|
||||
{ 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 -- )
|
||||
normalize-path
|
||||
dup exists? [ touch ] [
|
||||
touch-mode file-mode open close
|
||||
touch-mode file-mode open-file close-file
|
||||
] if ;
|
||||
|
||||
M: unix move-file ( from to -- )
|
||||
[ normalize-path ] bi@ rename io-error ;
|
||||
|
||||
M: unix delete-file ( path -- )
|
||||
normalize-path unlink io-error ;
|
||||
M: unix delete-file ( path -- ) normalize-path unlink-file ;
|
||||
|
||||
M: unix make-directory ( path -- )
|
||||
normalize-path OCT: 777 mkdir io-error ;
|
||||
|
|
@ -106,6 +105,4 @@ M: unix make-link ( path1 path2 -- )
|
|||
normalize-path symlink io-error ;
|
||||
|
||||
M: unix read-link ( path -- path' )
|
||||
normalize-path
|
||||
PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
|
||||
dup io-error head-slice >string ;
|
||||
normalize-path read-symbolic-link ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel io.nonblocking io.unix.backend math.bitfields
|
||||
USING: kernel io.ports io.unix.backend math.bitfields
|
||||
unix io.files.unique.backend system ;
|
||||
IN: io.unix.files.unique
|
||||
|
||||
|
|
@ -6,6 +6,6 @@ IN: io.unix.files.unique
|
|||
{ O_RDWR O_CREAT O_EXCL } flags ;
|
||||
|
||||
M: unix (make-unique-file) ( path -- )
|
||||
open-unique-flags file-mode open dup io-error close ;
|
||||
open-unique-flags file-mode open-file close-file ;
|
||||
|
||||
M: unix temporary-path ( -- path ) "/tmp" ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces
|
|||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations sets
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
||||
io.ports io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
|
|
|
|||
|
|
@ -110,3 +110,5 @@ accessors kernel sequences io.encodings.utf8 ;
|
|||
] times
|
||||
"append-test" temp-file utf8 file-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [ "ls" utf8 <process-stream> contents drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: kernel namespaces math system sequences debugger
|
||||
continuations arrays assocs combinators alien.c-types strings
|
||||
threads accessors
|
||||
io io.backend io.launcher io.nonblocking io.files
|
||||
io io.backend io.launcher io.ports io.files
|
||||
io.files.private io.unix.files io.unix.backend
|
||||
io.unix.launcher.parser
|
||||
unix unix.process ;
|
||||
|
|
@ -31,7 +31,7 @@ USE: unix
|
|||
] when* ;
|
||||
|
||||
: redirect-fd ( oldfd fd -- )
|
||||
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
|
||||
2dup = [ 2drop ] [ dupd dup2 io-error close-file ] if ;
|
||||
|
||||
: reset-fd ( fd -- )
|
||||
#! We drop the error code because on *BSD, fcntl of
|
||||
|
|
@ -44,7 +44,7 @@ USE: unix
|
|||
|
||||
: redirect-file ( obj mode fd -- )
|
||||
>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 -- )
|
||||
>r drop path>> normalize-path open-append r> redirect-fd ;
|
||||
|
|
@ -58,7 +58,7 @@ USE: unix
|
|||
{ [ pick string? ] [ redirect-file ] }
|
||||
{ [ pick appender? ] [ redirect-file-append ] }
|
||||
{ [ pick +closed+ eq? ] [ redirect-closed ] }
|
||||
{ [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] }
|
||||
{ [ pick fd? ] [ >r drop fd>> dup reset-fd r> redirect-fd ] }
|
||||
[ >r >r underlying-handle r> r> redirect ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||
io.files io.buffers io.monitors io.ports io.timeouts
|
||||
io.unix.backend io.unix.select io.encodings.utf8
|
||||
unix.linux.inotify assocs namespaces threads continuations init
|
||||
math math.bitfields sets alien alien.strings alien.c-types
|
||||
|
|
@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- )
|
|||
] if ;
|
||||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
dup wait-to-read
|
||||
0 over buffer>> parse-file-notifications
|
||||
0 over buffer>> buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
|
|
|||
|
|
@ -1,22 +1,25 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien io io.files kernel math system unix io.unix.backend
|
||||
io.mmap ;
|
||||
USING: alien io io.files kernel math math.bitfields system unix
|
||||
io.unix.backend io.ports io.mmap destructors locals accessors ;
|
||||
IN: io.unix.mmap
|
||||
|
||||
: open-r/w ( path -- fd ) O_RDWR file-mode open dup io-error ;
|
||||
: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
|
||||
|
||||
: mmap-open ( length prot flags path -- alien fd )
|
||||
>r f -roll r> open-r/w [ 0 mmap ] keep
|
||||
over MAP_FAILED = [ close (io-error) ] when ;
|
||||
:: mmap-open ( length prot flags path -- alien fd )
|
||||
[
|
||||
f length prot flags
|
||||
path open-r/w dup close-later
|
||||
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
|
||||
] with-destructors ;
|
||||
|
||||
M: unix (mapped-file) ( path length -- obj )
|
||||
M: unix (mapped-file)
|
||||
swap >r
|
||||
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
|
||||
r> mmap-open f mapped-file boa ;
|
||||
{ PROT_READ PROT_WRITE } flags
|
||||
{ MAP_FILE MAP_SHARED } flags
|
||||
r> mmap-open ;
|
||||
|
||||
M: unix close-mapped-file ( mmap -- )
|
||||
[ mapped-file-address ] keep
|
||||
[ mapped-file-length munmap ] keep
|
||||
mapped-file-handle close
|
||||
io-error ;
|
||||
[ [ address>> ] [ length>> ] bi munmap io-error ]
|
||||
[ handle>> close-file ]
|
||||
bi ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system alien.c-types kernel unix math sequences
|
||||
qualified io.unix.backend io.nonblocking ;
|
||||
qualified io.unix.backend io.ports ;
|
||||
IN: io.unix.pipes
|
||||
QUALIFIED: io.pipes
|
||||
|
||||
M: unix io.pipes:(pipe) ( -- pair )
|
||||
2 "int" <c-array>
|
||||
dup pipe io-error
|
||||
2 c-int-array> first2
|
||||
2 c-int-array> first2 [ <fd> ] bi@
|
||||
[ [ init-handle ] bi@ ] [ io.pipes:pipe boa ] 2bi ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
USING: alien.c-types kernel io.ports io.unix.backend
|
||||
bit-arrays sequences assocs unix math namespaces structs
|
||||
accessors math.order ;
|
||||
accessors math.order locals ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||
|
|
@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
: clear-nth ( n seq -- ? )
|
||||
[ nth ] [ f -rot set-nth ] 2bi ;
|
||||
|
||||
: check-fd ( fd task fdset mx -- )
|
||||
roll munge rot clear-nth
|
||||
[ swap perform-io-task ] [ 2drop ] if ;
|
||||
:: check-fd ( fd fdset mx quot -- )
|
||||
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
|
||||
|
||||
: check-fdset ( tasks fdset mx -- )
|
||||
[ check-fd ] 2curry assoc-each ;
|
||||
: check-fdset ( fds fdset mx quot -- )
|
||||
[ check-fd ] 3curry each ; inline
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
: init-fdset ( fds fdset -- )
|
||||
[ >r t swap munge r> set-nth ] curry each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
[ reads>> ] [ read-fdset>> ] bi ;
|
||||
[ reads>> keys ] [ read-fdset>> ] bi ;
|
||||
|
||||
: write-fdset/tasks
|
||||
[ writes>> ] [ write-fdset>> ] bi ;
|
||||
[ writes>> keys ] [ write-fdset>> ] bi ;
|
||||
|
||||
: max-fd ( assoc -- n )
|
||||
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||
|
|
@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks tuck init-fdset ]
|
||||
[ write-fdset/tasks tuck init-fdset ] tri
|
||||
[ read-fdset/tasks [ init-fdset ] keep ]
|
||||
[ write-fdset/tasks [ init-fdset ] keep ] tri
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r dup init-fdsets r> dup [ make-timeval ] when
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick check-fdset
|
||||
dup write-fdset/tasks rot check-fdset ;
|
||||
M:: select-mx wait-for-events ( ms mx -- )
|
||||
mx
|
||||
[ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ]
|
||||
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -4,94 +4,138 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math
|
|||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
openssl openssl.libcrypto openssl.libssl
|
||||
io.files io.nonblocking io.unix.backend io.unix.sockets
|
||||
io.files io.ports io.unix.backend io.unix.sockets
|
||||
io.encodings.ascii io.buffers io.sockets io.sockets.secure
|
||||
unix ;
|
||||
unix system ;
|
||||
IN: io.unix.sockets.secure
|
||||
|
||||
! todo: SSL_pending, rehandshake
|
||||
! do we call write twice, wth 0 bytes at the end?
|
||||
! check-certificate at some point
|
||||
! test on windows
|
||||
|
||||
M: ssl-handle handle-fd file>> ;
|
||||
M: ssl-handle handle-fd file>> handle-fd ;
|
||||
|
||||
: syscall-error ( port r -- )
|
||||
: syscall-error ( r -- * )
|
||||
ERR_get_error dup zero? [
|
||||
drop
|
||||
{
|
||||
{ -1 [ err_no strerror ] }
|
||||
{ 0 [ "Premature EOF" ] }
|
||||
{ -1 [ (io-error) ] }
|
||||
{ 0 [ "Premature EOF" throw ] }
|
||||
} case
|
||||
] [
|
||||
nip (ssl-error-string)
|
||||
] if swap report-error ;
|
||||
nip (ssl-error)
|
||||
] if ;
|
||||
|
||||
: check-response ( port r -- port r n )
|
||||
over handle>> handle>> over SSL_get_error ; inline
|
||||
|
||||
! Input ports
|
||||
: report-ssl-error ( port r -- )
|
||||
drop ssl-error-string swap report-error ;
|
||||
|
||||
: check-read-response ( port r -- ? )
|
||||
: check-read-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ swap buffer>> n>buffer t ] }
|
||||
{ SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
|
||||
{ SSL_ERROR_ZERO_RETURN [ drop eof f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: ssl-handle refill
|
||||
drop
|
||||
dup buffer>> buffer-empty? [
|
||||
dup
|
||||
[ handle>> handle>> ] ! ssl
|
||||
[ buffer>> buffer-end ] ! buf
|
||||
[ buffer>> buffer-capacity ] tri ! len
|
||||
SSL_read
|
||||
check-read-response
|
||||
] [ drop t ] if ;
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer-end ] ! buf
|
||||
[ buffer-capacity ] bi ! len
|
||||
SSL_read
|
||||
check-read-response ;
|
||||
|
||||
! Output ports
|
||||
: check-write-response ( port r -- ? )
|
||||
: check-write-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
|
||||
! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: ssl-handle drain
|
||||
drop
|
||||
dup
|
||||
[ handle>> handle>> ] ! ssl
|
||||
[ buffer>> buffer@ ] ! buf
|
||||
[ buffer>> buffer-length ] tri ! len
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer@ ] ! buf
|
||||
[ buffer-length ] bi ! len
|
||||
SSL_write
|
||||
check-write-response ;
|
||||
|
||||
! Client sockets
|
||||
M: ssl ((client)) ( addrspec -- handle )
|
||||
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
|
||||
: <ssl-socket> ( fd -- ssl )
|
||||
[ 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
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
: 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)
|
||||
handle>> ! ssl
|
||||
SSL_connect
|
||||
check-connect-response ;
|
||||
addrspec>>
|
||||
[ >r file>> r> (wait-to-connect) ]
|
||||
[ 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.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings generic kernel math
|
||||
namespaces threads sequences byte-arrays io.nonblocking
|
||||
io.binary io.unix.backend io.streams.duplex io.sockets.impl
|
||||
io.backend io.nonblocking io.files io.files.private
|
||||
namespaces threads sequences byte-arrays io.ports
|
||||
io.binary io.unix.backend io.streams.duplex
|
||||
io.backend io.ports io.files io.files.private
|
||||
io.encodings.utf8 math.parser continuations libc combinators
|
||||
system accessors qualified destructors unix ;
|
||||
system accessors qualified destructors unix locals ;
|
||||
|
||||
EXCLUDE: io => read write close ;
|
||||
EXCLUDE: io.sockets => accept ;
|
||||
|
||||
IN: io.unix.sockets
|
||||
|
||||
: socket-fd ( domain type -- socket )
|
||||
0 socket
|
||||
dup io-error
|
||||
dup close-later
|
||||
dup init-handle ;
|
||||
: socket-fd ( domain type -- fd )
|
||||
0 socket dup io-error <fd> [ close-later ] [ init-handle ] [ ] tri ;
|
||||
|
||||
: sockopt ( fd level opt -- )
|
||||
1 <int> "int" heap-size setsockopt io-error ;
|
||||
: set-socket-option ( fd level opt -- )
|
||||
>r >r handle-fd r> r> 1 <int> "int" heap-size setsockopt io-error ;
|
||||
|
||||
M: unix addrinfo-error ( n -- )
|
||||
dup zero? [ drop ] [ gai_strerror throw ] if ;
|
||||
|
||||
! Client sockets - TCP and Unix domain
|
||||
: init-client-socket ( fd -- )
|
||||
SOL_SOCKET SO_OOBINLINE sockopt ;
|
||||
SOL_SOCKET SO_OOBINLINE set-socket-option ;
|
||||
|
||||
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 )
|
||||
connect-task <io-task> ;
|
||||
: get-peer-name ( fd addrspec -- sockaddr )
|
||||
>r handle-fd r> empty-sockaddr/size
|
||||
[ getpeername io-error ] 2keep drop ;
|
||||
|
||||
GENERIC: (wait-to-connect) ( port handle -- ? )
|
||||
|
||||
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: fd (wait-to-connect)
|
||||
>r >r +output+ wait-for-port r> r> get-socket-name ;
|
||||
|
||||
M: object ((client)) ( addrspec -- fd )
|
||||
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
|
||||
[ 2drop ] [ connect ] 3bi
|
||||
zero? err_no EINPROGRESS = or
|
||||
>r >r dup handle-fd r> r> connect zero? err_no EINPROGRESS = or
|
||||
[ dup init-client-socket ] [ (io-error) ] if ;
|
||||
|
||||
! Server sockets - TCP and Unix domain
|
||||
: init-server-socket ( fd -- )
|
||||
SOL_SOCKET SO_REUSEADDR sockopt ;
|
||||
|
||||
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 ;
|
||||
SOL_SOCKET SO_REUSEADDR set-socket-option ;
|
||||
|
||||
: server-socket-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> socket-fd
|
||||
dup init-server-socket
|
||||
dup rot make-sockaddr/size bind
|
||||
zero? [ dup close (io-error) ] unless ;
|
||||
dup handle-fd rot make-sockaddr/size bind io-error ;
|
||||
|
||||
M: unix (server) ( addrspec -- handle )
|
||||
M: object (server) ( addrspec -- handle sockaddr )
|
||||
[
|
||||
SOCK_STREAM server-socket-fd
|
||||
dup 10 listen io-error
|
||||
[
|
||||
SOCK_STREAM server-socket-fd
|
||||
dup handle-fd 10 listen io-error
|
||||
dup
|
||||
] keep
|
||||
get-socket-name
|
||||
] with-destructors ;
|
||||
|
||||
M: unix (accept) ( server -- addrspec handle )
|
||||
#! Wait for a client connection.
|
||||
check-server-port
|
||||
[ wait-to-accept ]
|
||||
[ pending-error ]
|
||||
[ [ client-addr>> ] [ client>> ] bi ] tri ;
|
||||
: do-accept ( server addrspec -- fd remote )
|
||||
[ handle>> handle-fd ] [ empty-sockaddr/size ] bi*
|
||||
[ accept ] 2keep drop ; inline
|
||||
|
||||
M: object (accept) ( server addrspec -- fd remote )
|
||||
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
|
||||
M: unix <datagram>
|
||||
[
|
||||
[ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
|
||||
] with-destructors ;
|
||||
M: unix (datagram)
|
||||
[ SOCK_DGRAM server-socket-fd ] with-destructors ;
|
||||
|
||||
SYMBOL: receive-buffer
|
||||
|
||||
|
|
@ -106,76 +88,45 @@ SYMBOL: receive-buffer
|
|||
|
||||
packet-size <byte-array> receive-buffer set-global
|
||||
|
||||
: setup-receive ( port -- s buffer len flags from fromlen )
|
||||
dup port-handle
|
||||
swap datagram-port-addr sockaddr-type
|
||||
dup <c-object> swap heap-size <int>
|
||||
>r >r receive-buffer get-global packet-size 0 r> r> ;
|
||||
:: do-receive ( port -- packet sockaddr )
|
||||
port addr>> empty-sockaddr/size [| sockaddr len |
|
||||
port handle>> handle-fd ! s
|
||||
receive-buffer get-global ! buf
|
||||
packet-size ! nbytes
|
||||
0 ! flags
|
||||
sockaddr ! from
|
||||
len ! fromlen
|
||||
recvfrom dup 0 >= [
|
||||
receive-buffer get-global swap head sockaddr
|
||||
] [
|
||||
drop f f
|
||||
] if
|
||||
] call ;
|
||||
|
||||
: do-receive ( s buffer len flags from fromlen -- sockaddr data )
|
||||
over >r recvfrom r>
|
||||
over -1 = [
|
||||
2drop f f
|
||||
] [
|
||||
receive-buffer get-global
|
||||
rot head
|
||||
M: unix (receive) ( datagram -- packet sockaddr )
|
||||
dup do-receive dup [ rot drop ] [
|
||||
2drop [ +input+ wait-for-port ] [ (receive) ] bi
|
||||
] if ;
|
||||
|
||||
TUPLE: receive-task < input-task ;
|
||||
:: do-send ( packet sockaddr len socket datagram -- )
|
||||
socket 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 )
|
||||
receive-task <io-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
dup setup-receive do-receive dup [
|
||||
pick set-datagram-port-packet
|
||||
over datagram-port-addr parse-sockaddr
|
||||
swap set-datagram-port-packet-addr
|
||||
t
|
||||
] [
|
||||
2drop defer-error
|
||||
] if ;
|
||||
|
||||
: wait-receive ( stream -- )
|
||||
[ <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 ;
|
||||
M: unix (send) ( packet addrspec datagram -- )
|
||||
[ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
|
||||
|
||||
! Unix domain sockets
|
||||
M: local protocol-family drop PF_UNIX ;
|
||||
|
||||
M: local sockaddr-type drop "sockaddr-un" c-type ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: io.nonblocking io.windows threads.private kernel
|
||||
USING: io.ports io.windows threads.private kernel
|
||||
io.backend windows.winsock windows.kernel32 windows
|
||||
io.streams.duplex io namespaces alien.syntax system combinators
|
||||
io.buffers io.encodings io.encodings.utf8 combinators.lib ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.files io.nonblocking io.windows kernel libc math namespaces
|
||||
io.files io.ports io.windows kernel libc math namespaces
|
||||
prettyprint sequences strings threads threads.private
|
||||
windows windows.kernel32 io.windows.ce.backend system ;
|
||||
IN: windows.ce.files
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
|
||||
io.ports io.sockets io.windows kernel libc
|
||||
math namespaces prettyprint qualified sequences strings threads
|
||||
threads.private windows windows.kernel32 io.windows.ce.backend
|
||||
byte-arrays system ;
|
||||
|
|
@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle )
|
|||
|
||||
M: wince (accept) ( server -- client )
|
||||
[
|
||||
dup check-server-port
|
||||
[
|
||||
dup port-handle win32-file-handle
|
||||
swap server-port-addr sockaddr-type heap-size
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types io.backend io.files io.windows kernel math
|
||||
windows windows.kernel32 windows.time calendar combinators
|
||||
math.functions sequences namespaces words symbols system
|
||||
combinators.lib io.nonblocking destructors math.bitfields.lib ;
|
||||
combinators.lib io.ports destructors math.bitfields.lib ;
|
||||
IN: io.windows.files
|
||||
|
||||
SYMBOLS: +read-only+ +hidden+ +system+
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel system io.files.unique.backend
|
||||
windows.kernel32 io.windows io.nonblocking windows ;
|
||||
windows.kernel32 io.windows io.ports windows ;
|
||||
IN: io.windows.files.unique
|
||||
|
||||
M: windows (make-unique-file) ( path -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations io
|
||||
io.windows io.windows.nt.pipes libc io.nonblocking
|
||||
io.windows io.windows.nt.pipes libc io.ports
|
||||
windows.types math windows.kernel32
|
||||
namespaces io.launcher kernel sequences windows.errors
|
||||
splitting system threads init strings combinators
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types alien.syntax arrays continuations
|
||||
destructors generic io.mmap io.nonblocking io.windows
|
||||
destructors generic io.mmap io.ports io.windows
|
||||
kernel libc math namespaces quotations sequences windows
|
||||
windows.advapi32 windows.kernel32 io.backend system ;
|
||||
IN: io.windows.mmap
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.nonblocking
|
||||
continuations destructors io io.backend io.ports
|
||||
io.windows libc kernel math namespaces sequences
|
||||
threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files qualified ascii
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: continuations destructors io.buffers io.files io.backend
|
||||
io.timeouts io.nonblocking io.windows io.windows.nt.backend
|
||||
io.timeouts io.ports io.windows io.windows.nt.backend
|
||||
kernel libc math threads windows windows.kernel32 system
|
||||
alien.c-types alien.arrays alien.strings sequences combinators
|
||||
combinators.lib sequences.lib ascii splitting alien strings
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows libc io.nonblocking io.pipes windows.types
|
||||
io.windows libc io.ports io.pipes windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend io.files
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables
|
|||
sorting arrays combinators math.bitfields strings system
|
||||
accessors threads splitting
|
||||
io.backend io.windows io.windows.nt.backend io.windows.nt.files
|
||||
io.monitors io.nonblocking io.buffers io.files io.timeouts io
|
||||
io.monitors io.ports io.buffers io.files io.timeouts io
|
||||
windows windows.kernel32 windows.types ;
|
||||
IN: io.windows.nt.monitors
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien alien.c-types arrays destructors io io.windows libc
|
||||
windows.types math.bitfields windows.kernel32 windows namespaces
|
||||
kernel sequences windows.errors assocs math.parser system random
|
||||
combinators accessors io.pipes io.nonblocking ;
|
||||
combinators accessors io.pipes io.ports ;
|
||||
IN: io.windows.nt.pipes
|
||||
|
||||
! This code is based on
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.accessors alien.c-types byte-arrays
|
||||
continuations destructors io.nonblocking io.timeouts io.sockets
|
||||
io.sockets.impl io namespaces io.streams.duplex io.windows
|
||||
continuations destructors io.ports io.timeouts io.sockets
|
||||
io.sockets io namespaces io.streams.duplex io.windows
|
||||
io.windows.nt.backend windows.winsock kernel libc math sequences
|
||||
threads classes.tuple.lib system accessors ;
|
||||
IN: io.windows.nt.sockets
|
||||
|
|
@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port
|
|||
M: winnt (accept) ( server -- addrspec handle )
|
||||
[
|
||||
[
|
||||
check-server-port
|
||||
\ AcceptEx-args new
|
||||
[ init-accept ] keep
|
||||
[ ((accept)) ] keep
|
||||
|
|
@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle )
|
|||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt <datagram> ( addrspec -- datagram )
|
||||
M: winnt (datagram) ( addrspec -- handle )
|
||||
[
|
||||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] keep <datagram-port>
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.nonblocking io.sockets io.binary
|
||||
io.sockets.impl windows.errors strings
|
||||
io.buffers io.files io.ports io.sockets io.binary
|
||||
io.sockets windows.errors strings
|
||||
kernel math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations math.bitfields system accessors ;
|
||||
|
|
|
|||
|
|
@ -148,7 +148,7 @@ DEFER: (d)
|
|||
: nth-basis-elt ( generators n -- elt )
|
||||
over length [
|
||||
3dup bit? [ nth ] [ 2drop f ] if
|
||||
] map [ ] filter 2nip ;
|
||||
] map sift 2nip ;
|
||||
|
||||
: basis ( generators -- seq )
|
||||
natural-sort dup length 2^ [ nth-basis-elt ] with map ;
|
||||
|
|
|
|||
|
|
@ -26,14 +26,14 @@ DEFER: funcall
|
|||
unclip convert-form swap convert-body [ , % funcall ] bake ;
|
||||
|
||||
<PRIVATE
|
||||
: localize-body ( vars body -- newbody )
|
||||
[ dup lisp-symbol? [ tuck name>> swap member? [ name>> make-local ] [ ] if ]
|
||||
[ dup s-exp? [ body>> localize-body <s-exp> ] [ nip ] if ] if
|
||||
] with map ;
|
||||
: localize-body ( assoc body -- assoc newbody )
|
||||
[ dup lisp-symbol? [ over dupd [ name>> ] dip at swap or ]
|
||||
[ dup s-exp? [ body>> localize-body <s-exp> ] when ] if
|
||||
] map ;
|
||||
|
||||
: localize-lambda ( body vars -- newbody newvars )
|
||||
dup make-locals dup push-locals [ swap localize-body <s-exp> convert-form ] dipd
|
||||
pop-locals swap ;
|
||||
make-locals dup push-locals swap
|
||||
[ swap localize-body <s-exp> convert-form swap pop-locals ] dip swap ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -8,6 +8,14 @@ IN: lisp.parser.tests
|
|||
"1234" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ -42 } [
|
||||
"-42" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 37/52 } [
|
||||
"37/52" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
||||
{ 123.98 } [
|
||||
"123.98" "atom" \ lisp-expr rule parse parse-result-ast
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 James Cash
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel peg.ebnf peg.expr math.parser sequences arrays strings
|
||||
combinators.lib ;
|
||||
combinators.lib math ;
|
||||
|
||||
IN: lisp.parser
|
||||
|
||||
|
|
@ -18,9 +18,11 @@ RPAREN = ")"
|
|||
dquote = '"'
|
||||
squote = "'"
|
||||
digit = [0-9]
|
||||
integer = (digit)+ => [[ string>number ]]
|
||||
float = (digit)+ "." (digit)* => [[ first3 >string [ >string ] dipd 3append string>number ]]
|
||||
integer = ("-")? (digit)+ => [[ first2 append string>number ]]
|
||||
float = integer "." (digit)* => [[ first3 >string [ number>string ] dipd 3append string>number ]]
|
||||
rational = integer "/" (digit)+ => [[ first3 nip string>number / ]]
|
||||
number = float
|
||||
| rational
|
||||
| integer
|
||||
id-specials = "!" | "$" | "%" | "&" | "*" | "/" | ":" | "<"
|
||||
| " =" | ">" | "?" | "^" | "_" | "~" | "+" | "-" | "." | "@"
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ SYMBOL: log-files
|
|||
write bl write ": " write print ;
|
||||
|
||||
: write-message ( msg word-name level -- )
|
||||
rot [ empty? not ] filter {
|
||||
rot harvest {
|
||||
{ [ dup empty? ] [ 3drop ] }
|
||||
{ [ dup length 1 = ] [ first -rot f (write-message) ] }
|
||||
[
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ FUNCTION: int SSL_write ( ssl-pointer ssl, void* buf, int num ) ;
|
|||
|
||||
FUNCTION: int SSL_read ( ssl-pointer ssl, void* buf, int num ) ;
|
||||
|
||||
FUNCTION: void SSL_shutdown ( ssl-pointer ssl ) ;
|
||||
FUNCTION: int SSL_shutdown ( ssl-pointer ssl ) ;
|
||||
|
||||
FUNCTION: void SSL_free ( ssl-pointer ssl ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
|
|||
continuations destructors debugger inspector
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.nonblocking io.files io.encodings.ascii io.sockets.secure ;
|
||||
io.backend io.ports io.files io.encodings.ascii io.sockets.secure ;
|
||||
IN: openssl
|
||||
|
||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||
|
|
@ -25,8 +25,11 @@ M: TLSv1 ssl-method drop TLSv1_method ;
|
|||
: ssl-error-string ( -- string )
|
||||
ERR_get_error ERR_clear_error f ERR_error_string ;
|
||||
|
||||
: (ssl-error) ( -- * )
|
||||
ssl-error-string throw ;
|
||||
|
||||
: ssl-error ( obj -- )
|
||||
{ f 0 } member? [ ssl-error-string throw ] when ;
|
||||
{ f 0 } member? [ (ssl-error) ] when ;
|
||||
|
||||
: init-ssl ( -- )
|
||||
SSL_library_init ssl-error
|
||||
|
|
@ -117,7 +120,7 @@ M: openssl-context dispose
|
|||
dup handle>> [ SSL_CTX_free ] when* f >>handle
|
||||
drop ;
|
||||
|
||||
TUPLE: ssl-handle file handle disposed ;
|
||||
TUPLE: ssl-handle file handle connected disposed ;
|
||||
|
||||
ERROR: no-ssl-context ;
|
||||
|
||||
|
|
@ -129,20 +132,19 @@ M: no-ssl-context summary
|
|||
|
||||
: <ssl-handle> ( fd -- ssl )
|
||||
current-ssl-context handle>> SSL_new dup ssl-error
|
||||
f ssl-handle boa ;
|
||||
f f ssl-handle boa ;
|
||||
|
||||
: <ssl-socket> ( fd -- ssl )
|
||||
[ BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep
|
||||
<ssl-handle>
|
||||
[ handle>> swap dup SSL_set_bio ] keep ;
|
||||
M: ssl-handle init-handle file>> init-handle ;
|
||||
|
||||
M: ssl-handle init-handle drop ;
|
||||
HOOK: ssl-shutdown io-backend ( handle -- )
|
||||
|
||||
M: ssl-handle close-handle
|
||||
dup disposed>> [ drop ] [
|
||||
[ t >>disposed drop ]
|
||||
t >>disposed
|
||||
[ ssl-shutdown ]
|
||||
[ handle>> SSL_free ]
|
||||
[ file>> close-handle ]
|
||||
[ handle>> SSL_free ] tri
|
||||
tri
|
||||
] if ;
|
||||
|
||||
ERROR: certificate-verify-error result ;
|
||||
|
|
|
|||
|
|
@ -17,14 +17,14 @@ MEMO: any-char-parser ( -- parser )
|
|||
|
||||
: search ( string parser -- seq )
|
||||
any-char-parser [ drop f ] action 2array choice repeat0 parse dup [
|
||||
parse-result-ast [ ] filter
|
||||
parse-result-ast sift
|
||||
] [
|
||||
drop { }
|
||||
] if ;
|
||||
|
||||
|
||||
: (replace) ( string parser -- seq )
|
||||
any-char-parser 2array choice repeat0 parse parse-result-ast [ ] filter ;
|
||||
any-char-parser 2array choice repeat0 parse parse-result-ast sift ;
|
||||
|
||||
: replace ( string parser -- result )
|
||||
[ (replace) [ tree-write ] each ] with-string-writer ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ IN: qualified
|
|||
] curry map zip ;
|
||||
|
||||
: partial-vocab-ignoring ( words name -- assoc )
|
||||
[ vocab-words keys swap diff ] keep partial-vocab ;
|
||||
[ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
|
||||
|
||||
: EXCLUDE:
|
||||
#! Syntax: EXCLUDE: vocab => words ... ;
|
||||
|
|
@ -32,12 +32,12 @@ IN: qualified
|
|||
|
||||
: FROM:
|
||||
#! Syntax: FROM: vocab => words... ;
|
||||
scan expect=>
|
||||
scan dup load-vocab drop expect=>
|
||||
";" parse-tokens swap partial-vocab use get push ; parsing
|
||||
|
||||
: RENAME:
|
||||
#! Syntax: RENAME: word vocab => newname
|
||||
scan scan lookup [ "No such word" throw ] unless*
|
||||
scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
|
||||
expect=>
|
||||
scan associate use get push ; parsing
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien.c-types io io.files io.nonblocking kernel
|
||||
USING: alien.c-types io io.files io.ports kernel
|
||||
namespaces random io.encodings.binary init
|
||||
accessors system ;
|
||||
IN: random.unix
|
||||
|
|
|
|||
|
|
@ -216,7 +216,7 @@ USE: continuations
|
|||
>r dup length swap r>
|
||||
[ = [ ] [ drop f ] if ] curry
|
||||
2map
|
||||
[ ] filter ;
|
||||
sift ;
|
||||
|
||||
<PRIVATE
|
||||
: (attempt-each-integer) ( i n quot -- result )
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ IN: tools.deploy.shaker
|
|||
|
||||
[
|
||||
io.backend:io-backend ,
|
||||
"default-buffer-size" "io.nonblocking" lookup ,
|
||||
"default-buffer-size" "io.ports" lookup ,
|
||||
] { } make
|
||||
{ "alarms" "io" "tools" } strip-vocab-globals %
|
||||
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@ C: <vocab-author> vocab-author
|
|||
: vocab-xref ( vocab quot -- vocabs )
|
||||
>r dup vocab-name swap words r> map
|
||||
[ [ word? ] filter [ word-vocabulary ] map ] map>set
|
||||
remove [ ] filter [ vocab ] map ; inline
|
||||
remove sift [ vocab ] map ; inline
|
||||
|
||||
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ TUPLE: track sizes ;
|
|||
|
||||
: normalized-sizes ( track -- seq )
|
||||
track-sizes
|
||||
[ [ ] filter sum ] keep [ dup [ over / ] when ] map nip ;
|
||||
[ sift sum ] keep [ dup [ over / ] when ] map nip ;
|
||||
|
||||
: <track> ( orientation -- track )
|
||||
<pack> V{ } clone
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ IN: ui.tools.tests
|
|||
[ ] [ "w" get com-scroll-down ] unit-test
|
||||
[ t ] [
|
||||
"w" get workspace-book gadget-children
|
||||
[ tool-scroller ] map [ ] filter [ scroller? ] all?
|
||||
[ tool-scroller ] map sift [ scroller? ] all?
|
||||
] unit-test
|
||||
[ ] [ "w" get hide-popup ] unit-test
|
||||
[ ] [ <gadget> "w" get show-popup ] unit-test
|
||||
|
|
|
|||
|
|
@ -24,8 +24,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ;
|
|||
[ blank? ] right-trim ;
|
||||
|
||||
: process-other-extend ( lines -- set )
|
||||
[ "#" split1 drop ";" split1 drop trim-blank ] map
|
||||
[ empty? not ] filter
|
||||
[ "#" split1 drop ";" split1 drop trim-blank ] map harvest
|
||||
[ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
|
||||
concat unique ;
|
||||
|
||||
|
|
|
|||
|
|
@ -89,7 +89,7 @@ IN: unicode.data
|
|||
] assoc-map >hashtable ;
|
||||
|
||||
: multihex ( hexstring -- string )
|
||||
" " split [ hex> ] map [ ] filter ;
|
||||
" " split [ hex> ] map sift ;
|
||||
|
||||
TUPLE: code-point lower title upper ;
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: interned
|
|||
|
||||
: parse-script ( stream -- assoc )
|
||||
! assoc is code point/range => name
|
||||
lines [ "#" split1 drop ] map [ empty? not ] filter [
|
||||
lines [ "#" split1 drop ] map harvest [
|
||||
";" split1 [ [ blank? ] trim ] bi@
|
||||
] H{ } map>assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
USING: kernel alien alien.c-types
|
||||
io.sockets
|
||||
io.sockets.impl
|
||||
unix
|
||||
unix.linux.sockios
|
||||
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 ;
|
||||
|
||||
: route ( dst gateway genmask flags -- )
|
||||
|
|
|
|||
|
|
@ -1,12 +1,20 @@
|
|||
USING: kernel alien.c-types alien.strings sequences math unix
|
||||
vectors kernel namespaces continuations threads assocs vectors
|
||||
io.unix.backend io.encodings.utf8 ;
|
||||
USING: kernel alien.c-types alien.strings sequences math alien.syntax unix
|
||||
vectors kernel namespaces continuations threads assocs vectors
|
||||
io.unix.backend io.encodings.utf8 ;
|
||||
IN: unix.process
|
||||
|
||||
! Low-level Unix process launching utilities. These are used
|
||||
! to implement io.launcher on Unix. User code should use
|
||||
! 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 )
|
||||
[ utf8 malloc-string ] map f suffix >c-void*-array ;
|
||||
|
||||
|
|
@ -29,10 +37,65 @@ IN: unix.process
|
|||
>r [ first ] [ ] bi r> exec-with-env ;
|
||||
|
||||
: 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 )
|
||||
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
|
||||
: SIGKILL 9 ; inline
|
||||
: SIGTERM 15 ; inline
|
||||
|
||||
FUNCTION: int kill ( pid_t pid, int sig ) ;
|
||||
|
||||
: PRIO_PROCESS 0 ; inline
|
||||
: PRIO_PGRP 1 ; inline
|
||||
: PRIO_USER 2 ; inline
|
||||
|
||||
: PRIO_MIN -20 ; inline
|
||||
: PRIO_MAX 20 ; inline
|
||||
|
||||
! which/who = 0 for current process
|
||||
FUNCTION: int getpriority ( int which, int who ) ;
|
||||
FUNCTION: int setpriority ( int which, int who, int prio ) ;
|
||||
|
||||
: set-priority ( n -- )
|
||||
0 0 rot setpriority io-error ;
|
||||
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.
|
||||
|
||||
USING: alien alien.c-types alien.syntax kernel libc structs sequences
|
||||
continuations
|
||||
continuations byte-arrays strings
|
||||
math namespaces system combinators vocabs.loader qualified
|
||||
accessors inference macros fry arrays.lib
|
||||
accessors inference macros locals shuffle arrays.lib
|
||||
unix.types ;
|
||||
|
||||
IN: unix
|
||||
|
|
@ -50,32 +50,40 @@ LIBRARY: factor
|
|||
FUNCTION: void clear_err_no ( ) ;
|
||||
FUNCTION: int err_no ( ) ;
|
||||
|
||||
ERROR: unix-system-call-error word args message ;
|
||||
|
||||
DEFER: strerror
|
||||
|
||||
MACRO: unix-system-call ( quot -- )
|
||||
[ ] [ infer in>> ] [ first ] tri
|
||||
'[
|
||||
[ @ dup 0 < [ dup throw ] [ ] if ]
|
||||
[ drop , narray , swap err_no strerror unix-system-call-error ]
|
||||
recover
|
||||
] ;
|
||||
|
||||
LIBRARY: libc
|
||||
|
||||
ERROR: unix-system-call-error args message word ;
|
||||
|
||||
FUNCTION: char* strerror ( int errno ) ;
|
||||
|
||||
MACRO:: unix-system-call ( quot -- )
|
||||
[let | n [ quot infer in>> ]
|
||||
word [ quot first ] |
|
||||
[
|
||||
n ndup quot call dup 0 < [
|
||||
drop
|
||||
n narray
|
||||
err_no strerror
|
||||
word unix-system-call-error
|
||||
] [
|
||||
n nnip
|
||||
] if
|
||||
]
|
||||
] ;
|
||||
|
||||
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
|
||||
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
|
||||
FUNCTION: int chdir ( char* path ) ;
|
||||
FUNCTION: int chown ( char* path, uid_t owner, gid_t group ) ;
|
||||
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 dup2 ( int oldd, int newd ) ;
|
||||
! 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 -- * )
|
||||
#! We throw to give this a terminating stack effect.
|
||||
"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 fcntl ( int fd, int cmd, int arg ) ;
|
||||
FUNCTION: int flock ( int fd, int operation ) ;
|
||||
FUNCTION: pid_t fork ( ) ;
|
||||
FUNCTION: void freeaddrinfo ( addrinfo* ai ) ;
|
||||
FUNCTION: int futimes ( int id, timeval[2] times ) ;
|
||||
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 gethostname ( char* name, int len ) ;
|
||||
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
|
||||
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
|
||||
FUNCTION: uid_t getuid ;
|
||||
FUNCTION: uint htonl ( uint n ) ;
|
||||
FUNCTION: ushort htons ( ushort n ) ;
|
||||
|
|
@ -135,7 +143,17 @@ FUNCTION: int pclose ( void* file ) ;
|
|||
FUNCTION: int pipe ( int* filedes ) ;
|
||||
FUNCTION: void* popen ( char* command, char* type ) ;
|
||||
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
|
||||
|
||||
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 recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
|
||||
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 setuid ( uid_t uid ) ;
|
||||
FUNCTION: int socket ( int domain, int type, int protocol ) ;
|
||||
FUNCTION: char* strerror ( int errno ) ;
|
||||
FUNCTION: int symlink ( char* path1, char* path2 ) ;
|
||||
FUNCTION: int system ( char* command ) ;
|
||||
|
||||
FUNCTION: int unlink ( char* path ) ;
|
||||
|
||||
: unlink-file ( path -- ) [ unlink ] unix-system-call drop ;
|
||||
|
||||
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 ) ;
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -45,8 +45,7 @@ unless
|
|||
<com-function-definition> ;
|
||||
|
||||
: parse-com-functions ( -- functions )
|
||||
";" parse-tokens { ")" } split
|
||||
[ empty? not ] filter
|
||||
";" parse-tokens { ")" } split harvest
|
||||
[ (parse-com-function) ] map ;
|
||||
|
||||
: (iid-word) ( definition -- word )
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ IN: wrap
|
|||
SYMBOL: width
|
||||
|
||||
: line-chunks ( string -- words-lines )
|
||||
"\n" split [ " \t" split [ empty? not ] filter ] map ;
|
||||
"\n" split [ " \t" split harvest ] map ;
|
||||
|
||||
: (split-chunk) ( words -- )
|
||||
-1 over [ length + 1+ dup width get > ] find drop nip
|
||||
|
|
|
|||
Loading…
Reference in New Issue