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 ;
9 TUPLE: limited-stream stream count limit current start stop ;
10 INSTANCE: limited-stream input-stream
12 : <limited-stream> ( stream limit -- stream' )
18 : <limited-file-reader> ( path encoding -- stream' )
20 [ drop file-info size>> ] 2bi
23 GENERIC# limit-stream 1 ( stream limit -- stream' )
25 M: decoder limit-stream ( stream limit -- stream' )
26 '[ stream>> _ limit-stream ] [ code>> ] [ cr>> ] tri
29 M: object limit-stream ( stream limit -- stream' )
32 : limited-input ( limit -- )
33 [ input-stream ] dip '[ _ limit-stream ] change ;
35 : with-limited-stream ( stream limit quot -- )
36 [ limit-stream ] dip call ; inline
38 : with-limited-input ( limit quot -- )
39 [ [ input-stream get ] dip limit-stream input-stream ] dip
40 with-variable ; inline
42 ERROR: limit-exceeded n stream ;
46 : adjust-current-limit ( n stream -- n' stream )
47 2dup [ + ] change-current
48 [ current>> ] [ stop>> ] bi >
50 dup [ current>> ] [ stop>> ] bi -
54 : adjust-count-limit ( n stream -- n' stream )
55 2dup [ + ] change-count
56 [ count>> ] [ limit>> ] bi >
58 dup [ count>> ] [ limit>> ] bi -
63 : check-count-bounds ( n stream -- n stream )
64 dup [ count>> ] [ limit>> ] bi >
65 [ throw-limit-exceeded ] when ;
67 : check-current-bounds ( n stream -- n stream )
68 dup [ current>> ] [ start>> ] bi <
69 [ throw-limit-exceeded ] when ;
71 : adjust-limited-read ( n stream -- n stream )
73 check-current-bounds adjust-current-limit
75 check-count-bounds adjust-count-limit
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
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
88 M: limited-stream stream-read1
90 [ nip stream-read1 ] maybe-read ;
92 M: limited-stream stream-read-unsafe
93 [ stream-read-unsafe ] maybe-read-unsafe ;
95 M: limited-stream stream-read-partial-unsafe
96 [ stream-read-partial-unsafe ] maybe-read-unsafe ;
100 : (read-until) ( stream seps buf -- stream seps buf sep/f )
101 3dup [ [ stream-read1 dup ] dip member-eq? ] dip
105 over [ push (read-until) ] [ drop ] if
108 :: limited-stream-seek ( n seek-type stream -- )
110 { seek-absolute [ n stream current<< ] }
111 { seek-relative [ stream [ n + ] change-current drop ] }
112 { seek-end [ stream stop>> n - stream current<< ] }
116 : >limited-seek ( stream -- stream' )
118 dup stream-tell >>current
119 dup [ current>> ] [ count>> ] bi - >>start
120 dup [ start>> ] [ limit>> ] bi + >>stop
125 M: limited-stream stream-read-until
126 swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
128 M: limited-stream stream-tell
129 stream>> stream-tell ;
131 M: limited-stream stream-seek
133 [ stream>> stream-seek ]
134 [ limited-stream-seek ] 3bi ;
136 M: limited-stream stream-seekable?
137 stream>> stream-seekable? ; inline
139 M: limited-stream stream-length
140 dup stream>> stream-length
141 [ swap limit>> min ] [ drop f ] if* ; inline
143 M: limited-stream dispose stream>> dispose ;
145 M: limited-stream stream-element-type
146 stream>> stream-element-type ;
148 GENERIC: unlimit-stream ( stream -- stream' )
150 M: decoder unlimit-stream ( stream -- stream' )
151 [ stream>> stream>> ] [ code>> ] [ cr>> ] tri decoder boa ;
153 M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
155 : unlimited-input ( -- )
156 input-stream [ unlimit-stream ] change ;
158 : with-unlimited-stream ( stream quot -- )
159 [ unlimit-stream ] dip call ; inline
161 : with-unlimited-input ( quot -- )
162 [ input-stream get unlimit-stream input-stream ] dip
163 with-variable ; inline