basis/io/ports/ports.factor

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