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 ;
13 GENERIC: handle-fd ( handle -- fd )
15 TUPLE: fd < disposable fd ;
17 : init-fd ( fd -- fd )
20 dup fd>> F_SETFL O_NONBLOCK [ fcntl ] unix-system-call drop
21 dup fd>> F_SETFD FD_CLOEXEC [ fcntl ] unix-system-call drop
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
29 fd new-disposable swap >>fd ;
32 dup disposed>> [ drop ] [
36 [ unregister-disposable ]
41 M: fd handle-fd dup check-disposed fd>> ;
43 M: fd cancel-operation ( fd -- )
44 dup disposed>> [ drop ] [
47 [ remove-input-callbacks [ t swap resume-with ] each ]
48 [ remove-output-callbacks [ t swap resume-with ] each ]
52 M: unix tell-handle ( handle -- n )
53 fd>> 0 SEEK_CUR [ lseek ] unix-system-call [ io-error ] [ ] bi ;
55 M: unix seek-handle ( n seek-type handle -- )
57 { io:seek-absolute [ SEEK_SET ] }
58 { io:seek-relative [ SEEK_CUR ] }
59 { io:seek-end [ SEEK_END ] }
62 [ fd>> swap ] dip [ lseek ] unix-system-call drop ;
64 SYMBOL: +retry+ ! just try the operation again without blocking
70 M: io-timeout summary drop "I/O operation timed out" ;
72 : wait-for-fd ( handle event -- )
73 dup +retry+ eq? [ 2drop ] [
75 swap handle-fd mx get-global _ {
76 { +input+ [ add-input-callback ] }
77 { +output+ [ add-output-callback ] }
79 ] "I/O" suspend nip [ io-timeout ] when
82 : wait-for-port ( port event -- )
83 '[ handle>> _ wait-for-fd ] with-timeout ;
86 CONSTANT: file-mode OCT: 0666
89 : (refill) ( port -- n )
91 [ buffer>> buffer-end ]
92 [ buffer>> buffer-capacity ] tri read ;
94 ! Returns an event to wait for which will ensure completion of
96 GENERIC: refill ( port handle -- event/f )
99 fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
101 { [ dup 0 >= ] [ swap buffer>> n>buffer f ] }
102 { [ errno EINTR = ] [ 2drop +retry+ ] }
103 { [ errno EAGAIN = ] [ 2drop +input+ ] }
107 M: unix (wait-to-read) ( port -- )
109 dup handle>> dup check-disposed refill dup
110 [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
113 GENERIC: drain ( port handle -- event/f )
116 fd>> over buffer>> [ buffer@ ] [ buffer-length ] bi write
119 over buffer>> buffer-consume
120 buffer>> buffer-empty? f +output+ ?
122 { [ errno EINTR = ] [ 2drop +retry+ ] }
123 { [ errno EAGAIN = ] [ 2drop +output+ ] }
127 M: unix (wait-to-write) ( port -- )
129 dup handle>> dup check-disposed drain
130 dup [ wait-for-port ] [ 2drop ] if ;
132 M: unix io-multiplex ( ms/f -- )
133 mx get-global wait-for-events ;
135 ! On Unix, you're not supposed to set stdin to non-blocking
136 ! because the fd might be shared with another process (either
137 ! parent or child). So what we do is have the VM start a thread
138 ! which pumps data from the real stdin to a pipe. We set the
139 ! pipe to non-blocking, and read from it instead of the real
140 ! stdin. Very crufty, but it will suffice until we get native
141 ! threading support at the language level.
142 TUPLE: stdin < disposable control size data ;
146 [ control>> &dispose drop ]
147 [ size>> &dispose drop ]
148 [ data>> &dispose drop ]
152 : wait-for-stdin ( stdin -- n )
153 [ control>> CHAR: X over io:stream-write1 io:stream-flush ]
154 [ size>> ssize_t heap-size swap io:stream-read *int ]
157 :: refill-stdin ( buffer stdin size -- )
158 stdin data>> handle-fd buffer buffer-end size read
161 errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if
163 size = [ "Error reading stdin pipe" throw ] unless
168 [ buffer>> ] [ dup wait-for-stdin ] bi* refill-stdin f ;
170 : control-write-fd ( -- fd ) &: control_write *uint ;
172 : size-read-fd ( -- fd ) &: size_read *uint ;
174 : data-read-fd ( -- fd ) &: stdin_read *uint ;
176 : <stdin> ( -- stdin )
178 control-write-fd <fd> <output-port> >>control
179 size-read-fd <fd> init-fd <input-port> >>size
180 data-read-fd <fd> >>data ;
188 ! mx io-task for embedding an fd-based mx inside another mx
189 TUPLE: mx-port < port mx ;
191 : <mx-port> ( mx -- port )
192 dup fd>> mx-port <port> swap >>mx ;
194 : multiplexer-error ( n -- n )
196 errno [ EAGAIN = ] [ EINTR = ] bi or
197 [ drop 0 ] [ (io-error) ] if
200 : ?flag ( n mask symbol -- n )
201 pick rot bitand 0 > [ , ] [ drop ] if ;