2bi
] if ;
-M: unix (stream-seek) ( n seek-type stream -- )
+M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] }
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
- [ handle>> fd>> swap ] dip lseek io-error ;
+ [ fd>> swap ] dip lseek io-error ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
-M: winnt (stream-seek) ( n seek-type stream -- )
+M: winnt seek-handle ( n seek-type handle -- )
swap {
- { seek-absolute [ handle>> (>>ptr) ] }
- { seek-relative [ handle>> [ + ] change-ptr drop ] }
- { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] }
+ { seek-absolute [ (>>ptr) ] }
+ { seek-relative [ [ + ] change-ptr drop ] }
+ { seek-end [ [ handle>> handle>file-size + ] keep (>>ptr) ] }
[ bad-seek-type ]
} case ;
: buffer-reset ( n buffer -- )
swap >>fill 0 >>pos drop ;
-: buffer-reset-hard ( buffer -- )
- 0 >>fill 0 >>pos drop ;
-
: buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ; inline
HOOK: (wait-to-write) io-backend ( port -- )
-HOOK: (stream-seek) os ( n seek-type stream -- )
+HOOK: seek-handle os ( n seek-type handle -- )
-M: port stream-seek ( n seek-type stream -- )
- dup check-disposed
- [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ;
+M: input-port stream-seek ( n seek-type stream -- )
+ [ check-disposed ]
+ [ buffer>> 0 swap buffer-reset ]
+ [ handle>> seek-handle ] tri ;
+M: output-port stream-seek ( n seek-type stream -- )
+ [ check-disposed ]
+ [ stream-flush ]
+ [ handle>> seek-handle ] tri ;
GENERIC: shutdown ( handle -- )
-USING: tools.test io.files io.files.private io.files.temp
-io.directories io.encodings.8-bit arrays make system
-io.encodings.binary io threads kernel continuations
-io.encodings.ascii sequences strings accessors
-io.encodings.utf8 math destructors namespaces ;
+USING: arrays debugger.threads destructors io io.directories
+io.encodings.8-bit io.encodings.ascii io.encodings.binary
+io.files io.files.private io.files.temp io.files.unique kernel
+make math sequences system threads tools.test ;
IN: io.files.tests
\ exists? must-infer
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
+
+! File seeking tests
+[ B{ 3 2 3 4 5 } ]
+[
+ "seek-test1" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 3 } ]
+[
+ "seek-test2" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 5 0 3 } ]
+[
+ "seek-test3" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 3 } ]
+[
+ B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
+ set-file-contents
+ ] [
+ [
+ -3 seek-end seek-input 1 read
+ ] with-file-reader
+ ] 2bi
+] unit-test
+
+[ B{ 2 } ]
+[
+ B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
+ set-file-contents
+ ] [
+ [
+ 3 seek-absolute seek-input
+ -2 seek-relative seek-input
+ 1 read
+ ] with-file-reader
+ ] 2bi
+] unit-test
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
+
+HELP: stream-seek
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
+}
+{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
+ "Three methods of seeking are supported:"
+ { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
+}
+{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
+
+HELP: seek-absolute
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the beginning of the stream." } ;
+
+HELP: seek-end
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
+
+HELP: seek-relative
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the current position of the stream pointer." } ;
+
+
+HELP: seek-input
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
+
+HELP: seek-output
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
+
HELP: input-stream
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
{ $subsection stream-write }
"This word is only required for string output streams:"
{ $subsection stream-nl }
+"This word is for streams that allow seeking:"
+{ $subsection stream-seek }
"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
{ $see-also "io.timeouts" } ;
{ $subsection read-partial }
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
{ $subsection readln }
+"Seeking on the default input stream:"
+{ $subsection seek-input }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
-"Words writing to the default input stream:"
+"Words writing to the default output stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
+"Seeking on the default output stream:"
+{ $subsection seek-output }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
-USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces make io.encodings.8-bit
-io.encodings.binary sequences io.files.unique ;
+USING: io parser tools.test words ;
IN: io.tests
[ f ] [
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
-
-[ B{ 3 2 3 4 5 } ]
-[
- "seek-test1" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 3 } ]
-[
- "seek-test2" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 5 0 3 } ]
-[
- "seek-test3" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 3 } ]
-[
- B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
- set-file-contents
- ] [
- [
- -3 seek-end seek-input 1 read
- ] with-file-reader
- ] 2bi
-] unit-test
-
-[ B{ 2 } ]
-[
- B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
- set-file-contents
- ] [
- [
- 3 seek-absolute seek-input
- -2 seek-relative seek-input
- 1 read
- ] with-file-reader
- ] 2bi
-] unit-test
projects / factor.git / commitdiff