extra/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 debugger classes byte-arrays namespaces splitting
   6 dlists assocs io.encodings.binary inspector accessors
   7 destructors ;
   8 IN: io.ports
   9
  10 SYMBOL: default-buffer-size
  11 64 1024 * default-buffer-size set-global
  12
  13 TUPLE: port handle timeout disposed ;
  14
  15 M: port timeout timeout>> ;
  16
  17 M: port set-timeout (>>timeout) ;
  18
  19 : <port> ( handle class -- port )
  20     new swap >>handle ; inline
  21
  22 TUPLE: buffered-port < port 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 : <input-port> ( handle -- input-port )
  31     input-port <buffered-port> ;
  32
  33 HOOK: (wait-to-read) io-backend ( port -- )
  34
  35 : wait-to-read ( port -- eof? )
  36     dup buffer>> buffer-empty? [
  37         dup (wait-to-read) buffer>> buffer-empty?
  38     ] [ drop f ] if ;
  39
  40 M: input-port stream-read1
  41     dup check-disposed
  42     dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
  43
  44 : read-step ( count port -- byte-array/f )
  45     dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
  46
  47 M: input-port stream-read-partial ( max stream -- byte-array/f )
  48     dup check-disposed
  49     >r 0 max >integer r> read-step ;
  50
  51 : read-loop ( count port accum -- )
  52     pick over length - dup 0 > [
  53         pick read-step dup [
  54             over push-all read-loop
  55         ] [
  56             2drop 2drop
  57         ] if
  58     ] [
  59         2drop 2drop
  60     ] if ;
  61
  62 M: input-port stream-read
  63     dup check-disposed
  64     >r 0 max >fixnum r>
  65     2dup read-step dup [
  66         pick over length > [
  67             pick <byte-vector>
  68             [ push-all ] keep
  69             [ read-loop ] keep
  70             B{ } like
  71         ] [ 2nip ] if
  72     ] [ 2nip ] if ;
  73
  74 TUPLE: output-port < buffered-port ;
  75
  76 : <output-port> ( handle -- output-port )
  77     output-port <buffered-port> ;
  78
  79 : can-write? ( len buffer -- ? )
  80     [ buffer-fill + ] keep buffer-capacity <= ;
  81
  82 : wait-to-write ( len port -- )
  83     tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
  84
  85 M: output-port stream-write1
  86     dup check-disposed
  87     1 over wait-to-write
  88     buffer>> byte>buffer ;
  89
  90 M: output-port stream-write
  91     dup check-disposed
  92     over length over buffer>> buffer-size > [
  93         [ buffer>> buffer-size <groups> ]
  94         [ [ stream-write ] curry ] bi
  95         each
  96     ] [
  97         [ >r length r> wait-to-write ]
  98         [ buffer>> >buffer ] 2bi
  99     ] if ;
 100
 101 HOOK: (wait-to-write) io-backend ( port -- )
 102
 103 GENERIC: shutdown ( handle -- )
 104
 105 M: object shutdown drop ;
 106
 107 : port-flush ( port -- )
 108     dup buffer>> buffer-empty?
 109     [ drop ] [ dup (wait-to-write) port-flush ] if ;
 110
 111 M: output-port stream-flush ( port -- )
 112     [ check-disposed ] [ port-flush ] bi ;
 113
 114 M: output-port dispose*
 115     [
 116         [ handle>> &dispose drop ]
 117         [ port-flush ]
 118         [ handle>> shutdown ]
 119         tri
 120     ] with-destructors ;
 121
 122 M: buffered-port dispose*
 123     [ call-next-method ]
 124     [ [ [ buffer-free ] when* f ] change-buffer drop ]
 125     bi ;
 126
 127 M: port cancel-operation handle>> cancel-operation ;
 128
 129 M: port dispose*
 130     [
 131         [ handle>> &dispose drop ]
 132         [ handle>> shutdown ]
 133         bi
 134     ] with-destructors ;