factor/basis/io/backend/unix/unix.factor

202 lines
5.7 KiB
Factor
Raw Normal View History

2008-01-18 18:18:54 -05:00
! Copyright (C) 2004, 2008 Slava Pestov.
2007-09-20 18:09:08 -04:00
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax generic assocs kernel
kernel.private math io.ports sequences strings sbufs threads
unix vectors io.buffers io.backend io.encodings math.parser
continuations system libc namespaces make io.timeouts
io.encodings.utf8 destructors destructors.private accessors
summary combinators locals unix.time unix.types fry
io.backend.unix.multiplexers ;
2008-01-18 18:18:54 -05:00
QUALIFIED: io
IN: io.backend.unix
2007-09-20 18:09:08 -04:00
GENERIC: handle-fd ( handle -- fd )
TUPLE: fd < disposable fd ;
2008-05-14 04:55:33 -04:00
2008-07-03 18:44:44 -04:00
: init-fd ( fd -- fd )
[
|dispose
dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call io-error
dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call io-error
2008-07-03 18:44:44 -04:00
] with-destructors ;
2008-05-15 19:14:46 -04:00
: <fd> ( n -- 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 new-disposable swap >>fd ;
2008-05-14 04:55:33 -04:00
2008-05-22 01:41:18 -04:00
M: fd dispose
dup disposed>> [ drop ] [
{
[ cancel-operation ]
[ t >>disposed drop ]
[ unregister-disposable ]
[ fd>> close-file ]
} cleave
2008-05-22 01:41:18 -04:00
] if ;
2008-05-14 04:55:33 -04:00
2008-05-20 19:52:11 -04:00
M: fd handle-fd dup check-disposed fd>> ;
M: fd cancel-operation ( fd -- )
2008-05-20 19:52:11 -04:00
dup disposed>> [ drop ] [
fd>>
mx get-global
[ remove-input-callbacks [ t swap resume-with ] each ]
[ remove-output-callbacks [ t swap resume-with ] each ]
2bi
] if ;
2008-05-13 19:24:46 -04:00
M: unix tell-handle ( handle -- n )
fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] }
{ io:seek-end [ SEEK_END ] }
2009-02-07 12:24:12 -05:00
[ io:bad-seek-type ]
} case
[ fd>> swap ] dip [ lseek ] unix-system-call io-error ;
2009-02-07 02:03:12 -05:00
2008-05-13 19:24:46 -04:00
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
SYMBOL: +output+
ERROR: io-timeout ;
M: io-timeout summary drop "I/O operation timed out" ;
: wait-for-fd ( handle event -- )
dup +retry+ eq? [ 2drop ] [
'[
swap handle-fd mx get-global _ {
2008-05-14 04:55:33 -04:00
{ +input+ [ add-input-callback ] }
{ +output+ [ add-output-callback ] }
} case
] "I/O" suspend nip [ io-timeout ] when
2008-05-13 19:24:46 -04:00
] if ;
2007-09-20 18:09:08 -04:00
2008-05-14 04:55:33 -04:00
: wait-for-port ( port event -- )
'[ handle>> _ wait-for-fd ] with-timeout ;
2008-05-14 04:55:33 -04:00
2007-09-20 18:09:08 -04:00
! Some general stuff
CONSTANT: file-mode OCT: 0666
2007-09-20 18:09:08 -04:00
! Readers
: (refill) ( port -- n )
[ handle>> ]
[ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ;
2007-09-20 18:09:08 -04:00
2008-05-13 19:24:46 -04:00
! Returns an event to wait for which will ensure completion of
! this request
GENERIC: refill ( port handle -- event/f )
2008-05-14 04:55:33 -04:00
M: fd refill
fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
2008-05-13 19:24:46 -04:00
{
2008-05-18 20:02:50 -04:00
{ [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +input+ ] }
2008-05-13 19:24:46 -04:00
[ (io-error) ]
} cond ;
M: unix (wait-to-read) ( port -- )
dup
dup handle>> dup check-disposed refill dup
2008-05-13 19:24:46 -04:00
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
2007-09-20 18:09:08 -04:00
! Writers
2008-05-13 19:24:46 -04:00
GENERIC: drain ( port handle -- event/f )
2008-05-14 04:55:33 -04:00
M: fd drain
fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
2008-05-13 19:24:46 -04:00
{
{ [ dup 0 >= ] [
over buffer>> buffer-consume
buffer>> buffer-empty? f +output+ ?
] }
{ [ errno EINTR = ] [ 2drop +retry+ ] }
{ [ errno EAGAIN = ] [ 2drop +output+ ] }
2008-05-13 19:24:46 -04:00
[ (io-error) ]
} cond ;
M: unix (wait-to-write) ( port -- )
dup
dup handle>> dup check-disposed drain
dup [ wait-for-port ] [ 2drop ] if ;
2007-09-20 18:09:08 -04:00
2008-04-02 21:09:56 -04:00
M: unix io-multiplex ( ms/f -- )
2008-02-09 22:34:42 -05:00
mx get-global wait-for-events ;
2007-09-20 18:09:08 -04:00
2008-07-03 18:44:44 -04:00
! On Unix, you're not supposed to set stdin to non-blocking
! because the fd might be shared with another process (either
! parent or child). So what we do is have the VM start a thread
! which pumps data from the real stdin to a pipe. We set the
! pipe to non-blocking, and read from it instead of the real
! stdin. Very crufty, but it will suffice until we get native
! threading support at the language level.
TUPLE: stdin < disposable control size data ;
2008-07-03 18:44:44 -04:00
2008-07-09 20:23:35 -04:00
M: stdin dispose*
2008-07-03 18:44:44 -04:00
[
[ control>> &dispose drop ]
[ size>> &dispose drop ]
[ data>> &dispose drop ]
tri
] with-destructors ;
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
[ size>> ssize_t heap-size swap io:stream-read *int ]
2008-07-03 18:44:44 -04:00
bi ;
:: refill-stdin ( buffer stdin size -- )
stdin data>> handle-fd buffer buffer-end size read
dup 0 < [
drop
errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
2008-07-03 18:44:44 -04:00
] [
size = [ "Error reading stdin pipe" throw ] unless
size buffer n>buffer
] if ;
M: stdin refill
[ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
: control-write-fd ( -- fd ) &: control_write *uint ;
2008-07-03 18:44:44 -04:00
: size-read-fd ( -- fd ) &: size_read *uint ;
2008-07-03 18:44:44 -04:00
: data-read-fd ( -- fd ) &: stdin_read *uint ;
2008-07-03 18:44:44 -04:00
: <stdin> ( -- stdin )
stdin new-disposable
2008-07-09 20:23:35 -04:00
control-write-fd <fd> <output-port> >>control
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
2008-07-03 18:44:44 -04:00
M: unix init-stdio
2008-07-03 18:44:44 -04:00
<stdin> <input-port>
2008-05-14 04:55:33 -04:00
1 <fd> <output-port>
2 <fd> <output-port>
set-stdio ;
2008-01-18 19:43:14 -05:00
! mx io-task for embedding an fd-based mx inside another mx
2008-04-11 17:08:40 -04:00
TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
2008-04-11 17:08:40 -04:00
dup fd>> mx-port <port> swap >>mx ;
: multiplexer-error ( n -- n )
dup 0 < [
errno [ EAGAIN = ] [ EINTR = ] bi or
[ drop 0 ] [ (io-error) ] if
2008-05-13 19:24:46 -04:00
] when ;
2008-04-11 10:54:50 -04:00
: ?flag ( n mask symbol -- n )
pick rot bitand 0 > [ , ] [ drop ] if ;