basis/io/ports/ports.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov, Doug Coleman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien classes combinators destructors hints io
   4 io.backend io.buffers io.encodings io.files io.timeouts kernel
   5 kernel.private libc locals math math.order math.private
   6 namespaces sequences strings system ;
   7 IN: io.ports
   8
   9 SYMBOL: default-buffer-size
  10 64 1024 * default-buffer-size set-global
  11
  12 TUPLE: port < disposable handle timeout ;
  13
  14 M: port timeout timeout>> ;
  15
  16 M: port set-timeout timeout<< ;
  17
  18 : <port> ( handle class -- port )
  19     new-disposable swap >>handle ; inline
  20
  21 TUPLE: buffered-port < port { buffer buffer } ;
  22
  23 : <buffered-port> ( handle class -- port )
  24     <port>
  25         default-buffer-size get <buffer> >>buffer ; inline
  26
  27 TUPLE: input-port < buffered-port ;
  28 INSTANCE: input-port input-stream
  29 INSTANCE: input-port file-reader
  30
  31 : <input-port> ( handle -- input-port )
  32     input-port <buffered-port> ; inline
  33
  34 HOOK: (wait-to-read) io-backend ( port -- )
  35
  36 : wait-to-read ( port -- eof? )
  37     dup buffer>> buffer-empty? [
  38         dup (wait-to-read) buffer>> buffer-empty?
  39     ] [ drop f ] if ; inline
  40
  41 M: input-port stream-read1
  42     check-disposed
  43     dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
  44
  45 <PRIVATE
  46
  47 : read-step ( count port -- count ptr/f )
  48     {
  49         { [ over 0 = ] [ 2drop 0 f ] }
  50         { [ dup wait-to-read ] [ 2drop 0 f ] }
  51         [ buffer>> buffer-read-unsafe ]
  52     } cond
  53     { fixnum c-ptr } declare ; inline
  54
  55 : prepare-read ( count port -- count' port )
  56     [ integer>fixnum-strict 0 max ] dip check-disposed ; inline
  57
  58 :: read-loop ( dst n-remaining port n-read -- n-total )
  59     n-remaining port read-step :> ( n-buffered ptr )
  60     ptr [
  61         dst ptr n-buffered memcpy
  62         n-remaining n-buffered fixnum-fast :> n-remaining'
  63         n-read n-buffered fixnum+fast :> n-read'
  64         n-buffered dst <displaced-alien> :> dst'
  65         dst' n-remaining' port n-read' read-loop
  66     ] [ n-read ] if ; inline recursive
  67
  68 PRIVATE>
  69
  70 M: input-port stream-read-partial-unsafe
  71     [ c-ptr check-instance swap ] dip prepare-read read-step
  72     [ swap [ memcpy ] keep ] [ 2drop 0 ] if* ;
  73
  74 M: input-port stream-read-unsafe
  75     [ c-ptr check-instance swap ] dip prepare-read 0 read-loop ;
  76
  77 <PRIVATE
  78
  79 : read-until-step ( seps port -- byte-array/f sep/f )
  80     dup wait-to-read [ 2drop f f ] [
  81         buffer>> buffer-read-until
  82     ] if ; inline
  83
  84 : read-until-loop ( seps port accum -- sep/f )
  85     2over read-until-step over [
  86         [ append! ] dip dup [
  87             3nip
  88         ] [
  89             drop read-until-loop
  90         ] if
  91     ] [
  92         4nip
  93     ] if ; inline recursive
  94
  95 PRIVATE>
  96
  97 M: input-port stream-read-until
  98     2dup read-until-step dup [
  99         2nipd
 100     ] [
 101         over [
 102             drop
 103             BV{ } like [ read-until-loop ] keep B{ } like swap
 104         ] [
 105             2nipd
 106         ] if
 107     ] if ;
 108
 109 TUPLE: output-port < buffered-port ;
 110 INSTANCE: output-port output-stream
 111 INSTANCE: output-port file-writer
 112
 113 : <output-port> ( handle -- output-port )
 114     output-port <buffered-port> ;
 115
 116 HOOK: (wait-to-write) io-backend ( port -- )
 117
 118 <PRIVATE
 119
 120 : port-flush ( port -- )
 121     dup buffer>> buffer-empty?
 122     [ drop ] [ dup (wait-to-write) port-flush ] if ; inline recursive
 123
 124 PRIVATE>
 125
 126 M: output-port stream-flush
 127     check-disposed port-flush ;
 128
 129 : wait-to-write ( len port -- )
 130     [ nip ] [ buffer>> buffer-capacity <= ] 2bi
 131     [ drop ] [ port-flush ] if ; inline
 132
 133 M: output-port stream-write1
 134     check-disposed
 135     1 over wait-to-write
 136     buffer>> buffer-write1 ; inline
 137
 138 <PRIVATE
 139
 140 :: port-write ( c-ptr n-remaining port -- )
 141     port buffer>> :> buffer
 142     n-remaining buffer size>> min :> n-write
 143
 144     n-write port wait-to-write
 145     c-ptr n-write buffer buffer-write
 146
 147     n-remaining n-write fixnum-fast dup 0 > [
 148         n-write c-ptr <displaced-alien> swap port port-write
 149     ] [ drop ] if ; inline recursive
 150
 151 PRIVATE>
 152
 153 M: output-port stream-write
 154     check-disposed [
 155         binary-object
 156         [ c-ptr check-instance ] [ integer>fixnum-strict ] bi*
 157     ] [ port-write ] bi* ;
 158
 159 HOOK: tell-handle os ( handle -- n )
 160
 161 HOOK: seek-handle os ( n seek-type handle -- )
 162
 163 HOOK: can-seek-handle? os ( handle -- ? )
 164
 165 HOOK: handle-length os ( handle -- n/f )
 166
 167 <PRIVATE
 168
 169 : port-tell ( port -- tell-handle buffer-length )
 170     [ handle>> tell-handle ] [ buffer>> buffer-length ] bi ; inline
 171
 172 PRIVATE>
 173
 174 M: input-port stream-tell
 175     check-disposed port-tell - ;
 176
 177 M: output-port stream-tell
 178     check-disposed port-tell + ;
 179
 180 <PRIVATE
 181
 182 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
 183     ! seek-relative needs special handling here, because of the
 184     ! buffer.
 185     seek-type seek-relative eq?
 186     [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
 187     stream ; inline
 188
 189 PRIVATE>
 190
 191 M: input-port stream-seek
 192     check-disposed
 193     do-seek-relative
 194     [ buffer>> 0 swap buffer-reset ]
 195     [ handle>> seek-handle ] bi ;
 196
 197 M: output-port stream-seek
 198     check-disposed
 199     do-seek-relative
 200     [ stream-flush ]
 201     [ handle>> seek-handle ] bi ;
 202
 203 M: buffered-port stream-seekable?
 204     handle>> can-seek-handle? ;
 205
 206 M: buffered-port stream-length
 207     handle>> handle-length [ f ] when-zero ;
 208
 209 GENERIC: shutdown ( handle -- )
 210
 211 M: object shutdown drop ;
 212
 213 M: output-port dispose*
 214     [
 215         {
 216             [ handle>> &dispose drop ]
 217             [ buffer>> &dispose drop ]
 218             [ port-flush ]
 219             [ handle>> shutdown ]
 220         } cleave
 221     ] with-destructors ;
 222
 223 M: buffered-port dispose*
 224     [
 225         [ buffer>> &dispose drop ]
 226         [ call-next-method ] bi
 227     ] with-destructors ;
 228
 229 M: port cancel-operation handle>> cancel-operation ;
 230
 231 M: port dispose*
 232     [ handle>> &dispose shutdown ] with-destructors ;
 233
 234 GENERIC: underlying-port ( stream -- port )
 235
 236 M: port underlying-port ;
 237
 238 M: encoder underlying-port stream>> underlying-port ;
 239
 240 M: decoder underlying-port stream>> underlying-port ;
 241
 242 GENERIC: underlying-handle ( stream -- handle )
 243
 244 M: object underlying-handle underlying-port handle>> ;
 245
 246 ! Fast-path optimization
 247
 248 HINTS: (decode-until)
 249     { string input-port object } ;