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 assocs io.encodings.binary summary
   7 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-peek1
  45     dup check-disposed dup wait-to-read
  46     [ drop f ] [ buffer>> buffer-peek1 ] if ; inline
  47
  48 M: input-port stream-read1
  49     dup check-disposed
  50     dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
  51
  52 : read-step ( count port -- byte-array/f )
  53     {
  54         { [ over 0 = ] [ 2drop f ] }
  55         { [ dup wait-to-read ] [ 2drop f ] }
  56         [ buffer>> buffer-read ]
  57     } cond ;
  58
  59 : prepare-read ( count stream -- count stream )
  60     dup check-disposed [ 0 max >fixnum ] dip ; inline
  61
  62 M: input-port stream-read-partial ( max stream -- byte-array/f )
  63     prepare-read read-step ;
  64
  65 : read-loop ( count port accum -- )
  66     pick over length - dup 0 > [
  67         pick read-step dup [
  68             append! read-loop
  69         ] [
  70             2drop 2drop
  71         ] if
  72     ] [
  73         2drop 2drop
  74     ] if ;
  75
  76 M: input-port stream-read
  77     prepare-read
  78     2dup read-step dup [
  79         pick over length > [
  80             pick <byte-vector>
  81             [ push-all ] keep
  82             [ read-loop ] keep
  83             B{ } like
  84         ] [ 2nip ] if
  85     ] [ 2nip ] if ;
  86
  87 M: input-port stream-peek [ stream-read ] with-input-rewind ;
  88
  89 : read-until-step ( separators port -- string/f separator/f )
  90     dup wait-to-read [ 2drop f f ] [ buffer>> buffer-until ] if ;
  91
  92 : read-until-loop ( seps port buf -- separator/f )
  93     2over read-until-step over [
  94         [ append! ] dip dup [
  95             [ 3drop ] dip
  96         ] [
  97             drop read-until-loop
  98         ] if
  99     ] [
 100         [ 2drop 2drop ] dip
 101     ] if ;
 102
 103 M: input-port stream-read-until ( seps port -- str/f sep/f )
 104     2dup read-until-step dup [ [ 2drop ] 2dip ] [
 105         over [
 106             drop
 107             BV{ } like [ read-until-loop ] keep B{ } like swap
 108         ] [ [ 2drop ] 2dip ] if
 109     ] if ;
 110
 111 TUPLE: output-port < buffered-port ;
 112
 113 : <output-port> ( handle -- output-port )
 114     output-port <buffered-port> ;
 115
 116 : wait-to-write ( len port -- )
 117     [ nip ] [ buffer>> buffer-capacity <= ] 2bi
 118     [ drop ] [ stream-flush ] if ; inline
 119
 120 M: output-port stream-element-type
 121     stream>> stream-element-type ; inline
 122
 123 M: output-port stream-write1
 124     dup check-disposed
 125     1 over wait-to-write
 126     buffer>> byte>buffer ; inline
 127
 128 : write-in-groups ( byte-array port -- )
 129     [ binary-object <direct-uchar-array> ] dip
 130     [ buffer>> size>> <sliced-groups> ] [ '[ _ stream-write ] ] bi
 131     each ;
 132
 133 M: output-port stream-write
 134     dup check-disposed
 135     2dup [ byte-length ] [ buffer>> size>> ] bi* > [
 136         write-in-groups
 137     ] [
 138         [ [ byte-length ] dip wait-to-write ]
 139         [ buffer>> >buffer ] 2bi
 140     ] if ;
 141
 142 HOOK: (wait-to-write) io-backend ( port -- )
 143
 144 : port-flush ( port -- )
 145     dup buffer>> buffer-empty?
 146     [ drop ] [ dup (wait-to-write) port-flush ] if ;
 147
 148 M: output-port stream-flush ( port -- )
 149     [ check-disposed ] [ port-flush ] bi ;
 150
 151 HOOK: tell-handle os ( handle -- n )
 152
 153 HOOK: seek-handle os ( n seek-type handle -- )
 154
 155 M: input-port stream-tell ( stream -- n )
 156     [ check-disposed ]
 157     [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi - ] bi ;
 158
 159 M: output-port stream-tell ( stream -- n )
 160     [ check-disposed ]
 161     [ [ handle>> tell-handle ] [ buffer>> buffer-length ] bi + ] bi ;
 162
 163 :: do-seek-relative ( n seek-type stream -- n seek-type stream )
 164     ! seek-relative needs special handling here, because of the
 165     ! buffer.
 166     seek-type seek-relative eq?
 167     [ n stream stream-tell + seek-absolute ] [ n seek-type ] if
 168     stream ;
 169
 170 M: input-port stream-seek ( n seek-type stream -- )
 171     do-seek-relative
 172     [ check-disposed ]
 173     [ buffer>> 0 swap buffer-reset ]
 174     [ handle>> seek-handle ] tri ;
 175
 176 M: output-port stream-seek ( n seek-type stream -- )
 177     do-seek-relative
 178     [ check-disposed ]
 179     [ stream-flush ]
 180     [ handle>> seek-handle ] tri ;
 181
 182 GENERIC: shutdown ( handle -- )
 183
 184 M: object shutdown drop ;
 185
 186 M: output-port dispose*
 187     [
 188         {
 189             [ handle>> &dispose drop ]
 190             [ buffer>> &dispose drop ]
 191             [ port-flush ]
 192             [ handle>> shutdown ]
 193         } cleave
 194     ] with-destructors ;
 195
 196 M: buffered-port dispose*
 197     [ call-next-method ] [ buffer>> dispose ] bi ;
 198
 199 M: port cancel-operation handle>> cancel-operation ;
 200
 201 M: port dispose*
 202     [
 203         [ handle>> &dispose drop ]
 204         [ handle>> shutdown ]
 205         bi
 206     ] with-destructors ;
 207
 208 GENERIC: underlying-port ( stream -- port )
 209
 210 M: port underlying-port ;
 211
 212 M: encoder underlying-port stream>> underlying-port ;
 213
 214 M: decoder underlying-port stream>> underlying-port ;
 215
 216 GENERIC: underlying-handle ( stream -- handle )
 217
 218 M: object underlying-handle underlying-port handle>> ;
 219
 220 ! Fast-path optimization
 221 USING: hints strings io.encodings.utf8 io.encodings.ascii
 222 io.encodings.private ;
 223
 224 HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
 225
 226 HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;