basis/io/backend/unix/unix.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types alien.syntax generic assocs kernel
   4 kernel.private math io.ports sequences strings sbufs threads
   5 unix vectors io.buffers io.backend io.encodings math.parser
   6 continuations system libc namespaces make io.timeouts
   7 io.encodings.utf8 destructors accessors summary combinators
   8 locals unix.time fry io.backend.unix.multiplexers ;
   9 QUALIFIED: io
  10 IN: io.backend.unix
  11
  12 GENERIC: handle-fd ( handle -- fd )
  13
  14 TUPLE: fd fd disposed ;
  15
  16 : init-fd ( fd -- fd )
  17     [
  18         |dispose
  19         dup fd>> F_SETFL O_NONBLOCK fcntl io-error
  20         dup fd>> F_SETFD FD_CLOEXEC fcntl io-error
  21     ] with-destructors ;
  22
  23 : <fd> ( n -- fd )
  24     #! We drop the error code rather than calling io-error,
  25     #! since on OS X 10.3, this operation fails from init-io
  26     #! when running the Factor.app (presumably because fd 0 and
  27     #! 1 are closed).
  28     f fd boa ;
  29
  30 M: fd dispose
  31     dup disposed>> [ drop ] [
  32         [ cancel-operation ]
  33         [ t >>disposed drop ]
  34         [ fd>> close-file ]
  35         tri
  36     ] if ;
  37
  38 M: fd handle-fd dup check-disposed fd>> ;
  39
  40 M: fd cancel-operation ( fd -- )
  41     dup disposed>> [ drop ] [
  42         fd>>
  43         mx get-global
  44         [ remove-input-callbacks [ t swap resume-with ] each ]
  45         [ remove-output-callbacks [ t swap resume-with ] each ]
  46         2bi
  47     ] if ;
  48
  49 SYMBOL: +retry+ ! just try the operation again without blocking
  50 SYMBOL: +input+
  51 SYMBOL: +output+
  52
  53 ERROR: io-timeout ;
  54
  55 M: io-timeout summary drop "I/O operation timed out" ;
  56
  57 : wait-for-fd ( handle event -- )
  58     dup +retry+ eq? [ 2drop ] [
  59         '[
  60             swap handle-fd mx get-global _ {
  61                 { +input+ [ add-input-callback ] }
  62                 { +output+ [ add-output-callback ] }
  63             } case
  64         ] "I/O" suspend nip [ io-timeout ] when
  65     ] if ;
  66
  67 : wait-for-port ( port event -- )
  68     '[ handle>> _ wait-for-fd ] with-timeout ;
  69
  70 ! Some general stuff
  71 : file-mode OCT: 0666 ;
  72
  73 ! Readers
  74 : (refill) ( port -- n )
  75     [ handle>> ]
  76     [ buffer>> buffer-end ]
  77     [ buffer>> buffer-capacity ] tri read ;
  78
  79 ! Returns an event to wait for which will ensure completion of
  80 ! this request
  81 GENERIC: refill ( port handle -- event/f )
  82
  83 M: fd refill
  84     fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
  85     {
  86         { [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
  87         { [ err_no EINTR = ] [ 2drop +retry+ ] }
  88         { [ err_no EAGAIN = ] [ 2drop +input+ ] }
  89         [ (io-error) ]
  90     } cond ;
  91
  92 M: unix (wait-to-read) ( port -- )
  93     dup
  94     dup handle>> dup check-disposed refill dup
  95     [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
  96
  97 ! Writers
  98 GENERIC: drain ( port handle -- event/f )
  99
 100 M: fd drain
 101     fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
 102     {
 103         { [ dup 0 >= ] [
 104             over buffer>> buffer-consume
 105             buffer>> buffer-empty? f +output+ ?
 106         ] }
 107         { [ err_no EINTR = ] [ 2drop +retry+ ] }
 108         { [ err_no EAGAIN = ] [ 2drop +output+ ] }
 109         [ (io-error) ]
 110     } cond ;
 111
 112 M: unix (wait-to-write) ( port -- )
 113     dup
 114     dup handle>> dup check-disposed drain
 115     dup [ wait-for-port ] [ 2drop ] if ;
 116
 117 M: unix io-multiplex ( ms/f -- )
 118     mx get-global wait-for-events ;
 119
 120 ! On Unix, you're not supposed to set stdin to non-blocking
 121 ! because the fd might be shared with another process (either
 122 ! parent or child). So what we do is have the VM start a thread
 123 ! which pumps data from the real stdin to a pipe. We set the
 124 ! pipe to non-blocking, and read from it instead of the real
 125 ! stdin. Very crufty, but it will suffice until we get native
 126 ! threading support at the language level.
 127 TUPLE: stdin control size data disposed ;
 128
 129 M: stdin dispose*
 130     [
 131         [ control>> &dispose drop ]
 132         [ size>> &dispose drop ]
 133         [ data>> &dispose drop ]
 134         tri
 135     ] with-destructors ;
 136
 137 : wait-for-stdin ( stdin -- n )
 138     [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
 139     [ size>> "ssize_t" heap-size swap io:stream-read *int ]
 140     bi ;
 141
 142 :: refill-stdin ( buffer stdin size -- )
 143     stdin data>> handle-fd buffer buffer-end size read
 144     dup 0 < [
 145         drop
 146         err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
 147     ] [
 148         size = [ "Error reading stdin pipe" throw ] unless
 149         size buffer n>buffer
 150     ] if ;
 151
 152 M: stdin refill
 153     [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
 154
 155 : control-write-fd ( -- fd ) &: control_write *uint ;
 156
 157 : size-read-fd ( -- fd ) &: size_read *uint ;
 158
 159 : data-read-fd ( -- fd ) &: stdin_read *uint ;
 160
 161 : <stdin> ( -- stdin )
 162     stdin new
 163         control-write-fd <fd> <output-port> >>control
 164         size-read-fd <fd> init-fd <input-port> >>size
 165         data-read-fd <fd> >>data ;
 166
 167 M: unix (init-stdio)
 168     <stdin> <input-port>
 169     1 <fd> <output-port>
 170     2 <fd> <output-port> t ;
 171
 172 ! mx io-task for embedding an fd-based mx inside another mx
 173 TUPLE: mx-port < port mx ;
 174
 175 : <mx-port> ( mx -- port )
 176     dup fd>> mx-port <port> swap >>mx ;
 177
 178 : multiplexer-error ( n -- n )
 179     dup 0 < [
 180         err_no [ EAGAIN = ] [ EINTR = ] bi or
 181         [ drop 0 ] [ (io-error) ] if
 182     ] when ;
 183
 184 : ?flag ( n mask symbol -- n )
 185     pick rot bitand 0 > [ , ] [ drop ] if ;