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

db4
Doug Coleman 2008-05-06 11:15:05 -05:00
commit db5716ede7
147 changed files with 1208 additions and 831 deletions

View File

@ -265,7 +265,7 @@ ARTICLE: "embedding-restrictions" "Embedding API restrictions"
ARTICLE: "embedding-factor" "What embedding looks like from Factor" ARTICLE: "embedding-factor" "What embedding looks like from Factor"
"Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance." "Factor code will run inside an embedded instance in the same way it would run in a stand-alone instance."
$nl $nl
"One exception is the global " { $link stdio } " stream, which is by default not bound to the terminal where the process is running, to avoid conflicting with any I/O the host process might perform. To initialize the terminal stream, " { $link init-stdio } " must be called explicitly." "One exception is that the global " { $link input-stream } " and " { $link output-stream } " streams are not bound by default, to avoid conflicting with any I/O the host process might perform. The " { $link init-stdio } " words must be called explicitly to initialize terminal streams."
$nl $nl
"There is a word which can detect when Factor is embedded:" "There is a word which can detect when Factor is embedded:"
{ $subsection embedded? } { $subsection embedded? }

View File

@ -475,7 +475,7 @@ M: quotation '
"Writing image to " write "Writing image to " write
architecture get boot-image-name resource-path architecture get boot-image-name resource-path
[ write "..." print flush ] [ write "..." print flush ]
[ binary <file-writer> [ (write-image) ] with-stream ] bi ; [ binary [ (write-image) ] with-file-writer ] bi ;
PRIVATE> PRIVATE>

View File

@ -87,7 +87,7 @@ f error-continuation set-global
parse-command-line parse-command-line
run-user-init run-user-init
"run" get run "run" get run
stdio get [ stream-flush ] when* output-stream get [ stream-flush ] when*
] [ print-error 1 exit ] recover ] [ print-error 1 exit ] recover
] set-boot-quot ] set-boot-quot

View File

@ -21,19 +21,19 @@ HELP: compiler-error
HELP: compiler-error. HELP: compiler-error.
{ $values { "error" "an error" } { "word" word } } { $values { "error" "an error" } { "word" word } }
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ; { $description "Prints a compiler error to " { $link output-stream } "." } ;
HELP: compiler-errors. HELP: compiler-errors.
{ $values { "type" symbol } } { $values { "type" symbol } }
{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ; { $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
HELP: :errors HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ; { $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to the " { $link stdio } " stream." } ; { $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
HELP: :linkage HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to the " { $link stdio } " stream." } ; { $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ :errors :warnings } related-words { :errors :warnings } related-words

View File

@ -34,7 +34,7 @@ $nl
{ $code { $code
"<external-resource> ... do stuff ... dispose" "<external-resource> ... do stuff ... dispose"
} }
"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ; "The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-input-stream } " and " { $link with-output-stream } "; see " { $link "stdio" } " for details." ;
ARTICLE: "errors" "Error handling" ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."

View File

@ -39,7 +39,7 @@ IN: continuations.tests
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test [ ] [ [ [ "2 car" ] eval ] try ] unit-test
[ f throw ] must-fail [ f throw ] must-fail

View File

@ -64,7 +64,7 @@ HELP: :3
HELP: error. HELP: error.
{ $values { "error" "an error" } } { $values { "error" "an error" } }
{ $contract "Print an error to the " { $link stdio } " stream. You can define methods on this generic word to print human-readable messages for custom errors." } { $contract "Print an error to " { $link output-stream } ". You can define methods on this generic word to print human-readable messages for custom errors." }
{ $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ; { $notes "Code should call " { $link print-error } " instead, which handles the case where the printing of the error itself throws an error." } ;
HELP: error-help HELP: error-help
@ -75,11 +75,11 @@ HELP: error-help
HELP: print-error HELP: print-error
{ $values { "error" "an error" } } { $values { "error" "an error" } }
{ $description "Print an error to the " { $link stdio } " stream." } { $description "Print an error to " { $link output-stream } "." }
{ $notes "This word is called by the listener and other tools which report caught errors to the user." } ; { $notes "This word is called by the listener and other tools which report caught errors to the user." } ;
HELP: restarts. HELP: restarts.
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ; { $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
HELP: error-hook HELP: error-hook
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." } { $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }

View File

@ -1,13 +1,13 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic hashtables inspector io kernel USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private math namespaces prettyprint prettyprint.config sequences assocs
strings io.styles vectors words system splitting math.parser sequences.private strings io.styles vectors words system
classes.tuple continuations continuations.private combinators splitting math.parser classes.tuple continuations
generic.math io.streams.duplex classes.builtin classes continuations.private combinators generic.math
compiler.units generic.standard vocabs threads threads.private classes.builtin classes compiler.units generic.standard vocabs
init kernel.private libc io.encodings mirrors accessors threads threads.private init kernel.private libc io.encodings
math.order ; mirrors accessors math.order ;
IN: debugger IN: debugger
GENERIC: error. ( error -- ) GENERIC: error. ( error -- )
@ -64,17 +64,13 @@ M: string error. print ;
[ global [ "Error in print-error!" print drop ] bind ] [ global [ "Error in print-error!" print drop ] bind ]
recover ; recover ;
SYMBOL: error-hook : try ( quot -- )
[
[
print-error print-error
restarts. restarts.
nl nl
"Type :help for debugging help." print flush "Type :help for debugging help." print flush
] error-hook set-global ] recover ;
: try ( quot -- )
[ error-hook get call ] recover ;
ERROR: assert got expect ; ERROR: assert got expect ;
@ -209,9 +205,6 @@ M: no-next-method summary
M: inconsistent-next-method summary M: inconsistent-next-method summary
drop "Executing call-next-method with inconsistent parameters" ; drop "Executing call-next-method with inconsistent parameters" ;
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary M: check-method summary
drop "Invalid parameters for create-method" ; drop "Invalid parameters for create-method" ;
@ -241,6 +234,15 @@ M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ; M: assert summary drop "Assertion failed" ;
M: assert error.
"Assertion failed" print
standard-table-style [
15 length-limit set
5 line-limit set
[ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
[ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
] tabular-output ;
M: immutable summary drop "Sequence is immutable" ; M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error. M: redefine-error error.

View File

@ -127,8 +127,6 @@ M: echelon-dispatch-engine engine>quot
1 slot { tuple-layout } declare 1 slot { tuple-layout } declare
5 slot ; inline 5 slot ; inline
: unclip-last [ 1 head* ] [ peek ] bi ;
M: tuple-dispatch-engine engine>quot M: tuple-dispatch-engine engine>quot
[ [
picker % picker %

View File

@ -135,7 +135,7 @@ HELP: infer
HELP: infer. HELP: infer.
{ $values { "quot" "a quotation" } } { $values { "quot" "a quotation" } }
{ $description "Attempts to infer the quotation's stack effect, and prints this data to the " { $link stdio } " stream." } { $description "Attempts to infer the quotation's stack effect, and prints this data to " { $link output-stream } "." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words { infer infer. } related-words

View File

@ -108,4 +108,4 @@ HELP: me
HELP: inspector-hook HELP: inspector-hook
{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object." { $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
$nl $nl
"The default implementation calls " { $link describe } " which outputs on the " { $link stdio } " stream, but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ; "The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;

View File

@ -9,4 +9,4 @@ HELP: init-io
{ $contract "Initializes the I/O system. Called on startup." } ; { $contract "Initializes the I/O system. Called on startup." } ;
HELP: init-stdio HELP: init-stdio
{ $contract "Initializes the global " { $link stdio } " stream. Called on startup." } ; { $contract "Initializes the global " { $link input-stream } " and " { $link output-stream } ". Called on startup." } ;

View File

@ -11,8 +11,10 @@ HOOK: init-io io-backend ( -- )
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ) HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
: init-stdio ( -- ) : init-stdio ( -- )
(init-stdio) utf8 <encoder> stderr set-global (init-stdio)
utf8 <encoder-duplex> stdio set-global ; [ utf8 <decoder> input-stream set-global ]
[ utf8 <encoder> output-stream set-global ]
[ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( ms -- ) HOOK: io-multiplex io-backend ( ms -- )

View File

@ -12,8 +12,7 @@ ARTICLE: "io.encodings" "I/O encodings"
ARTICLE: "encodings-constructors" "Manually constructing an encoded stream" ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors." "The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection <encoder> } { $subsection <encoder> }
{ $subsection <decoder> } { $subsection <decoder> } ;
{ $subsection <encoder-duplex> } ;
HELP: <encoder> HELP: <encoder>
{ $values { "stream" "an output stream" } { $values { "stream" "an output stream" }
@ -29,16 +28,6 @@ HELP: <decoder>
{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } { $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
$low-level-note ; $low-level-note ;
HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "duplex" "an encoded duplex stream" } }
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
$low-level-note ;
{ <encoder> <decoder> <encoder-duplex> } related-words
ARTICLE: "encodings-descriptors" "Encoding descriptors" ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:" "An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $subsection "io.encodings.binary" } { $subsection "io.encodings.binary" }

View File

@ -10,7 +10,7 @@ IN: io.streams.encodings.tests
unit-test unit-test
: lines-test ( stream -- line1 line2 ) : lines-test ( stream -- line1 line2 )
[ readln readln ] with-stream ; [ readln readln ] with-input-stream ;
[ [
"This is a line." "This is a line."

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces growable USING: math kernel sequences sbufs vectors namespaces growable
strings io classes continuations combinators io.styles strings io classes continuations combinators io.styles
io.streams.plain splitting io.streams.duplex byte-arrays io.streams.plain splitting byte-arrays sequences.private
sequences.private accessors ; accessors ;
IN: io.encodings IN: io.encodings
! The encoding descriptor protocol ! The encoding descriptor protocol
@ -131,6 +131,3 @@ INSTANCE: encoder plain-writer
over decoder? [ >r decoder-stream r> ] when <decoder> ; over decoder? [ >r decoder-stream r> ] when <decoder> ;
PRIVATE> PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;

View File

@ -184,8 +184,12 @@ HELP: +unknown+
{ $description "A unknown file type." } ; { $description "A unknown file type." } ;
HELP: <file-reader> HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } } {
{ "stream" "an input stream" } } $values
{ "path" "a pathname string" }
{ "encoding" "an encoding descriptor" }
{ "stream" "an input stream" }
}
{ $description "Outputs an input stream for reading from the specified pathname using the given encoding." } { $description "Outputs an input stream for reading from the specified pathname using the given encoding." }
{ $errors "Throws an error if the file is unreadable." } ; { $errors "Throws an error if the file is unreadable." } ;
@ -201,17 +205,17 @@ HELP: <file-appender>
HELP: with-file-reader HELP: with-file-reader
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } { $description "Opens a file for reading and calls the quotation using " { $link with-input-stream } "." }
{ $errors "Throws an error if the file is unreadable." } ; { $errors "Throws an error if the file is unreadable." } ;
HELP: with-file-writer HELP: with-file-writer
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-stream } "." } { $description "Opens a file for writing using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: with-file-appender HELP: with-file-appender
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } } { $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "quot" "a quotation" } }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." } { $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-output-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ; { $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: set-file-lines HELP: set-file-lines

View File

@ -25,13 +25,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
<file-reader> lines ; <file-reader> lines ;
: with-file-reader ( path encoding quot -- ) : with-file-reader ( path encoding quot -- )
>r <file-reader> r> with-stream ; inline >r <file-reader> r> with-input-stream ; inline
: file-contents ( path encoding -- str ) : file-contents ( path encoding -- str )
<file-reader> contents ; <file-reader> contents ;
: with-file-writer ( path encoding quot -- ) : with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline >r <file-writer> r> with-output-stream ; inline
: set-file-lines ( seq path encoding -- ) : set-file-lines ( seq path encoding -- )
[ [ print ] each ] with-file-writer ; [ [ print ] each ] with-file-writer ;
@ -40,7 +40,7 @@ HOOK: (file-appender) io-backend ( path -- stream )
[ write ] with-file-writer ; [ write ] with-file-writer ;
: with-file-appender ( path encoding quot -- ) : with-file-appender ( path encoding quot -- )
>r <file-appender> r> with-stream ; inline >r <file-appender> r> with-output-stream ; inline
! Pathnames ! Pathnames
: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ; : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;

View File

@ -5,7 +5,7 @@ IN: io
ARTICLE: "stream-protocol" "Stream protocol" ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional." "The stream protocol consists of a large number of generic words, many of which are optional."
$nl $nl
"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in a " { $link with-stream } ". This leads more simpler, more reusable and more robust code." "Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "."
$nl $nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol." "All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl $nl
@ -26,24 +26,24 @@ $nl
{ $subsection stream-write-table } { $subsection stream-write-table }
{ $see-also "io.timeouts" } ; { $see-also "io.timeouts" } ;
ARTICLE: "stdio" "The default stream" ARTICLE: "stdio" "Default input and output streams"
"Most I/O code only operates on one stream at a time. The " { $emphasis "default stream" } " is an implicit parameter used by many I/O words designed for this particular use-case. Using this idiom improves code in three ways:" "Most I/O code only operates on one stream at a time. The " { $link input-stream } " and " { $link output-stream } " variables are implicit parameters used by many I/O words. Using this idiom improves code in three ways:"
{ $list { $list
{ "Code becomes simpler because there is no need to keep a stream around on the stack." } { "Code becomes simpler because there is no need to keep a stream around on the stack." }
{ "Code becomes more robust because " { $link with-stream } " automatically closes the stream if there is an error." } { "Code becomes more robust because " { $link with-input-stream } " and " { $link with-output-stream } " automatically close the streams if there is an error." }
{ "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-stream } " to specify the source or destination for I/O operations." } { "Code becomes more reusable because it can be written to not worry about which stream is being used, and instead the caller can use " { $link with-input-stream } " or " { $link with-output-stream } " to specify the source or destination for I/O operations." }
} }
"For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:" "For example, here is a program which reads the first line of a file, converts it to an integer, then reads that many characters, and splits them into groups of 16:"
{ $code { $code
"USING: continuations kernel io io.files math.parser splitting ;" "USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader>" "\"data.txt\" utf8 <file-reader>"
"dup stream-readln number>string over stream-read 16 group" "dup stream-readln number>string over stream-read 16 group"
"swap dispose" "swap dispose"
} }
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:" "This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
{ $code { $code
"USING: continuations kernel io io.files math.parser splitting ;" "USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader> [" "\"data.txt\" utf8 <file-reader> ["
" dup stream-readln number>string over stream-read" " dup stream-readln number>string over stream-read"
" 16 group" " 16 group"
"] with-disposal" "] with-disposal"
@ -51,17 +51,34 @@ ARTICLE: "stdio" "The default stream"
"This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:" "This code is robust however it is more complex than it needs to be since. This is where the default stream words come in; using them, the above can be rewritten as follows:"
{ $code { $code
"USING: continuations kernel io io.files math.parser splitting ;" "USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" <file-reader> [" "\"data.txt\" utf8 <file-reader> ["
" readln number>string read 16 group" " readln number>string read 16 group"
"] with-stream" "] with-input-stream"
} }
"The default stream is stored in a dynamically-scoped variable:" "An even better implementation that takes advantage of a utility word:"
{ $subsection stdio } { $code
"Unless rebound in a child namespace, this variable will be set to a console stream for interacting with the user." "USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 ["
" readln number>string read 16 group"
"] with-file-reader"
}
"The default input stream is stored in a dynamically-scoped variable:"
{ $subsection input-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for reading input from the user."
$nl
"Words reading from the default input stream:"
{ $subsection read1 } { $subsection read1 }
{ $subsection read } { $subsection read }
{ $subsection read-until } { $subsection read-until }
{ $subsection readln } { $subsection readln }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
"The default output stream is stored in a dynamically-scoped variable:"
{ $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:"
{ $subsection flush } { $subsection flush }
{ $subsection write1 } { $subsection write1 }
{ $subsection write } { $subsection write }
@ -78,9 +95,12 @@ ARTICLE: "stdio" "The default stream"
{ $subsection with-row } { $subsection with-row }
{ $subsection with-cell } { $subsection with-cell }
{ $subsection write-cell } { $subsection write-cell }
"A pair of combinators support rebinding the " { $link stdio } " variable:" "A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-stream } { $subsection with-output-stream }
{ $subsection with-stream* } ; { $subsection with-output-stream* }
"A pair of combinators for rebinding both default streams at once:"
{ $subsection with-streams }
{ $subsection with-streams* } ;
ARTICLE: "stream-utils" "Stream utilities" ARTICLE: "stream-utils" "Stream utilities"
"There are a few useful stream-related words which are not generic, but merely built up from the stream protocol." "There are a few useful stream-related words which are not generic, but merely built up from the stream protocol."
@ -204,62 +224,65 @@ HELP: stream-copy
{ $description "Copies the contents of one stream into another, closing both streams when done." } { $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ; $io-error ;
HELP: stdio HELP: input-stream
{ $var-description "Holds a stream, used for various implicit stream operations. Rebound using " { $link with-stream } " and " { $link with-stream* } "." } ; { $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
HELP: output-stream
{ $var-description "Holds an output stream for various implicit stream operations. Rebound using " { $link with-output-stream } " and " { $link with-output-stream* } "." } ;
HELP: readln HELP: readln
{ $values { "str/f" "a string or " { $link f } } } { $values { "str/f" "a string or " { $link f } } }
{ $description "Reads a line of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } { $description "Reads a line of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ; $io-error ;
HELP: read1 HELP: read1
{ $values { "ch/f" "a character or " { $link f } } } { $values { "ch/f" "a character or " { $link f } } }
{ $description "Reads a character of input from the " { $link stdio } " stream. Outputs " { $link f } " on stream exhaustion." } { $description "Reads a character of input from " { $link input-stream } ". Outputs " { $link f } " on stream exhaustion." }
$io-error ; $io-error ;
HELP: read HELP: read
{ $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } } { $values { "n" "a non-negative integer" } { "str/f" "a string or " { $link f } } }
{ $description "Reads " { $snippet "n" } " characters of input from the " { $link stdio } " stream. Outputs a truncated string or " { $link f } " on stream exhaustion." } { $description "Reads " { $snippet "n" } " characters of input from " { $link input-stream } ". Outputs a truncated string or " { $link f } " on stream exhaustion." }
$io-error ; $io-error ;
HELP: read-until HELP: read-until
{ $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } } { $values { "seps" string } { "str/f" "a string or " { $link f } } { "sep/f" "a character or " { $link f } } }
{ $contract "Reads characters from the " { $link stdio } " stream. until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." } { $contract "Reads characters from " { $link input-stream } ". until the first occurrence of a separator character, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output string. In the latter case, the entire stream contents are output, along with " { $link f } "." }
$io-error ; $io-error ;
HELP: write1 HELP: write1
{ $values { "ch" "a character" } } { $values { "ch" "a character" } }
{ $contract "Writes a character of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $contract "Writes a character of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ; $io-error ;
HELP: write HELP: write
{ $values { "str" string } } { $values { "str" string } }
{ $description "Writes a string of output to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $description "Writes a string of output to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ; $io-error ;
HELP: flush HELP: flush
{ $description "Waits for any pending output to the " { $link stdio } " stream to complete." } { $description "Waits for any pending output on " { $link output-stream } " to complete." }
$io-error ; $io-error ;
HELP: nl HELP: nl
{ $description "Writes a line terminator to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $description "Writes a line terminator to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
$io-error ; $io-error ;
HELP: format HELP: format
{ $values { "str" string } { "style" "a hashtable" } } { $values { "str" string } { "style" "a hashtable" } }
{ $description "Writes formatted text to the " { $link stdio } " stream. If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." } { $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." } { $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ; $io-error ;
HELP: with-nesting HELP: with-nesting
{ $values { "style" "a hashtable" } { "quot" "a quotation" } } { $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied." } { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." } { $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ; $io-error ;
HELP: tabular-output HELP: tabular-output
{ $values { "style" "a hashtable" } { "quot" quotation } } { $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on the " { $link stdio } " stream." { $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl $nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." } "The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
{ $examples { $examples
@ -279,7 +302,7 @@ $io-error ;
HELP: with-cell HELP: with-cell
{ $values { "quot" quotation } } { $values { "quot" quotation } }
{ $description "Calls a quotation in a new scope with the " { $link stdio } " stream rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." } { $description "Calls a quotation in a new scope with " { $link output-stream } " rebound. Output performed by the quotation is displayed in a table cell. This word can only be called inside the quotation given to " { $link with-row } "." }
$io-error ; $io-error ;
HELP: write-cell HELP: write-cell
@ -288,34 +311,54 @@ HELP: write-cell
$io-error ; $io-error ;
HELP: with-style HELP: with-style
{ $values { "style" "a hashtable" } { "quot" "a quotation" } } { $values { "style" "a hashtable" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." } { $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." } { $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ; $io-error ;
HELP: print HELP: print
{ $values { "string" string } } { $values { "string" string } }
{ $description "Writes a newline-terminated string to the " { $link stdio } " stream." } { $description "Writes a newline-terminated string to " { $link output-stream } "." }
$io-error ; $io-error ;
HELP: with-stream HELP: with-input-stream
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } } { $values { "stream" "an input stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ; { $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
{ with-stream with-stream* } related-words HELP: with-output-stream
{ $values { "stream" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-stream* HELP: with-streams
{ $values { "stream" "an input or output stream" } { "quot" "a quotation" } } { $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with the " { $link stdio } " variable rebound to " { $snippet "stream" } "." } { $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } ". The stream is closed if the quotation returns or throws an error." } ;
{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
HELP: with-streams*
{ $values { "input" "an input stream" } { "output" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "input" } " and " { $link output-stream } " rebound to " { $snippet "output" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-streams } "." } ;
{ with-input-stream with-input-stream* } related-words
{ with-output-stream with-output-stream* } related-words
HELP: with-input-stream*
{ $values { "stream" "an input stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link input-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-input-stream } "." } ;
HELP: with-output-stream*
{ $values { "stream" "an output stream" } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with " { $link output-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-output-stream } "." } ;
HELP: bl HELP: bl
{ $description "Outputs a space character (" { $snippet "\" \"" } ")." } { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ; $io-error ;
HELP: write-object HELP: write-object
{ $values { "str" string } { "obj" "an object" } } { $values { "str" string } { "obj" "an object" } }
{ $description "Writes a string to the " { $link stdio } " stream, associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." } { $description "Writes a string to " { $link output-stream } ", associating it with the object. If formatted output is supported, the string will become a clickable presentation of the object, otherwise this word behaves like a call to " { $link write } "." }
$io-error ; $io-error ;
HELP: lines HELP: lines

View File

@ -15,14 +15,14 @@ IN: io.tests
"This is a line.\rThis is another line.\r" "This is a line.\rThis is another line.\r"
] [ ] [
"core/io/test/mac-os-eol.txt" <resource-reader> "core/io/test/mac-os-eol.txt" <resource-reader>
[ 500 read ] with-stream [ 500 read ] with-input-stream
] unit-test ] unit-test
[ [
255 255
] [ ] [
"core/io/test/binary.txt" <resource-reader> "core/io/test/binary.txt" <resource-reader>
[ read1 ] with-stream >fixnum [ read1 ] with-input-stream >fixnum
] unit-test ] unit-test
! Make sure we use correct to_c_string form when writing ! Make sure we use correct to_c_string form when writing
@ -40,7 +40,7 @@ IN: io.tests
"J" read-until 2array , "J" read-until 2array ,
"i" read-until 2array , "i" read-until 2array ,
"X" read-until 2array , "X" read-until 2array ,
] with-stream ] with-input-stream
] { } make ] { } make
] unit-test ] unit-test
@ -49,12 +49,3 @@ IN: io.tests
10 [ 65536 read drop ] times 10 [ 65536 read drop ] times
] with-file-reader ] with-file-reader
] unit-test ] unit-test
! [ "" ] [ 0 read ] unit-test
! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
! [
! "/core/io/test/binary.txt" <resource-reader>
! [ 0.2 read ] with-stream
! ] must-fail

View File

@ -30,39 +30,52 @@ GENERIC: stream-write-table ( table-cells style stream -- )
[ 2dup (stream-copy) ] [ dispose dispose ] [ ] [ 2dup (stream-copy) ] [ dispose dispose ] [ ]
cleanup ; cleanup ;
! Default stream ! Default streams
SYMBOL: stdio SYMBOL: input-stream
SYMBOL: output-stream
SYMBOL: error-stream
! Default error stream : readln ( -- str/f ) input-stream get stream-readln ;
SYMBOL: stderr : read1 ( -- ch/f ) input-stream get stream-read1 ;
: read ( n -- str/f ) input-stream get stream-read ;
: read-until ( seps -- str/f sep/f ) input-stream get stream-read-until ;
: readln ( -- str/f ) stdio get stream-readln ; : write1 ( ch -- ) output-stream get stream-write1 ;
: read1 ( -- ch/f ) stdio get stream-read1 ; : write ( str -- ) output-stream get stream-write ;
: read ( n -- str/f ) stdio get stream-read ; : flush ( -- ) output-stream get stream-flush ;
: read-until ( seps -- str/f sep/f ) stdio get stream-read-until ;
: write1 ( ch -- ) stdio get stream-write1 ; : nl ( -- ) output-stream get stream-nl ;
: write ( str -- ) stdio get stream-write ; : format ( str style -- ) output-stream get stream-format ;
: flush ( -- ) stdio get stream-flush ;
: nl ( -- ) stdio get stream-nl ; : with-input-stream* ( stream quot -- )
: format ( str style -- ) stdio get stream-format ; input-stream swap with-variable ; inline
: with-stream* ( stream quot -- ) : with-input-stream ( stream quot -- )
stdio swap with-variable ; inline [ with-input-stream* ] curry with-disposal ; inline
: with-stream ( stream quot -- ) : with-output-stream* ( stream quot -- )
[ with-stream* ] curry with-disposal ; inline output-stream swap with-variable ; inline
: with-output-stream ( stream quot -- )
[ with-output-stream* ] curry with-disposal ; inline
: with-streams* ( input output quot -- )
[ output-stream set input-stream set ] prepose with-scope ; inline
: with-streams ( input output quot -- )
[ [ with-streams* ] 3curry ]
[ [ drop dispose dispose ] 3curry ] 3bi
[ ] cleanup ; inline
: tabular-output ( style quot -- ) : tabular-output ( style quot -- )
swap >r { } make r> stdio get stream-write-table ; inline swap >r { } make r> output-stream get stream-write-table ; inline
: with-row ( quot -- ) : with-row ( quot -- )
{ } make , ; inline { } make , ; inline
: with-cell ( quot -- ) : with-cell ( quot -- )
H{ } stdio get make-cell-stream H{ } output-stream get make-cell-stream
[ swap with-stream ] keep , ; inline [ swap with-output-stream ] keep , ; inline
: write-cell ( str -- ) : write-cell ( str -- )
[ write ] with-cell ; inline [ write ] with-cell ; inline
@ -71,13 +84,14 @@ SYMBOL: stderr
swap dup assoc-empty? [ swap dup assoc-empty? [
drop call drop call
] [ ] [
stdio get make-span-stream swap with-stream output-stream get make-span-stream swap with-output-stream
] if ; inline ] if ; inline
: with-nesting ( style quot -- ) : with-nesting ( style quot -- )
>r stdio get make-block-stream r> with-stream ; inline >r output-stream get make-block-stream
r> with-output-stream ; inline
: print ( string -- ) stdio get stream-print ; : print ( string -- ) output-stream get stream-print ;
: bl ( -- ) " " write ; : bl ( -- ) " " write ;
@ -85,9 +99,9 @@ SYMBOL: stderr
presented associate format ; presented associate format ;
: lines ( stream -- seq ) : lines ( stream -- seq )
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ; [ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
: contents ( stream -- str ) : contents ( stream -- str )
[ [
[ 65536 read dup ] [ ] [ drop ] unfold concat f like [ 65536 read dup ] [ ] [ drop ] unfold concat f like
] with-stream ; ] with-input-stream ;

View File

@ -25,10 +25,10 @@ HELP: <byte-writer>
HELP: with-byte-reader HELP: with-byte-reader
{ $values { "encoding" "an encoding descriptor" } { $values { "encoding" "an encoding descriptor" }
{ "quot" quotation } { "byte-array" byte-array } } { "quot" quotation } { "byte-array" byte-array } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream for reading from a byte array using an encoding." } ; { $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
HELP: with-byte-writer HELP: with-byte-writer
{ $values { "encoding" "an encoding descriptor" } { $values { "encoding" "an encoding descriptor" }
{ "quot" quotation } { "quot" quotation }
{ "byte-array" byte-array } } { "byte-array" byte-array } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an output stream writing data to a byte array using an encoding." } ; { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;

View File

@ -1,16 +1,16 @@
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private ; sequences io namespaces io.encodings.private accessors ;
IN: io.streams.byte-array IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream ) : <byte-writer> ( encoding -- stream )
512 <byte-vector> swap <encoder> ; 512 <byte-vector> swap <encoder> ;
: with-byte-writer ( encoding quot -- byte-array ) : with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream* >r <byte-writer> r> [ output-stream get ] compose with-output-stream*
dup encoder? [ encoder-stream ] when >byte-array ; inline dup encoder? [ stream>> ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream ) : <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ; >r >byte-vector dup reverse-here r> <decoder> ;
: with-byte-reader ( byte-array encoding quot -- ) : with-byte-reader ( byte-array encoding quot -- )
>r <byte-reader> r> with-stream ; inline >r <byte-reader> r> with-input-stream* ; inline

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces io io.encodings USING: kernel kernel.private namespaces io io.encodings
sequences math generic threads.private classes io.backend sequences math generic threads.private classes io.backend
io.streams.duplex io.files continuations byte-arrays ; io.files continuations byte-arrays ;
IN: io.streams.c IN: io.streams.c
TUPLE: c-writer handle ; TUPLE: c-writer handle ;

View File

@ -1,19 +0,0 @@
USING: help.markup help.syntax io continuations ;
IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
HELP: duplex-stream
{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;

View File

@ -17,7 +17,7 @@ HELP: <string-writer>
HELP: with-string-writer HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } } { $values { "quot" quotation } { "str" string } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ; { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a new string writer. The accumulated string is output when the quotation returns." } ;
HELP: <string-reader> HELP: <string-reader>
{ $values { "str" string } { "stream" "an input stream" } } { $values { "str" string } { "stream" "an input stream" } }
@ -26,4 +26,4 @@ HELP: <string-reader>
HELP: with-string-reader HELP: with-string-reader
{ $values { "str" string } { "quot" quotation } } { $values { "str" string } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link stdio } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ; { $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream reading " { $snippet "str" } " from beginning to end." } ;

View File

@ -35,7 +35,7 @@ unit-test
"J" read-until 2array , "J" read-until 2array ,
"i" read-until 2array , "i" read-until 2array ,
"X" read-until 2array , "X" read-until 2array ,
] with-stream ] with-input-stream
] { } make ] { } make
] unit-test ] unit-test

View File

@ -15,7 +15,7 @@ M: growable stream-flush drop ;
512 <sbuf> ; 512 <sbuf> ;
: with-string-writer ( quot -- str ) : with-string-writer ( quot -- str )
<string-writer> swap [ stdio get ] compose with-stream* <string-writer> swap [ output-stream get ] compose with-output-stream*
>string ; inline >string ; inline
M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ; M: growable stream-read1 dup empty? [ drop f ] [ pop ] if ;
@ -56,7 +56,7 @@ M: null decode-char drop stream-read1 ;
>sbuf dup reverse-here null <decoder> ; >sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- ) : with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline >r <string-reader> r> with-input-stream ; inline
INSTANCE: growable plain-writer INSTANCE: growable plain-writer
@ -67,15 +67,14 @@ INSTANCE: growable plain-writer
] unless ; ] unless ;
: map-last ( seq quot -- seq ) : map-last ( seq quot -- seq )
swap dup length <reversed> >r dup length <reversed> [ zero? ] r> compose 2map ; inline
[ zero? rot [ call ] keep swap ] 2map nip ; inline
: format-table ( table -- seq ) : format-table ( table -- seq )
flip [ format-column ] map-last flip [ format-column ] map-last
flip [ " " join ] map ; flip [ " " join ] map ;
M: plain-writer stream-write-table M: plain-writer stream-write-table
[ drop format-table [ print ] each ] with-stream* ; [ drop format-table [ print ] each ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ; M: plain-writer make-cell-stream 2drop <string-writer> ;

View File

@ -32,14 +32,14 @@ HELP: listener-hook
HELP: read-quot HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link stdio } " stream. Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ; { $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
HELP: listen HELP: listen
{ $description "Prompts for an expression on the " { $link stdio } " stream and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." } { $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
{ $errors "If the expression input by the user throws an error, the error is printed to the " { $link stdio } " stream and the word returns normally." } ; { $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
HELP: listener HELP: listener
{ $description "Prompts for expressions on the " { $link stdio } " stream and evaluates them until end of file is reached." } ; { $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
HELP: bye HELP: bye
{ $description "Exits the current listener." } { $description "Exits the current listener." }

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io kernel math math.parser memory USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators vectors words generic system combinators continuations debugger
continuations debugger definitions compiler.units accessors ; definitions compiler.units accessors ;
IN: listener IN: listener
SYMBOL: quit-flag SYMBOL: quit-flag
@ -35,10 +35,7 @@ GENERIC: stream-read-quot ( stream -- quot/f )
M: object stream-read-quot M: object stream-read-quot
V{ } clone read-quot-loop ; V{ } clone read-quot-loop ;
M: duplex-stream stream-read-quot : read-quot ( -- quot/f ) input-stream get stream-read-quot ;
duplex-stream-in stream-read-quot ;
: read-quot ( -- quot/f ) stdio get stream-read-quot ;
: bye ( -- ) quit-flag on ; : bye ( -- ) quit-flag on ;
@ -46,9 +43,11 @@ M: duplex-stream stream-read-quot
"( " in get " )" 3append "( " in get " )" 3append
H{ { background { 1 0.7 0.7 1 } } } format bl flush ; H{ { background { 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: error-hook
: listen ( -- ) : listen ( -- )
listener-hook get call prompt. listener-hook get call prompt.
[ read-quot [ try ] [ bye ] if* ] [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[ [
dup parse-error? [ dup parse-error? [
error-hook get call error-hook get call

View File

@ -98,3 +98,9 @@ unit-test
[ 1 1 >base ] must-fail [ 1 1 >base ] must-fail
[ 1 0 >base ] must-fail [ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail [ 1 -1 >base ] must-fail
[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test

View File

@ -140,9 +140,9 @@ M: ratio >base
M: float >base M: float >base
drop { drop {
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
[ float>string fix-float ] [ float>string fix-float ]
} cond ; } cond ;

View File

@ -5,7 +5,7 @@ quotations namespaces compiler.units assocs ;
IN: parser IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names" ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
"If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, a message is printed to the " { $link stdio } " stream. Except when debugging suspected name clashes, these messages can be ignored." "If adding a vocabulary to the search path results in a word in another vocabulary becoming inaccessible due to the new vocabulary defining a word with the same name, we say that the old word has been " { $emphasis "shadowed" } "."
$nl $nl
"Here is an example where shadowing occurs:" "Here is an example where shadowing occurs:"
{ $code { $code
@ -13,18 +13,18 @@ $nl
"USING: sequences io ;" "USING: sequences io ;"
"" ""
": append" ": append"
" \"foe::append calls sequences::append\" print append ;" " \"foe::append calls sequences:append\" print append ;"
"" ""
"IN: fee" "IN: fee"
"" ""
": append" ": append"
" \"fee::append calls fee::append\" print append ;" " \"fee::append calls fee:append\" print append ;"
"" ""
"IN: fox" "IN: fox"
"USE: foe" "USE: foe"
"" ""
": append" ": append"
" \"fox::append calls foe::append\" print append ;" " \"fox::append calls foe:append\" print append ;"
"" ""
"\"1234\" \"5678\" append print" "\"1234\" \"5678\" append print"
"" ""
@ -33,12 +33,13 @@ $nl
} }
"When placed in a source file and run, the above code produces the following output:" "When placed in a source file and run, the above code produces the following output:"
{ $code { $code
"foe::append calls sequences::append" "foe:append calls sequences:append"
"12345678" "12345678"
"fee::append calls foe::append" "fee:append calls foe:append"
"foe::append calls sequences::append" "foe:append calls sequences:append"
"12345678" "12345678"
} ; }
"The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ;
ARTICLE: "vocabulary-search-errors" "Word lookup errors" ARTICLE: "vocabulary-search-errors" "Word lookup errors"
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:" "If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
@ -215,7 +216,7 @@ HELP: save-location
{ $description "Saves the location of a definition and associates this definition with the current source file." } ; { $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: parser-notes HELP: parser-notes
{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ; { $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
HELP: parser-notes? HELP: parser-notes?
{ $values { "?" "a boolean" } } { $values { "?" "a boolean" } }
@ -506,7 +507,7 @@ HELP: bootstrap-file
HELP: eval>string HELP: eval>string
{ $values { "str" string } { "output" string } } { $values { "str" string } { "output" string } }
{ $description "Evaluates the Factor code in " { $snippet "str" } " with the " { $link stdio } " stream rebound to a string output stream, then outputs the resulting string." } ; { $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
HELP: staging-violation HELP: staging-violation
{ $values { "word" word } } { $values { "word" word } }

View File

@ -135,7 +135,7 @@ ARTICLE: "prettyprint" "The prettyprinter"
$nl $nl
"Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary." "Prettyprinter words are found in the " { $vocab-link "prettyprint" } " vocabulary."
$nl $nl
"The key words to print an object to the " { $link stdio } " stream; the first two emit a trailing newline, the second two do not:" "The key words to print an object to " { $link output-stream } "; the first two emit a trailing newline, the second two do not:"
{ $subsection . } { $subsection . }
{ $subsection short. } { $subsection short. }
{ $subsection pprint } { $subsection pprint }
@ -161,17 +161,17 @@ ABOUT: "prettyprint"
HELP: with-pprint HELP: with-pprint
{ $values { "obj" object } { "quot" quotation } } { $values { "obj" object } { "quot" quotation } }
{ $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to the " { $link stdio } " stream." } ; { $description "Sets up the prettyprinter and calls the quotation in a new scope. The quotation should add sections to the top-level block. When the quotation returns, the top-level block is printed to " { $link output-stream } "." } ;
HELP: pprint HELP: pprint
{ $values { "obj" object } } { $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ; { $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
{ pprint pprint* with-pprint } related-words { pprint pprint* with-pprint } related-words
HELP: . HELP: .
{ $values { "obj" object } } { $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ; { $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
HELP: unparse HELP: unparse
{ $values { "obj" object } { "str" "Factor source string" } } { $values { "obj" object } { "str" "Factor source string" } }
@ -179,11 +179,11 @@ HELP: unparse
HELP: pprint-short HELP: pprint-short
{ $values { "obj" object } } { $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream. This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ; { $description "Prettyprints an object to " { $link output-stream } ". This word rebinds printer control variables to enforce ``shorter'' output. See " { $link "prettyprint-variables" } "." } ;
HELP: short. HELP: short.
{ $values { "obj" object } } { $values { "obj" object } }
{ $description "Prettyprints an object to the " { $link stdio } " stream with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ; { $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. This word rebinds printer control variables to enforce ``shorter'' output." } ;
HELP: .b HELP: .b
{ $values { "n" "an integer" } } { $values { "n" "an integer" } }

View File

@ -15,7 +15,7 @@ HELP: line-limit?
HELP: do-indent HELP: do-indent
{ $description "Outputs the current indent nesting to the " { $link stdio } " stream." } ; { $description "Outputs the current indent nesting to " { $link output-stream } "." } ;
HELP: fresh-line HELP: fresh-line
{ $values { "n" "the current column position" } } { $values { "n" "the current column position" } }

View File

@ -670,9 +670,15 @@ PRIVATE>
: unclip ( seq -- rest first ) : unclip ( seq -- rest first )
[ rest ] [ first ] bi ; [ rest ] [ first ] bi ;
: unclip-last ( seq -- butfirst last )
[ 1 head* ] [ peek ] bi ;
: unclip-slice ( seq -- rest first ) : unclip-slice ( seq -- rest first )
[ rest-slice ] [ first ] bi ; [ rest-slice ] [ first ] bi ;
: unclip-last-slice ( seq -- butfirst last )
[ 1 head-slice* ] [ peek ] bi ;
: <flat-slice> ( seq -- slice ) : <flat-slice> ( seq -- slice )
dup slice? [ { } like ] when 0 over length rot <slice> ; dup slice? [ { } like ] when 0 over length rot <slice> ;
inline inline

View File

@ -1,42 +1,72 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces strings arrays vectors sequences USING: kernel math namespaces strings arrays vectors sequences
sets math.order ; sets math.order accessors ;
IN: splitting IN: splitting
TUPLE: groups seq n sliced? ; TUPLE: abstract-groups seq n ;
: check-groups 0 <= [ "Invalid group count" throw ] when ; : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
: construct-groups ( seq n class -- groups )
>r check-groups r> boa ; inline
GENERIC: group@ ( n groups -- from to seq )
M: abstract-groups nth group@ subseq ;
M: abstract-groups set-nth group@ <slice> 0 swap copy ;
M: abstract-groups like drop { } like ;
INSTANCE: abstract-groups sequence
TUPLE: groups < abstract-groups ;
: <groups> ( seq n -- groups ) : <groups> ( seq n -- groups )
dup check-groups f groups boa ; inline groups construct-groups ; inline
: <sliced-groups> ( seq n -- groups )
<groups> t over set-groups-sliced? ;
M: groups length M: groups length
dup groups-seq length swap groups-n [ + 1- ] keep /i ; [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
M: groups set-length M: groups set-length
[ groups-n * ] keep groups-seq set-length ; [ n>> * ] [ seq>> ] bi set-length ;
: group@ ( n groups -- from to seq ) M: groups group@
[ groups-n [ * dup ] keep + ] keep [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
groups-seq [ length min ] keep ;
M: groups nth TUPLE: sliced-groups < groups ;
[ group@ ] keep
groups-sliced? [ <slice> ] [ subseq ] if ;
M: groups set-nth : <sliced-groups> ( seq n -- groups )
group@ <slice> 0 swap copy ; sliced-groups construct-groups ; inline
M: groups like drop { } like ; M: sliced-groups nth group@ <slice> ;
INSTANCE: groups sequence TUPLE: clumps < abstract-groups ;
: <clumps> ( seq n -- groups )
clumps construct-groups ; inline
M: clumps length
[ seq>> length ] [ n>> ] bi - 1+ ;
M: clumps set-length
[ n>> + 1- ] [ seq>> ] bi set-length ;
M: clumps group@
[ n>> over + ] [ seq>> ] bi ;
TUPLE: sliced-clumps < groups ;
: <sliced-clumps> ( seq n -- groups )
sliced-clumps construct-groups ; inline
M: sliced-clumps nth group@ <slice> ;
: group ( seq n -- array ) <groups> { } like ; : group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: ?head ( seq begin -- newseq ? ) : ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ; 2dup head? [ length tail t ] [ drop f ] if ;

View File

@ -116,10 +116,13 @@ $nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; "Other threads may interrupt the sleep by calling " { $link interrupt } "." } ;
HELP: sleep HELP: sleep
{ $values { "ms" "a non-negative integer" } } { $values { "dt" "a duration" } }
{ $description "Suspends the current thread for " { $snippet "ms" } " milliseconds." { $description "Suspends the current thread for the given duration."
$nl $nl
"Other threads may interrupt the sleep by calling " { $link interrupt } "." } ; "Other threads may interrupt the sleep by calling " { $link interrupt } "." }
{ $examples
{ $code "USING: threads calendar ;" "10 seconds sleep" }
} ;
HELP: interrupt HELP: interrupt
{ $values { "thread" thread } } { $values { "thread" thread } }

View File

@ -93,7 +93,7 @@ PRIVATE>
<PRIVATE <PRIVATE
: schedule-sleep ( thread ms -- ) : schedule-sleep ( thread dt -- )
>r check-registered dup r> sleep-queue heap-push* >r check-registered dup r> sleep-queue heap-push*
>>sleep-entry drop ; >>sleep-entry drop ;
@ -153,7 +153,7 @@ M: integer sleep-until
M: f sleep-until M: f sleep-until
drop [ drop ] "interrupt" suspend drop ; drop [ drop ] "interrupt" suspend drop ;
GENERIC: sleep ( ms -- ) GENERIC: sleep ( dt -- )
M: real sleep M: real sleep
millis + >integer sleep-until ; millis + >integer sleep-until ;

View File

@ -1,16 +1,16 @@
USING: asn1 asn1.ldap io io.streams.string tools.test ; USING: asn1 asn1.ldap io io.streams.string tools.test ;
[ 6 ] [ [ 6 ] [
"\u000002\u000001\u000006" <string-reader> [ asn-syntax read-ber ] with-stream "\u000002\u000001\u000006" <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test ] unit-test
[ "testing" ] [ [ "testing" ] [
"\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-stream "\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test ] unit-test
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [ [ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
"0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus" "0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
<string-reader> [ asn-syntax read-ber ] with-stream <string-reader> [ asn-syntax read-ber ] with-input-stream
] unit-test ] unit-test
[ [

View File

@ -98,7 +98,7 @@ DEFER: read-ber
SYMBOL: end SYMBOL: end
: (read-array) ( stream -- ) : (read-array) ( -- )
elements get element-id [ elements get element-id [
elements get element-syntax read-ber elements get element-syntax read-ber
dup end = [ drop ] [ , (read-array) ] if dup end = [ drop ] [ , (read-array) ] if
@ -106,7 +106,7 @@ SYMBOL: end
: read-array ( -- array ) [ (read-array) ] { } make ; : read-array ( -- array ) [ (read-array) ] { } make ;
: set-case ( -- ) : set-case ( -- object )
elements get element-newobj elements get element-newobj
elements get element-objtype { elements get element-objtype {
{ "boolean" [ "\0" = not ] } { "boolean" [ "\0" = not ] }

View File

@ -32,13 +32,11 @@ HINTS: do-line vector string ;
readln [ do-line (reverse-complement) ] [ show-seq ] if* ; readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- ) : reverse-complement ( infile outfile -- )
ascii <file-writer> [ ascii [
swap ascii <file-reader> [ ascii [
swap <duplex-stream> [
500000 <vector> (reverse-complement) 500000 <vector> (reverse-complement)
] with-stream ] with-file-reader
] with-disposal ] with-file-writer ;
] with-disposal ;
: reverse-complement-in : reverse-complement-in
"reverse-complement-in.txt" temp-file ; "reverse-complement-in.txt" temp-file ;

View File

@ -1,6 +1,6 @@
USING: io.sockets io kernel math threads io.encodings.ascii USING: io.sockets io kernel math threads io.encodings.ascii
debugger tools.time prettyprint concurrency.count-downs io.streams.duplex debugger tools.time prettyprint
namespaces arrays continuations ; concurrency.count-downs namespaces arrays continuations ;
IN: benchmark.sockets IN: benchmark.sockets
SYMBOL: counter SYMBOL: counter
@ -30,17 +30,17 @@ SYMBOL: counter
] ignore-errors ; ] ignore-errors ;
: simple-client ( -- ) : simple-client ( -- )
server-addr ascii <client> [ server-addr ascii [
CHAR: b write1 flush CHAR: b write1 flush
number-of-requests number-of-requests
[ CHAR: a dup write1 flush read1 assert= ] times [ CHAR: a dup write1 flush read1 assert= ] times
counter get count-down counter get count-down
] with-stream ; ] with-client ;
: stop-server ( -- ) : stop-server ( -- )
server-addr ascii <client> [ server-addr ascii [
CHAR: x write1 CHAR: x write1
] with-stream ; ] with-client ;
: clients ( n -- ) : clients ( n -- )
dup pprint " clients: " write [ dup pprint " clients: " write [

View File

@ -16,7 +16,7 @@ IN: builder.util
: minutes>ms ( min -- ms ) 60 * 1000 * ; : minutes>ms ( min -- ms ) 60 * 1000 * ;
: file>string ( file -- string ) utf8 [ stdio get contents ] with-file-reader ; : file>string ( file -- string ) utf8 file-contents ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -107,5 +107,5 @@ USE: prettyprint
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: git-id ( -- id ) : git-id ( -- id )
{ "git" "show" } utf8 <process-stream> [ readln ] with-stream { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
" " split second ; " " split second ;

View File

@ -180,4 +180,4 @@ SINGLETON: md5
INSTANCE: md5 checksum INSTANCE: md5 checksum
M: md5 checksum-stream ( stream -- byte-array ) M: md5 checksum-stream ( stream -- byte-array )
drop [ initialize-md5 stream>md5 get-md5 ] with-stream ; drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;

View File

@ -111,7 +111,7 @@ SINGLETON: sha1
INSTANCE: sha1 checksum INSTANCE: sha1 checksum
M: sha1 checksum-stream ( stream -- sha1 ) M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-stream ; drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
: sha1-interleave ( string -- seq ) : sha1-interleave ( string -- seq )
[ zero? ] left-trim [ zero? ] left-trim

View File

@ -3,7 +3,7 @@
USING: serialize sequences concurrency.messaging threads io USING: serialize sequences concurrency.messaging threads io
io.server qualified arrays namespaces kernel io.encodings.binary io.server qualified arrays namespaces kernel io.encodings.binary
accessors ; accessors ;
QUALIFIED: io.sockets FROM: io.sockets => host-name <inet> with-client ;
IN: concurrency.distributed IN: concurrency.distributed
SYMBOL: local-node SYMBOL: local-node
@ -23,7 +23,7 @@ SYMBOL: local-node
: start-node ( port -- ) : start-node ( port -- )
[ internet-server ] [ internet-server ]
[ io.sockets:host-name swap io.sockets:<inet> ] bi [ host-name swap <inet> ] bi
(start-node) ; (start-node) ;
TUPLE: remote-process id node ; TUPLE: remote-process id node ;
@ -31,8 +31,7 @@ TUPLE: remote-process id node ;
C: <remote-process> remote-process C: <remote-process> remote-process
: send-remote-message ( message node -- ) : send-remote-message ( message node -- )
binary io.sockets:<client> binary [ serialize ] with-client ;
[ serialize ] with-stream ;
M: remote-process send ( message thread -- ) M: remote-process send ( message thread -- )
[ id>> 2array ] [ node>> ] bi [ id>> 2array ] [ node>> ] bi

View File

@ -7,7 +7,7 @@ IN: contributors
: changelog ( -- authors ) : changelog ( -- authors )
image parent-directory [ image parent-directory [
"git-log --pretty=format:%an" <process-stream> lines "git-log --pretty=format:%an" <process-reader> lines
] with-directory ; ] with-directory ;
: patch-counts ( authors -- assoc ) : patch-counts ( authors -- assoc )

View File

@ -1,5 +1,5 @@
USING: kernel cpu.8080 cpu.8080.emulator math math io USING: kernel cpu.8080 cpu.8080.emulator math math io
tools.time combinators sequences io.files ; tools.time combinators sequences io.files io.encodings.ascii ;
IN: cpu.8080.test IN: cpu.8080.test
: step ( cpu -- ) : step ( cpu -- )
@ -29,7 +29,7 @@ IN: cpu.8080.test
: >ppm ( cpu filename -- cpu ) : >ppm ( cpu filename -- cpu )
#! Dump the current screen image to a ppm image file with the given name. #! Dump the current screen image to a ppm image file with the given name.
<file-writer> [ ascii [
"P3" print "P3" print
"256 224" print "256 224" print
"1" print "1" print
@ -45,7 +45,7 @@ IN: cpu.8080.test
] each-8bit drop ] each-8bit drop
] each drop nl ] each drop nl
] each ] each
] with-stream ; ] with-file-writer ;
: time-test ( -- ) : time-test ( -- )
test-cpu [ 1000000 run-n drop ] time ; test-cpu [ 1000000 run-n drop ] time ;

View File

@ -30,7 +30,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
ipad seq-bitxor ; ipad seq-bitxor ;
: stream>sha1-hmac ( K stream -- hmac ) : stream>sha1-hmac ( K stream -- hmac )
[ init-hmac sha1-hmac ] with-stream ; [ init-hmac sha1-hmac ] with-input-stream ;
: file>sha1-hmac ( K path -- hmac ) : file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ; binary <file-reader> stream>sha1-hmac ;
@ -39,7 +39,7 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
binary <byte-reader> stream>sha1-hmac ; binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac ) : stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ; [ init-hmac md5-hmac ] with-input-stream ;
: file>md5-hmac ( K path -- hmac ) : file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ; binary <file-reader> stream>md5-hmac ;

View File

@ -61,11 +61,11 @@ VAR: delimiter
: csv-row ( stream -- row ) : csv-row ( stream -- row )
init-vars init-vars
[ row nip ] with-stream ; [ row nip ] with-input-stream ;
: csv ( stream -- rows ) : csv ( stream -- rows )
init-vars init-vars
[ [ (csv) ] { } make ] with-stream ; [ [ (csv) ] { } make ] with-input-stream ;
: with-delimiter ( char quot -- ) : with-delimiter ( char quot -- )
delimiter swap with-variable ; inline delimiter swap with-variable ; inline

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg ! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs prettyprint.sections USING: delegate sequences.private sequences assocs prettyprint.sections
io definitions kernel continuations ; io definitions kernel continuations listener ;
IN: delegate.protocols IN: delegate.protocols
PROTOCOL: sequence-protocol PROTOCOL: sequence-protocol
@ -12,8 +12,10 @@ PROTOCOL: assoc-protocol
at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 } at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ; delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: stream-protocol PROTOCOL: input-stream-protocol
stream-read1 stream-read stream-read-until dispose stream-read1 stream-read stream-read-until stream-read-quot ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-format stream-flush stream-write1 stream-write stream-format
stream-nl make-span-stream make-block-stream stream-readln stream-nl make-span-stream make-block-stream stream-readln
make-cell-stream stream-write-table ; make-cell-stream stream-write-table ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: continuations io.backend libc kernel namespaces USING: continuations io.backend io.nonblocking libc kernel
sequences system vectors ; namespaces sequences system vectors ;
IN: destructors IN: destructors
SYMBOL: error-destructors SYMBOL: error-destructors
@ -59,10 +59,8 @@ TUPLE: handle-destructor alien ;
C: <handle-destructor> handle-destructor C: <handle-destructor> handle-destructor
HOOK: destruct-handle io-backend ( obj -- )
M: handle-destructor dispose ( obj -- ) M: handle-destructor dispose ( obj -- )
handle-destructor-alien destruct-handle ; handle-destructor-alien close-handle ;
: close-always ( handle -- ) : close-always ( handle -- )
<handle-destructor> add-always-destructor ; <handle-destructor> add-always-destructor ;

View File

@ -25,11 +25,11 @@ IN: editors.jedit
] with-byte-writer ; ] with-byte-writer ;
: send-jedit-request ( request -- ) : send-jedit-request ( request -- )
jedit-server-info "localhost" rot <inet> binary <client> [ jedit-server-info "localhost" rot <inet> binary [
4 >be write 4 >be write
dup length 2 >be write dup length 2 >be write
write write
] with-stream ; ] with-client ;
: jedit-location ( file line -- ) : jedit-location ( file line -- )
number>string "+line:" prepend 2array number>string "+line:" prepend 2array

View File

@ -1,2 +1,2 @@
collections collections
collections sequences sequences

View File

@ -0,0 +1,46 @@
USING: kernel sequences io.files io.launcher io.encodings.ascii
io.streams.string http.client sequences.lib combinators
math.parser math.vectors math.intervals interval-maps memoize
csv accessors assocs strings math splitting ;
IN: geo-ip
: db-path "IpToCountry.csv" temp-file ;
: db-url "http://software77.net/cgi-bin/ip-country/geo-ip.pl?action=download" ;
: download-db ( -- path )
db-path dup exists? [
db-url over ".gz" append download-to
{ "gunzip" } over ".gz" append (normalize-path) suffix try-process
] unless ;
TUPLE: ip-entry from to registry assigned city cntry country ;
: parse-ip-entry ( row -- ip-entry )
7 firstn {
[ string>number ]
[ string>number ]
[ ]
[ ]
[ ]
[ ]
[ ]
} spread ip-entry boa ;
MEMO: ip-db ( -- seq )
download-db ascii file-lines
[ "#" head? not ] filter "\n" join <string-reader> csv
[ parse-ip-entry ] map ;
MEMO: ip-intervals ( -- interval-map )
ip-db [ [ [ from>> ] [ to>> ] bi [a,b] ] keep ] { } map>assoc
<interval-map> ;
GENERIC: lookup-ip ( ip -- ip-entry )
M: string lookup-ip
"." split [ string>number ] map
{ HEX: 1000000 HEX: 10000 HEX: 100 1 } v.
lookup-ip ;
M: integer lookup-ip ip-intervals interval-at ;

1
extra/geo-ip/summary.txt Normal file
View File

@ -0,0 +1 @@
IP address geolocation using database from http://software77.net/cgi-bin/ip-country/

1
extra/geo-ip/tags.txt Normal file
View File

@ -0,0 +1 @@
enterprise

View File

@ -15,13 +15,13 @@ TUPLE: gesture-logger stream ;
M: gesture-logger handle-gesture* M: gesture-logger handle-gesture*
drop drop
dup T{ button-down } = [ over request-focus ] when dup T{ button-down } = [ over request-focus ] when
swap gesture-logger-stream [ . ] with-stream* swap gesture-logger-stream [ . ] with-output-stream*
t ; t ;
M: gesture-logger user-input* M: gesture-logger user-input*
gesture-logger-stream [ gesture-logger-stream [
"User input: " write print "User input: " write print
] with-stream* t ; ] with-output-stream* t ;
: gesture-logger ( -- ) : gesture-logger ( -- )
[ [

View File

@ -205,8 +205,8 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
} }
"Send some bytes to a remote host:" "Send some bytes to a remote host:"
{ $code { $code
"\"myhost\" 1033 <inet> <client>" "\"myhost\" 1033 <inet>"
"[ { 12 17 102 } >string write ] with-stream" "[ { 12 17 102 } >string write ] with-client"
} }
{ $references { $references
{ } { }

View File

@ -31,7 +31,7 @@ $nl
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } } { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
{ { $snippet { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple accessors) outputs the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } } { { $snippet { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple accessors) outputs the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
{ { $snippet "set-" { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple mutators) sets the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } } { { $snippet "set-" { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple mutators) sets the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
{ { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } } { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
} }
{ $heading "Stack effect conventions" } { $heading "Stack effect conventions" }
@ -193,17 +193,19 @@ ARTICLE: "io" "Input and output"
"Utilities:" "Utilities:"
{ $subsection "stream-binary" } { $subsection "stream-binary" }
{ $subsection "styles" } { $subsection "styles" }
{ $heading "Files" }
{ $subsection "io.files" }
{ $subsection "io.mmap" }
{ $subsection "io.monitors" }
{ $heading "Encodings" } { $heading "Encodings" }
{ $subsection "encodings-introduction" } { $subsection "encodings-introduction" }
{ $subsection "io.encodings" } { $subsection "io.encodings" }
{ $subsection "io.encodings.string" } { $subsection "io.encodings.string" }
{ $heading "Other features" } { $heading "Files" }
{ $subsection "io.files" }
{ $subsection "io.mmap" }
{ $subsection "io.monitors" }
{ $heading "Communications" }
{ $subsection "network-streams" } { $subsection "network-streams" }
{ $subsection "io.launcher" } { $subsection "io.launcher" }
{ $subsection "io.pipes" }
{ $heading "Other features" }
{ $subsection "io.timeouts" } { $subsection "io.timeouts" }
{ $subsection "checksums" } ; { $subsection "checksums" } ;

View File

@ -126,7 +126,7 @@ HELP: $title
HELP: help HELP: help
{ $values { "topic" "an article name or a word" } } { $values { "topic" "an article name or a word" } }
{ $description { $description
"Displays a help article or documentation associated to a word on the " { $link stdio } " stream." "Displays a help article or documentation associated to a word on " { $link output-stream } "."
} ; } ;
HELP: about HELP: about
@ -151,7 +151,7 @@ HELP: $index
HELP: ($index) HELP: ($index)
{ $values { "articles" "a sequence of help articles" } } { $values { "articles" "a sequence of help articles" } }
{ $description "Writes a list of " { $link $subsection } " elements to the " { $link stdio } " stream." } ; { $description "Writes a list of " { $link $subsection } " elements to " { $link output-stream } "." } ;
HELP: xref-help HELP: xref-help
{ $description "Update help cross-referencing. Usually this is done automatically." } ; { $description "Update help cross-referencing. Usually this is done automatically." } ;
@ -168,11 +168,11 @@ HELP: $predicate
HELP: print-element HELP: print-element
{ $values { "element" "a markup element" } } { $values { "element" "a markup element" } }
{ $description "Prints a markup element to the " { $link stdio } " stream." } ; { $description "Prints a markup element to " { $link output-stream } "." } ;
HELP: print-content HELP: print-content
{ $values { "element" "a markup element" } } { $values { "element" "a markup element" } }
{ $description "Prints a top-level markup element to the " { $link stdio } " stream." } ; { $description "Prints a top-level markup element to " { $link output-stream } "." } ;
HELP: simple-element HELP: simple-element
{ $class-description "Class of simple elements, which are just arrays of elements." } ; { $class-description "Class of simple elements, which are just arrays of elements." } ;

View File

@ -135,7 +135,7 @@ $nl
{ $code "[ Letter? ] filter >lower" } { $code "[ Letter? ] filter >lower" }
"This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":"
{ $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" } { $code ": normalize ( str -- newstr ) [ Letter? ] filter >lower ;" }
"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." "You will need to add " { $vocab-link "unicode.case" } " and " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file."
$nl $nl
"We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
{ $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" } { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }

View File

@ -24,7 +24,7 @@ IN: html.tests
] unit-test ] unit-test
[ "<" ] [ [ "<" ] [
[ "<" H{ } stdio get format-html-span ] make-html-string [ "<" H{ } output-stream get format-html-span ] make-html-string
] unit-test ] unit-test
TUPLE: funky town ; TUPLE: funky town ;

View File

@ -44,7 +44,7 @@ TUPLE: html-sub-stream style stream ;
rot html-sub-stream-stream ; rot html-sub-stream-stream ;
: delegate-write ( string -- ) : delegate-write ( string -- )
stdio get delegate stream-write ; output-stream get delegate stream-write ;
: object-link-tag ( style quot -- ) : object-link-tag ( style quot -- )
presented pick at [ presented pick at [
@ -101,7 +101,7 @@ TUPLE: html-sub-stream style stream ;
: format-html-span ( string style stream -- ) : format-html-span ( string style stream -- )
[ [
[ [ drop delegate-write ] span-tag ] object-link-tag [ [ drop delegate-write ] span-tag ] object-link-tag
] with-stream* ; ] with-output-stream* ;
TUPLE: html-span-stream ; TUPLE: html-span-stream ;
@ -134,7 +134,7 @@ M: html-span-stream dispose
: format-html-div ( string style stream -- ) : format-html-div ( string style stream -- )
[ [
[ [ delegate-write ] div-tag ] object-link-tag [ [ delegate-write ] div-tag ] object-link-tag
] with-stream* ; ] with-output-stream* ;
TUPLE: html-block-stream ; TUPLE: html-block-stream ;
@ -184,17 +184,17 @@ M: html-stream stream-write-table ( grid style stream -- )
</td> </td>
] with each </tr> ] with each </tr>
] with each </table> ] with each </table>
] with-stream* ; ] with-output-stream* ;
M: html-stream make-cell-stream ( style stream -- stream' ) M: html-stream make-cell-stream ( style stream -- stream' )
(html-sub-stream) ; (html-sub-stream) ;
M: html-stream stream-nl ( stream -- ) M: html-stream stream-nl ( stream -- )
dup test-last-div? [ drop ] [ [ <br/> ] with-stream* ] if ; dup test-last-div? [ drop ] [ [ <br/> ] with-output-stream* ] if ;
! Utilities ! Utilities
: with-html-stream ( quot -- ) : with-html-stream ( quot -- )
stdio get <html-stream> swap with-stream* ; inline output-stream get <html-stream> swap with-output-stream* ; inline
: xhtml-preamble : xhtml-preamble
"<?xml version=\"1.0\"?>" write-html "<?xml version=\"1.0\"?>" write-html

View File

@ -3,7 +3,8 @@
USING: assocs http kernel math math.parser namespaces sequences USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors math.order splitting calendar continuations accessors vectors math.order
io.encodings.8-bit io.encodings.binary fry debugger inspector ; io.encodings.8-bit io.encodings.binary io.streams.duplex
fry debugger inspector ;
IN: http.client IN: http.client
: max-redirects 10 ; : max-redirects 10 ;
@ -26,73 +27,56 @@ DEFER: http-request
: store-path ( request path -- request ) : store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ; "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
: request-with-url ( url request -- request ) : request-with-url ( request url -- request )
swap parse-url >r >r store-path r> >>host r> >>port ; parse-url >r >r store-path r> >>host r> >>port ;
! This is all pretty complex because it needs to handle
! HTTP redirects, which might be absolute or relative
: absolute-redirect ( url -- request )
request get request-with-url ;
: relative-redirect ( path -- request )
request get swap store-path ;
SYMBOL: redirects SYMBOL: redirects
: absolute-url? ( url -- ? ) : absolute-url? ( url -- ? )
[ "http://" head? ] [ "https://" head? ] bi or ; [ "http://" head? ] [ "https://" head? ] bi or ;
: do-redirect ( response -- response stream ) : do-redirect ( response data -- response data )
dup response-code 300 399 between? [ over code>> 300 399 between? [
stdio get dispose drop
redirects inc redirects inc
redirects get max-redirects < [ redirects get max-redirects < [
header>> "location" swap at request get
dup absolute-url? [ swap "location" header dup absolute-url?
absolute-redirect [ request-with-url ] [ store-path ] if
] [ "GET" >>method http-request
relative-redirect
] if "GET" >>method http-request
] [ ] [
too-many-redirects too-many-redirects
] if ] if
] [ ] when ;
stdio get
] if ;
: close-on-error ( stream quot -- )
'[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
PRIVATE> PRIVATE>
: http-request ( request -- response stream )
dup request [
dup request-addr latin1 <client>
1 minutes over set-timeout
[
write-request flush
read-response
do-redirect
] close-on-error
] with-variable ;
: read-chunks ( -- ) : read-chunks ( -- )
read-crlf ";" split1 drop hex> dup { f 0 } member? read-crlf ";" split1 drop hex> dup { f 0 } member?
[ drop ] [ read % read-crlf "" assert= read-chunks ] if ; [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
: do-chunked-encoding ( response stream -- response stream/string ) : read-response-body ( response -- response data )
over "transfer-encoding" header "chunked" = [ dup "transfer-encoding" header "chunked" =
[ [ read-chunks ] "" make ] with-stream [ [ read-chunks ] "" make ] [ input-stream get contents ] if ;
] when ;
: http-request ( request -- response data )
dup request [
dup request-addr latin1 [
1 minutes timeouts
write-request
read-response
read-response-body
] with-client
do-redirect
] with-variable ;
: <get-request> ( url -- request ) : <get-request> ( url -- request )
<request> request-with-url "GET" >>method ; <request>
swap request-with-url
"GET" >>method ;
: string-or-contents ( stream/string -- string ) : http-get* ( url -- response data )
dup string? [ contents ] unless ; <get-request> http-request ;
: http-get-stream ( url -- response stream/string )
<get-request> http-request do-chunked-encoding ;
: success? ( code -- ? ) 200 = ; : success? ( code -- ? ) 200 = ;
@ -112,29 +96,24 @@ M: download-failed error.
over code>> success? [ nip ] [ download-failed ] if ; over code>> success? [ nip ] [ download-failed ] if ;
: http-get ( url -- string ) : http-get ( url -- string )
http-get-stream string-or-contents check-response ; http-get* check-response ;
: download-name ( url -- name ) : download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ; file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- ) : download-to ( url file -- )
#! Downloads the contents of a URL to a file. #! Downloads the contents of a URL to a file.
swap http-get-stream check-response >r http-get r> latin1 [ write ] with-file-writer ;
dup string? [
latin1 [ write ] with-file-writer
] [
[ swap latin1 <file-writer> stream-copy ] with-disposal
] if ;
: download ( url -- ) : download ( url -- )
dup download-name download-to ; dup download-name download-to ;
: <post-request> ( content-type content url -- request ) : <post-request> ( content-type content url -- request )
<request> <request>
request-with-url
"POST" >>method "POST" >>method
swap request-with-url
swap >>post-data swap >>post-data
swap >>post-data-type ; swap >>post-data-type ;
: http-post ( content-type content url -- response string ) : http-post ( content-type content url -- response data )
<post-request> http-request do-chunked-encoding string-or-contents ; <post-request> http-request ;

View File

@ -31,6 +31,7 @@ IN: http.tests
[ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test [ H{ { "a" { "b" "c" } } } ] [ "a=b&a=c" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test [ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
: lf>crlf "\n" split "\r\n" join ; : lf>crlf "\n" split "\r\n" join ;
STRING: read-request-test-1 STRING: read-request-test-1
@ -183,12 +184,12 @@ test-db [
! Try with a slightly malformed request ! Try with a slightly malformed request
[ t ] [ [ t ] [
"localhost" 1237 <inet> ascii <client> [ "localhost" 1237 <inet> ascii [
"GET nested HTTP/1.0\r\n" write flush "GET nested HTTP/1.0\r\n" write flush
"\r\n" write flush "\r\n" write flush
read-crlf drop read-crlf drop
read-header read-header
] with-stream "location" swap at "/" head? ] with-client "location" swap at "/" head?
] unit-test ] unit-test
[ "http://localhost:1237/redirect-loop" http-get ] [ "http://localhost:1237/redirect-loop" http-get ]

View File

@ -472,7 +472,7 @@ M: string write-response-body* write ;
M: callable write-response-body* call ; M: callable write-response-body* call ;
M: object write-response-body* stdio get stream-copy ; M: object write-response-body* output-stream get stream-copy ;
: write-response-body ( response -- response ) : write-response-body ( response -- response )
dup body>> write-response-body* ; dup body>> write-response-body* ;

View File

@ -82,10 +82,8 @@ IN: http.server.auth.admin
same-password-twice same-password-twice
user new "username" value >>username select-tuple [ user new "username" value >>username select-tuple
user-exists? on [ user-exists ] when
validation-failed
] when
"username" value <user> "username" value <user>
"realname" value >>realname "realname" value >>realname

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators USING: namespaces kernel assocs io.files io.streams.duplex
arrays io.launcher io http.server.static http.server combinators arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser fry ; http accessors sequences strings math.parser fry ;
IN: http.server.cgi IN: http.server.cgi
@ -51,9 +51,9 @@ IN: http.server.cgi
200 >>code 200 >>code
"CGI output follows" >>message "CGI output follows" >>message
swap '[ swap '[
, stdio get swap <cgi-process> <process-stream> [ , output-stream get swap <cgi-process> <process-stream> [
post? [ request get post-data>> write flush ] when post? [ request get post-data>> write flush ] when
stdio get swap (stream-copy) input-stream get swap (stream-copy)
] with-stream ] with-stream
] >>body ; ] >>body ;

View File

@ -260,15 +260,13 @@ SYMBOL: exit-continuation
bi bi
] recover ; ] recover ;
: default-timeout 1 minutes stdio get set-timeout ;
: ?refresh-all ( -- ) : ?refresh-all ( -- )
development-mode get-global development-mode get-global
[ global [ refresh-all ] bind ] when ; [ global [ refresh-all ] bind ] when ;
: handle-client ( -- ) : handle-client ( -- )
[ [
default-timeout 1 minutes timeouts
?refresh-all ?refresh-all
read-request read-request
do-request do-request

View File

@ -36,7 +36,7 @@ TUPLE: file-responder root hook special allow-listings ;
[ size>> "content-length" set-header ] [ size>> "content-length" set-header ]
[ modified>> "last-modified" set-header ] bi [ modified>> "last-modified" set-header ] bi
] ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ] bi [ '[ , binary <file-reader> output-stream get stream-copy ] >>body ] bi
] <file-responder> ; ] <file-responder> ;
: serve-static ( filename mime-type -- response ) : serve-static ( filename mime-type -- response )

View File

@ -0,0 +1 @@
Daniel Ehrenberg

View File

@ -0,0 +1,29 @@
USING: help.markup help.syntax ;
IN: interval-maps
HELP: interval-at*
{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } { "?" "whether the key is present" } }
{ $description "Looks up a key in an interval map, returning the corresponding value if the item is in an interval in the map, and a boolean flag. The operation takes O(log n) time." } ;
HELP: interval-at
{ $values { "key" "an object" } { "map" "an interval map" } { "value" "the value for the key, or f" } }
{ $description "Looks up a key in an interval map, returning the value of the corresponding interval, or f if the interval is not present in the map." } ;
HELP: interval-key?
{ $values { "key" "an object" } { "map" "an interval map" } { "?" "a boolean" } }
{ $description "Tests whether an object is in an interval in the interval map, returning t if the object is present." } ;
HELP: <interval-map>
{ $values { "specification" "an assoc" } { "map" "an interval map" } }
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
ARTICLE: "interval-maps" "Interval maps"
"Interval maps are a mechanism, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
"The following operations are used to query interval maps:"
{ $subsection interval-at* }
{ $subsection interval-at }
{ $subsection interval-key? }
"Use the following to construct interval maps"
{ $subsection <interval-map> } ;
ABOUT: "interval-maps"

View File

@ -0,0 +1,13 @@
USING: kernel namespaces interval-maps tools.test ;
IN: interval-maps.test
SYMBOL: test
[ ] [ { { { 4 8 } 3 } { 1 2 } } <interval-map> test set ] unit-test
[ 3 ] [ 5 test get interval-at ] unit-test
[ 3 ] [ 8 test get interval-at ] unit-test
[ 3 ] [ 4 test get interval-at ] unit-test
[ f ] [ 9 test get interval-at ] unit-test
[ 2 ] [ 1 test get interval-at ] unit-test
[ f ] [ 2 test get interval-at ] unit-test
[ f ] [ 0 test get interval-at ] unit-test

View File

@ -0,0 +1,41 @@
USING: kernel sequences arrays math.intervals accessors
math.order sorting math assocs ;
IN: interval-maps
TUPLE: interval-map array ;
<PRIVATE
TUPLE: interval-node interval value ;
: fixup-value ( value ? -- value/f ? )
[ drop f f ] unless* ;
: find-interval ( key interval-map -- i )
[ interval>> from>> first <=> ] binsearch ;
GENERIC: >interval ( object -- interval )
M: number >interval [a,a] ;
M: sequence >interval first2 [a,b] ;
M: interval >interval ;
: all-intervals ( sequence -- intervals )
[ >r >interval r> ] assoc-map ;
: ensure-disjoint ( intervals -- intervals )
dup keys [ interval-intersect not ] monotonic?
[ "Intervals are not disjoint" throw ] unless ;
PRIVATE>
: interval-at* ( key map -- value ? )
array>> [ find-interval ] 2keep swapd nth
[ nip value>> ] [ interval>> interval-contains? ] 2bi
fixup-value ;
: interval-at ( key map -- value ) interval-at* drop ;
: interval-key? ( key map -- ? ) interval-at* nip ;
: <interval-map> ( specification -- map )
all-intervals ensure-disjoint
[ [ first to>> ] compare ] sort
[ interval-node boa ] { } assoc>map
interval-map boa ;

View File

@ -0,0 +1 @@
Interval maps for disjoint closed ranges

1
extra/interval-maps/tags.txt Executable file
View File

@ -0,0 +1 @@
collections

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax quotations kernel io math USING: help.markup help.syntax quotations kernel io io.files
calendar ; math calendar ;
IN: io.launcher IN: io.launcher
ARTICLE: "io.launcher.command" "Specifying a command" ARTICLE: "io.launcher.command" "Specifying a command"
@ -26,10 +26,10 @@ $nl
"To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:" "To specify redirection, set the " { $snippet "stdin" } ", " { $snippet "stdout" } " and " { $snippet "stderr" } " slots of a " { $link process } " to one of the following values:"
{ $list { $list
{ { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" } { { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link <process-stream> } " pipe" }
{ { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link <process-stream> } " pipe" }
{ { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" } { { $link +closed+ } " - the stream is closed; reads will return end of file and writes will fails" }
{ { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" } { { $link +stdout+ } " - a special value for the " { $snippet "stderr" } " slot only, indicating that the standard output and standard error streams should be merged" }
{ "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" } { "a path name - the stream is sent to the given file, which must exist for input and is created automatically on output" }
{ "an " { $link appender } " wrapping a path name - output is sent to the end given file, as with " { $link <file-appender> } }
{ "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" } { "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
} ; } ;
@ -47,12 +47,16 @@ ARTICLE: "io.launcher.priority" "Setting process priority"
HELP: +closed+ HELP: +closed+
{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ; { $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
HELP: +inherit+
{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
HELP: +stdout+ HELP: +stdout+
{ $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ; { $description "Possible value for the " { $snippet "stderr" } " slot of a " { $link process } "." } ;
HELP: appender
{ $class-description "An object representing a file to append to. Instances are created with " { $link <appender> } "." } ;
HELP: <appender>
{ $values { "path" "a pathname string" } { "appender" appender } }
{ $description "Creates an object which may be stored in the " { $snippet "stdout" } " or " { $snippet "stderr" } " slot of a " { $link process } " instance." } ;
HELP: +prepend-environment+ HELP: +prepend-environment+
{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "." { $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
$nl $nl
@ -138,13 +142,6 @@ HELP: <process-stream>
{ "stream" "a bidirectional stream" } } { "stream" "a bidirectional stream" } }
{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ; { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
HELP: with-process-stream
{ $values
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "status" "an exit code" } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process HELP: wait-for-process
{ $values { "process" process } { "status" integer } } { $values { "process" process } { "status" integer } }
{ $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ; { $description "If the process is still running, waits for it to exit, otherwise outputs the exit code immediately. Can be called multiple times on the same process." } ;
@ -175,8 +172,9 @@ ARTICLE: "io.launcher.launch" "Launching processes"
{ $subsection try-process } { $subsection try-process }
{ $subsection run-detached } { $subsection run-detached }
"Redirecting standard input and output to a pipe:" "Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> } { $subsection <process-reader> }
{ $subsection with-process-stream } ; { $subsection <process-writer> }
{ $subsection <process-stream> } ;
ARTICLE: "io.launcher.examples" "Launcher examples" ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:" "Starting a command and waiting for it to finish:"
@ -212,7 +210,7 @@ ARTICLE: "io.launcher.examples" "Launcher examples"
" <process>" " <process>"
" swap >>stderr" " swap >>stderr"
" \"report\" >>command" " \"report\" >>command"
" ascii <process-stream> lines sort reverse [ print ] each" " ascii <process-reader> lines sort reverse [ print ] each"
"] with-disposal" "] with-disposal"
} ; } ;

View File

@ -2,3 +2,5 @@ IN: io.launcher.tests
USING: tools.test io.launcher ; USING: tools.test io.launcher ;
\ <process-stream> must-infer \ <process-stream> must-infer
\ <process-reader> must-infer
\ <process-writer> must-infer

View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.timeouts system kernel namespaces USING: io io.backend io.timeouts io.pipes system kernel
strings hashtables sequences assocs combinators vocabs.loader namespaces strings hashtables sequences assocs combinators
init threads continuations math io.encodings io.streams.duplex vocabs.loader init threads continuations math io.encodings
io.nonblocking accessors concurrency.flags ; io.streams.duplex io.nonblocking io.streams.duplex accessors
concurrency.flags destructors ;
IN: io.launcher IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -26,9 +27,12 @@ handle status
killed ; killed ;
SYMBOL: +closed+ SYMBOL: +closed+
SYMBOL: +inherit+
SYMBOL: +stdout+ SYMBOL: +stdout+
TUPLE: appender path ;
: <appender> ( path -- appender ) appender boa ;
SYMBOL: +prepend-environment+ SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+ SYMBOL: +replace-environment+
SYMBOL: +append-environment+ SYMBOL: +append-environment+
@ -145,20 +149,67 @@ M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ; M: process timed-out kill-process ;
HOOK: (process-stream) io-backend ( process -- handle in out ) M: object pipeline-element-quot
[
>process
swap >>stdout
swap >>stdin
run-detached
] curry ;
: <process-stream*> ( desc encoding -- stream process ) M: process wait-for-pipeline-element wait-for-process ;
>r >process dup dup (process-stream) <reader&writer>
r> <encoder-duplex> -roll : <process-reader*> ( process encoding -- process stream )
process-started ; [
>r (pipe) {
[ add-error-destructor ]
[
swap >process
[ swap out>> or ] change-stdout
run-detached
]
[ out>> close-handle ]
[ in>> <reader> ]
} cleave r> <decoder>
] with-destructors ;
: <process-reader> ( desc encoding -- stream )
<process-reader*> nip ; inline
: <process-writer*> ( process encoding -- process stream )
[
>r (pipe) {
[ add-error-destructor ]
[
swap >process
[ swap in>> or ] change-stdout
run-detached
]
[ in>> close-handle ]
[ out>> <writer> ]
} cleave r> <encoder>
] with-destructors ;
: <process-writer> ( desc encoding -- stream )
<process-writer*> nip ; inline
: <process-stream*> ( process encoding -- process stream )
[
>r (pipe) (pipe) {
[ [ add-error-destructor ] bi@ ]
[
rot >process
[ swap out>> or ] change-stdout
[ swap in>> or ] change-stdin
run-detached
]
[ [ in>> close-handle ] [ out>> close-handle ] bi* ]
[ [ in>> <reader> ] [ out>> <writer> ] bi* ]
} 2cleave r> <encoder-duplex>
] with-destructors ;
: <process-stream> ( desc encoding -- stream ) : <process-stream> ( desc encoding -- stream )
<process-stream*> drop ; inline <process-stream*> nip ; inline
: with-process-stream ( desc quot -- status )
swap <process-stream*> >r
[ swap with-stream ] keep
r> wait-for-process ; inline
: notify-exit ( process status -- ) : notify-exit ( process status -- )
>>status >>status
@ -168,9 +219,9 @@ HOOK: (process-stream) io-backend ( process -- handle in out )
GENERIC: underlying-handle ( stream -- handle ) GENERIC: underlying-handle ( stream -- handle )
M: port underlying-handle port-handle ; M: port underlying-handle handle>> ;
M: duplex-stream underlying-handle M: duplex-stream underlying-handle
dup duplex-stream-in underlying-handle [ in>> underlying-handle ]
swap duplex-stream-out underlying-handle tuck = [ out>> underlying-handle ] bi
[ "Invalid duplex stream" throw ] when ; [ = [ "Invalid duplex stream" throw ] when ] keep ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math kernel io sequences io.buffers io.timeouts generic USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings math.order byte-vectors system io.encodings math.order io.backend
io.backend continuations debugger classes byte-arrays namespaces continuations debugger classes byte-arrays namespaces splitting
splitting dlists assocs io.encodings.binary inspector accessors ; dlists assocs io.encodings.binary inspector accessors ;
IN: io.nonblocking IN: io.nonblocking
SYMBOL: default-buffer-size SYMBOL: default-buffer-size

View File

@ -0,0 +1,47 @@
USING: help.markup help.syntax continuations io ;
IN: io.pipes
HELP: pipe
{ $class-description "A low-level pipe. Instances are created by calling " { $link (pipe) } " and closed by calling " { $link dispose } "." } ;
HELP: (pipe)
{ $values { "pipe" pipe } }
{ $description "Opens a new pipe. This is a low-level word; the " { $link <pipe> } " and " { $link run-pipeline } " words can be used in most cases instead." } ;
HELP: <pipe>
{ $values { "encoding" "an encoding specifier" } { "stream" "a bidirectional stream" } }
{ $description "Opens a new pipe and wraps it in a stream. Data written from the stream can be read back from the same stream instance." }
{ $notes "Pipe streams must be disposed by calling " { $link dispose } " or " { $link with-disposal } " to avoid resource leaks." } ;
HELP: run-pipeline
{ $values { "seq" "a sequence of pipeline components" } { "results" "a sequence of pipeline results" } }
{ $description
"Creates a pipe between each pipeline component, with the output of each component becoming the input of the next."
$nl
"The first component reads input from " { $link input-stream } " and the last component writes output to " { $link output-stream } "."
$nl
"Each component runs in its own thread, and the word returns when all components finish executing. Each component outputs a result value."
$nl
"Pipeline components must be one of the following:"
{ $list
{ "A quotation. The quotation is called with both " { $link input-stream } " and " { $link output-stream } " rebound, except for the first and last pipeline components, and it must output a single value." }
{ "A process launch descriptor. See " { $link "io.launcher.descriptors" } "." }
}
}
{ $examples
"Print the lines of a log file which contain the string ``error'', sort them and filter out duplicates, using Unix shell commands only:"
{ $code "{ \"cat log.txt\" \"grep error\" \"sort\" \"uniq\" } run-pipeline" }
} ;
ARTICLE: "io.pipes" "Pipes"
"A " { $emphasis "pipe" } " is a unidirectional channel for transfer of bytes. Data written to one end of the pipe can be read from the other. Pipes can be used to pass data between processes; they can also be used within a single process to implement communication between coroutines."
$nl
"Low-level pipes:"
{ $subsection pipe }
{ $subsection (pipe) }
"High-level pipe streams:"
{ $subsection <pipe> }
"Pipelines of coroutines and processes:"
{ $subsection run-pipeline } ;
ABOUT: "io.pipes"

View File

@ -0,0 +1,26 @@
USING: io io.pipes io.streams.string io.encodings.utf8
io.streams.duplex io.encodings namespaces continuations
tools.test kernel ;
IN: io.pipes.tests
[ "Hello" ] [
utf8 <pipe> [
"Hello" print flush
readln
] with-stream
] unit-test
[ { } ] [ { } run-pipeline ] unit-test
[ { f } ] [ { [ f ] } run-pipeline ] unit-test
[ { "Hello" } ] [
"Hello" [
{ [ input-stream [ utf8 <decoder> ] change readln ] } run-pipeline
] with-string-reader
] unit-test
[ { f "Hello" } ] [
{
[ output-stream [ utf8 <encoder> ] change "Hello" print flush f ]
[ input-stream [ utf8 <decoder> ] change readln ]
} run-pipeline
] unit-test

View File

@ -0,0 +1,56 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings io.backend io.nonblocking io.streams.duplex
io splitting sequences sequences.lib namespaces kernel
destructors math concurrency.combinators accessors
arrays continuations quotations ;
IN: io.pipes
TUPLE: pipe in out ;
M: pipe dispose ( pipe -- )
[ in>> close-handle ] [ out>> close-handle ] bi ;
HOOK: (pipe) io-backend ( -- pipe )
: <pipe> ( encoding -- stream )
[
>r (pipe)
[ add-error-destructor ]
[ in>> <reader> ]
[ out>> <writer> ]
tri
r> <encoder-duplex>
] with-destructors ;
: with-fds ( input-fd output-fd quot -- )
>r >r [ <reader> dup add-always-destructor ] [ input-stream get ] if* r> r> [
>r [ <writer> dup add-always-destructor ] [ output-stream get ] if* r>
with-output-stream*
] 2curry with-input-stream* ; inline
: <pipes> ( n -- pipes )
[ (pipe) dup add-always-destructor ] replicate
f f pipe boa [ prefix ] [ suffix ] bi
2 <clumps> ;
: with-pipe-fds ( seq -- results )
[
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
[ >r [ first in>> ] [ second out>> ] bi r> 2curry ] 2map
[ call ] parallel-map
] with-destructors ;
GENERIC: pipeline-element-quot ( obj -- quot )
M: callable pipeline-element-quot
[ with-fds ] curry ;
GENERIC: wait-for-pipeline-element ( obj -- result )
M: object wait-for-pipeline-element ;
: run-pipeline ( seq -- results )
[ pipeline-element-quot ] map
with-pipe-fds
[ wait-for-pipeline-element ] map ;

View File

@ -3,8 +3,8 @@ IN: io.server
HELP: with-server HELP: with-server
{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } { $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } }
{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being the " { $link stdio } " stream. Client connections are logged to the " { $link stdio } " stream at the time the server was started." } ; { $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ;
HELP: with-datagrams HELP: with-datagrams
{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } { $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } }
{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received. Datagram packets are logged to the " { $link stdio } " stream at the time the server was started." } ; { $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov. ! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.sockets io.files logging continuations kernel USING: io io.sockets io.files io.streams.duplex logging
math math.parser namespaces parser sequences strings continuations kernel math math.parser namespaces parser
prettyprint debugger quotations calendar sequences strings prettyprint debugger quotations calendar
threads concurrency.combinators assocs ; threads concurrency.combinators assocs ;
IN: io.server IN: io.server

View File

@ -14,6 +14,7 @@ ARTICLE: "network-addressing" "Address specifiers"
ARTICLE: "network-connection" "Connection-oriented networking" ARTICLE: "network-connection" "Connection-oriented networking"
"Network connections can be established with this word:" "Network connections can be established with this word:"
{ $subsection <client> } { $subsection <client> }
{ $subsection with-client }
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:" "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> } { $subsection <server> }
{ $subsection accept } { $subsection accept }

View File

@ -1,7 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg. ! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.nonblocking accessors ; sequences arrays io.encodings io.nonblocking io.streams.duplex
accessors ;
IN: io.sockets IN: io.sockets
TUPLE: local path ; TUPLE: local path ;
@ -30,6 +31,9 @@ M: object (client) ((client)) ;
: <client> ( addrspec encoding -- stream ) : <client> ( addrspec encoding -- stream )
>r (client) r> <encoder-duplex> ; >r (client) r> <encoder-duplex> ;
: with-client ( addrspec encoding quot -- )
>r <client> r> with-stream ; inline
HOOK: (server) io-backend ( addrspec -- handle ) HOOK: (server) io-backend ( addrspec -- handle )
: <server> ( addrspec encoding -- server ) : <server> ( addrspec encoding -- server )

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1,39 @@
USING: help.markup help.syntax io continuations quotations ;
IN: io.streams.duplex
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
{ $subsection <duplex-stream> }
"A pair of combinators for rebinding both default streams at once:"
{ $subsection with-stream }
{ $subsection with-stream* } ;
ABOUT: "io.streams.duplex"
HELP: duplex-stream
{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
HELP: with-stream
{ $values { "stream" duplex-stream } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } ". The stream is closed if the quotation returns or throws an error." } ;
HELP: with-stream*
{ $values { "stream" duplex-stream } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope, with both " { $link input-stream } " and " { $link output-stream } " rebound to " { $snippet "stream" } "." }
{ $notes "This word does not close the stream. Compare with " { $link with-stream } "." } ;
HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "duplex" "an encoded duplex stream" } }
{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
$low-level-note ;

View File

@ -1,6 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel continuations io accessors ; USING: kernel continuations io io.encodings io.encodings.private
io.timeouts debugger inspector listener accessors delegate
delegate.protocols ;
IN: io.streams.duplex IN: io.streams.duplex
! We ensure that the stream can only be closed once, to preserve ! We ensure that the stream can only be closed once, to preserve
@ -13,6 +15,9 @@ TUPLE: duplex-stream in out closed ;
ERROR: stream-closed-twice ; ERROR: stream-closed-twice ;
M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
<PRIVATE <PRIVATE
: check-closed ( stream -- stream ) : check-closed ( stream -- stream )
@ -24,47 +29,12 @@ ERROR: stream-closed-twice ;
PRIVATE> PRIVATE>
M: duplex-stream stream-flush CONSULT: input-stream-protocol duplex-stream in ;
out stream-flush ;
M: duplex-stream stream-readln CONSULT: output-stream-protocol duplex-stream out ;
in stream-readln ;
M: duplex-stream stream-read1 M: duplex-stream set-timeout
in stream-read1 ; [ in set-timeout ] [ out set-timeout ] 2bi ;
M: duplex-stream stream-read-until
in stream-read-until ;
M: duplex-stream stream-read-partial
in stream-read-partial ;
M: duplex-stream stream-read
in stream-read ;
M: duplex-stream stream-write1
out stream-write1 ;
M: duplex-stream stream-write
out stream-write ;
M: duplex-stream stream-nl
out stream-nl ;
M: duplex-stream stream-format
out stream-format ;
M: duplex-stream make-span-stream
out make-span-stream ;
M: duplex-stream make-block-stream
out make-block-stream ;
M: duplex-stream make-cell-stream
out make-cell-stream ;
M: duplex-stream stream-write-table
out stream-write-table ;
M: duplex-stream dispose M: duplex-stream dispose
#! The output stream is closed first, in case both streams #! The output stream is closed first, in case both streams
@ -75,3 +45,12 @@ M: duplex-stream dispose
[ dup out>> dispose ] [ dup out>> dispose ]
[ dup in>> dispose ] [ ] cleanup [ dup in>> dispose ] [ ] cleanup
] unless drop ; ] unless drop ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;
: with-stream* ( stream quot -- )
>r [ in>> ] [ out>> ] bi r> with-streams* ; inline
: with-stream ( stream quot -- )
>r [ in>> ] [ out>> ] bi r> with-streams ; inline

View File

@ -1,25 +1,38 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: io.streams.null IN: io.streams.null
USING: kernel io io.timeouts continuations ; USING: kernel io io.timeouts io.streams.duplex continuations ;
TUPLE: null-stream ; TUPLE: null-stream ;
M: null-stream dispose drop ; M: null-stream dispose drop ;
M: null-stream set-timeout 2drop ; M: null-stream set-timeout 2drop ;
M: null-stream stream-readln drop f ;
M: null-stream stream-read1 drop f ; TUPLE: null-reader < null-stream ;
M: null-stream stream-read-until 2drop f f ;
M: null-stream stream-read 2drop f ; M: null-reader stream-readln drop f ;
M: null-stream stream-write1 2drop ; M: null-reader stream-read1 drop f ;
M: null-stream stream-write 2drop ; M: null-reader stream-read-until 2drop f f ;
M: null-stream stream-nl drop ; M: null-reader stream-read 2drop f ;
M: null-stream stream-flush drop ;
M: null-stream stream-format 3drop ; TUPLE: null-writer < null-stream ;
M: null-stream make-span-stream nip ;
M: null-stream make-block-stream nip ; M: null-writer stream-write1 2drop ;
M: null-stream make-cell-stream nip ; M: null-writer stream-write 2drop ;
M: null-stream stream-write-table 3drop ; M: null-writer stream-nl drop ;
M: null-writer stream-flush drop ;
M: null-writer stream-format 3drop ;
M: null-writer make-span-stream nip ;
M: null-writer make-block-stream nip ;
M: null-writer make-cell-stream nip ;
M: null-writer stream-write-table 3drop ;
: with-null-reader ( quot -- )
T{ null-reader } swap with-input-stream* ; inline
: with-null-writer ( quot -- )
T{ null-writer } swap with-output-stream* ; inline
: with-null-stream ( quot -- ) : with-null-stream ( quot -- )
T{ null-stream } swap with-stream* ; inline T{ duplex-stream f T{ null-reader } T{ null-writer } }
swap with-stream* ; inline

View File

@ -1,20 +1,16 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman ! Copyright (C) 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel calendar alarms io.streams.duplex io.encodings ; USING: kernel calendar alarms io io.encodings accessors
namespaces ;
IN: io.timeouts IN: io.timeouts
! Won't need this with new slot accessors ! Won't need this with new slot accessors
GENERIC: timeout ( obj -- dt/f ) GENERIC: timeout ( obj -- dt/f )
GENERIC: set-timeout ( dt/f obj -- ) GENERIC: set-timeout ( dt/f obj -- )
M: duplex-stream set-timeout M: decoder set-timeout stream>> set-timeout ;
2dup
duplex-stream-in set-timeout
duplex-stream-out set-timeout ;
M: decoder set-timeout decoder-stream set-timeout ; M: encoder set-timeout stream>> set-timeout ;
M: encoder set-timeout encoder-stream set-timeout ;
GENERIC: timed-out ( obj -- ) GENERIC: timed-out ( obj -- )
@ -29,3 +25,7 @@ M: object timed-out drop ;
] [ ] [
2drop call 2drop call
] if ; inline ] if ; inline
: timeouts ( dt -- )
[ input-stream get set-timeout ]
[ output-stream get set-timeout ] bi ;

View File

@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien generic assocs kernel kernel.private math USING: alien generic assocs kernel kernel.private math
io.nonblocking sequences strings structs sbufs io.nonblocking sequences strings structs sbufs threads unix
threads unix vectors io.buffers io.backend io.encodings vectors io.buffers io.backend io.encodings math.parser
io.streams.duplex math.parser continuations system libc continuations system libc qualified namespaces io.timeouts
qualified namespaces io.timeouts io.encodings.utf8 accessors ; io.encodings.utf8 accessors ;
QUALIFIED: io QUALIFIED: io
IN: io.unix.backend IN: io.unix.backend
@ -78,7 +78,8 @@ M: integer init-handle ( fd -- )
#! since on OS X 10.3, this operation fails from init-io #! since on OS X 10.3, this operation fails from init-io
#! when running the Factor.app (presumably because fd 0 and #! when running the Factor.app (presumably because fd 0 and
#! 1 are closed). #! 1 are closed).
F_SETFL O_NONBLOCK fcntl drop ; [ F_SETFL O_NONBLOCK fcntl drop ]
[ F_SETFD FD_CLOEXEC fcntl drop ] bi ;
M: integer close-handle ( fd -- ) M: integer close-handle ( fd -- )
close ; close ;

View File

@ -31,16 +31,7 @@ accessors kernel sequences io.encodings.utf8 ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-stream> contents ascii <process-reader> contents
] unit-test
[ f ] [
<process>
"cat"
"launcher-test-1" temp-file
2array >>command
+inherit+ >>stdout
ascii <process-stream> contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -59,7 +50,7 @@ accessors kernel sequences io.encodings.utf8 ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-stream> contents ascii <process-reader> contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -77,14 +68,14 @@ accessors kernel sequences io.encodings.utf8 ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-stream> contents ascii <process-reader> contents
] unit-test ] unit-test
[ t ] [ [ t ] [
<process> <process>
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-stream> lines ascii <process-reader> lines
"A=B" swap member? "A=B" swap member?
] unit-test ] unit-test
@ -93,7 +84,7 @@ accessors kernel sequences io.encodings.utf8 ;
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
ascii <process-stream> lines ascii <process-reader> lines
] unit-test ] unit-test
[ "hi\n" ] [ [ "hi\n" ] [
@ -107,3 +98,15 @@ accessors kernel sequences io.encodings.utf8 ;
temp-directory "aloha" append-path temp-directory "aloha" append-path
utf8 file-contents utf8 file-contents
] unit-test ] unit-test
[ ] [ "append-test" temp-file delete-file ] unit-test
[ "hi\nhi\n" ] [
2 [
<process>
"echo hi" >>command
"append-test" temp-file <appender> >>stdout
try-process
] times
"append-test" temp-file utf8 file-contents
] unit-test

View File

@ -1,10 +1,12 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io io.backend io.launcher io.nonblocking io.unix.backend USING: kernel namespaces math system sequences debugger
io.unix.files io.nonblocking sequences kernel namespaces math continuations arrays assocs combinators alien.c-types strings
system alien.c-types debugger continuations arrays assocs threads accessors
combinators unix.process strings threads unix io io.backend io.launcher io.nonblocking io.files
io.unix.launcher.parser accessors io.files io.files.private ; io.files.private io.unix.files io.unix.backend
io.unix.launcher.parser
unix unix.process ;
IN: io.unix.launcher IN: io.unix.launcher
! Search unix first ! Search unix first
@ -34,7 +36,8 @@ USE: unix
: reset-fd ( fd -- ) : reset-fd ( fd -- )
#! We drop the error code because on *BSD, fcntl of #! We drop the error code because on *BSD, fcntl of
#! /dev/null fails. #! /dev/null fails.
F_SETFL 0 fcntl drop ; [ F_SETFL 0 fcntl drop ]
[ F_SETFD 0 fcntl drop ] bi ;
: redirect-inherit ( obj mode fd -- ) : redirect-inherit ( obj mode fd -- )
2nip reset-fd ; 2nip reset-fd ;
@ -43,19 +46,20 @@ USE: unix
>r >r normalize-path r> file-mode >r >r normalize-path r> file-mode
open dup io-error r> redirect-fd ; open dup io-error r> redirect-fd ;
: redirect-file-append ( obj mode fd -- )
>r drop path>> normalize-path open-append r> redirect-fd ;
: redirect-closed ( obj mode fd -- ) : redirect-closed ( obj mode fd -- )
>r >r drop "/dev/null" r> r> redirect-file ; >r >r drop "/dev/null" r> r> redirect-file ;
: redirect-stream ( obj mode fd -- )
>r drop underlying-handle dup reset-fd r> redirect-fd ;
: redirect ( obj mode fd -- ) : redirect ( obj mode fd -- )
{ {
{ [ pick not ] [ redirect-inherit ] } { [ pick not ] [ redirect-inherit ] }
{ [ pick string? ] [ redirect-file ] } { [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-file-append ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] } { [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick +inherit+ eq? ] [ redirect-closed ] } { [ pick integer? ] [ >r drop dup reset-fd r> redirect-fd ] }
[ redirect-stream ] [ >r >r underlying-handle r> r> redirect ]
} cond ; } cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ; : ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
@ -90,27 +94,10 @@ M: unix run-process* ( process -- pid )
M: unix kill-process* ( pid -- ) M: unix kill-process* ( pid -- )
SIGTERM kill io-error ; SIGTERM kill io-error ;
: open-pipe ( -- pair )
2 "int" <c-array> dup pipe zero?
[ 2 c-int-array> ] [ drop f ] if ;
: setup-stdio-pipe ( stdin stdout -- )
2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ;
M: unix (process-stream)
>r open-pipe open-pipe r>
[ >r setup-stdio-pipe r> spawn-process ] curry
[ -rot 2dup second close first close ]
with-fork
first swap second ;
: find-process ( handle -- process ) : find-process ( handle -- process )
processes get swap [ nip swap handle>> = ] curry processes get swap [ nip swap handle>> = ] curry
assoc-find 2drop ; assoc-find 2drop ;
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
M: unix wait-for-processes ( -- ? ) M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid -1 0 <int> tuck WNOHANG waitpid
dup 0 <= [ dup 0 <= [

Some files were not shown because too many files have changed in this diff Show More