diff options
| -rw-r--r-- | scsh-process.scm | 44 | ||||
| -rw-r--r-- | tests/run.scm | 11 |
2 files changed, 39 insertions, 16 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index 50c2431..6102c4d 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -44,7 +44,8 @@ ;; macros run/collecting run/string run/strings run/port run/file run/sexp run/sexps || && - (& maybe-symbol->string) (run maybe-symbol->string) (exec-epf maybe-symbol->string)) + (& run-final-thunk maybe-symbol->string) + (run maybe-symbol->string) (exec-epf maybe-symbol->string)) (import chicken scheme data-structures) @@ -61,6 +62,17 @@ (define (fork/pipe #!optional thunk) (fork/pipe+ '((1 2 0)) thunk)) +;; Run a thunk and exit 0 after the thunk returns. +;; If an exception occurs, handle it and exit 1. +(define (run-final-thunk thunk) + (handle-exceptions exn + ;; TODO: Figure out how SCSH does this. It shows the error + ;; on stderr in the REPL, but then still quits it. + ;; If we just invoke current-handler, it'll get a second REPL + (begin (print-error-message exn) (exit 1)) + (thunk) + (exit 0))) + (define (fork/pipe+ conns #!optional thunk) ;; Blergh, this is silly overhead we don't really need (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns)) @@ -79,7 +91,7 @@ ;; Not needed anymore after duplication is complete. (file-close (cadr p))) pipe-pairs from-fds) - (if thunk (begin (thunk) (exit 0)) pid)) + (if thunk (run-final-thunk thunk) pid)) (begin ; Parent (for-each (lambda (p to-fd) ;; Close sending end in parent. @@ -113,11 +125,21 @@ (apply values (fork/pipe+ conns thunk) temp-files))) (define (run/port* thunk) - (fork/pipe (lambda () - (with-output-to-port (open-output-file* 1) - (lambda () - (with-error-output-to-port (open-output-file* 2) thunk))))) - (open-input-file* 0)) + (receive (in out) + (create-pipe) + (process-fork + (lambda () + (run-final-thunk + (lambda () + (file-close in) + (duplicate-fileno out 1) + (duplicate-fileno out 2) + (with-output-to-port (open-output-file* out) + (lambda () + (with-error-output-to-port (open-output-file* out) thunk))))))) + (file-close out) + (open-input-file* in))) + (define (run/file* thunk) (let* ((temp-file (create-temporary-file))) (process-wait ; This is peculiar @@ -129,6 +151,7 @@ (lambda () (with-error-output-to-port (open-output-file* 2) thunk))))))) temp-file)) + (define (run/string* thunk) (read-string #f (run/port* thunk))) (define (run/strings* thunk) @@ -175,12 +198,7 @@ (syntax-rules () ((_ ?epf ...) (process-fork (lambda () - (handle-exceptions exn - ;; TODO: Figure out how SCSH does this. It shows the error - ;; on stderr in the REPL, but then still quits it. - ;; If we just invoke current-handler, it'll get a second REPL - (begin (print-error-message exn) (exit 1)) - (exec-epf ?epf ...))))))) + (run-final-thunk (lambda () (exec-epf ?epf ...)))))))) (define-syntax run (syntax-rules () diff --git a/tests/run.scm b/tests/run.scm index f537ad8..4e3bb8a 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -35,9 +35,10 @@ '(a b c) (read (run/port (echo "(a b c)")))) - (test "Simple run/file" - "blah\n" - (with-input-from-file (run/file (echo "blah")) read-all))) + (let ((tmpfile (run/file (echo "blah")))) + (test "Simple run/file" + "blah\n" + (with-input-from-file tmpfile read-all)))) (test-group "Subprocesses" (let ((outfile "outfile")) @@ -96,4 +97,8 @@ #f (|| (false) (epf (sh -c "echo hi && false") (- 1)))))) +;; TODO: Find a way to test that the input port didn't get replaced by +;; one from a subshell. This happened before, but not sure how +;; to detect this except running it manually from the REPL. + (test-exit)
\ No newline at end of file |