basis/io/streams/limited/limited.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! Copyright (C) 2009 Doug Coleman.
   3 ! See http://factorcode.org/license.txt for BSD license.
   4 USING: accessors byte-vectors combinators destructors fry io
   5 io.encodings io.files io.files.info kernel locals math
   6 namespaces sequences math.order ;
   7 IN: io.streams.limited
   8
   9 TUPLE: limited-stream stream count limit current start stop ;
  10 INSTANCE: limited-stream input-stream
  11
  12 : <limited-stream> ( stream limit -- stream' )
  13     limited-stream new
  14         swap >>limit
  15         swap >>stream
  16         0 >>count ;
  17
  18 : <limited-file-reader> ( path encoding -- stream' )
  19     [ <file-reader> ]
  20     [ drop file-info size>> ] 2bi
  21     <limited-stream> ;
  22
  23 GENERIC#: limit-stream 1 ( stream limit -- stream' )
  24
  25 M: decoder limit-stream ( stream limit -- stream' )
  26     '[ stream>> _ limit-stream ] [ code>> ] [ cr>> ] tri
  27     decoder boa ; inline
  28
  29 M: object limit-stream ( stream limit -- stream' )
  30     <limited-stream> ;
  31
  32 : limited-input ( limit -- )
  33     [ input-stream ] dip '[ _ limit-stream ] change ;
  34
  35 : with-limited-stream ( stream limit quot -- )
  36     [ limit-stream ] dip call ; inline
  37
  38 : with-limited-input ( limit quot -- )
  39     [ [ input-stream get ] dip limit-stream input-stream ] dip
  40     with-variable ; inline
  41
  42 ERROR: limit-exceeded n stream ;
  43
  44 <PRIVATE
  45
  46 : adjust-current-limit ( n stream -- n' stream )
  47     2dup [ + ] change-current
  48     [ current>> ] [ stop>> ] bi >
  49     [
  50         dup [ current>> ] [ stop>> ] bi -
  51         '[ _ - ] dip
  52     ] when ; inline
  53
  54 : adjust-count-limit ( n stream -- n' stream )
  55     2dup [ + ] change-count
  56     [ count>> ] [ limit>> ] bi >
  57     [
  58         dup [ count>> ] [ limit>> ] bi -
  59         '[ _ - ] dip
  60         dup limit>> >>count
  61     ] when ; inline
  62
  63 : check-count-bounds ( n stream -- n stream )
  64     dup [ count>> ] [ limit>> ] bi >
  65     [ limit-exceeded ] when ;
  66
  67 : check-current-bounds ( n stream -- n stream )
  68     dup [ current>> ] [ start>> ] bi <
  69     [ limit-exceeded ] when ;
  70
  71 : adjust-limited-read ( n stream -- n stream )
  72     dup start>> [
  73         check-current-bounds adjust-current-limit
  74     ] [
  75         check-count-bounds adjust-count-limit
  76     ] if ;
  77
  78 : maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f )
  79     [ adjust-limited-read ] dip
  80     pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline
  81
  82 :: maybe-read-unsafe ( n buf limited-stream quot: ( n buf stream -- count ) -- count )
  83     n limited-stream adjust-limited-read :> ( n' lstream' )
  84     n' 0 <= [ 0 ] [ n' buf lstream' stream>> quot call ] if ; inline
  85
  86 PRIVATE>
  87
  88 M: limited-stream stream-read1
  89     1 swap
  90     [ nip stream-read1 ] maybe-read ;
  91
  92 M: limited-stream stream-read-unsafe
  93     [ stream-read-unsafe ] maybe-read-unsafe ;
  94
  95 M: limited-stream stream-read-partial-unsafe
  96     [ stream-read-partial-unsafe ] maybe-read-unsafe ;
  97
  98 <PRIVATE
  99
 100 : (read-until) ( stream seps buf -- stream seps buf sep/f )
 101     3dup [ [ stream-read1 dup ] dip member-eq? ] dip
 102     swap [
 103         drop
 104     ] [
 105         over [ push (read-until) ] [ drop ] if
 106     ] if ;
 107
 108 :: limited-stream-seek ( n seek-type stream -- )
 109     seek-type {
 110         { seek-absolute [ n stream current<< ] }
 111         { seek-relative [ stream [ n + ] change-current drop ] }
 112         { seek-end [ stream stop>> n - stream current<< ] }
 113         [ bad-seek-type ]
 114     } case ;
 115
 116 : >limited-seek ( stream -- stream' )
 117     dup start>> [
 118         dup stream-tell >>current
 119         dup [ current>> ] [ count>> ] bi - >>start
 120         dup [ start>> ] [ limit>> ] bi + >>stop
 121     ] unless ;
 122
 123 PRIVATE>
 124
 125 M: limited-stream stream-read-until
 126     swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
 127
 128 M: limited-stream stream-tell
 129     stream>> stream-tell ;
 130
 131 M: limited-stream stream-seek
 132     >limited-seek
 133     [ stream>> stream-seek ]
 134     [ limited-stream-seek ] 3bi ;
 135
 136 M: limited-stream stream-seekable?
 137     stream>> stream-seekable? ; inline
 138
 139 M: limited-stream stream-length
 140     dup stream>> stream-length
 141     [ swap limit>> min ] [ drop f ] if* ; inline
 142
 143 M: limited-stream dispose stream>> dispose ;
 144
 145 M: limited-stream stream-element-type
 146     stream>> stream-element-type ;
 147
 148 GENERIC: unlimit-stream ( stream -- stream' )
 149
 150 M: decoder unlimit-stream ( stream -- stream' )
 151     [ stream>> stream>> ] [ code>> ] [ cr>> ] tri decoder boa ;
 152
 153 M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
 154
 155 : unlimited-input ( -- )
 156     input-stream [ unlimit-stream ] change ;
 157
 158 : with-unlimited-stream ( stream quot -- )
 159     [ unlimit-stream ] dip call ; inline
 160
 161 : with-unlimited-input ( quot -- )
 162     [ input-stream get unlimit-stream input-stream ] dip
 163     with-variable ; inline