Merge branch 'master' of git://factorcode.org/git/factor
commit
eb5d47a5eb
|
@ -21,12 +21,12 @@ HELP: graph
|
|||
|
||||
HELP: add-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
HELP: remove-vertex
|
||||
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
|
||||
{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
|
||||
{ $description "Removes a vertex from a graph, using the given edges sequence." }
|
||||
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
|
||||
{ $side-effects "graph" } ;
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien io kernel namespaces core-foundation cocoa.messages
|
||||
cocoa cocoa.classes cocoa.runtime sequences threads
|
||||
debugger init inspector kernel.private ;
|
||||
USING: alien io kernel namespaces core-foundation
|
||||
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
|
||||
cocoa.runtime sequences threads debugger init inspector
|
||||
kernel.private ;
|
||||
IN: cocoa.application
|
||||
|
||||
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
|
||||
|
@ -21,8 +22,6 @@ IN: cocoa.application
|
|||
: with-cocoa ( quot -- )
|
||||
[ NSApp drop call ] with-autorelease-pool ;
|
||||
|
||||
: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
|
||||
|
||||
: next-event ( app -- event )
|
||||
0 f CFRunLoopDefaultMode 1
|
||||
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
|
||||
|
|
|
@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef
|
|||
TYPEDEF: void* CFStringRef
|
||||
TYPEDEF: void* CFURLRef
|
||||
TYPEDEF: void* CFUUIDRef
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
TYPEDEF: bool Boolean
|
||||
TYPEDEF: int CFIndex
|
||||
TYPEDEF: int SInt32
|
||||
TYPEDEF: double CFTimeInterval
|
||||
TYPEDEF: double CFAbsoluteTime
|
||||
|
||||
|
@ -85,5 +85,3 @@ FUNCTION: void CFRelease ( void* cf ) ;
|
|||
] [
|
||||
"Cannot load bundled named " prepend throw
|
||||
] ?if ;
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax kernel math sequences
|
||||
namespaces assocs init continuations core-foundation ;
|
||||
namespaces assocs init accessors continuations combinators
|
||||
core-foundation core-foundation.run-loop ;
|
||||
IN: core-foundation.fsevents
|
||||
|
||||
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
|
||||
|
@ -182,11 +183,11 @@ SYMBOL: event-stream-callbacks
|
|||
}
|
||||
"cdecl" [
|
||||
[ >event-triple ] 3curry map
|
||||
swap event-stream-callbacks get at call
|
||||
drop
|
||||
swap event-stream-callbacks get at
|
||||
dup [ call drop ] [ 3drop ] if
|
||||
] alien-callback ;
|
||||
|
||||
TUPLE: event-stream info handle ;
|
||||
TUPLE: event-stream info handle closed ;
|
||||
|
||||
: <event-stream> ( quot paths latency flags -- event-stream )
|
||||
>r >r >r
|
||||
|
@ -194,9 +195,15 @@ TUPLE: event-stream info handle ;
|
|||
>r master-event-source-callback r>
|
||||
r> r> r> <FSEventStream>
|
||||
dup enable-event-stream
|
||||
event-stream construct-boa ;
|
||||
f event-stream construct-boa ;
|
||||
|
||||
M: event-stream dispose
|
||||
dup event-stream-info remove-event-source-callback
|
||||
event-stream-handle dup disable-event-stream
|
||||
FSEventStreamRelease ;
|
||||
dup closed>> [ drop ] [
|
||||
t >>closed
|
||||
{
|
||||
[ info>> remove-event-source-callback ]
|
||||
[ handle>> disable-event-stream ]
|
||||
[ handle>> FSEventStreamInvalidate ]
|
||||
[ handle>> FSEventStreamRelease ]
|
||||
} cleave
|
||||
] if ;
|
||||
|
|
|
@ -0,0 +1,38 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel threads init namespaces alien
|
||||
core-foundation ;
|
||||
IN: core-foundation.run-loop
|
||||
|
||||
: kCFRunLoopRunFinished 1 ; inline
|
||||
: kCFRunLoopRunStopped 2 ; inline
|
||||
: kCFRunLoopRunTimedOut 3 ; inline
|
||||
: kCFRunLoopRunHandledSource 4 ; inline
|
||||
|
||||
TYPEDEF: void* CFRunLoopRef
|
||||
|
||||
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
|
||||
|
||||
FUNCTION: SInt32 CFRunLoopRunInMode (
|
||||
CFStringRef mode,
|
||||
CFTimeInterval seconds,
|
||||
Boolean returnAfterSourceHandled
|
||||
) ;
|
||||
|
||||
: CFRunLoopDefaultMode ( -- alien )
|
||||
#! Ugly, but we don't have static NSStrings
|
||||
\ CFRunLoopDefaultMode get-global dup expired? [
|
||||
drop
|
||||
"kCFRunLoopDefaultMode" <CFString>
|
||||
dup \ CFRunLoopDefaultMode set-global
|
||||
] when ;
|
||||
|
||||
: run-loop-thread ( -- )
|
||||
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
|
||||
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
|
||||
run-loop-thread ;
|
||||
|
||||
: start-run-loop-thread ( -- )
|
||||
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
|
||||
|
||||
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
|
|
@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
|
|||
}
|
||||
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
|
||||
{ $code
|
||||
"\"mydata.dat\" dup file-info file-info-length ["
|
||||
"\"mydata.dat\" dup file-info size>> ["
|
||||
" 4 <sliced-groups> [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
}
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: http.server.static
|
|||
TUPLE: file-responder root hook special ;
|
||||
|
||||
: file-http-date ( filename -- string )
|
||||
file-info file-info-modified timestamp>http-string ;
|
||||
file-info modified>> timestamp>http-string ;
|
||||
|
||||
: last-modified-matches? ( filename -- ? )
|
||||
file-http-date dup [
|
||||
|
@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ;
|
|||
[
|
||||
<content>
|
||||
swap
|
||||
[ file-info file-info-size "content-length" set-header ]
|
||||
[ file-info size>> "content-length" set-header ]
|
||||
[ file-http-date "last-modified" set-header ]
|
||||
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
|
||||
tri
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
USING: inverse tools.test arrays math kernel sequences
|
||||
math.functions math.constants ;
|
||||
math.functions math.constants continuations ;
|
||||
IN: inverse-tests
|
||||
|
||||
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
||||
|
@ -51,7 +51,7 @@ C: <nil> nil
|
|||
{
|
||||
{ [ <cons> ] [ list-sum + ] }
|
||||
{ [ <nil> ] [ 0 ] }
|
||||
{ [ ] [ "Malformed list" throw ] }
|
||||
[ "Malformed list" throw ]
|
||||
} switch ;
|
||||
|
||||
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
|
||||
|
@ -59,6 +59,7 @@ C: <nil> nil
|
|||
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
|
||||
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
|
||||
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
|
||||
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
|
||||
|
||||
: empty-cons ( -- cons ) cons construct-empty ;
|
||||
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
|
||||
|
@ -68,3 +69,4 @@ C: <nil> nil
|
|||
|
||||
[ t ] [ pi [ pi ] matches? ] unit-test
|
||||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||
[ ] [ 3 [ _ ] undo ] unit-test
|
||||
|
|
|
@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
|
|||
PREDICATE: pop-inverse < word "pop-length" word-prop ;
|
||||
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
||||
|
||||
: enough? ( stack quot -- ? )
|
||||
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
|
||||
recover ;
|
||||
: enough? ( stack word -- ? )
|
||||
dup deferred? [ 2drop f ] [
|
||||
[ >r length r> 1quotation infer effect-in >= ]
|
||||
[ 3drop f ] recover
|
||||
] if ;
|
||||
|
||||
: fold-word ( stack quot -- stack )
|
||||
: fold-word ( stack word -- stack )
|
||||
2dup enough?
|
||||
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
|
||||
|
||||
|
@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
|||
[ { } swap [ fold-word ] each % ] [ ] make ;
|
||||
|
||||
: flattenable? ( object -- ? )
|
||||
[ [ word? ] [ primitive? not ] and? ] [
|
||||
{ [ word? ] [ primitive? not ] [
|
||||
{ "inverse" "math-inverse" "pop-inverse" }
|
||||
[ word-prop ] with contains? not
|
||||
] and? ;
|
||||
] } <-&& ;
|
||||
|
||||
: (flatten) ( quot -- )
|
||||
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
|
||||
|
@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
2curry
|
||||
] define-pop-inverse
|
||||
|
||||
: _ f ;
|
||||
DEFER: _
|
||||
\ _ [ drop ] define-inverse
|
||||
|
||||
: both ( object object -- object )
|
||||
|
@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
|
|||
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
|
||||
|
||||
: [switch] ( quot-alist -- quot )
|
||||
[ dup quotation? [ [ ] swap 2array ] when ] map
|
||||
reverse [ >r [undo] r> compose ] { } assoc>map
|
||||
recover-chain ;
|
||||
|
||||
|
|
|
@ -29,9 +29,10 @@ IN: io.encodings.8-bit
|
|||
{ "mac-roman" "ROMAN" }
|
||||
} ;
|
||||
|
||||
: full-path ( file-name -- path )
|
||||
: encoding-file ( file-name -- stream )
|
||||
"extra/io/encodings/8-bit/" ".TXT"
|
||||
swapd 3append resource-path ;
|
||||
swapd 3append resource-path
|
||||
ascii <file-reader> ;
|
||||
|
||||
: tail-if ( seq n -- newseq )
|
||||
2dup swap length <= [ tail ] [ drop ] if ;
|
||||
|
@ -48,8 +49,8 @@ IN: io.encodings.8-bit
|
|||
: ch>byte ( assoc -- newassoc )
|
||||
[ swap ] assoc-map >hashtable ;
|
||||
|
||||
: parse-file ( file-name -- byte>ch ch>byte )
|
||||
ascii file-lines process-contents
|
||||
: parse-file ( path -- byte>ch ch>byte )
|
||||
lines process-contents
|
||||
[ byte>ch ] [ ch>byte ] bi ;
|
||||
|
||||
TUPLE: 8-bit name decode encode ;
|
||||
|
@ -71,13 +72,13 @@ M: 8-bit decode-char
|
|||
: make-8-bit ( word byte>ch ch>byte -- )
|
||||
[ 8-bit construct-boa ] 2curry dupd curry define ;
|
||||
|
||||
: define-8-bit-encoding ( name path -- )
|
||||
: define-8-bit-encoding ( name stream -- )
|
||||
>r in get create r> parse-file make-8-bit ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
[
|
||||
"io.encodings.8-bit" in [
|
||||
mappings [ full-path define-8-bit-encoding ] assoc-each
|
||||
mappings [ encoding-file define-8-bit-encoding ] assoc-each
|
||||
] with-variable
|
||||
] with-compilation-unit
|
||||
|
|
|
@ -129,9 +129,6 @@ HELP: <process>
|
|||
{ $values { "process" process } }
|
||||
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
|
||||
|
||||
HELP: process-stream
|
||||
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
|
||||
|
||||
HELP: <process-stream>
|
||||
{ $values
|
||||
{ "desc" "a launch descriptor" }
|
||||
|
@ -144,7 +141,7 @@ HELP: with-process-stream
|
|||
{ "desc" "a launch descriptor" }
|
||||
{ "quot" quotation }
|
||||
{ "status" "an exit code" } }
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
|
||||
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
|
||||
|
||||
HELP: wait-for-process
|
||||
{ $values { "process" process } { "status" integer } }
|
||||
|
|
|
@ -150,18 +150,18 @@ M: process timed-out kill-process ;
|
|||
|
||||
HOOK: (process-stream) io-backend ( process -- handle in out )
|
||||
|
||||
TUPLE: process-stream process ;
|
||||
: <process-stream*> ( desc encoding -- stream process )
|
||||
>r >process dup dup (process-stream) <reader&writer>
|
||||
r> <encoder-duplex> -roll
|
||||
process-started ;
|
||||
|
||||
: <process-stream> ( desc encoding -- stream )
|
||||
>r >process dup dup (process-stream)
|
||||
>r >r process-started process-stream construct-boa
|
||||
r> r> <reader&writer> r> <encoder-duplex>
|
||||
over set-delegate ;
|
||||
<process-stream*> drop ; inline
|
||||
|
||||
: with-process-stream ( desc quot -- status )
|
||||
swap <process-stream>
|
||||
swap <process-stream*> >r
|
||||
[ swap with-stream ] keep
|
||||
process>> wait-for-process ; inline
|
||||
r> wait-for-process ; inline
|
||||
|
||||
: notify-exit ( process status -- )
|
||||
>>status
|
||||
|
|
|
@ -1,10 +1,10 @@
|
|||
USING: io io.mmap io.files kernel tools.test continuations
|
||||
sequences io.encodings.ascii ;
|
||||
sequences io.encodings.ascii accessors ;
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
|
||||
[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
|
||||
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
|
||||
|
|
|
@ -75,13 +75,13 @@ os { winnt linux macosx } member? [
|
|||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c1" get 5 seconds await-timeout ] unit-test
|
||||
[ ] [ "c1" get 15 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c2" get 5 seconds await-timeout ] unit-test
|
||||
[ ] [ "c2" get 15 seconds await-timeout ] unit-test
|
||||
|
||||
! Dispose twice
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
|
|
@ -36,10 +36,10 @@ HELP: port
|
|||
$nl
|
||||
"Ports have the following slots:"
|
||||
{ $list
|
||||
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
|
||||
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
{ { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
|
||||
{ { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
|
||||
{ { $snippet "type" } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
} } ;
|
||||
|
||||
HELP: input-port
|
||||
|
@ -53,8 +53,8 @@ HELP: init-handle
|
|||
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
|
||||
|
||||
HELP: <port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " with no buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: <buffered-port>
|
||||
|
|
|
@ -1,46 +1,39 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.nonblocking
|
||||
USING: math kernel io sequences io.buffers io.timeouts generic
|
||||
byte-vectors system io.streams.duplex io.encodings
|
||||
io.backend continuations debugger classes byte-arrays namespaces
|
||||
splitting dlists assocs io.encodings.binary ;
|
||||
splitting dlists assocs io.encodings.binary accessors ;
|
||||
IN: io.nonblocking
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port
|
||||
handle
|
||||
error
|
||||
timeout
|
||||
type eof? ;
|
||||
TUPLE: port handle buffer error timeout closed eof ;
|
||||
|
||||
M: port timeout port-timeout ;
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
M: port set-timeout set-port-timeout ;
|
||||
|
||||
SYMBOL: closed
|
||||
|
||||
PREDICATE: input-port < port port-type input-port eq? ;
|
||||
PREDICATE: output-port < port port-type output-port eq? ;
|
||||
M: port set-timeout (>>timeout) ;
|
||||
|
||||
GENERIC: init-handle ( handle -- )
|
||||
|
||||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
} port construct ;
|
||||
: <port> ( handle class -- port )
|
||||
construct-empty
|
||||
swap dup init-handle >>handle ; inline
|
||||
|
||||
: <buffered-port> ( handle type -- port )
|
||||
default-buffer-size get <buffer> swap <port> ;
|
||||
: <buffered-port> ( handle class -- port )
|
||||
<port>
|
||||
default-buffer-size get <buffer> >>buffer ; inline
|
||||
|
||||
TUPLE: input-port < port ;
|
||||
|
||||
: <reader> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
||||
TUPLE: output-port < port ;
|
||||
|
||||
: <writer> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
|
@ -48,7 +41,10 @@ GENERIC: close-handle ( handle -- )
|
|||
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
dup port-error f rot set-port-error [ throw ] when* ;
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
: check-closed ( port -- port )
|
||||
dup closed>> [ "Port closed" throw ] when ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
|
@ -59,21 +55,22 @@ M: port timed-out cancel-io ;
|
|||
GENERIC: (wait-to-read) ( port -- )
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: wait-to-read1 ( port -- )
|
||||
1 swap wait-to-read ;
|
||||
|
||||
: unless-eof ( port quot -- value )
|
||||
>r dup buffer-empty? over port-eof? and
|
||||
[ f swap set-port-eof? f ] r> if ; inline
|
||||
>r dup buffer>> buffer-empty? over eof>> and
|
||||
[ f >>eof drop f ] r> if ; inline
|
||||
|
||||
M: input-port stream-read1
|
||||
dup wait-to-read1 [ buffer-pop ] unless-eof ;
|
||||
check-closed
|
||||
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
|
||||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ dupd buffer-read ] unless-eof nip ;
|
||||
[ dupd buffer>> buffer-read ] unless-eof nip ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
|
@ -87,6 +84,7 @@ M: input-port stream-read1
|
|||
] if ;
|
||||
|
||||
M: input-port stream-read
|
||||
check-closed
|
||||
>r 0 max >fixnum r>
|
||||
2dup read-step dup [
|
||||
pick over length > [
|
||||
|
@ -94,72 +92,75 @@ M: input-port stream-read
|
|||
[ push-all ] keep
|
||||
[ read-loop ] keep
|
||||
B{ } like
|
||||
] [
|
||||
2nip
|
||||
] if
|
||||
] [
|
||||
2nip
|
||||
] if ;
|
||||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
|
||||
: can-write? ( len writer -- ? )
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
||||
: wait-to-write ( len port -- )
|
||||
tuck can-write? [ drop ] [ stream-flush ] if ;
|
||||
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
|
||||
|
||||
M: output-port stream-write1
|
||||
1 over wait-to-write byte>buffer ;
|
||||
check-closed
|
||||
1 over wait-to-write
|
||||
buffer>> byte>buffer ;
|
||||
|
||||
M: output-port stream-write
|
||||
over length over buffer-size > [
|
||||
[ buffer-size <groups> ] keep
|
||||
[ stream-write ] curry each
|
||||
check-closed
|
||||
over length over buffer>> buffer-size > [
|
||||
[ buffer>> buffer-size <groups> ]
|
||||
[ [ stream-write ] curry ] bi
|
||||
each
|
||||
] [
|
||||
over length over wait-to-write >buffer
|
||||
[ >r length r> wait-to-write ]
|
||||
[ buffer>> >buffer ] 2bi
|
||||
] if ;
|
||||
|
||||
GENERIC: port-flush ( port -- )
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
dup port-flush pending-error ;
|
||||
check-closed
|
||||
[ port-flush ] [ pending-error ] bi ;
|
||||
|
||||
: close-port ( port type -- )
|
||||
output-port eq? [ dup port-flush ] when
|
||||
GENERIC: close-port ( port -- )
|
||||
|
||||
M: output-port close-port
|
||||
[ port-flush ] [ call-next-method ] bi ;
|
||||
|
||||
M: port close-port
|
||||
dup cancel-io
|
||||
dup port-handle close-handle
|
||||
dup delegate [ buffer-free ] when*
|
||||
f swap set-delegate ;
|
||||
dup handle>> close-handle
|
||||
[ [ buffer-free ] when* f ] change-buffer drop ;
|
||||
|
||||
M: port dispose
|
||||
dup port-type closed eq?
|
||||
[ drop ]
|
||||
[ dup port-type >r closed over set-port-type r> close-port ]
|
||||
if ;
|
||||
dup closed>> [ drop ] [ t >>closed close-port ] if ;
|
||||
|
||||
TUPLE: server-port addr client client-addr encoding ;
|
||||
TUPLE: server-port < port addr client client-addr encoding ;
|
||||
|
||||
: <server-port> ( handle addr encoding -- server )
|
||||
rot f server-port <port>
|
||||
{ set-server-port-addr set-server-port-encoding set-delegate }
|
||||
server-port construct ;
|
||||
rot server-port <port>
|
||||
swap >>encoding
|
||||
swap >>addr ;
|
||||
|
||||
: check-server-port ( port -- )
|
||||
port-type server-port assert= ;
|
||||
: check-server-port ( port -- port )
|
||||
dup server-port? [ "Not a server port" throw ] unless ; inline
|
||||
|
||||
TUPLE: datagram-port addr packet packet-addr ;
|
||||
TUPLE: datagram-port < port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
>r f datagram-port <port> r>
|
||||
{ set-delegate set-datagram-port-addr }
|
||||
datagram-port construct ;
|
||||
swap datagram-port <port>
|
||||
swap >>addr ;
|
||||
|
||||
: check-datagram-port ( port -- )
|
||||
port-type datagram-port assert= ;
|
||||
: check-datagram-port ( port -- port )
|
||||
check-closed
|
||||
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
|
||||
|
||||
: check-datagram-send ( packet addrspec port -- )
|
||||
dup check-datagram-port
|
||||
datagram-port-addr [ class ] bi@ assert=
|
||||
class byte-array assert= ;
|
||||
: check-datagram-send ( packet addrspec port -- packet addrspec port )
|
||||
check-datagram-port
|
||||
2dup addr>> [ class ] bi@ assert=
|
||||
pick class byte-array assert= ;
|
||||
|
|
|
@ -12,17 +12,17 @@ SYMBOL: servers
|
|||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-client ( client quot -- )
|
||||
: with-client ( client addrspec quot -- )
|
||||
[
|
||||
over client-stream-addr accepted-connection
|
||||
swap accepted-connection
|
||||
with-stream*
|
||||
] curry with-disposal ; inline
|
||||
] 2curry with-disposal ; inline
|
||||
|
||||
\ with-client DEBUG add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[
|
||||
>r accept r> [ with-client ] 2curry "Client" spawn drop
|
||||
>r accept r> [ with-client ] 3curry "Client" spawn drop
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( addrspec encoding quot -- )
|
||||
|
|
|
@ -17,8 +17,6 @@ ARTICLE: "network-connection" "Connection-oriented networking"
|
|||
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
|
||||
{ $subsection <server> }
|
||||
{ $subsection accept }
|
||||
"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
|
||||
{ $subsection client-stream-addr }
|
||||
"Server sockets are closed by calling " { $link dispose } "."
|
||||
$nl
|
||||
"Address specifiers have the following interpretation with connection-oriented networking words:"
|
||||
|
@ -118,10 +116,8 @@ HELP: <server>
|
|||
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
|
||||
|
||||
HELP: accept
|
||||
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
|
||||
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
|
||||
$nl
|
||||
"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
|
||||
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
|
||||
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
|
||||
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
|
||||
|
||||
HELP: <datagram>
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel io.backend namespaces continuations
|
||||
sequences arrays io.encodings io.nonblocking ;
|
||||
sequences arrays io.encodings io.nonblocking accessors ;
|
||||
IN: io.sockets
|
||||
|
||||
TUPLE: local path ;
|
||||
|
@ -21,20 +21,14 @@ TUPLE: inet host port ;
|
|||
|
||||
C: <inet> inet
|
||||
|
||||
TUPLE: client-stream addr ;
|
||||
HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
|
||||
|
||||
: <client-stream> ( addrspec delegate -- stream )
|
||||
{ set-client-stream-addr set-delegate }
|
||||
client-stream construct ;
|
||||
|
||||
HOOK: (client) io-backend ( addrspec -- client-in client-out )
|
||||
|
||||
GENERIC: client* ( addrspec -- client-in client-out )
|
||||
M: array client* [ (client) 2array ] attempt-all first2 ;
|
||||
M: object client* (client) ;
|
||||
GENERIC: (client) ( addrspec -- client-in client-out )
|
||||
M: array (client) [ ((client)) 2array ] attempt-all first2 ;
|
||||
M: object (client) ((client)) ;
|
||||
|
||||
: <client> ( addrspec encoding -- stream )
|
||||
>r client* r> <encoder-duplex> ;
|
||||
>r (client) r> <encoder-duplex> ;
|
||||
|
||||
HOOK: (server) io-backend ( addrspec -- handle )
|
||||
|
||||
|
@ -43,10 +37,9 @@ HOOK: (server) io-backend ( addrspec -- handle )
|
|||
|
||||
HOOK: (accept) io-backend ( server -- addrspec handle )
|
||||
|
||||
: accept ( server -- client )
|
||||
[ (accept) dup <reader&writer> ] keep
|
||||
server-port-encoding <encoder-duplex>
|
||||
<client-stream> ;
|
||||
: accept ( server -- client addrspec )
|
||||
[ (accept) dup <reader&writer> ] [ encoding>> ] bi
|
||||
<encoder-duplex> swap ;
|
||||
|
||||
HOOK: <datagram> io-backend ( addrspec -- datagram )
|
||||
|
||||
|
@ -58,7 +51,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq )
|
|||
|
||||
HOOK: host-name io-backend ( -- string )
|
||||
|
||||
M: inet client*
|
||||
dup inet-host swap inet-port f resolve-host
|
||||
dup empty? [ "Host name lookup failed" throw ] when
|
||||
client* ;
|
||||
M: inet (client)
|
||||
[ host>> ] [ port>> ] bi f resolve-host
|
||||
[ empty? [ "Host name lookup failed" throw ] when ]
|
||||
[ (client) ]
|
||||
bi ;
|
||||
|
|
|
@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ;
|
|||
: io-task-fd port>> handle>> ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
|
||||
r> construct-delegate ; inline
|
||||
construct-empty
|
||||
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
|
||||
swap >>port ; inline
|
||||
|
||||
TUPLE: input-task ;
|
||||
TUPLE: input-task < io-task ;
|
||||
|
||||
: <input-task> ( port continuation class -- task )
|
||||
>r input-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
TUPLE: output-task ;
|
||||
|
||||
: <output-task> ( port continuation class -- task )
|
||||
>r output-task <io-task> r> construct-delegate ; inline
|
||||
TUPLE: output-task < io-task ;
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
|
@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ;
|
|||
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||
|
||||
: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
|
||||
: construct-mx ( class -- obj )
|
||||
construct-empty
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
|
@ -123,16 +119,18 @@ M: unix cancel-io ( port -- )
|
|||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
dup buffer-empty? [ t >>eof? ] when drop ;
|
||||
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer-end ]
|
||||
[ buffer>> buffer-capacity ] tri read ;
|
||||
|
||||
: refill ( port -- ? )
|
||||
#! Return f if there is a recoverable error
|
||||
dup buffer-empty? [
|
||||
dup buffer>> buffer-empty? [
|
||||
dup (refill) dup 0 >= [
|
||||
swap n>buffer t
|
||||
swap buffer>> n>buffer t
|
||||
] [
|
||||
drop defer-error
|
||||
] if
|
||||
|
@ -140,10 +138,10 @@ M: unix cancel-io ( port -- )
|
|||
drop t
|
||||
] if ;
|
||||
|
||||
TUPLE: read-task ;
|
||||
TUPLE: read-task < input-task ;
|
||||
|
||||
: <read-task> ( port continuation -- task )
|
||||
read-task <input-task> ;
|
||||
read-task <io-task> ;
|
||||
|
||||
M: read-task do-io-task
|
||||
io-task-port dup refill
|
||||
|
@ -155,28 +153,33 @@ M: input-port (wait-to-read)
|
|||
|
||||
! Writers
|
||||
: write-step ( port -- ? )
|
||||
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
|
||||
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
|
||||
dup
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer@ ]
|
||||
[ buffer>> buffer-length ] tri
|
||||
write dup 0 >=
|
||||
[ swap buffer>> buffer-consume f ]
|
||||
[ drop defer-error ] if ;
|
||||
|
||||
TUPLE: write-task ;
|
||||
TUPLE: write-task < output-task ;
|
||||
|
||||
: <write-task> ( port continuation -- task )
|
||||
write-task <output-task> ;
|
||||
write-task <io-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup [ buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over port-handle mx get-global mx-writes at*
|
||||
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: port port-flush ( port -- )
|
||||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
M: output-port port-flush ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
@ -187,13 +190,12 @@ M: unix (init-stdio) ( -- )
|
|||
2 <writer> ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port mx ;
|
||||
TUPLE: mx-port < port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup fd>> f mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
dup fd>> mx-port <port> swap >>mx ;
|
||||
|
||||
TUPLE: mx-task ;
|
||||
TUPLE: mx-task < io-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f mx-task <io-task> ;
|
||||
|
|
|
@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math
|
|||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
||||
TUPLE: epoll-mx events ;
|
||||
TUPLE: epoll-mx < mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ;
|
|||
epoll_ctl io-error ;
|
||||
|
||||
M: epoll-mx register-io-task ( task mx -- )
|
||||
2dup EPOLL_CTL_ADD do-epoll-ctl
|
||||
delegate register-io-task ;
|
||||
[ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
|
||||
|
||||
M: epoll-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
EPOLL_CTL_DEL do-epoll-ctl ;
|
||||
[ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
|
||||
|
||||
: wait-event ( mx timeout -- n )
|
||||
>r { mx-fd epoll-mx-events } get-slots max-events
|
||||
|
|
|
@ -72,7 +72,7 @@ M: unix delete-directory ( path -- )
|
|||
M: unix copy-file ( from to -- )
|
||||
[ normalize-path ] bi@
|
||||
[ (copy-file) ]
|
||||
[ swap file-info file-info-permissions chmod io-error ]
|
||||
[ swap file-info permissions>> chmod io-error ]
|
||||
2bi ;
|
||||
|
||||
: stat>type ( stat -- type )
|
||||
|
|
|
@ -8,7 +8,7 @@ io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
|||
io.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx events monitors ;
|
||||
TUPLE: kqueue-mx < mx events monitors ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
@ -43,12 +43,14 @@ M: io-task io-task-fflags drop 0 ;
|
|||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
over EV_ADD make-kevent over register-kevent
|
||||
delegate register-io-task ;
|
||||
[ >r EV_ADD make-kevent r> register-kevent ]
|
||||
[ call-next-method ]
|
||||
2bi ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
swap EV_DELETE make-kevent swap register-kevent ;
|
||||
[ call-next-method ]
|
||||
[ >r EV_DELETE make-kevent r> register-kevent ]
|
||||
2bi ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
|
|
|
@ -103,8 +103,8 @@ M: linux-monitor dispose ( monitor -- )
|
|||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
0 over parse-file-notifications
|
||||
0 over buffer-reset
|
||||
0 over buffer>> parse-file-notifications
|
||||
0 over buffer>> buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
||||
: inotify-read-thread ( port -- )
|
||||
|
|
|
@ -5,7 +5,7 @@ bit-arrays sequences assocs unix math namespaces structs
|
|||
accessors ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx read-fdset write-fdset ;
|
||||
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||
|
||||
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||
! FD_SET to be an array of cells, so we have to account for
|
||||
|
|
|
@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
|
|||
io.nonblocking parser threads unix sequences
|
||||
byte-arrays io.sockets io.binary io.unix.backend
|
||||
io.streams.duplex io.sockets.impl math.parser continuations libc
|
||||
combinators io.backend io.files io.files.private system ;
|
||||
combinators io.backend io.files io.files.private system accessors ;
|
||||
IN: io.unix.sockets
|
||||
|
||||
: pending-init-error ( port -- )
|
||||
|
@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- )
|
|||
: init-client-socket ( fd -- )
|
||||
SOL_SOCKET SO_OOBINLINE sockopt ;
|
||||
|
||||
TUPLE: connect-task ;
|
||||
TUPLE: connect-task < output-task ;
|
||||
|
||||
: <connect-task> ( port continuation -- task )
|
||||
connect-task <output-task> ;
|
||||
connect-task <io-task> ;
|
||||
|
||||
M: connect-task do-io-task
|
||||
io-task-port dup port-handle f 0 write
|
||||
|
@ -42,7 +42,7 @@ M: connect-task do-io-task
|
|||
: wait-to-connect ( port -- )
|
||||
[ <connect-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix (client) ( addrspec -- client-in client-out )
|
||||
M: unix ((client)) ( addrspec -- client-in client-out )
|
||||
dup make-sockaddr/size >r >r
|
||||
protocol-family SOCK_STREAM socket-fd
|
||||
dup r> r> connect
|
||||
|
@ -61,10 +61,10 @@ USE: unix
|
|||
: init-server-socket ( fd -- )
|
||||
SOL_SOCKET SO_REUSEADDR sockopt ;
|
||||
|
||||
TUPLE: accept-task ;
|
||||
TUPLE: accept-task < input-task ;
|
||||
|
||||
: <accept-task> ( port continuation -- task )
|
||||
accept-task <input-task> ;
|
||||
accept-task <io-task> ;
|
||||
|
||||
: accept-sockaddr ( port -- fd sockaddr )
|
||||
dup port-handle swap server-port-addr sockaddr-type
|
||||
|
@ -97,11 +97,10 @@ M: unix (server) ( addrspec -- handle )
|
|||
|
||||
M: unix (accept) ( server -- addrspec handle )
|
||||
#! Wait for a client connection.
|
||||
dup check-server-port
|
||||
dup wait-to-accept
|
||||
dup pending-error
|
||||
dup server-port-client-addr
|
||||
swap server-port-client ;
|
||||
check-server-port
|
||||
[ wait-to-accept ]
|
||||
[ pending-error ]
|
||||
[ [ client-addr>> ] [ client>> ] bi ] tri ;
|
||||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix <datagram>
|
||||
|
@ -128,10 +127,10 @@ packet-size <byte-array> receive-buffer set-global
|
|||
rot head
|
||||
] if ;
|
||||
|
||||
TUPLE: receive-task ;
|
||||
TUPLE: receive-task < input-task ;
|
||||
|
||||
: <receive-task> ( stream continuation -- task )
|
||||
receive-task <input-task> ;
|
||||
receive-task <io-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
|
@ -148,19 +147,18 @@ M: receive-task do-io-task
|
|||
[ <receive-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
dup wait-receive
|
||||
dup pending-error
|
||||
dup datagram-port-packet
|
||||
swap datagram-port-packet-addr ;
|
||||
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 packet sockaddr len ;
|
||||
TUPLE: send-task < output-task packet sockaddr len ;
|
||||
|
||||
: <send-task> ( packet sockaddr len stream continuation -- task )
|
||||
send-task <output-task> [
|
||||
send-task <io-task> [
|
||||
{
|
||||
set-send-task-packet
|
||||
set-send-task-sockaddr
|
||||
|
@ -180,7 +178,7 @@ M: send-task do-io-task
|
|||
2drop 2drop ;
|
||||
|
||||
M: unix send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
check-datagram-send
|
||||
[ >r make-sockaddr/size r> wait-send ] keep
|
||||
pending-error ;
|
||||
|
||||
|
|
|
@ -11,7 +11,7 @@ IN: io.unix.tests
|
|||
|
||||
socket-server <local>
|
||||
ascii <server> [
|
||||
accept [
|
||||
accept drop [
|
||||
"Hello world" print flush
|
||||
readln "XYZ" = "FOO" "BAR" ? print flush
|
||||
] with-stream
|
||||
|
|
|
@ -64,7 +64,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
dup pending-error
|
||||
tuck get-overlapped-result
|
||||
dup pick update-file-ptr
|
||||
swap buffer-consume ;
|
||||
swap buffer>> buffer-consume ;
|
||||
|
||||
: (flush-output) ( port -- )
|
||||
dup make-FileArgs
|
||||
|
@ -73,7 +73,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
>r FileArgs-lpOverlapped r>
|
||||
[ save-callback ] 2keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
@ -82,7 +82,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
|
|||
[ [ (flush-output) ] with-timeout ] with-destructors ;
|
||||
|
||||
M: port port-flush
|
||||
dup buffer-empty? [ dup flush-output ] unless drop ;
|
||||
dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
|
||||
|
||||
: finish-read ( overlapped port -- )
|
||||
dup pending-error
|
||||
|
|
|
@ -37,10 +37,12 @@ M: winnt <monitor> ( path recursive? -- monitor )
|
|||
] with-destructors ;
|
||||
|
||||
: begin-reading-changes ( monitor -- overlapped )
|
||||
dup port-handle win32-file-handle
|
||||
over buffer-ptr
|
||||
pick buffer-size
|
||||
roll win32-monitor-recursive? 1 0 ?
|
||||
{
|
||||
[ handle>> handle>> ]
|
||||
[ buffer>> buffer-ptr ]
|
||||
[ buffer>> buffer-size ]
|
||||
[ win32-monitor-recursive? 1 0 ? ]
|
||||
} cleave
|
||||
FILE_NOTIFY_CHANGE_ALL
|
||||
0 <uint>
|
||||
(make-overlapped)
|
||||
|
@ -82,6 +84,6 @@ M: winnt <monitor> ( path recursive? -- monitor )
|
|||
[ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
|
||||
|
||||
M: win32-monitor fill-queue ( monitor -- )
|
||||
dup buffer-ptr over read-changes
|
||||
dup buffer>> buffer-ptr over read-changes
|
||||
[ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
|
||||
swap set-monitor-queue ;
|
||||
|
|
|
@ -122,7 +122,7 @@ TUPLE: AcceptEx-args port
|
|||
M: winnt (accept) ( server -- addrspec handle )
|
||||
[
|
||||
[
|
||||
dup check-server-port
|
||||
check-server-port
|
||||
\ AcceptEx-args construct-empty
|
||||
[ init-accept ] keep
|
||||
[ ((accept)) ] keep
|
||||
|
@ -159,7 +159,7 @@ TUPLE: WSARecvFrom-args port
|
|||
: init-WSARecvFrom ( datagram WSARecvFrom -- )
|
||||
[ set-WSARecvFrom-args-port ] 2keep
|
||||
[
|
||||
>r delegate port-handle delegate win32-file-handle r>
|
||||
>r handle>> handle>> r>
|
||||
set-WSARecvFrom-args-s*
|
||||
] 2keep [
|
||||
>r datagram-port-addr sockaddr-type heap-size r>
|
||||
|
@ -192,7 +192,7 @@ TUPLE: WSARecvFrom-args port
|
|||
|
||||
M: winnt receive ( datagram -- packet addrspec )
|
||||
[
|
||||
dup check-datagram-port
|
||||
check-datagram-port
|
||||
\ WSARecvFrom-args construct-empty
|
||||
[ init-WSARecvFrom ] keep
|
||||
[ call-WSARecvFrom ] keep
|
||||
|
@ -244,7 +244,7 @@ USE: io.sockets
|
|||
|
||||
M: winnt send ( packet addrspec datagram -- )
|
||||
[
|
||||
3dup check-datagram-send
|
||||
check-datagram-send
|
||||
\ WSASendTo-args construct-empty
|
||||
[ init-WSASendTo ] keep
|
||||
[ call-WSASendTo ] keep
|
||||
|
|
|
@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- )
|
|||
] when drop ;
|
||||
|
||||
: open-append ( path -- handle length )
|
||||
[ dup file-info file-info-size ] [ drop 0 ] recover
|
||||
[ dup file-info size>> ] [ drop 0 ] recover
|
||||
>r (open-append) r> 2dup set-file-pointer ;
|
||||
|
||||
TUPLE: FileArgs
|
||||
|
@ -103,9 +103,9 @@ C: <FileArgs> FileArgs
|
|||
|
||||
: make-FileArgs ( port -- <FileArgs> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
[ delegate ] keep
|
||||
[ buffer>> ] keep
|
||||
[
|
||||
buffer-length
|
||||
buffer>> buffer-length
|
||||
"DWORD" <c-object>
|
||||
] keep FileArgs-overlapped <FileArgs> ;
|
||||
|
||||
|
@ -152,11 +152,10 @@ M: windows delete-directory ( path -- )
|
|||
|
||||
HOOK: WSASocket-flags io-backend ( -- DWORD )
|
||||
|
||||
TUPLE: win32-socket ;
|
||||
TUPLE: win32-socket < win32-file ;
|
||||
|
||||
: <win32-socket> ( handle -- win32-socket )
|
||||
f <win32-file>
|
||||
\ win32-socket construct-delegate ;
|
||||
f win32-file construct-boa ;
|
||||
|
||||
: open-socket ( family type -- socket )
|
||||
0 f 0 WSASocket-flags WSASocket dup socket-error ;
|
||||
|
|
|
@ -22,9 +22,8 @@ IN: tools.deploy.backend
|
|||
+stdout+ >>stderr
|
||||
+closed+ >>stdin
|
||||
+low-priority+ >>priority
|
||||
utf8 <process-stream>
|
||||
dup copy-lines
|
||||
process>> wait-for-process zero? [
|
||||
utf8 <process-stream*>
|
||||
>r copy-lines r> wait-for-process zero? [
|
||||
"Deployment failed" throw
|
||||
] unless ;
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
IN: tools.deploy.tests
|
||||
USING: tools.test system io.files kernel tools.deploy.config
|
||||
tools.deploy.backend math sequences io.launcher arrays
|
||||
namespaces continuations layouts ;
|
||||
namespaces continuations layouts accessors ;
|
||||
|
||||
: shake-and-bake ( vocab -- )
|
||||
[ "test.image" temp-file delete-file ] ignore-errors
|
||||
|
@ -12,7 +12,7 @@ namespaces continuations layouts ;
|
|||
] with-directory ;
|
||||
|
||||
: small-enough? ( n -- ? )
|
||||
>r "test.image" temp-file file-info file-info-size r> <= ;
|
||||
>r "test.image" temp-file file-info size>> r> <= ;
|
||||
|
||||
[ ] [ "hello-world" shake-and-bake ] unit-test
|
||||
|
||||
|
|
|
@ -1,8 +1,9 @@
|
|||
IN: ui.tools.interactor.tests
|
||||
USING: ui.tools.interactor ui.gadgets.panes namespaces
|
||||
ui.gadgets.editors concurrency.promises threads listener
|
||||
tools.test kernel calendar ;
|
||||
tools.test kernel calendar parser ;
|
||||
|
||||
[
|
||||
\ <interactor> must-infer
|
||||
|
||||
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
|
||||
|
@ -25,3 +26,4 @@ tools.test kernel calendar ;
|
|||
[ ] [ "interactor" get evaluate-input ] unit-test
|
||||
|
||||
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
|
||||
] with-interactive-vocabs
|
||||
|
|
Loading…
Reference in New Issue