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