Merge branch 'master' of git://factorcode.org/git/factor

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

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 ]

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-docs.factor

@@ -24,7 +24,22 @@ HELP: limit
         "    \"123456\" <string-reader> 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

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" <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
+
+[ 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

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/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 -- )) }
     { "<wrapper>" "kernel" (( obj -- wrapper )) }

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

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-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 <c-reader> stream-contents
     >string
 ] unit-test
+
+[ 0 ]
+[ "test.txt" temp-file "rb" fopen <c-reader> [ stream-tell ] [ dispose ] bi ] unit-test
+
+[ 3 ] [
+    "test.txt" temp-file "rb" fopen <c-reader>
+    3 over stream-read drop
+    [ stream-tell ] [ dispose ] bi
+] unit-test

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

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

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"

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"

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)

vm/primitives.hpp

@@ -136,6 +136,7 @@ PRIMITIVE(fread);
 PRIMITIVE(fputc);
 PRIMITIVE(fwrite);
 PRIMITIVE(fflush);
+PRIMITIVE(ftell);
 PRIMITIVE(fseek);
 PRIMITIVE(fclose);
 PRIMITIVE(wrapper);

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