diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4b7ef4b40f..ebb8f1ec05 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -49,6 +49,9 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +M: unix tell-handle ( handle -- n ) + fd>> 0 SEEK_CUR lseek [ io-error ] [ ] bi ; + M: unix seek-handle ( n seek-type handle -- ) swap { { io:seek-absolute [ SEEK_SET ] } diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 49f6166e00..8cdd1d97bd 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -124,8 +124,14 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) +HOOK: tell-handle os ( handle -- n ) HOOK: seek-handle os ( n seek-type handle -- ) +M: buffered-port stream-tell ( stream -- n ) + [ check-disposed ] + [ handle>> tell-handle ] + [ [ buffer>> size>> - 0 max ] [ buffer>> pos>> ] bi + ] tri ; + M: input-port stream-seek ( n seek-type stream -- ) [ check-disposed ] [ buffer>> 0 swap buffer-reset ] diff --git a/basis/io/streams/duplex/duplex.factor b/basis/io/streams/duplex/duplex.factor index 4903195abc..0e4d1fd195 100644 --- a/basis/io/streams/duplex/duplex.factor +++ b/basis/io/streams/duplex/duplex.factor @@ -44,4 +44,3 @@ M: duplex-stream underlying-handle >duplex-stream< [ underlying-handle ] bi@ [ = [ invalid-duplex-stream ] when ] keep ; - diff --git a/basis/io/streams/limited/limited-docs.factor b/basis/io/streams/limited/limited-docs.factor index a7199eaad1..833e53820e 100755 --- a/basis/io/streams/limited/limited-docs.factor +++ b/basis/io/streams/limited/limited-docs.factor @@ -24,7 +24,22 @@ HELP: limit " \"123456\" 3 stream-throws limit" " 100 swap stream-read ." "] [ ] recover ." - "T{ limit-exceeded }" +"""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:" { $example diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor index f052be3b74..022d20eb5e 100644 --- a/basis/io/streams/limited/limited-tests.factor +++ b/basis/io/streams/limited/limited-tests.factor @@ -1,7 +1,8 @@ -USING: io io.streams.limited io.encodings io.encodings.string -io.encodings.ascii io.encodings.binary io.streams.byte-array -namespaces tools.test strings kernel io.streams.string accessors -io.encodings.utf8 io.files destructors ; +USING: accessors continuations destructors io io.encodings +io.encodings.8-bit io.encodings.ascii io.encodings.binary +io.encodings.string io.encodings.utf8 io.files io.pipes +io.streams.byte-array io.streams.limited io.streams.string +kernel namespaces strings tools.test system ; IN: io.streams.limited.tests [ ] [ @@ -89,3 +90,127 @@ IN: io.streams.limited.tests unlimited-input contents ] with-input-stream ] unit-test + +[ 4 ] [ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input tell-input + ] with-input-stream +] unit-test + +[ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input + 4 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" 4 stream-throws [ + 4 seek-relative seek-input + -2 seek-relative + 2 read + ] with-input-stream +] [ + limit-exceeded? +] must-fail-with + +[ + "abcdefgh" [ + 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" [ + 4 seek-relative seek-input + 2 stream-throws limit-input + 4 seek-absolute seek-input + 2 read + ] with-input-stream +] unit-test + +[ "ef" ] [ + "abcdefgh" [ + 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 +[ "as" ] [ + latin1 [ 2 stream-throws ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ + latin1 [ 2 stream-throws ] 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 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +! test seeking on limited unseekable streams +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 2 swap stream-read +] unit-test + +[ "as" ] [ + latin1 [ 2 stream-eofs ] change-in + "asdf" over stream-write dup stream-flush + 3 swap stream-read +] unit-test + +[ + latin1 [ 2 stream-throws ] change-in + 2 seek-absolute rot in>> stream-seek +] must-fail + +[ + "as" +] [ + latin1 [ 2 stream-throws ] 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 [ + 7 read drop + tell-input + ] with-input-stream +] unit-test + +[ 70000 ] [ + image binary stream-throws [ + 70000 read drop + tell-input + ] with-input-stream +] unit-test diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor index c71e99ab91..403643ed73 100755 --- a/basis/io/streams/limited/limited.factor +++ b/basis/io/streams/limited/limited.factor @@ -2,11 +2,14 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors byte-vectors combinators destructors fry io -io.encodings io.files io.files.info kernel math namespaces -sequences ; +io.encodings io.files io.files.info kernel locals math +namespaces sequences ; IN: io.streams.limited -TUPLE: limited-stream stream count limit mode stack ; +TUPLE: limited-stream + stream mode + count limit + current start stop ; SINGLETONS: stream-throws stream-eofs ; @@ -51,13 +54,27 @@ M: object unlimited ( stream -- stream' ) : with-limited-stream ( stream limit mode quot -- ) [ limit ] dip call ; inline -ERROR: limit-exceeded ; +ERROR: limit-exceeded n stream ; ERROR: bad-stream-mode mode ; > ] [ stop>> ] bi > + [ + dup mode>> { + { stream-throws [ limit-exceeded ] } + { stream-eofs [ + dup [ current>> ] [ stop>> ] bi - + '[ _ - ] dip + ] } + [ bad-stream-mode ] + } case + ] when ; inline + +: adjust-count-limit ( n stream -- n' stream ) 2dup [ + ] change-count [ count>> ] [ limit>> ] bi > [ @@ -66,13 +83,29 @@ ERROR: bad-stream-mode mode ; { stream-eofs [ dup [ count>> ] [ limit>> ] bi - '[ _ - ] dip + dup limit>> >>count ] } [ bad-stream-mode ] } case ] when ; inline +: check-count-bounds ( n stream -- n stream ) + dup [ count>> ] [ limit>> ] bi > + [ limit-exceeded ] when ; + +: check-current-bounds ( n stream -- n stream ) + dup [ current>> ] [ start>> ] bi < + [ limit-exceeded ] when ; + +: adjust-limited-read ( n stream -- n stream ) + dup start>> [ + check-current-bounds adjust-current-limit + ] [ + check-count-bounds adjust-count-limit + ] if ; + : maybe-read ( n limited-stream quot: ( n stream -- seq/f ) -- seq/f ) - [ adjust-limit ] dip + [ adjust-limited-read ] dip pick 0 <= [ 3drop f ] [ [ stream>> ] dip call ] if ; inline PRIVATE> @@ -93,16 +126,35 @@ M: limited-stream stream-read-partial 3dup [ [ stream-read1 dup ] dip memq? ] dip swap [ drop ] [ push (read-until) ] if ; +:: limited-stream-seek ( n seek-type stream -- ) + seek-type { + { seek-absolute [ n stream (>>current) ] } + { seek-relative [ stream [ n + ] change-current drop ] } + { seek-end [ stream stop>> n - stream (>>current) ] } + [ bad-seek-type ] + } case ; + +: >limited-seek ( stream -- stream' ) + dup start>> [ + dup stream-tell >>current + dup [ current>> ] [ count>> ] bi - >>start + dup [ start>> ] [ limit>> ] bi + >>stop + ] unless ; + PRIVATE> M: limited-stream stream-read-until swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ; -M: limited-stream stream-seek - stream>> stream-seek ; +M: limited-stream stream-tell + stream>> stream-tell ; -M: limited-stream dispose - stream>> dispose ; +M: limited-stream stream-seek + >limited-seek + [ stream>> stream-seek ] + [ limited-stream-seek ] 3bi ; + +M: limited-stream dispose stream>> dispose ; M: limited-stream stream-element-type stream>> stream-element-type ; diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index 85cb3022f5..be9016d1f2 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces sequences sbufs strings generic splitting continuations destructors sequences.private -io.streams.plain io.encodings math.order growable io.streams.sequence ; +io.streams.plain io.encodings math.order growable io.streams.sequence +io.private ; IN: io.streams.string ! Readers @@ -13,6 +14,8 @@ M: string-reader stream-read-partial stream-read ; M: string-reader stream-read sequence-read ; M: string-reader stream-read1 sequence-read1 ; M: string-reader stream-read-until sequence-read-until ; +M: string-reader stream-tell i>> ; +M: string-reader stream-seek (stream-seek) ; M: string-reader dispose drop ; [ swap with-output-stream* - ] keep >string ; inline \ No newline at end of file + ] keep >string ; inline diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f7fb28c8f4..f42ab779f4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -486,6 +486,7 @@ tuple { "fputc" "io.streams.c" (( ch alien -- )) } { "fwrite" "io.streams.c" (( string alien -- )) } { "fflush" "io.streams.c" (( alien -- )) } + { "ftell" "io.streams.c" (( alien -- n )) } { "fseek" "io.streams.c" (( alien offset whence -- )) } { "fclose" "io.streams.c" (( alien -- )) } { "" "kernel" (( obj -- wrapper )) } diff --git a/core/io/encodings/encodings-tests.factor b/core/io/encodings/encodings-tests.factor index fa8832deab..9b88db5136 100644 --- a/core/io/encodings/encodings-tests.factor +++ b/core/io/encodings/encodings-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.streams.string io io.streams.byte-array tools.test kernel io.encodings.ascii io.encodings.utf8 -namespaces accessors io.encodings ; +namespaces accessors io.encodings io.streams.limited ; IN: io.streams.encodings.tests [ { } ] diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 174816dd34..03e8723d20 100644 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -50,6 +50,10 @@ M: object f decoder boa ; M: decoder stream-element-type drop +character+ ; +M: decoder stream-tell stream>> stream-tell ; + +M: decoder stream-seek stream>> stream-seek ; + M: decoder stream-read1 dup >decoder< decode-char fix-read1 ; diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 13048fdb61..e0b74d5ab3 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -86,6 +86,14 @@ HELP: stream-copy { $description "Copies the contents of one stream into another, closing both streams when done." } $io-error ; +HELP: stream-tell +{ $values + { "stream" "a stream" } { "n" integer } +} +{ $description "Returns the index of the stream pointer if the stream is seekable." } +{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ; + + HELP: stream-seek { $values { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" } @@ -274,8 +282,11 @@ $nl } "This word is only required for string output streams:" { $subsections stream-nl } -"This word is for streams that allow seeking:" -{ $subsections stream-seek } +"These words are for seekable streams:" +{ $subsections + stream-tell + stream-seek +} { $see-also "io.timeouts" } ; ARTICLE: "stdio-motivation" "Motivation for default streams" diff --git a/core/io/io.factor b/core/io/io.factor index 669f104a5f..e240467c07 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: hashtables generic kernel math namespaces make sequences -continuations destructors assocs combinators ; +USING: accessors combinators continuations destructors kernel +math namespaces sequences ; IN: io SYMBOLS: +byte+ +character+ ; @@ -23,9 +23,24 @@ ERROR: bad-seek-type type ; SINGLETONS: seek-absolute seek-relative seek-end ; +GENERIC: stream-tell ( stream -- n ) GENERIC: stream-seek ( n seek-type stream -- ) -: stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; +>i) ] } + { seek-relative [ [ + ] change-i drop ] } + { seek-end [ [ underlying>> length + ] [ (>>i) ] bi ] } + [ bad-seek-type ] + } case ; + +PRIVATE> + +: stream-print ( str stream -- ) [ stream-write ] [ stream-nl ] bi ; ! Default streams SYMBOL: input-stream @@ -37,6 +52,8 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; +: tell-input ( -- n ) input-stream get stream-tell ; +: tell-output ( -- n ) output-stream get stream-tell ; : seek-input ( n seek-type -- ) input-stream get stream-seek ; : seek-output ( n seek-type -- ) output-stream get stream-seek ; diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor index 3a08dd10d9..96b122549d 100644 --- a/core/io/streams/byte-array/byte-array-tests.factor +++ b/core/io/streams/byte-array/byte-array-tests.factor @@ -29,7 +29,11 @@ io.encodings.utf8 io kernel arrays strings namespaces math ; ] with-byte-reader ] unit-test +[ 0 ] [ + B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary [ tell-input ] with-byte-reader +] unit-test + ! Overly aggressive compiler optimizations [ B{ 123 } ] [ binary [ 123 >bignum write1 ] with-byte-writer -] unit-test \ No newline at end of file +] unit-test diff --git a/core/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor index 4cb50dfbc1..6f9b05cf18 100644 --- a/core/io/streams/byte-array/byte-array.factor +++ b/core/io/streams/byte-array/byte-array.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays byte-vectors kernel io.encodings sequences io -namespaces io.encodings.private accessors sequences.private -io.streams.sequence destructors math combinators ; +USING: accessors byte-arrays byte-vectors destructors io +io.encodings io.private io.streams.sequence kernel namespaces +sequences sequences.private ; IN: io.streams.byte-array M: byte-vector stream-element-type drop +byte+ ; @@ -24,13 +24,8 @@ M: byte-reader stream-read1 sequence-read1 ; M: byte-reader stream-read-until sequence-read-until ; M: byte-reader dispose drop ; -M: byte-reader stream-seek ( n seek-type stream -- ) - swap { - { seek-absolute [ (>>i) ] } - { seek-relative [ [ + ] change-i drop ] } - { seek-end [ [ underlying>> length + ] keep (>>i) ] } - [ bad-seek-type ] - } case ; +M: byte-reader stream-tell i>> ; +M: byte-reader stream-seek (stream-seek) ; : ( byte-array encoding -- stream ) [ B{ } like 0 byte-reader boa ] dip ; diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor index 6a82d6d545..657c6ccd75 100644 --- a/core/io/streams/c/c-tests.factor +++ b/core/io/streams/c/c-tests.factor @@ -1,5 +1,5 @@ USING: tools.test io.files io.files.temp io io.streams.c -io.encodings.ascii strings ; +io.encodings.ascii strings destructors kernel ; IN: io.streams.c.tests [ "hello world" ] [ @@ -8,3 +8,12 @@ IN: io.streams.c.tests "test.txt" temp-file "rb" fopen stream-contents >string ] unit-test + +[ 0 ] +[ "test.txt" temp-file "rb" fopen [ stream-tell ] [ dispose ] bi ] unit-test + +[ 3 ] [ + "test.txt" temp-file "rb" fopen + 3 over stream-read drop + [ stream-tell ] [ dispose ] bi +] unit-test diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index aebc709a9e..6ff1a4b35c 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -13,6 +13,8 @@ TUPLE: c-stream < disposable handle ; M: c-stream dispose* handle>> fclose ; +M: c-stream stream-tell handle>> ftell ; + M: c-stream stream-seek handle>> swap { { seek-absolute [ 0 ] } diff --git a/vm/io.cpp b/vm/io.cpp index 18a553af89..8e6eff730e 100755 --- a/vm/io.cpp +++ b/vm/io.cpp @@ -164,6 +164,17 @@ void factor_vm::primitive_fwrite() } } +void factor_vm::primitive_ftell() +{ + FILE *file = (FILE *)unbox_alien(); + off_t offset; + + if((offset = FTELL(file)) == -1) + io_error(); + + box_signed_8(offset); +} + void factor_vm::primitive_fseek() { int whence = to_fixnum(dpop()); diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 7470c4ff45..05ab8b1120 100644 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -23,6 +23,7 @@ typedef char symbol_char; #define STRNCMP strncmp #define STRDUP strdup +#define FTELL ftello #define FSEEK fseeko #define FIXNUM_FORMAT "%ld" diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index d1db3c26ac..319ad6c42a 100644 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -19,7 +19,8 @@ typedef wchar_t vm_char; #define STRNCMP wcsncmp #define STRDUP _wcsdup #define MIN(a,b) ((a)>(b)?(b):(a)) -#define FSEEK fseek +#define FTELL _ftelli64 +#define FSEEK _fseeki64 #ifdef WIN64 #define CELL_FORMAT "%Iu" diff --git a/vm/primitives.cpp b/vm/primitives.cpp index f8552ab635..e2e663333f 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -128,6 +128,7 @@ const primitive_type primitives[] = { primitive_fputc, primitive_fwrite, primitive_fflush, + primitive_ftell, primitive_fseek, primitive_fclose, primitive_wrapper, @@ -254,6 +255,7 @@ PRIMITIVE_FORWARD(fread) PRIMITIVE_FORWARD(fputc) PRIMITIVE_FORWARD(fwrite) PRIMITIVE_FORWARD(fflush) +PRIMITIVE_FORWARD(ftell) PRIMITIVE_FORWARD(fseek) PRIMITIVE_FORWARD(fclose) PRIMITIVE_FORWARD(wrapper) diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 983d2589b2..dd264869b2 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -136,6 +136,7 @@ PRIMITIVE(fread); PRIMITIVE(fputc); PRIMITIVE(fwrite); PRIMITIVE(fflush); +PRIMITIVE(ftell); PRIMITIVE(fseek); PRIMITIVE(fclose); PRIMITIVE(wrapper); diff --git a/vm/vm.hpp b/vm/vm.hpp index ff96467179..09eda62f54 100644 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -493,6 +493,7 @@ struct factor_vm void primitive_fread(); void primitive_fputc(); void primitive_fwrite(); + void primitive_ftell(); void primitive_fseek(); void primitive_fflush(); void primitive_fclose();