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 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 ;
   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 ERROR: not-a-c-ptr object ;
  46
  47 : check-c-ptr ( c-ptr -- c-ptr )
  48     dup c-ptr? [ throw-not-a-c-ptr ] unless ; inline
  49
  50 <PRIVATE
  51
  52 : read-step ( count port -- count ptr/f )
  53     {
  54         { [ over 0 = ] [ 2drop 0 f ] }
  55         { [ dup wait-to-read ] [ 2drop 0 f ] }
  56         [ buffer>> buffer-read-unsafe ]
  57     } cond
  58     { fixnum c-ptr } declare ; inline
  59
  60 : prepare-read ( count port -- count' port )
  61     [ integer>fixnum-strict 0 max ] dip check-disposed ; inline
  62
  63 :: read-loop ( dst n-remaining port n-read -- n-total )
  64     n-remaining port read-step :> ( n-buffered ptr )
  65     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
  72
  73 PRIVATE>
  74
  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* ;
  78
  79 M: input-port stream-read-unsafe
  80     [ check-c-ptr swap ] dip prepare-read 0 read-loop ;
  81
  82 <PRIVATE
  83
  84 : read-until-step ( seps port -- byte-array/f sep/f )
  85     dup wait-to-read [ 2drop f f ] [
  86         buffer>> buffer-read-until
  87     ] if ; inline
  88
  89 : read-until-loop ( seps port accum -- sep/f )
  90     2over read-until-step over [
  91         [ append! ] dip dup [
  92             [ 3drop ] dip
  93         ] [
  94             drop read-until-loop
  95         ] if
  96     ] [
  97         [ 4drop ] dip
  98     ] if ; inline recursive
  99
 100 PRIVATE>
 101
 102 M: input-port stream-read-until
 103     2dup read-until-step dup [
 104         [ 2drop ] 2dip
 105     ] [
 106         over [
 107             drop
 108             BV{ } like [ read-until-loop ] keep B{ } like swap
 109         ] [
 110             [ 2drop ] 2dip
 111         ] if
 112     ] if ;
 113
 114 TUPLE: output-port < buffered-port ;
 115 INSTANCE: output-port output-stream
 116 INSTANCE: output-port file-writer
 117
 118 : <output-port> ( handle -- output-port )
 119     output-port <buffered-port> ;
 120
 121 HOOK: (wait-to-write) io-backend ( port -- )
 122
 123 <PRIVATE
 124
 125 : port-flush ( port -- )
 126     dup buffer>> buffer-empty?
 127     [ drop ] [ dup (wait-to-write) port-flush ] if ; inline recursive
 128
 129 PRIVATE>
 130
 131 M: output-port stream-flush
 132     check-disposed port-flush ;
 133
 134 : wait-to-write ( len port -- )
 135     [ nip ] [ buffer>> buffer-capacity <= ] 2bi
 136     [ drop ] [ port-flush ] if ; inline
 137
 138 M: output-port stream-write1
 139     check-disposed
 140     1 over wait-to-write
 141     buffer>> buffer-write1 ; inline
 142
 143 <PRIVATE
 144
 145 :: port-write ( c-ptr n-remaining port -- )
 146     port buffer>> :> buffer
 147     n-remaining buffer size>> min :> n-write
 148
 149     n-write port wait-to-write
 150     c-ptr n-write buffer buffer-write
 151
 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
 155
 156 PRIVATE>
 157
 158 M: output-port stream-write
 159     check-disposed [
 160         binary-object
 161         [ check-c-ptr ] [ integer>fixnum-strict ] bi*
 162     ] [ port-write ] bi* ;
 163
 164 HOOK: tell-handle os ( handle -- n )
 165
 166 HOOK: seek-handle os ( n seek-type handle -- )
 167
 168 HOOK: can-seek-handle? os ( handle -- ? )
 169
 170 HOOK: handle-length os ( handle -- n/f )
 171
 172 <PRIVATE
 173
 174 : port-tell ( port -- tell-handle buffer-length )
 175     [ handle>> tell-handle ] [ buffer>> buffer-length ] bi ; inline
 176
 177 PRIVATE>
 178
 179 M: input-port stream-tell
 180     check-disposed port-tell - ;
 181
 182 M: output-port stream-tell
 183     check-disposed port-tell + ;
 184
 185 <PRIVATE
 186
 187 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
 188     ! seek-relative needs special handling here, because of the
 189     ! buffer.
 190     seek-type seek-relative eq?
 191     [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
 192     stream ; inline
 193
 194 PRIVATE>
 195
 196 M: input-port stream-seek
 197     check-disposed
 198     do-seek-relative
 199     [ buffer>> 0 swap buffer-reset ]
 200     [ handle>> seek-handle ] bi ;
 201
 202 M: output-port stream-seek
 203     check-disposed
 204     do-seek-relative
 205     [ stream-flush ]
 206     [ handle>> seek-handle ] bi ;
 207
 208 M: buffered-port stream-seekable?
 209     handle>> can-seek-handle? ;
 210
 211 ! Cannot be ``handle>> handle-length`` because of a race condition.
 212 M: buffered-port stream-length
 213     drop f ;
 214
 215 GENERIC: shutdown ( handle -- )
 216
 217 M: object shutdown drop ;
 218
 219 M: output-port dispose*
 220     [
 221         {
 222             [ handle>> &dispose drop ]
 223             [ buffer>> &dispose drop ]
 224             [ port-flush ]
 225             [ handle>> shutdown ]
 226         } cleave
 227     ] with-destructors ;
 228
 229 M: buffered-port dispose*
 230     [
 231         [ buffer>> &dispose drop ]
 232         [ call-next-method ] bi
 233     ] with-destructors ;
 234
 235 M: port cancel-operation handle>> cancel-operation ;
 236
 237 M: port dispose*
 238     [ handle>> &dispose shutdown ] with-destructors ;
 239
 240 GENERIC: underlying-port ( stream -- port )
 241
 242 M: port underlying-port ;
 243
 244 M: encoder underlying-port stream>> underlying-port ;
 245
 246 M: decoder underlying-port stream>> underlying-port ;
 247
 248 GENERIC: underlying-handle ( stream -- handle )
 249
 250 M: object underlying-handle underlying-port handle>> ;
 251
 252 ! Fast-path optimization
 253
 254 HINTS: (decode-until)
 255     { string input-port object } ;