@@ -49,17 +47,10 @@
-
-
- passwords do not match
-
+
-
-
-
-
-
+ Delete
diff --git a/extra/http/server/auth/admin/new-user.xml b/extra/http/server/auth/admin/new-user.xml
index 072e0c95bd..2d67639985 100644
--- a/extra/http/server/auth/admin/new-user.xml
+++ b/extra/http/server/auth/admin/new-user.xml
@@ -42,14 +42,7 @@
-
-
- username taken
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/edit-profile.xml b/extra/http/server/auth/login/edit-profile.xml
index 107dbba2b8..1eaf65fa07 100644
--- a/extra/http/server/auth/login/edit-profile.xml
+++ b/extra/http/server/auth/login/edit-profile.xml
@@ -62,14 +62,7 @@
-
-
- invalid password
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
index 28486f3362..9f1fe6fe77 100755
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@@ -30,8 +30,6 @@ http.server.validators ;
IN: http.server.auth.login
QUALIFIED: smtp
-SYMBOL: login-failed?
-
TUPLE: login < dispatcher users checksum ;
: users ( -- provider )
@@ -82,6 +80,8 @@ M: user-saver dispose
username>> set-uid
"$login" end-flow ;
+: login-failed "invalid username or password" validation-failed-with ;
+
:: ( -- action )
[let | form [ ] |
@@ -94,12 +94,8 @@ M: user-saver dispose
form validate-form
- "password" value "username" value check-login [
- successful-login
- ] [
- login-failed? on
- validation-failed
- ] if*
+ "password" value "username" value check-login
+ [ successful-login ] [ login-failed ] if*
] >>submit
] ;
@@ -121,14 +117,13 @@ M: user-saver dispose
"email" add-field
"captcha" add-field ;
-SYMBOL: password-mismatch?
-SYMBOL: user-exists?
+: password-mismatch "passwords do not match" validation-failed-with ;
+
+: user-exists "username taken" validation-failed-with ;
: same-password-twice ( -- )
- "new-password" value "verify-password" value = [
- password-mismatch? on
- validation-failed
- ] unless ;
+ "new-password" value "verify-password" value =
+ [ password-mismatch ] unless ;
:: ( -- action )
[let | form [ ] |
@@ -150,10 +145,7 @@ SYMBOL: user-exists?
"email" value >>email
H{ } clone >>profile
- users new-user [
- user-exists? on
- validation-failed
- ] unless*
+ users new-user [ user-exists ] unless*
successful-login
@@ -201,7 +193,7 @@ SYMBOL: user-exists?
same-password-twice
"password" value uid check-login
- [ login-failed? on validation-failed ] unless
+ [ login-failed ] unless
"new-password" value >>encoded-password
] unless
diff --git a/extra/http/server/auth/login/login.xml b/extra/http/server/auth/login/login.xml
index 0524d0889f..d0a73a4d8b 100644
--- a/extra/http/server/auth/login/login.xml
+++ b/extra/http/server/auth/login/login.xml
@@ -23,10 +23,8 @@
+
-
- invalid username or password
-
diff --git a/extra/http/server/auth/login/recover-3.xml b/extra/http/server/auth/login/recover-3.xml
index 61ef0aef86..6c60b257a8 100644
--- a/extra/http/server/auth/login/recover-3.xml
+++ b/extra/http/server/auth/login/recover-3.xml
@@ -32,10 +32,7 @@
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/auth/login/register.xml b/extra/http/server/auth/login/register.xml
index 19917002b5..9b45a7f087 100644
--- a/extra/http/server/auth/login/register.xml
+++ b/extra/http/server/auth/login/register.xml
@@ -63,14 +63,7 @@
-
-
- username taken
-
-
-
- passwords do not match
-
+
diff --git a/extra/http/server/cgi/cgi.factor b/extra/http/server/cgi/cgi.factor
index 509943faa8..20eb7318d0 100755
--- a/extra/http/server/cgi/cgi.factor
+++ b/extra/http/server/cgi/cgi.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs io.files combinators
-arrays io.launcher io http.server.static http.server
+USING: namespaces kernel assocs io.files io.streams.duplex
+combinators arrays io.launcher io http.server.static http.server
http accessors sequences strings math.parser fry ;
IN: http.server.cgi
@@ -51,9 +51,9 @@ IN: http.server.cgi
200 >>code
"CGI output follows" >>message
swap '[
- , stdio get swap [
+ , output-stream get swap [
post? [ request get post-data>> write flush ] when
- stdio get swap (stream-copy)
+ input-stream get swap (stream-copy)
] with-stream
] >>body ;
diff --git a/extra/http/server/components/code/code.factor b/extra/http/server/components/code/code.factor
index 8bf07700e8..19fc8c5ca8 100644
--- a/extra/http/server/components/code/code.factor
+++ b/extra/http/server/components/code/code.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: splitting kernel io sequences xmode.code2html accessors
-http.server.components xml.entities ;
+http.server.components html xml.entities ;
IN: http.server.components.code
TUPLE: code-renderer < text-renderer mode ;
@@ -11,7 +11,9 @@ TUPLE: code-renderer < text-renderer mode ;
swap >>mode ;
M: code-renderer render-view*
- [ string-lines ] [ mode>> value ] bi* htmlize-lines ;
+ [
+ [ string-lines ] [ mode>> value ] bi* htmlize-lines
+ ] with-html-stream ;
: ( id mode -- component )
swap
diff --git a/extra/http/server/components/components.factor b/extra/http/server/components/components.factor
index c0bac1fb99..7f2a5a9ce1 100755
--- a/extra/http/server/components/components.factor
+++ b/extra/http/server/components/components.factor
@@ -3,7 +3,7 @@
USING: accessors namespaces kernel io math.parser assocs classes
words classes.tuple arrays sequences splitting mirrors
hashtables fry locals combinators continuations math
-calendar.format html.elements xml.entities
+calendar.format html html.elements xml.entities
http.server.validators ;
IN: http.server.components
@@ -24,9 +24,6 @@ M: field render-view*
M: field render-edit*
> =type =name =value input/> ;
-: render-error ( message -- )
- escape-string write ;
-
TUPLE: hidden < field ;
: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor
index f6dd6c57bb..70c1e9a1f5 100755
--- a/extra/http/server/server.factor
+++ b/extra/http/server/server.factor
@@ -260,15 +260,13 @@ SYMBOL: exit-continuation
bi
] recover ;
-: default-timeout 1 minutes stdio get set-timeout ;
-
: ?refresh-all ( -- )
development-mode get-global
[ global [ refresh-all ] bind ] when ;
: handle-client ( -- )
[
- default-timeout
+ 1 minutes timeouts
?refresh-all
read-request
do-request
diff --git a/extra/http/server/static/static.factor b/extra/http/server/static/static.factor
index 2ecc347d76..b9a8e9d46e 100755
--- a/extra/http/server/static/static.factor
+++ b/extra/http/server/static/static.factor
@@ -36,7 +36,7 @@ TUPLE: file-responder root hook special allow-listings ;
[ size>> "content-length" set-header ]
[ modified>> "last-modified" set-header ] bi
]
- [ '[ , binary stdio get stream-copy ] >>body ] bi
+ [ '[ , binary output-stream get stream-copy ] >>body ] bi
] ;
: serve-static ( filename mime-type -- response )
diff --git a/extra/http/server/templating/chloe/chloe.factor b/extra/http/server/templating/chloe/chloe.factor
index a8a456cdb2..c3d93f5909 100644
--- a/extra/http/server/templating/chloe/chloe.factor
+++ b/extra/http/server/templating/chloe/chloe.factor
@@ -1,10 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
-io io.files io.encodings.utf8 html.elements unicode.case
-tuple-syntax xml xml.data xml.writer xml.utilities
+io io.files io.encodings.utf8 io.streams.string
+unicode.case tuple-syntax html html.elements
+multiline xml xml.data xml.writer xml.utilities
http.server
http.server.auth
http.server.flows
+http.server.actions
http.server.components
http.server.sessions
http.server.templating
@@ -21,7 +25,10 @@ DEFER: process-template
: chloe-ns "http://factorcode.org/chloe/1.0" ; inline
-: filter-chloe-attrs ( assoc -- assoc' )
+: chloe-attrs-only ( assoc -- assoc' )
+ [ drop name-url chloe-ns = ] assoc-filter ;
+
+: non-chloe-attrs-only ( assoc -- assoc' )
[ drop name-url chloe-ns = not ] assoc-filter ;
: chloe-tag? ( tag -- ? )
@@ -45,6 +52,12 @@ MEMO: chloe-name ( string -- name )
: optional-attr ( tag name -- value )
chloe-name swap at ;
+: children>string ( tag -- string )
+ [ [ process-template ] each ] with-string-writer ;
+
+: title-tag ( tag -- )
+ children>string set-title ;
+
: write-title-tag ( tag -- )
drop
"head" tags get member? "title" tags get member? not and
@@ -131,16 +144,20 @@ MEMO: chloe-name ( string -- name )
: form-start-tag ( tag -- )
[
- ]
tri ;
+DEFER: process-chloe-tag
+
+STRING: button-tag-markup
+
+
+
+;
+
+: add-tag-attrs ( attrs tag -- )
+ tag-attrs swap update ;
+
+: button-tag ( tag -- )
+ button-tag-markup string>xml delegate
+ {
+ [ >r tag-attrs chloe-attrs-only r> add-tag-attrs ]
+ [ >r tag-attrs non-chloe-attrs-only r> "button" tag-named add-tag-attrs ]
+ [ >r children>string 1array r> "button" tag-named set-tag-children ]
+ [ nip ]
+ } 2cleave process-chloe-tag ;
+
: attr>word ( value -- word/f )
dup ":" split1 swap lookup
[ ] [ "No such word: " swap append throw ] ?if ;
@@ -159,23 +196,25 @@ MEMO: chloe-name ( string -- name )
] unless ;
: if-satisfied? ( tag -- ? )
+ t swap
{
- [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
- [ "var" optional-attr [ attr>var get ] [ t ] if* ]
- [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
- [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
- } cleave 4array [ ] all? ;
+ [ "code" optional-attr [ attr>word execute and ] when* ]
+ [ "var" optional-attr [ attr>var get and ] when* ]
+ [ "svar" optional-attr [ attr>var sget and ] when* ]
+ [ "uvar" optional-attr [ attr>var uget and ] when* ]
+ [ "value" optional-attr [ value and ] when* ]
+ } cleave ;
: if-tag ( tag -- )
dup if-satisfied? [ process-tag-children ] [ drop ] if ;
-: error-tag ( tag -- )
+: error-message-tag ( tag -- )
children>string render-error ;
: process-chloe-tag ( tag -- )
dup name-tag {
{ "chloe" [ [ process-template ] each ] }
- { "title" [ children>string set-title ] }
+ { "title" [ title-tag ] }
{ "write-title" [ write-title-tag ] }
{ "style" [ style-tag ] }
{ "write-style" [ write-style-tag ] }
@@ -186,7 +225,9 @@ MEMO: chloe-name ( string -- name )
{ "summary" [ summary-tag ] }
{ "a" [ a-tag ] }
{ "form" [ form-tag ] }
- { "error" [ error-tag ] }
+ { "button" [ button-tag ] }
+ { "error-message" [ error-message-tag ] }
+ { "validation-message" [ drop render-validation-message ] }
{ "if" [ if-tag ] }
{ "comment" [ drop ] }
{ "call-next-template" [ drop call-next-template ] }
diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor
index e88301c7f8..ca6f9d5905 100755
--- a/extra/icfp/2006/2006.factor
+++ b/extra/icfp/2006/2006.factor
@@ -148,4 +148,4 @@ SYMBOL: open-arrays
init f exec-loop ;
: run-sand ( -- )
- "extra/icfp/2006/sandmark.umz" resource-path run-prog ;
+ "resource:extra/icfp/2006/sandmark.umz" run-prog ;
diff --git a/extra/interval-maps/authors.txt b/extra/interval-maps/authors.txt
new file mode 100755
index 0000000000..504363d316
--- /dev/null
+++ b/extra/interval-maps/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/extra/interval-maps/interval-maps-docs.factor b/extra/interval-maps/interval-maps-docs.factor
new file mode 100755
index 0000000000..1a862fbe2d
--- /dev/null
+++ b/extra/interval-maps/interval-maps-docs.factor
@@ -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:
+{ $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 } ;
+
+ABOUT: "interval-maps"
diff --git a/extra/interval-maps/interval-maps-tests.factor b/extra/interval-maps/interval-maps-tests.factor
new file mode 100755
index 0000000000..5a4b508939
--- /dev/null
+++ b/extra/interval-maps/interval-maps-tests.factor
@@ -0,0 +1,18 @@
+USING: kernel namespaces interval-maps tools.test ;
+IN: interval-maps.test
+
+SYMBOL: test
+
+[ ] [ { { { 4 8 } 3 } { 1 2 } } 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
+
+[ { { { 1 4 } 3 } { { 4 8 } 6 } } ] must-fail
+
+[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
+[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test
diff --git a/extra/interval-maps/interval-maps.factor b/extra/interval-maps/interval-maps.factor
new file mode 100755
index 0000000000..7dcb9466cc
--- /dev/null
+++ b/extra/interval-maps/interval-maps.factor
@@ -0,0 +1,56 @@
+USING: kernel sequences arrays math.intervals accessors
+math.order sorting math assocs locals namespaces ;
+IN: interval-maps
+
+TUPLE: interval-map array ;
+
+> 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 ;
+
+: ( specification -- map )
+ all-intervals { } assoc-like
+ [ [ first to>> ] compare ] sort ensure-disjoint
+ [ interval-node boa ] { } assoc>map
+ interval-map boa ;
+
+:: coalesce ( alist -- specification )
+ ! Only works with integer keys, because they're discrete
+ ! Makes 2array keys
+ [
+ alist sort-keys unclip first2 dupd roll
+ [| oldkey oldval key val | ! Underneath is start
+ oldkey 1+ key =
+ oldval val = and
+ [ oldkey 2array oldval 2array , key ] unless
+ key val
+ ] assoc-each [ 2array ] bi@ ,
+ ] { } make ;
diff --git a/extra/interval-maps/summary.txt b/extra/interval-maps/summary.txt
new file mode 100755
index 0000000000..d25263260e
--- /dev/null
+++ b/extra/interval-maps/summary.txt
@@ -0,0 +1 @@
+Interval maps for disjoint closed ranges
diff --git a/extra/interval-maps/tags.txt b/extra/interval-maps/tags.txt
new file mode 100755
index 0000000000..5e9549f425
--- /dev/null
+++ b/extra/interval-maps/tags.txt
@@ -0,0 +1 @@
+collections
diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 265675f8df..705c2d070b 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -197,7 +197,7 @@ DEFER: _
\ prefix [ unclip ] define-inverse
\ unclip [ prefix ] define-inverse
-\ suffix [ dup 1 head* swap peek ] define-inverse
+\ suffix [ dup but-last swap peek ] define-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )
diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor
index 3fbb3908e2..88414efd16 100755
--- a/extra/io/encodings/8-bit/8-bit.factor
+++ b/extra/io/encodings/8-bit/8-bit.factor
@@ -30,9 +30,8 @@ IN: io.encodings.8-bit
} ;
: encoding-file ( file-name -- stream )
- "extra/io/encodings/8-bit/" ".TXT"
- swapd 3append resource-path
- ascii ;
+ "resource:extra/io/encodings/8-bit/" ".TXT"
+ swapd 3append ascii ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index dadb627fc0..45bbec20e3 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations kernel io math
-calendar ;
+USING: help.markup help.syntax quotations kernel io io.files
+math calendar ;
IN: io.launcher
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:"
{ $list
{ { $link f } " - default value; the stream is either inherited from the current process, or is a " { $link } " pipe" }
- { { $link +inherit+ } " - the stream is inherited from the current process, overriding a " { $link } " pipe" }
{ { $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" }
{ "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 } }
{ "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+
{ $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+
{ $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 } "." } ;
+
+HELP:
+{ $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+
{ $description "Possible value of " { $snippet "environment-mode" } " slot of a " { $link process } "."
$nl
@@ -138,13 +142,6 @@ HELP:
{ "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." } ;
-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
{ $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." } ;
@@ -175,8 +172,9 @@ ARTICLE: "io.launcher.launch" "Launching processes"
{ $subsection try-process }
{ $subsection run-detached }
"Redirecting standard input and output to a pipe:"
-{ $subsection }
-{ $subsection with-process-stream } ;
+{ $subsection }
+{ $subsection }
+{ $subsection } ;
ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:"
@@ -212,7 +210,7 @@ ARTICLE: "io.launcher.examples" "Launcher examples"
" "
" swap >>stderr"
" \"report\" >>command"
- " ascii lines sort reverse [ print ] each"
+ " ascii lines sort reverse [ print ] each"
"] with-disposal"
} ;
diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor
index bacb8eb5a9..003f382020 100755
--- a/extra/io/launcher/launcher-tests.factor
+++ b/extra/io/launcher/launcher-tests.factor
@@ -2,3 +2,5 @@ IN: io.launcher.tests
USING: tools.test io.launcher ;
\ must-infer
+\ must-infer
+\ must-infer
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 6ee8660528..e9fbdaea62 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.backend io.timeouts system kernel namespaces
-strings hashtables sequences assocs combinators vocabs.loader
-init threads continuations math io.encodings io.streams.duplex
-io.nonblocking accessors concurrency.flags ;
+USING: system kernel namespaces strings hashtables sequences
+assocs combinators vocabs.loader init threads continuations
+math accessors concurrency.flags destructors
+io io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io.streams.duplex io.nonblocking ;
IN: io.launcher
TUPLE: process < identity-tuple
@@ -26,9 +27,12 @@ handle status
killed ;
SYMBOL: +closed+
-SYMBOL: +inherit+
SYMBOL: +stdout+
+TUPLE: appender path ;
+
+: ( path -- appender ) appender boa ;
+
SYMBOL: +prepend-environment+
SYMBOL: +replace-environment+
SYMBOL: +append-environment+
@@ -145,20 +149,63 @@ M: process set-timeout set-process-timeout ;
M: process timed-out kill-process ;
-HOOK: (process-stream) io-backend ( process -- handle in out )
+M: object run-pipeline-element
+ [ >process swap >>stdout swap >>stdin run-detached ]
+ [ drop [ [ close-handle ] when* ] bi@ ]
+ 3bi
+ wait-for-process ;
-: ( desc encoding -- stream process )
- >r >process dup dup (process-stream)
- r> -roll
- process-started ;
+: ( process encoding -- process stream )
+ [
+ >r (pipe) {
+ [ add-error-destructor ]
+ [
+ swap >process
+ [ swap out>> or ] change-stdout
+ run-detached
+ ]
+ [ out>> close-handle ]
+ [ in>> ]
+ } cleave r>
+ ] with-destructors ;
+
+: ( desc encoding -- stream )
+ nip ; inline
+
+: ( process encoding -- process stream )
+ [
+ >r (pipe) {
+ [ add-error-destructor ]
+ [
+ swap >process
+ [ swap in>> or ] change-stdout
+ run-detached
+ ]
+ [ in>> close-handle ]
+ [ out>> ]
+ } cleave r>
+ ] with-destructors ;
+
+: ( desc encoding -- stream )
+ nip ; inline
+
+: ( 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>> ] [ out>> ] bi* ]
+ } 2cleave r>
+ ] with-destructors ;
: ( desc encoding -- stream )
- drop ; inline
-
-: with-process-stream ( desc quot -- status )
- swap