support limited-streams correctly for seekable streams

basis/io/backend/unix/unix.factor

@@ -49,6 +49,9 @@ M: fd cancel-operation ( fd -- )
         2bi
     ] if ;
 
+M: unix tell-handle ( handle -- n )
+    fd>> SEEK_SET 0 lseek [ io-error ] [ ] bi ;
+
 M: unix seek-handle ( n seek-type handle -- )
     swap {
         { io:seek-absolute [ SEEK_SET ] }

basis/io/ports/ports.factor

@@ -124,8 +124,13 @@ 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 ] bi ;
+
 M: input-port stream-seek ( n seek-type stream -- )
     [ check-disposed ]
     [ buffer>> 0 swap buffer-reset ]

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 ;
-

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 ;
 IN: io.streams.limited.tests
 
 [ ] [
@@ -89,3 +90,113 @@ IN: io.streams.limited.tests
         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
+[ "as" ] [
+    latin1 <pipe> [ 2 stream-throws <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
+    "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
+    "asdf" over stream-write dup stream-flush
+    2 swap stream-read
+] unit-test
+
+[ "as" ] [
+    latin1 <pipe> [ 2 stream-eofs <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

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 ;
 
 <PRIVATE
 
-: adjust-limit ( n stream -- n' stream )
+: 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
+    ] 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 ;

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 ;
 
 <PRIVATE
@@ -35,4 +38,4 @@ M: sbuf stream-element-type drop +character+ ;
 : with-string-writer ( quot -- str )
     <string-writer> [
         swap with-output-stream*
-    ] keep >string ; inline
+    ] keep >string ; inline

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
 
 [ { } ]

core/io/encodings/encodings.factor

@@ -50,6 +50,10 @@ M: object <decoder> 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 ;
 

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 ;
+<PRIVATE
+
+SLOT: i
+
+: (stream-seek) ( n seek-type stream -- )
+    swap {
+        { seek-absolute [ (>>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 ;
 

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
+] unit-test

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-reader> ( byte-array encoding -- stream )
     [ B{ } like 0 byte-reader boa ] dip <decoder> ;

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 ] }