basis/io/backend/unix/unix.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data alien.syntax classes
   4 classes.struct combinators destructors destructors.private fry
   5 io.backend io.backend.unix.multiplexers io.buffers io.files
   6 io.ports io.timeouts kernel kernel.private libc locals make math
   7 namespaces sequences summary system threads unix unix.ffi
   8 unix.signals unix.stat unix.types ;
   9 QUALIFIED: io
  10 IN: io.backend.unix
  11
  12 CONSTANT: file-mode 0o0666
  13
  14 GENERIC: handle-fd ( handle -- fd )
  15
  16 TUPLE: fd < disposable fd ;
  17
  18 : init-fd ( fd -- fd )
  19     [
  20         |dispose
  21         dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call drop
  22         dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call drop
  23     ] with-destructors ;
  24
  25 : <fd> ( n -- fd )
  26     fd new-disposable swap >>fd ;
  27
  28 M: fd dispose
  29     [
  30         {
  31             [ cancel-operation ]
  32             [ t >>disposed drop ]
  33             [ unregister-disposable ]
  34             [ fd>> close-file ]
  35         } cleave
  36     ] unless-disposed ;
  37
  38 M: fd handle-fd check-disposed fd>> ;
  39
  40 M: fd cancel-operation
  41     [
  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     ] unless-disposed ;
  48
  49 M: unix tell-handle
  50     fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
  51
  52 M: unix seek-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 ] unix-system-call drop ;
  60
  61 M: unix can-seek-handle?
  62     fd>> SEEK_CUR 0 lseek -1 = not ;
  63
  64 M: unix handle-length
  65     fd>> \ stat new [ fstat -1 = not ] keep
  66     swap [ st_size>> ] [ drop f ] if ;
  67
  68 ERROR: io-timeout ;
  69
  70 M: io-timeout summary drop "I/O operation timed out" ;
  71
  72 M: unix wait-for-fd
  73     dup +retry+ eq? [ 2drop ] [
  74         [ [ self ] dip handle-fd mx get-global ] dip {
  75             { +input+ [ add-input-callback ] }
  76             { +output+ [ add-output-callback ] }
  77         } case
  78         "I/O" suspend [ io-timeout ] when
  79     ] if ;
  80
  81 ! Some general stuff
  82
  83 M: fd refill
  84     [ buffered-port check-instance buffer>> ] [ fd>> ] bi*
  85     over [ buffer-end ] [ buffer-capacity ] bi read
  86     { fixnum } declare dup 0 >= [
  87         swap buffer+ f
  88     ] [
  89         errno {
  90             { EINTR [ 2drop +retry+ ] }
  91             { EAGAIN [ 2drop +input+ ] }
  92             [ (throw-errno) ]
  93         } case
  94     ] if ;
  95
  96 M: unix (wait-to-read)
  97     dup
  98     dup handle>> check-disposed refill dup
  99     [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
 100
 101 ! Writers
 102 M: fd drain
 103     [ buffered-port check-instance buffer>> ] [ fd>> ] bi*
 104     over [ buffer@ ] [ buffer-length ] bi write
 105     { fixnum } declare dup 0 >= [
 106         over buffer-consume
 107         buffer-empty? f +output+ ?
 108     ] [
 109         errno {
 110             { EINTR [ 2drop +retry+ ] }
 111             { EAGAIN [ 2drop +output+ ] }
 112             { ENOBUFS [ 2drop +output+ ] }
 113             [ (throw-errno) ]
 114         } case
 115     ] if ;
 116
 117 M: unix (wait-to-write)
 118     dup
 119     dup handle>> check-disposed drain
 120     [ wait-for-port ] [ drop ] if* ;
 121
 122 M: unix io-multiplex
 123     mx get-global wait-for-events ;
 124
 125 ! On Unix, you're not supposed to set stdin to non-blocking
 126 ! because the fd might be shared with another process (either
 127 ! parent or child). So what we do is have the VM start a thread
 128 ! which pumps data from the real stdin to a pipe. We set the
 129 ! pipe to non-blocking, and read from it instead of the real
 130 ! stdin. Very crufty, but it will suffice until we get native
 131 ! threading support at the language level.
 132 TUPLE: stdin < disposable control size data ;
 133
 134 M: stdin dispose*
 135     [
 136         [ control>> &dispose drop ]
 137         [ size>> &dispose drop ]
 138         [ data>> &dispose drop ]
 139         tri
 140     ] with-destructors ;
 141
 142 : wait-for-stdin ( stdin -- size )
 143     [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
 144     [ size>> ssize_t swap stream-read-c-ptr ]
 145     bi ;
 146
 147 :: refill-stdin ( buffer stdin size -- )
 148     stdin data>> handle-fd buffer buffer-end size read
 149     dup 0 < [
 150         drop
 151         errno EINTR = [
 152             buffer stdin size refill-stdin
 153         ] [
 154             throw-errno
 155         ] if
 156     ] [
 157         size = [ "Error reading stdin pipe" throw ] unless
 158         size buffer buffer+
 159     ] if ;
 160
 161 M: stdin refill
 162     '[
 163         buffer>> _ dup wait-for-stdin refill-stdin f
 164     ] with-timeout ;
 165
 166 M: stdin cancel-operation
 167     [ size>> ] [ control>> ] bi [ cancel-operation ] bi@ ;
 168
 169 : control-write-fd ( -- fd ) &: control_write uint deref ;
 170
 171 : size-read-fd ( -- fd ) &: size_read uint deref ;
 172
 173 : data-read-fd ( -- fd ) &: stdin_read uint deref ;
 174
 175 : <stdin> ( -- stdin )
 176     stdin new-disposable
 177         control-write-fd <fd> <output-port> >>control
 178         size-read-fd <fd> init-fd <input-port> >>size
 179         data-read-fd <fd> >>data ;
 180
 181 : signal-pipe-fd ( -- n )
 182     OBJ-SIGNAL-PIPE special-object ; inline
 183
 184 : signal-pipe-loop ( port -- )
 185     '[
 186         int heap-size _ io:stream-read
 187         dup [ int deref dispatch-signal-hook get-global call( x -- ) ] when*
 188     ] loop ;
 189
 190 : start-signal-pipe-thread ( -- )
 191     signal-pipe-fd [
 192         <fd> init-fd <input-port>
 193         '[ _ signal-pipe-loop ] "Signals" spawn drop
 194     ] when* ;
 195
 196 M: unix init-stdio
 197     <stdin> <input-port>
 198     1 <fd> <output-port>
 199     2 <fd> <output-port>
 200     set-stdio ;
 201
 202 ! mx io-task for embedding an fd-based mx inside another mx
 203 TUPLE: mx-port < port mx ;
 204
 205 : <mx-port> ( mx -- port )
 206     dup fd>> mx-port <port> swap >>mx ;
 207
 208 : multiplexer-error ( n -- n )
 209     dup 0 < [
 210         errno [ EAGAIN = ] [ EINTR = ] bi or
 211         [ drop 0 ] [ throw-errno ] if
 212     ] when ;
 213
 214 :: ?flag ( n mask symbol -- n )
 215     n mask bitand 0 > [ symbol , ] when n ;