From 52d91bf0bc0a568ae4d561890cd0082b3410b387 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:15:29 -0600 Subject: [PATCH] Add try-process word --- extra/benchmark/bootstrap2/bootstrap2.factor | 2 +- extra/bootstrap/image/upload/upload.factor | 3 +-- extra/editors/emacs/emacs.factor | 2 +- extra/editors/textmate/textmate.factor | 2 +- extra/io/launcher/launcher-docs.factor | 10 ++++++++++ extra/io/launcher/launcher.factor | 9 +++++++++ extra/logging/parser/parser.factor | 10 +++++++--- extra/tools/deploy/backend/backend.factor | 5 ++++- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 9 files changed, 36 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/bootstrap/image/upload/upload.factor diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index 54bc73f4a1..f57e92e5e0 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -9,6 +9,6 @@ IN: benchmark.bootstrap2 "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , - ] { } make run-process drop ; + ] { } make try-process ; MAIN: bootstrap-benchmark diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor old mode 100644 new mode 100755 index a9f5d1dcd4..3b5ab4cb77 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ "scp" , boot-image-names % "checksums.txt" , destination , - ] { } make run-process - wait-for-process zero? [ "Upload failed" throw ] unless ; + ] { } make try-process ; : new-images ( -- ) make-images compute-checksums upload-images ; diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor index 31e0761043..966c4f368e 100755 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -8,7 +8,7 @@ IN: editors.emacs "--no-wait" , "+" swap number>string append , , - ] { } make run-process drop ; + ] { } make try-process ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor index 0145ccae81..12d45aa192 100755 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -5,6 +5,6 @@ IN: editors.textmate : textmate-location ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - run-process drop ; + try-process ; [ textmate-location ] edit-hook set-global diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4979f135ac..e414d98d65 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process-failed +{ $values { "code" "an exit status" } } +{ $description "Throws a " { $link process-failed } " error." } +{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ; + +HELP: try-process +{ $values { "desc" "a launch descriptor" } } +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -175,6 +184,7 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +{ $subsection try-process } "Stopping processes:" { $subsection kill-process } "Redirecting standard input and output to a pipe:" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f2ed59a591..7044004218 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +TUPLE: process-failed code ; + +: process-failed ( code -- * ) + process-failed construct-boa throw ; + +: try-process ( desc -- ) + run-process wait-for-process dup zero? + [ drop ] [ process-failed ] if ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f1cb7aa17e..f9bf97a442 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -2,13 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files -namespaces combinators combinators.lib logging.server ; +namespaces combinators combinators.lib logging.server +calendar ; IN: logging.parser : string-of satisfy [ >string ] <@ ; +SYMBOL: multiline + : 'date' - [ CHAR: ] eq? not ] string-of + multiline-header token [ drop multiline ] <@ + [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> "[" "]" surrounded-by ; : 'log-level' @@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser ) first malformed eq? ; : multiline? ( line -- ? ) - first first CHAR: - = ; + first multiline eq? ; : malformed-line "Warning: malformed log line:" print diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index c295f6369d..2439ef8636 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,7 +22,10 @@ IN: tools.deploy.backend +stdout+ +stderr+ set ] H{ } make-assoc dup duplex-stream-out dispose - copy-lines ; + dup copy-lines + process-stream-process wait-for-process zero? [ + "Deployment failed" throw + ] unless ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 1bbf198ea0..eb1a4af4a7 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process drop ; + { "touch" } swap add try-process ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process drop ; + { "rm" "-rf" } swap add try-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ;