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