Fix conflict

db4
Slava Pestov 2008-05-18 16:55:21 -05:00
commit ad2ebc90c5
12 changed files with 122 additions and 118 deletions

View File

@ -105,6 +105,8 @@ strings accessors io.encodings.utf8 math destructors ;
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
[ "test-blah" temp-file delete-tree ] ignore-errors
[ ] [ "test-blah" temp-file make-directory ] unit-test
[ ] [

View File

@ -10,12 +10,15 @@ TUPLE: c-writer handle disposed ;
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-write1
dup check-disposed
handle>> fputc ;
M: c-writer stream-write
dup check-disposed
handle>> fwrite ;
M: c-writer stream-flush
dup check-disposed
handle>> fflush ;
M: c-writer dispose*
@ -26,12 +29,14 @@ TUPLE: c-reader handle disposed ;
: <c-reader> ( handle -- stream ) f c-reader boa ;
M: c-reader stream-read
dup check-disposed
handle>> fread ;
M: c-reader stream-read-partial
stream-read ;
M: c-reader stream-read1
dup check-disposed
handle>> fgetc ;
: read-until-loop ( stream delim -- ch )
@ -42,6 +47,7 @@ M: c-reader stream-read1
] if ;
M: c-reader stream-read-until
dup check-disposed
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;

19
extra/io/monitors/monitors-tests.factor Normal file → Executable file
View File

@ -1,7 +1,7 @@
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors ;
threads calendar prettyprint destructors io.timeouts ;
os { winnt linux macosx } member? [
[
@ -91,4 +91,21 @@ os { winnt linux macosx } member? [
! Out-of-scope disposal should not fail
[ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test
[ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test
! Timeouts
[
[ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test
! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] unit-test
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
[ ] [ "m" get dispose ] unit-test
] with-monitors
] when

View File

@ -29,15 +29,7 @@ $nl
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."
$nl
"Ports have the following slots:"
{ $list
{ { $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" }
} } ;
{ $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." } ;
HELP: input-port
{ $class-description "The class of ports implementing the input stream protocol." } ;
@ -65,10 +57,6 @@ HELP: <output-port>
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
$low-level-note ;
HELP: pending-error
{ $values { "port" port } }
{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ;
HELP: (wait-to-read)
{ $values { "port" input-port } }
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;

View File

@ -10,7 +10,7 @@ IN: io.ports
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
TUPLE: port handle error timeout disposed ;
TUPLE: port handle timeout disposed ;
M: port timeout timeout>> ;
@ -19,9 +19,6 @@ M: port set-timeout (>>timeout) ;
: <port> ( handle class -- port )
new swap >>handle ; inline
: pending-error ( port -- )
[ f ] change-error drop [ throw ] when* ;
TUPLE: buffered-port < port buffer ;
: <buffered-port> ( handle class -- port )
@ -106,14 +103,15 @@ M: output-port stream-write
HOOK: (wait-to-write) io-backend ( port -- )
: flush-port ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
: port-flush ( port -- )
dup buffer>> buffer-empty?
[ drop ] [ dup (wait-to-write) port-flush ] if ;
M: output-port stream-flush ( port -- )
[ check-disposed ] [ flush-port ] bi ;
[ check-disposed ] [ port-flush ] bi ;
M: output-port dispose*
[ flush-port ] [ call-next-method ] bi ;
M: output-port dispose
[ port-flush ] [ call-next-method ] bi ;
M: buffered-port dispose*
[ call-next-method ]

View File

@ -1,6 +1,6 @@
IN: io.sockets.tests
USING: io.sockets sequences math tools.test namespaces accessors
kernel destructors ;
kernel destructors calendar io.timeouts ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
@ -62,3 +62,9 @@ kernel destructors ;
[ ] [ "datagram1" get dispose ] unit-test
[ ] [ "datagram2" get dispose ] unit-test
! Test timeouts
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram3" set ] unit-test
[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test
[ "datagram3" get receive ] must-fail

31
extra/io/unix/backend/backend.factor Normal file → Executable file
View File

@ -62,21 +62,18 @@ GENERIC: wait-for-events ( ms mx -- )
: output-available ( fd mx -- )
remove-output-callbacks [ resume ] each ;
TUPLE: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
M: unix cancel-io ( port -- )
io-timeout new >>error
handle>> handle-fd mx get-global
[ input-available ] [ output-available ] 2bi ;
[ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
: wait-for-fd ( handle event -- timeout? )
dup +retry+ eq? [ 2drop f ] [
[
>r
swap handle-fd
@ -85,12 +82,18 @@ SYMBOL: +output+
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] curry "I/O" suspend 2drop
] curry "I/O" suspend nip
] if ;
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-port ( port event -- )
[ >r dup handle>> r> wait-for-fd ] curry
with-timeout pending-error ;
[
>r handle>> r> wait-for-fd
[ io-timeout ] when
] with-timeout ;
! Some general stuff
: file-mode OCT: 0666 ;
@ -147,8 +150,7 @@ M: fd drain
} cond ;
M: unix (wait-to-write) ( port -- )
dup dup handle>> drain dup
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
@ -166,7 +168,8 @@ TUPLE: mx-port < port mx ;
: multiplexer-error ( n -- )
0 < [
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
err_no [ EAGAIN = ] [ EINTR = ] bi or
[ (io-error) ] unless
] when ;
: ?flag ( n mask symbol -- n )

6
extra/io/unix/sockets/secure/secure.factor Normal file → Executable file
View File

@ -111,7 +111,7 @@ M: secure (server) addrspec>> (server) ;
: 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 ;
[ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
M: secure (accept)
[
@ -120,7 +120,7 @@ M: secure (accept)
dup do-ssl-accept r>
] with-destructors ;
: check-shutdown-response ( handle r -- event ) USING: io prettyprint ;
: check-shutdown-response ( handle r -- event )
#! SSL_shutdown always returns 0 due to openssl bugs?
{
{ 1 [ drop f ] }
@ -146,5 +146,5 @@ M: secure (accept)
M: unix ssl-shutdown
dup connected>> [
dup dup handle>> SSL_shutdown check-shutdown-response
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
] [ drop ] if ;

View File

@ -8,7 +8,8 @@ accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
SYMBOL: io-hash
! Global variable with assoc mapping overlapped to threads
SYMBOL: pending-overlapped
TUPLE: io-callback port thread ;
@ -33,62 +34,41 @@ M: winnt add-completion ( win32-handle -- )
handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
: overlapped-error? ( port n -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
{ [ dup eof? ] [ drop t >>eof drop f ] }
[ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
[
<io-callback> swap
dup alien? [ "bad overlapped in save-callback" throw ] unless
io-hash get-global set-at
] "I/O" suspend 3drop ;
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[ save-callback ]
[ get-overlapped-result ]
[ nip pending-error ]
2tri ;
:: wait-for-overlapped ( ms -- overlapped ? )
master-completion-port get-global
0 <int> ! bytes
f <void*> ! key
f <void*> ! overlapped
[
ms INFINITE or ! timeout
GetQueuedCompletionStatus
] keep *void* swap zero? ;
drop
[ pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ (win32-error-string) throw ] if
] }
} cond
] with-timeout ;
: lookup-callback ( overlapped -- callback )
io-hash get-global delete-at* drop
dup io-callback? [ "no callback in io-hash" throw ] unless ;
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
master-completion-port get-global
0 <int> [ ! bytes
f <void*> ! key
f <void*> [ ! overlapped
ms INFINITE or ! timeout
GetQueuedCompletionStatus zero?
] keep *void*
] keep *int spin ;
: resume-callback ( result overlapped -- )
pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( timeout -- ? )
wait-for-overlapped [
GetLastError dup expected-io-error? [ 2drop f ] [
>r lookup-callback [ thread>> ] [ port>> ] bi r>
dup eof?
[ drop t >>eof ]
[ (win32-error-string) >>error ] if drop
resume t
] if
>r drop GetLastError
[ 1array ] [ expected-io-error? ] bi
[ r> 2drop f ] [ r> resume-callback t ] if
] [
lookup-callback
thread>> resume t
resume-callback t
] if ;
M: winnt cancel-io
@ -99,29 +79,35 @@ M: winnt io-multiplex ( ms -- )
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
H{ } clone pending-overlapped set-global
windows.winsock:init-winsock ;
: file-error? ( n -- eof? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ (win32-error-string) throw ]
} cond
] [ f ] if ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-flush ( n port -- )
: finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
: ((wait-to-write)) ( port -- )
dup make-FileArgs
tuck setup-write WriteFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] keep
[ finish-flush ] keep
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
] [
2drop
] if ;
M: winnt (wait-to-write)
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
[
[ make-FileArgs dup setup-write WriteFile ]
[ wait-for-file ]
[ finish-write ]
tri
] with-destructors ;
: finish-read ( n port -- )
over zero? [
@ -130,13 +116,10 @@ M: winnt (wait-to-write)
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
] if ;
: ((wait-to-read)) ( port -- )
dup make-FileArgs
tuck setup-read ReadFile
dupd overlapped-error? [
>r lpOverlapped>> r>
[ twiddle-thumbs ] [ finish-read ] bi
] [ 2drop ] if ;
M: winnt (wait-to-read) ( port -- )
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
[
[ make-FileArgs dup setup-read ReadFile ]
[ wait-for-file ]
[ finish-read ]
tri
] with-destructors ;

View File

@ -35,7 +35,7 @@ TUPLE: win32-monitor < monitor port ;
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
: read-changes ( port -- bytes )
: read-changes ( port -- bytes-transferred )
[
[ begin-reading-changes ] [ twiddle-thumbs ] bi
] with-destructors ;

View File

@ -131,7 +131,8 @@ TUPLE: WSARecvFrom-args port
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
M: winnt (receive) ( datagram -- packet addrspec )
[

View File

@ -235,13 +235,13 @@ SYMBOL: init
: init-openal ( -- )
init get-global expired? [
f f alutInit drop
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
: exit-openal ( -- )
init get-global expired? [
alutExit drop
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;