io.encodings.binary
io.streams.limited
io.streams.string
+io.streams.throwing
io.servers.connection
io.timeouts
io.crlf
SYMBOL: upload-limit
: read-multipart-data ( request -- mime-parts )
- [ "content-type" header ]
- [ "content-length" header string>number ] bi
unlimited-input
- upload-limit get stream-throws limit-input
- stream-eofs limit-input
- binary decode-input
- parse-multipart-form-data parse-multipart ;
+ upload-limit get limited-input
+ [ "content-type" header ]
+ [ "content-length" header string>number limited-input ] bi
+ [
+ binary decode-input
+ parse-multipart-form-data parse-multipart
+ ] input-throws-on-eof ;
: read-content ( request -- bytes )
"content-length" header string>number read ;
SYMBOL: request-limit
-64 1024 * request-limit set-global
+request-limit [ 64 1024 * ] initialize
M: http-server handle-client*
drop [
- request-limit get stream-throws limit-input
- ?refresh-all
- [ read-request ] ?benchmark
- [ do-request ] ?benchmark
- [ do-response ] ?benchmark
+ request-limit get limited-input
+ [
+ ?refresh-all
+ [ read-request ] ?benchmark
+ [ do-request ] ?benchmark
+ [ do-response ] ?benchmark
+ ] input-throws-on-eof
] with-destructors ;
: <http-server> ( -- server )
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators compression.run-length endian fry grouping images
-images.loader images.normalization io io.binary
-io.encodings.8-bit.latin1 io.encodings.binary
-io.encodings.string io.files io.streams.limited kernel locals
-macros math math.bitwise math.functions namespaces sequences
+USING: accessors alien.c-types arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader
+images.normalization io io.binary io.encodings.8-bit.latin1
+io.encodings.string kernel math math.bitwise sequences
specialized-arrays summary ;
QUALIFIED-WITH: bitstreams b
SPECIALIZED-ARRAYS: uint ushort ;
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays byte-arrays combinators
-compression.run-length fry grouping images images.loader io
-io.binary io.encodings.binary
-io.encodings.string io.streams.limited kernel math math.bitwise
-io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
! Copyright (C) 2009 Marc Fauconneau.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays combinators
-grouping compression.huffman images fry
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader io.streams.limited ;
-IN: images.jpeg
-
+compression.huffman fry grouping images images.loader
+images.processing io io.binary io.encodings.binary
+io.streams.byte-array io.streams.limited io.streams.throwing
+kernel locals math math.bitwise math.blas.matrices
+math.blas.vectors math.constants math.functions math.matrices
+math.order math.vectors memoize namespaces sequences
+sequences.deep ;
QUALIFIED-WITH: bitstreams bs
+IN: images.jpeg
SINGLETON: jpeg-image
: decode-huff-table ( chunk -- )
data>> [ binary <byte-reader> ] [ length ] bi
- stream-throws limit
+ limit-stream <throws-on-eof>
[
[ input-stream get [ count>> ] [ limit>> ] bi < ]
[
: idct-factor ( b -- b' ) dct-matrix v.m ;
-USE: math.blas.vectors
-USE: math.blas.matrices
-
MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
: V.M ( x A -- x.A ) Mtranspose swap M.V ;
: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays combinators images
-io.encodings.binary io.files io.pathnames io.streams.byte-array
-io.streams.limited kernel namespaces sequences splitting
-strings unicode.case ;
+USING: assocs byte-arrays io.encodings.binary io.files
+io.pathnames io.streams.byte-array io.streams.limited
+io.streams.throwing kernel namespaces sequences strings
+unicode.case fry ;
IN: images.loader
ERROR: unknown-image-extension extension ;
[ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
- binary stream-throws <limited-file-reader> ;
+ binary <limited-file-reader> ;
PRIVATE>
M: byte-array load-image*
[
- [ binary <byte-reader> ]
- [ length stream-throws <limited-stream> ] bi
- ] dip stream>image ;
+ [ binary <byte-reader> ] [ length ] bi
+ <limited-stream> dup
+ ] dip '[ _ stream>image ] throws-on-eof ;
M: limited-stream load-image* stream>image ;
HELP: <limited-stream>
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "an input stream" }
}
-{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
+{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit-stream } " or " { $link limited-input } "." } ;
-HELP: limit
+HELP: limit-stream
{ $values
- { "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
+ { "stream" "an input stream" } { "limit" integer }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
-{ $examples "Throwing an exception:"
- { $example
- "USING: continuations io io.streams.limited io.streams.string"
- "kernel prettyprint ;"
- "["
- " \"123456\" <string-reader> 3 stream-throws limit"
- " 100 swap stream-read ."
- "] [ ] recover ."
-"""T{ limit-exceeded
- { n 1 }
- { stream
- T{ limited-stream
- { stream
- T{ string-reader
- { underlying "123456" }
- { i 3 }
- }
- }
- { mode stream-throws }
- { count 4 }
- { limit 3 }
- }
- }
-}"""
- }
- "Returning " { $link f } " on exhaustion:"
+{ $examples
+ "Limiting a longer stream to length three:"
{ $example
"USING: accessors continuations io io.streams.limited"
"io.streams.string kernel prettyprint ;"
- "\"123456\" <string-reader> 3 stream-eofs limit"
+ "\"123456\" <string-reader> 3 limit-stream"
"100 swap stream-read ."
"\"123\""
}
} ;
-HELP: unlimited
+HELP: unlimit-stream
{ $values
{ "stream" "an input stream" }
{ "stream'" "a stream" }
}
{ $description "Limited streams wrap other streams, changing their behavior to throw an exception or return " { $link f } " upon exhaustion." } ;
-HELP: limit-input
-{ $values
- { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
-}
+HELP: limited-input
+{ $values { "limit" integer } }
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
HELP: unlimited-input
{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
-HELP: stream-eofs
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
-
-HELP: stream-throws
-{ $values
- { "value" { $link stream-throws } " or " { $link stream-eofs } }
-}
-{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
-
-{ stream-eofs stream-throws } related-words
-
ARTICLE: "io.streams.limited" "Limited input streams"
"The " { $vocab-link "io.streams.limited" } " vocabulary wraps a stream to behave as if it had only a limited number of bytes, either throwing an error or returning " { $link f } " upon reaching the end. Limiting a non-seekable stream keeps a byte count and triggers the end-of-stream behavior when this byte count has been reached. However, limiting a seekable stream creates a window of bytes that supports seeking and re-reading of bytes in that window." $nl
"Wrap a stream in a limited stream:"
-{ $subsections limit }
+{ $subsections limited-stream }
"Wrap the current " { $link input-stream } " in a limited stream:"
-{ $subsections limit-input }
+{ $subsections limited-input }
"Unlimits a limited stream:"
-{ $subsections unlimited }
+{ $subsections unlimit-stream }
"Unlimits the current " { $link input-stream } ":"
-{ $subsections unlimited-input }
-"Make a limited stream throw an exception on exhaustion:"
-{ $subsections stream-throws }
-"Make a limited stream return " { $link f } " on exhaustion:"
-{ $subsections stream-eofs } ;
+{ $subsections unlimited-input } ;
ABOUT: "io.streams.limited"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 24 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 24 <limited-stream> "limited" set ] unit-test
[ CHAR: h ] [ "limited" get stream-read1 ] unit-test
[ "how " ] [ 4 "decoded" get stream-read ] unit-test
-[ "decoded" get stream-readln ] [ limit-exceeded? ] must-fail-with
+[ "are you " ] [ "decoded" get stream-readln ] unit-test
+
+[ f ] [ "decoded" get stream-readln ] unit-test
+
[ ] [
"abc\ndef\nghi"
ascii encode binary <byte-reader> "data" set
] unit-test
-[ ] [ "data" get 7 stream-throws <limited-stream> "limited" set ] unit-test
+[ ] [ "data" get 4 <limited-stream> "limited" set ] unit-test
-[ "abc" CHAR: \n ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
+[ "abc" CHAR: \n ]
+[ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "\n" "limited" get stream-read-until ] [ limit-exceeded? ] must-fail-with
+[ "" f ] [ "\n" "limited" get stream-read-until [ >string ] dip ] unit-test
-[ "he" CHAR: l ] [
- B{ CHAR: h CHAR: e CHAR: l CHAR: l CHAR: o }
- ascii <byte-reader> [
- 5 stream-throws limit-input
- "l" read-until
- ] with-input-stream
-] unit-test
[ CHAR: a ]
-[ "a" <string-reader> 1 stream-eofs <limited-stream> stream-read1 ] unit-test
+[ "a" <string-reader> 1 <limited-stream> stream-read1 ] unit-test
[ "abc" ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 swap stream-read
] unit-test
[ f ]
[
- "abc" <string-reader> 3 stream-eofs <limited-stream>
+ "abc" <string-reader> 3 <limited-stream>
4 over stream-read drop 10 swap stream-read
] unit-test
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimited
+ "abc" <string-reader> 3 limit-stream unlimit-stream
"abc" <string-reader> =
] unit-test
[ t ]
[
- "abc" <string-reader> 3 stream-eofs limit unlimited
+ "abc" <string-reader> 3 limit-stream unlimit-stream
"abc" <string-reader> =
] unit-test
[
[
"resource:license.txt" utf8 <file-reader> &dispose
- 3 stream-eofs limit unlimited
+ 3 limit-stream unlimit-stream
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors
] unit-test
-[ "HELL" ] [
- "HELLO"
- [ f stream-throws limit-input 4 read ]
- with-string-reader
-] unit-test
-
[ "asdf" ] [
- "asdf" <string-reader> 2 stream-eofs <limited-stream> [
+ "asdf" <string-reader> 2 <limited-stream> [
unlimited-input contents
] with-input-stream
] unit-test
-[ 4 ] [
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input tell-input
- ] with-input-stream
-] unit-test
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- 4 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> 4 stream-throws <limited-stream> [
- 4 seek-relative seek-input
- -2 seek-relative
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- -2 seek-relative seek-input
- 2 read
- ] with-input-stream
-] [
- limit-exceeded?
-] must-fail-with
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-relative seek-input
- 2 stream-throws limit-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-[ "ef" ] [
- "abcdefgh" <string-reader> [
- 4 seek-absolute seek-input
- 2 stream-throws limit-input
- 2 seek-absolute seek-input
- 4 seek-absolute seek-input
- 2 read
- ] with-input-stream
-] unit-test
-
-! stream-throws, pipes are duplex and not seekable
+! pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 3 swap stream-read
-] [
- limit-exceeded?
-] must-fail-with
-
-! stream-eofs, pipes are duplex and not seekable
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- 2 swap stream-read
-] unit-test
-
-[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
! test seeking on limited unseekable streams
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
2 swap stream-read
] unit-test
[ "as" ] [
- latin1 <pipe> [ 2 stream-eofs <limited-stream> ] change-in
+ latin1 <pipe> [ 2 <limited-stream> ] change-in
"asdf" over stream-write dup stream-flush
3 swap stream-read
] unit-test
-
-[
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- 2 seek-absolute rot in>> stream-seek
-] must-fail
-
-[
- "as"
-] [
- latin1 <pipe> [ 2 stream-throws <limited-stream> ] change-in
- "asdf" over stream-write dup stream-flush
- [ 2 seek-absolute rot in>> stream-seek ] [ drop ] recover
- 2 swap stream-read
-] unit-test
-
-[ 7 ] [
- image binary stream-throws <limited-file-reader> [
- 7 read drop
- tell-input
- ] with-input-stream
-] unit-test
-
-[ 70000 ] [
- image binary stream-throws <limited-file-reader> [
- 70000 read drop
- tell-input
- ] with-input-stream
-] unit-test
namespaces sequences ;
IN: io.streams.limited
-TUPLE: limited-stream
- stream mode
- count limit
- current start stop ;
+TUPLE: limited-stream stream count limit current start stop ;
-SINGLETONS: stream-throws stream-eofs ;
-
-: <limited-stream> ( stream limit mode -- stream' )
+: <limited-stream> ( stream limit -- stream' )
limited-stream new
- swap >>mode
swap >>limit
swap >>stream
0 >>count ;
-: <limited-file-reader> ( path encoding mode -- stream' )
- [
- [ <file-reader> ]
- [ drop file-info size>> ] 2bi
- ] dip <limited-stream> ;
+: <limited-file-reader> ( path encoding -- stream' )
+ [ <file-reader> ]
+ [ drop file-info size>> ] 2bi
+ <limited-stream> ;
-GENERIC# limit 2 ( stream limit mode -- stream' )
+GENERIC# limit-stream 1 ( stream limit -- stream' )
-M: decoder limit ( stream limit mode -- stream' )
- [ clone ] 2dip '[ _ _ limit ] change-stream ;
+M: decoder limit-stream ( stream limit -- stream' )
+ [ clone ] dip '[ _ limit-stream ] change-stream ;
-M: object limit ( stream limit mode -- stream' )
- over [ <limited-stream> ] [ 2drop ] if ;
+M: object limit-stream ( stream limit -- stream' )
+ <limited-stream> ;
-GENERIC: unlimited ( stream -- stream' )
+GENERIC: unlimit-stream ( stream -- stream' )
-M: decoder unlimited ( stream -- stream' )
+M: decoder unlimit-stream ( stream -- stream' )
[ stream>> ] change-stream ;
-M: object unlimited ( stream -- stream' )
- stream>> ;
+M: limited-stream unlimit-stream ( stream -- stream' ) stream>> ;
+
+M: object unlimit-stream ( stream -- stream' ) ;
-: limit-input ( limit mode -- )
- [ input-stream ] 2dip '[ _ _ limit ] change ;
+: limited-input ( limit -- )
+ [ input-stream ] dip '[ _ limit-stream ] change ;
: unlimited-input ( -- )
- input-stream [ unlimited ] change ;
+ input-stream [ unlimit-stream ] change ;
: with-unlimited-stream ( stream quot -- )
- [ clone unlimited ] dip call ; inline
+ [ clone unlimit-stream ] dip call ; inline
-: with-limited-stream ( stream limit mode quot -- )
- [ limit ] dip call ; inline
+: with-limited-stream ( stream limit quot -- )
+ [ limit-stream ] dip call ; inline
ERROR: limit-exceeded n stream ;
-ERROR: bad-stream-mode mode ;
-
<PRIVATE
: adjust-current-limit ( n stream -- n' stream )
2dup [ + ] change-current
[ current>> ] [ stop>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ current>> ] [ stop>> ] bi -
- '[ _ - ] dip
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ current>> ] [ stop>> ] bi -
+ '[ _ - ] dip
] when ; inline
: adjust-count-limit ( n stream -- n' stream )
2dup [ + ] change-count
[ count>> ] [ limit>> ] bi >
[
- dup mode>> {
- { stream-throws [ limit-exceeded ] }
- { stream-eofs [
- dup [ count>> ] [ limit>> ] bi -
- '[ _ - ] dip
- dup limit>> >>count
- ] }
- [ bad-stream-mode ]
- } case
+ dup [ count>> ] [ limit>> ] bi -
+ '[ _ - ] dip
+ dup limit>> >>count
] when ; inline
: check-count-bounds ( n stream -- n stream )
: (read-until) ( stream seps buf -- stream seps buf sep/f )
3dup [ [ stream-read1 dup ] dip member-eq? ] dip
- swap [ drop ] [ push (read-until) ] if ;
+ swap [
+ drop
+ ] [
+ over [ push (read-until) ] [ drop ] if
+ ] if ;
:: limited-stream-seek ( n seek-type stream -- )
seek-type {
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.streams.limited io.streams.string
+io.streams.throwing tools.test ;
+IN: io.streams.throwing.tests
+
+[ "as" ]
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 6 read-partial ] throws-on-eof
+] unit-test
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ contents ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 2 read read1 ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 3 read ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ 2 read 2 read ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
+
+[
+ "asdf" <string-reader> 2 <limited-stream>
+ [ contents contents ] throws-on-eof
+] [ stream-exhausted? ] must-fail-with
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors io kernel locals namespaces
+sequences ;
+IN: io.streams.throwing
+
+ERROR: stream-exhausted n stream word ;
+
+<PRIVATE
+
+TUPLE: throws-on-eof stream ;
+
+C: <throws-on-eof> throws-on-eof
+
+M: throws-on-eof stream-element-type stream>> stream-element-type ;
+
+M: throws-on-eof dispose stream>> dispose ;
+
+M:: throws-on-eof stream-read1 ( stream -- obj )
+ stream stream>> stream-read1
+ [ 1 stream \ read1 stream-exhausted ] unless* ;
+
+M:: throws-on-eof stream-read ( n stream -- seq )
+ n stream stream>> stream-read
+ dup length n = [ n stream \ read stream-exhausted ] unless ;
+
+M:: throws-on-eof stream-read-partial ( n stream -- seq )
+ n stream stream>> stream-read-partial
+ [ n stream \ read-partial stream-exhausted ] unless* ;
+
+PRIVATE>
+
+: throws-on-eof ( stream quot -- )
+ [ <throws-on-eof> ] dip with-input-stream ; inline
+
+: input-throws-on-eof ( quot -- )
+ [ input-stream get <throws-on-eof> ] dip with-input-stream ; inline
! Copyrigt (C) 2009 Doug Coleman, Keith Lazuka
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs combinators compression.lzw
+USING: accessors arrays combinators compression.lzw
constructors destructors grouping images images.loader io
-io.binary io.buffers io.encodings.binary io.encodings.string
-io.encodings.utf8 io.files io.files.info io.ports
-io.streams.limited kernel make math math.bitwise math.functions
-multiline namespaces prettyprint sequences ;
+io.binary io.buffers io.encodings.string io.encodings.utf8
+io.ports kernel make math math.bitwise namespaces sequences ;
IN: images.gif
SINGLETON: gif-image
projects / factor.git / commitdiff