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: math kernel io sequences io.buffers io.timeouts generic
   4 byte-vectors system io.encodings math.order io.backend
   5 continuations classes byte-arrays namespaces splitting grouping
   6 dlists alien alien.c-types alien.data assocs io.encodings.binary
   7 summary accessors destructors combinators fry specialized-arrays
   8 locals ;
   9 SPECIALIZED-ARRAY: uchar
  10 IN: io.ports
  11
  12 SYMBOL: default-buffer-size
  13 64 1024 * default-buffer-size set-global
  14
  15 TUPLE: port < disposable handle timeout ;
  16
  17 M: port timeout timeout>> ;
  18
  19 M: port set-timeout timeout<< ;
  20
  21 : <port> ( handle class -- port )
  22     new-disposable swap >>handle ; inline
  23
  24 TUPLE: buffered-port < port { buffer buffer } ;
  25
  26 : <buffered-port> ( handle class -- port )
  27     <port>
  28         default-buffer-size get <buffer> >>buffer ; inline
  29
  30 TUPLE: input-port < buffered-port ;
  31
  32 M: input-port stream-element-type drop +byte+ ; inline
  33
  34 : <input-port> ( handle -- input-port )
  35     input-port <buffered-port> ;
  36
  37 HOOK: (wait-to-read) io-backend ( port -- )
  38
  39 : wait-to-read ( port -- eof? )
  40     dup buffer>> buffer-empty? [
  41         dup (wait-to-read) buffer>> buffer-empty?
  42     ] [ drop f ] if ; inline
  43
  44 M: input-port stream-read1
  45     dup check-disposed
  46     dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
  47
  48 : read-step ( count port -- byte-array/f )
  49     {
  50         { [ over 0 = ] [ 2drop f ] }
  51         { [ dup wait-to-read ] [ 2drop f ] }
  52         [ buffer>> buffer-read ]
  53     } cond ;
  54
  55 : prepare-read ( count stream -- count stream )
  56     dup check-disposed [ 0 max >fixnum ] dip ; inline
  57
  58 M: input-port stream-read-partial ( max stream -- byte-array/f )
  59     prepare-read read-step ;
  60
  61 : read-loop ( count port accum -- )
  62     pick over length - dup 0 > [
  63         pick read-step dup [
  64             append! read-loop
  65         ] [
  66             2drop 2drop
  67         ] if
  68     ] [
  69         2drop 2drop
  70     ] if ;
  71
  72 M: input-port stream-read
  73     prepare-read
  74     2dup read-step dup [
  75         pick over length > [
  76             pick <byte-vector>
  77             [ push-all ] keep
  78             [ read-loop ] keep
  79             B{ } like
  80         ] [ 2nip ] if
  81     ] [ 2nip ] if ;
  82
  83 : read-until-step ( separators port -- string/f separator/f )
  84     dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
  85
  86 : read-until-loop ( seps port buf -- separator/f )
  87     2over read-until-step over [
  88         [ append! ] dip dup [
  89             [ 3drop ] dip
  90         ] [
  91             drop read-until-loop
  92         ] if
  93     ] [
  94         [ 2drop 2drop ] dip
  95     ] if ;
  96
  97 M: input-port stream-read-until ( seps port -- str/f sep/f )
  98     2dup read-until-step dup [ [ 2drop ] 2dip ] [
  99         over [
 100             drop
 101             BV{ } like [ read-until-loop ] keep B{ } like swap
 102         ] [ [ 2drop ] 2dip ] if
 103     ] if ;
 104
 105 TUPLE: output-port < buffered-port ;
 106
 107 : <output-port> ( handle -- output-port )
 108     output-port <buffered-port> ;
 109
 110 : wait-to-write ( len port -- )
 111     [ nip ] [ buffer>> buffer-capacity <= ] 2bi
 112     [ drop ] [ stream-flush ] if ; inline
 113
 114 M: output-port stream-element-type
 115     stream>> stream-element-type ; inline
 116
 117 M: output-port stream-write1
 118     dup check-disposed
 119     1 over wait-to-write
 120     buffer>> byte>buffer ; inline
 121
 122 : write-in-groups ( byte-array port -- )
 123     [ binary-object uchar <c-direct-array> ] dip
 124     [ buffer>> size>> <sliced-groups> ] [ '[ _ stream-write ] ] bi
 125     each ;
 126
 127 M: output-port stream-write
 128     dup check-disposed
 129     2dup [ byte-length ] [ buffer>> size>> ] bi* > [
 130         write-in-groups
 131     ] [
 132         [ [ byte-length ] dip wait-to-write ]
 133         [ buffer>> >buffer ] 2bi
 134     ] if ;
 135
 136 HOOK: (wait-to-write) io-backend ( port -- )
 137
 138 : port-flush ( port -- )
 139     dup buffer>> buffer-empty?
 140     [ drop ] [ dup (wait-to-write) port-flush ] if ;
 141
 142 M: output-port stream-flush ( port -- )
 143     [ check-disposed ] [ port-flush ] bi ;
 144
 145 HOOK: tell-handle os ( handle -- n )
 146
 147 HOOK: seek-handle os ( n seek-type handle -- )
 148
 149 M: input-port stream-tell ( stream -- n )
 150     [ check-disposed ]
 151     [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
 152
 153 M: output-port stream-tell ( stream -- n )
 154     [ check-disposed ]
 155     [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
 156
 157 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
 158     ! seek-relative needs special handling here, because of the
 159     ! buffer.
 160     seek-type seek-relative eq?
 161     [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
 162     stream ;
 163
 164 M: input-port stream-seek ( n seek-type stream -- )
 165     do-seek-relative
 166     [ check-disposed ]
 167     [ buffer>> 0 swap buffer-reset ]
 168     [ handle>> seek-handle ] tri ;
 169
 170 M: output-port stream-seek ( n seek-type stream -- )
 171     do-seek-relative
 172     [ check-disposed ]
 173     [ stream-flush ]
 174     [ handle>> seek-handle ] tri ;
 175
 176 GENERIC: shutdown ( handle -- )
 177
 178 M: object shutdown drop ;
 179
 180 M: output-port dispose*
 181     [
 182         {
 183             [ handle>> &dispose drop ]
 184             [ buffer>> &dispose drop ]
 185             [ port-flush ]
 186             [ handle>> shutdown ]
 187         } cleave
 188     ] with-destructors ;
 189
 190 M: buffered-port dispose*
 191     [ call-next-method ] [ buffer>> dispose ] bi ;
 192
 193 M: port cancel-operation handle>> cancel-operation ;
 194
 195 M: port dispose*
 196     [
 197         [ handle>> &dispose drop ]
 198         [ handle>> shutdown ]
 199         bi
 200     ] with-destructors ;
 201
 202 GENERIC: underlying-port ( stream -- port )
 203
 204 M: port underlying-port ;
 205
 206 M: encoder underlying-port stream>> underlying-port ;
 207
 208 M: decoder underlying-port stream>> underlying-port ;
 209
 210 GENERIC: underlying-handle ( stream -- handle )
 211
 212 M: object underlying-handle underlying-port handle>> ;
 213
 214 ! Fast-path optimization
 215 USING: hints strings io.encodings.utf8 io.encodings.ascii
 216 io.encodings.private ;
 217
 218 HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
 219
 220 HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;