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