diff options
| -rw-r--r-- | scsh-process.scm | 25 | ||||
| -rw-r--r-- | scsh-process.setup | 13 | ||||
| -rw-r--r-- | tests/run.scm | 17 |
3 files changed, 41 insertions, 14 deletions
diff --git a/scsh-process.scm b/scsh-process.scm index 7debdee..e53cbf3 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -8,7 +8,8 @@ ;; ;; || wasn't changed, but it's really the zero-length symbol ;; -;; BIG FAT WARNING: Don't mix this with threading, or Bad Things will happen +;; WARNING: Don't mix with threading unless you're using +;; Chicken 4.8.1 rev 47b5be71 or later. ;; ;;; Copyright (c) 2012, Peter Bex ;; All rights reserved. @@ -153,9 +154,8 @@ (define (exec-path prog . args) (process-execute (maybe->string prog) (map maybe->string args))) -;; TODO: continue-threads argument -(define (fork/pipe #!optional thunk) - (fork/pipe+ '((1 2 0)) thunk)) +(define (fork/pipe #!optional thunk continue-threads?) + (fork/pipe+ '((1 2 0)) thunk continue-threads?)) ;; Run a thunk and exit 0 after the thunk returns. ;; If an exception occurs, handle it and exit 1. @@ -168,18 +168,22 @@ (thunk) (exit 0))) -(define (fork #!optional thunk) - (let ((pid (if thunk (process-fork thunk) (process-fork)))) +(define (fork #!optional thunk continue-threads?) + (let ((pid (cond-expand + (has-thread-killer + (process-fork thunk (not continue-threads?))) + (else ;; Ignore both args if thunk is #f, so #f won't be applied + (if thunk (process-fork thunk) (process-fork)))))) (and (not (zero? pid)) (add-scsh-pending-process! pid)))) (define %fork fork) -(define (fork/pipe+ conns #!optional thunk) +(define (fork/pipe+ conns #!optional thunk continue-threads?) ;; Blergh, this is silly overhead we don't really need (let* ((from-fds (map (lambda (x) (drop-right x 1)) conns)) (to-fds (map last conns)) (pipe-pairs (map (lambda _ (receive (create-pipe))) to-fds)) - (proc (fork))) + (proc (fork #f continue-threads?))) (if (not proc) ; Child (begin (for-each (lambda (p from-fds-for-this-p) @@ -373,10 +377,7 @@ (exec-epf (epf ?last-pf)))))))) (pipe+ ?args ...))) ((_ (begin ?expr0 ...)) - (begin (setup-redirection (= 0 (current-input-port))) - (setup-redirection (= 1 (current-output-port))) - (setup-redirection (= 2 (current-error-port))) - ?expr0 ...)) + (begin (setup-redirection stdports) ?expr0 ...)) ((_ (epf ?args ...)) ; This disambiguates redirection (exec-epf ?args ...)) ((_ (?prog ?arg0 ...) ?redir0 ...) diff --git a/scsh-process.setup b/scsh-process.setup index 0dcea89..09fb10a 100644 --- a/scsh-process.setup +++ b/scsh-process.setup @@ -1,3 +1,14 @@ ;; -*- Scheme -*- -(standard-extension 'scsh-process "0.3.1") + +;; Assume people on old versions of 4.8.1 don't mind breakage (they're running git master!) +(let ((features (if (version>=? (chicken-version) "4.8.1") + '(-feature has-thread-killer) + '()))) + (compile -s -O3 scsh-process.scm ,@features -j scsh-process) + (compile -s -O3 scsh-process.import.scm)) + +(install-extension + 'scsh-process + '("scsh-process.so" "scsh-process.import.so") + `((version 0.3.2))) diff --git a/tests/run.scm b/tests/run.scm index ae12600..13313e5 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,7 +1,7 @@ #;(include "../scsh-process.scm") (use scsh-process) -(use test posix srfi-13) +(use test posix srfi-13 srfi-18 (only setup-api chicken-version version>=?)) (test-begin "scsh-process") @@ -59,6 +59,21 @@ (delete-file* tmpfile))) (test-group "Subprocesses" + (test "run/string with begin form" + "hi, there\n" + (run/string (pipe (begin (print "hi, there")) (cat)))) + (when (version>=? (chicken-version) "4.8.1") + (let ((child? #f)) + (thread-start! (lambda () + (thread-sleep! 0.5) + (when child? (print "haihai")))) + (test "Simple 'begin' form with threading" + "hi, there\n" + (run/string (pipe (begin (set! child? #t) + (thread-sleep! 1) + (print "hi, there")) + (cat)))))) + (let ((outfile "outfile")) (test "Subprocess writing to a file" "hi, there\n" |