1 ! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien byte-arrays combinators destructors hints
4 io io.backend io.buffers io.encodings io.files io.timeouts
5 kernel kernel.private libc locals math math.order math.private
6 namespaces sequences strings system ;
9 SYMBOL: default-buffer-size
10 64 1024 * default-buffer-size set-global
12 TUPLE: port < disposable handle timeout ;
14 M: port timeout timeout>> ;
16 M: port set-timeout timeout<< ;
18 : <port> ( handle class -- port )
19 new-disposable swap >>handle ; inline
21 TUPLE: buffered-port < port { buffer buffer } ;
23 : <buffered-port> ( handle class -- port )
25 default-buffer-size get <buffer> >>buffer ; inline
27 TUPLE: input-port < buffered-port ;
28 INSTANCE: input-port input-stream
29 INSTANCE: input-port file-reader
31 : <input-port> ( handle -- input-port )
32 input-port <buffered-port> ; inline
34 HOOK: (wait-to-read) io-backend ( port -- )
36 : wait-to-read ( port -- eof? )
37 dup buffer>> buffer-empty? [
38 dup (wait-to-read) buffer>> buffer-empty?
39 ] [ drop f ] if ; inline
41 M: input-port stream-read1
43 dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
45 ERROR: not-a-c-ptr object ;
47 : check-c-ptr ( c-ptr -- c-ptr )
48 dup c-ptr? [ throw-not-a-c-ptr ] unless ; inline
52 : read-step ( count port -- count ptr/f )
54 { [ over 0 = ] [ 2drop 0 f ] }
55 { [ dup wait-to-read ] [ 2drop 0 f ] }
56 [ buffer>> buffer-read-unsafe ]
58 { fixnum c-ptr } declare ; inline
60 : prepare-read ( count port -- count' port )
61 [ integer>fixnum-strict 0 max ] dip check-disposed ; inline
63 :: read-loop ( dst n-remaining port n-read -- n-total )
64 n-remaining port read-step :> ( n-buffered ptr )
66 dst ptr n-buffered memcpy
67 n-remaining n-buffered fixnum-fast :> n-remaining'
68 n-read n-buffered fixnum+fast :> n-read'
69 n-buffered dst <displaced-alien> :> dst'
70 dst' n-remaining' port n-read' read-loop
71 ] [ n-read ] if ; inline recursive
75 M: input-port stream-read-partial-unsafe
76 [ check-c-ptr swap ] dip prepare-read read-step
77 [ swap [ memcpy ] keep ] [ 2drop 0 ] if* ;
79 M: input-port stream-read-unsafe
80 [ check-c-ptr swap ] dip prepare-read 0 read-loop ;
84 : read-until-step ( seps port -- byte-array/f sep/f )
85 dup wait-to-read [ 2drop f f ] [
86 buffer>> buffer-read-until
89 : read-until-loop ( seps port accum -- sep/f )
90 2over read-until-step over [
98 ] if ; inline recursive
102 M: input-port stream-read-until
103 2dup read-until-step dup [
108 BV{ } like [ read-until-loop ] keep B{ } like swap
114 TUPLE: output-port < buffered-port ;
115 INSTANCE: output-port output-stream
116 INSTANCE: output-port file-writer
118 : <output-port> ( handle -- output-port )
119 output-port <buffered-port> ;
121 HOOK: (wait-to-write) io-backend ( port -- )
125 : port-flush ( port -- )
126 dup buffer>> buffer-empty?
127 [ drop ] [ dup (wait-to-write) port-flush ] if ; inline recursive
131 M: output-port stream-flush
132 check-disposed port-flush ;
134 : wait-to-write ( len port -- )
135 [ nip ] [ buffer>> buffer-capacity <= ] 2bi
136 [ drop ] [ port-flush ] if ; inline
138 M: output-port stream-write1
141 buffer>> buffer-write1 ; inline
145 :: port-write ( c-ptr n-remaining port -- )
146 port buffer>> :> buffer
147 n-remaining buffer size>> min :> n-write
149 n-write port wait-to-write
150 c-ptr n-write buffer buffer-write
152 n-remaining n-write fixnum-fast dup 0 > [
153 n-write c-ptr <displaced-alien> swap port port-write
154 ] [ drop ] if ; inline recursive
158 M: output-port stream-write
161 [ check-c-ptr ] [ integer>fixnum-strict ] bi*
162 ] [ port-write ] bi* ;
164 HOOK: tell-handle os ( handle -- n )
166 HOOK: seek-handle os ( n seek-type handle -- )
168 HOOK: can-seek-handle? os ( handle -- ? )
170 HOOK: handle-length os ( handle -- n/f )
174 : port-tell ( port -- tell-handle buffer-length )
175 [ handle>> tell-handle ] [ buffer>> buffer-length ] bi ; inline
179 M: input-port stream-tell
180 check-disposed port-tell - ;
182 M: output-port stream-tell
183 check-disposed port-tell + ;
187 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
188 ! seek-relative needs special handling here, because of the
190 seek-type seek-relative eq?
191 [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
196 M: input-port stream-seek
199 [ buffer>> 0 swap buffer-reset ]
200 [ handle>> seek-handle ] bi ;
202 M: output-port stream-seek
206 [ handle>> seek-handle ] bi ;
208 M: buffered-port stream-seekable?
209 handle>> can-seek-handle? ;
211 ! Cannot be ``handle>> handle-length`` because of a race condition.
212 M: buffered-port stream-length
215 GENERIC: shutdown ( handle -- )
217 M: object shutdown drop ;
219 M: output-port dispose*
222 [ handle>> &dispose drop ]
223 [ buffer>> &dispose drop ]
225 [ handle>> shutdown ]
229 M: buffered-port dispose*
231 [ buffer>> &dispose drop ]
232 [ call-next-method ] bi
235 M: port cancel-operation handle>> cancel-operation ;
238 [ handle>> &dispose shutdown ] with-destructors ;
240 GENERIC: underlying-port ( stream -- port )
242 M: port underlying-port ;
244 M: encoder underlying-port stream>> underlying-port ;
246 M: decoder underlying-port stream>> underlying-port ;
248 GENERIC: underlying-handle ( stream -- handle )
250 M: object underlying-handle underlying-port handle>> ;
252 ! Fast-path optimization
254 HINTS: (decode-until)
255 { string input-port object } ;