core/io/io.factor

   1 ! Copyright (C) 2003, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: io
   4 USING: hashtables generic kernel math namespaces
   5 sequences strings continuations assocs io.styles sbufs ;
   6
   7 GENERIC: stream-close ( stream -- )
   8 GENERIC: set-timeout ( n stream -- )
   9 GENERIC: stream-readln ( stream -- str )
  10 GENERIC: stream-read1 ( stream -- ch/f )
  11 GENERIC: stream-read ( n stream -- str/f )
  12 GENERIC: stream-read-until ( seps stream -- str/f sep/f )
  13 GENERIC: stream-read-partial ( max stream -- str/f )
  14 GENERIC: stream-write1 ( ch stream -- )
  15 GENERIC: stream-write ( str stream -- )
  16 GENERIC: stream-flush ( stream -- )
  17 GENERIC: stream-nl ( stream -- )
  18 GENERIC: stream-format ( str style stream -- )
  19 GENERIC: make-span-stream ( style stream -- stream' )
  20 GENERIC: make-block-stream ( style stream -- stream' )
  21 GENERIC: make-cell-stream ( style stream -- stream' )
  22 GENERIC: stream-write-table ( table-cells style stream -- )
  23
  24 : stream-print ( str stream -- )
  25     [ stream-write ] keep stream-nl ;
  26
  27 : (stream-copy) ( in out -- )
  28     64 1024 * pick stream-read
  29     [ over stream-write (stream-copy) ] [ 2drop ] if* ;
  30
  31 : stream-copy ( in out -- )
  32     [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ]
  33     cleanup ;
  34
  35 ! Default stream
  36 SYMBOL: stdio
  37
  38 : close ( -- ) stdio get stream-close ;
  39
  40 : readln ( -- str/f ) stdio get stream-readln ;
  41 : read1 ( -- ch/f ) stdio get stream-read1 ;
  42 : read ( n -- str/f ) stdio get stream-read ;
  43 : read-until ( seps -- str/f sep/f ) stdio get stream-read-until ;
  44
  45 : write1 ( ch -- ) stdio get stream-write1 ;
  46 : write ( str -- ) stdio get stream-write ;
  47 : flush ( -- ) stdio get stream-flush ;
  48
  49 : nl ( -- ) stdio get stream-nl ;
  50 : format ( str style -- ) stdio get stream-format ;
  51
  52 : with-stream* ( stream quot -- )
  53     stdio swap with-variable ; inline
  54
  55 : with-stream ( stream quot -- )
  56     swap [ [ close ] [ ] cleanup ] with-stream* ; inline
  57
  58 : tabular-output ( style quot -- )
  59     swap >r { } make r> stdio get stream-write-table ; inline
  60
  61 : with-row ( quot -- )
  62     { } make , ; inline
  63
  64 : with-cell ( quot -- )
  65     H{ } stdio get make-cell-stream
  66     [ swap with-stream ] keep , ; inline
  67
  68 : write-cell ( str -- )
  69     [ write ] with-cell ; inline
  70
  71 : with-style ( style quot -- )
  72     swap dup assoc-empty? [
  73         drop call
  74     ] [
  75         stdio get make-span-stream swap with-stream
  76     ] if ; inline
  77
  78 : with-nesting ( style quot -- )
  79     >r stdio get make-block-stream r> with-stream ; inline
  80
  81 : print ( string -- ) stdio get stream-print ;
  82
  83 : bl ( -- ) " " write ;
  84
  85 : write-object ( str obj -- )
  86     presented associate format ;
  87
  88 : lines-loop ( -- ) readln [ , lines-loop ] when* ;
  89
  90 : lines ( stream -- seq )
  91     [ [ lines-loop ] { } make ] with-stream ;
  92
  93 : contents ( stream -- str )
  94     2048 <sbuf> [ stream-copy ] keep >string ;