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
14 SINGLETONS: stream-throws stream-eofs ;
16 : <limited-stream> ( stream limit mode -- stream' )
23 : <limited-file-reader> ( path encoding mode -- stream' )
26 [ drop file-info size>> ] 2bi
27 ] dip <limited-stream> ;
29 GENERIC# limit 2 ( stream limit mode -- stream' )
31 M: decoder limit ( stream limit mode -- stream' )
32 [ clone ] 2dip '[ _ _ limit ] change-stream ;
34 M: object limit ( stream limit mode -- stream' )
35 over [ <limited-stream> ] [ 2drop ] if ;
37 GENERIC: unlimited ( stream -- stream' )
39 M: decoder unlimited ( stream -- stream' )
40 [ stream>> ] change-stream ;
42 M: object unlimited ( stream -- stream' )
45 : limit-input ( limit mode -- )
46 [ input-stream ] 2dip '[ _ _ limit ] change ;
48 : unlimited-input ( -- )
49 input-stream [ unlimited ] change ;
51 : with-unlimited-stream ( stream quot -- )
52 [ clone unlimited ] dip call ; inline
54 : with-limited-stream ( stream limit mode quot -- )
55 [ limit ] dip call ; inline
57 ERROR: limit-exceeded n stream ;
59 ERROR: bad-stream-mode mode ;
63 : adjust-current-limit ( n stream -- n' stream )
64 2dup [ + ] change-current
65 [ current>> ] [ stop>> ] bi >
68 { stream-throws [ limit-exceeded ] }
70 dup [ current>> ] [ stop>> ] bi -
77 : adjust-count-limit ( n stream -- n' stream )
78 2dup [ + ] change-count
79 [ count>> ] [ limit>> ] bi >
82 { stream-throws [ limit-exceeded ] }
84 dup [ count>> ] [ limit>> ] bi -
92 : check-count-bounds ( n stream -- n stream )
93 dup [ count>> ] [ limit>> ] bi >
94 [ limit-exceeded ] when ;
96 : check-current-bounds ( n stream -- n stream )
97 dup [ current>> ] [ start>> ] bi <
98 [ limit-exceeded ] when ;
100 : adjust-limited-read ( n stream -- n stream )
102 check-current-bounds adjust-current-limit
104 check-count-bounds adjust-count-limit
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
113 M: limited-stream stream-read1
115 [ nip stream-read1 ] maybe-read ;
117 M: limited-stream stream-read
118 [ stream-read ] maybe-read ;
120 M: limited-stream stream-read-partial
121 [ stream-read-partial ] maybe-read ;
125 : (read-until) ( stream seps buf -- stream seps buf sep/f )
126 3dup [ [ stream-read1 dup ] dip memq? ] dip
127 swap [ drop ] [ push (read-until) ] if ;
129 :: limited-stream-seek ( n seek-type stream -- )
131 { seek-absolute [ n stream (>>current) ] }
132 { seek-relative [ stream [ n + ] change-current drop ] }
133 { seek-end [ stream stop>> n - stream (>>current) ] }
137 : >limited-seek ( stream -- stream' )
139 dup stream-tell >>current
140 dup [ current>> ] [ count>> ] bi - >>start
141 dup [ start>> ] [ limit>> ] bi + >>stop
146 M: limited-stream stream-read-until
147 swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
149 M: limited-stream stream-tell
150 stream>> stream-tell ;
152 M: limited-stream stream-seek
154 [ stream>> stream-seek ]
155 [ limited-stream-seek ] 3bi ;
157 M: limited-stream dispose stream>> dispose ;
159 M: limited-stream stream-element-type
160 stream>> stream-element-type ;