diff options
| -rw-r--r-- | scsh-process.egg | 4 | ||||
| -rw-r--r-- | scsh-process.meta | 8 | ||||
| -rw-r--r-- | scsh-process.release-info | 30 | ||||
| -rw-r--r-- | scsh-process.release-info.chicken-5 | 7 | ||||
| -rw-r--r-- | scsh-process.scm | 348 | ||||
| -rw-r--r-- | tests/run.scm | 60 |
6 files changed, 191 insertions, 266 deletions
diff --git a/scsh-process.egg b/scsh-process.egg index 25b83f8..59ffcc9 100644 --- a/scsh-process.egg +++ b/scsh-process.egg @@ -4,8 +4,8 @@ (author "Peter Bex") (category os) (license "BSD") - (dependencies srfi-18 llrb-tree) + (dependencies srfi-18 srfi-69) (test-dependencies test) (components (extension scsh-process - (csc-options "-O3" "-feature" "has-thread-killer")))) + (csc-options "-O3")))) diff --git a/scsh-process.meta b/scsh-process.meta deleted file mode 100644 index 1dbb1be..0000000 --- a/scsh-process.meta +++ /dev/null @@ -1,8 +0,0 @@ -;;; scsh-process.meta -*- Scheme -*- - -((synopsis "A reimplementation for CHICKEN of SCSH's process notation.") - (author "Peter Bex") - (category os) - (license "BSD") - (depends llrb-tree) - (test-depends test)) diff --git a/scsh-process.release-info b/scsh-process.release-info index ef9f9ed..24cf402 100644 --- a/scsh-process.release-info +++ b/scsh-process.release-info @@ -1,31 +1,3 @@ (repo git "https://code.more-magic.net/{egg-name}") (uri targz "https://code.more-magic.net/{egg-name}/snapshot/{egg-name}-{egg-release}.tar.gz") -(release "0.1") -(release "0.1.1") -(release "0.1.2") -(release "0.2") -(release "0.2.1") -(release "0.3") -(release "0.3.1") -(release "0.4") -(release "0.4.1") -(release "0.5") -(release "0.6") -(release "0.7") -(release "0.7.1") -(release "0.8") -(release "0.8.1") -(release "0.8.2") -(release "0.8.3") -(release "0.9.0") -(release "1.0.0") -(release "1.1.0") -(release "1.2.0") -(release "1.2.1") -(release "1.2.2") -(release "1.3.0") -(release "1.4.0") -(release "1.5.0") -(release "1.5.1") -(release "1.5.2") -(release "1.6.0") +(release "1.7.0") diff --git a/scsh-process.release-info.chicken-5 b/scsh-process.release-info.chicken-5 deleted file mode 100644 index 62a173d..0000000 --- a/scsh-process.release-info.chicken-5 +++ /dev/null @@ -1,7 +0,0 @@ -(repo git "https://code.more-magic.net/{egg-name}") -(uri targz "https://code.more-magic.net/{egg-name}/snapshot/{egg-name}-{egg-release}.tar.gz") -(release "1.4.0") -(release "1.5.0") -(release "1.5.1") -(release "1.5.2") -(release "1.6.0") diff --git a/scsh-process.scm b/scsh-process.scm index af3586e..bcc6dbd 100644 --- a/scsh-process.scm +++ b/scsh-process.scm @@ -8,34 +8,31 @@ ;; ;; || wasn't changed, but it's really the zero-length symbol ;; -;; WARNING: Don't mix with threading unless you're using -;; Chicken 4.8.1 rev 47b5be71 or later. +;;; Copyright (c) 2012-2025, Peter Bex +;;; All rights reserved. ;; -;;; Copyright (c) 2012-2021, Peter Bex -;; All rights reserved. -; -; Redistribution and use in source and binary forms, with or without -; modification, are permitted provided that the following conditions -; are met: -; -; 1. Redistributions of source code must retain the above copyright -; notice, this list of conditions and the following disclaimer. -; 2. Redistributions in binary form must reproduce the above copyright -; notice, this list of conditions and the following disclaimer in the -; documentation and/or other materials provided with the distribution. -; -; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS -; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, -; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES -; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, -; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED -; OF THE POSSIBILITY OF SUCH DAMAGE. +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +;; OF THE POSSIBILITY OF SUCH DAMAGE. (declare ;; Avoid FD leaks due to context switch between create-pipe and fork @@ -50,20 +47,15 @@ run/collecting run/string run/strings run/port run/file run/sexp run/sexps || && (& run-final-thunk maybe->string) (run maybe->string) (exec-epf maybe->string) - process? proc:pid proc? wait signal-process process-sleep) + proc:pid proc? wait signal-process process-sleep) (import scheme) -(cond-expand - (chicken-5 (import (chicken base) (chicken condition) (chicken io) - (chicken port) (chicken file) (chicken file posix) - (chicken fixnum) (chicken string) (chicken process) - (chicken bitwise) (chicken process signal) - srfi-18 llrb-fixnum-table)) - (else (import chicken) - (use data-structures (rename extras (read-file read-list)) - utils files ports posix srfi-1 srfi-18) - (use llrb-fixnum-table))) +(import (chicken base) (chicken condition) (chicken io) + (chicken port) (chicken file) (chicken file posix) + (chicken fixnum) (chicken string) (chicken process) + (chicken bitwise) (chicken process signal) + srfi-18 srfi-69) ;;;;;;;;;;;;;;;;;;;;;;;;; ;; Process bookkeeping ;; @@ -73,15 +65,18 @@ ;; processes without having to wait for all of them in user code. We ;; need to keep a hash table around so that the user can still wait ;; for his own processes without the signal/chld handler interfering -;; with those. It's a bit of hack the way we overwrite the regular -;; process-wait procedure from POSIX, but this allows us to -;; transparently mark off processes which were waited on by the user. - -(define-record scsh-process pid exit-status ok? child-condition) - -;; Aaaand another hack to avoid getting "deadlock detected" when all -;; threads are waiting for a child condition. We can still get woken -;; up by the signal/chld handler (see below). +;; with those. +;; Now that process-wait from POSIX directly supports process objects, +;; we use those, but we still install a handler to allow waiting for +;; processes "in the background". This is because that will make this +;; egg (like scsh itself) easier to use as a shell replacement +;; without having to worry about zombie processes. To make that +;; work properly, we keep track of all processes started by this egg +;; in a global table. + +;; A hack to avoid getting "deadlock detected" when all threads are +;; waiting for a child condition. We can still get woken up by the +;; signal/chld handler (see below). (define (install-deadlock-workaround!) (thread-start! (make-thread (lambda () (let lp () (thread-sleep! 100) (lp))) @@ -89,146 +84,135 @@ (install-deadlock-workaround!) ;; And again on fork -(define proc:pid scsh-process-pid) -(define proc? scsh-process?) - -;; Deprecated -(define process? scsh-process?) +(define proc:pid process-id) +(define proc? process?) -(define *scsh-pending-processes* (make-table)) +(define *scsh-pending-processes* (make-hash-table)) (define (clear-scsh-pending-processes!) - (set! *scsh-pending-processes* (make-table))) + (set! *scsh-pending-processes* (make-hash-table))) -(define (add-scsh-pending-process! pid) - (let* ((c (make-condition-variable pid)) - (process (make-scsh-process pid #f #f c))) - (table-update! *scsh-pending-processes* pid (lambda (x) process) (lambda () #f)) +(define (add-scsh-pending-process! process) + (let* ((pid (process-id process)) + (condition (make-condition-variable (conc "process(" pid ")")))) + (hash-table-update! *scsh-pending-processes* pid (lambda (x) (cons process condition)) (lambda () #f)) process)) (define (scsh-pending-process-ref/default pid default) - (table-ref/default *scsh-pending-processes* pid default)) + (hash-table-ref/default *scsh-pending-processes* pid default)) (define (remove-scsh-pending-process! pid) - (table-delete! *scsh-pending-processes* pid)) + (hash-table-delete! *scsh-pending-processes* pid)) (define (scsh-pending-process-fold proc nil) - (table-fold *scsh-pending-processes* proc nil)) + (hash-table-fold *scsh-pending-processes* proc nil)) (define (snapshot-scsh-pending-process) - (let ((copy (table-copy *scsh-pending-processes*))) - (lambda (pid) (table-ref/default copy pid #f)))) + (let ((copy (hash-table-copy *scsh-pending-processes*))) + (lambda (pid) (hash-table-ref/default copy pid #f)))) (define wait #f) -(let ((posix-process-wait process-wait)) - (set! process-wait - (lambda (#!optional pid nohang) - (receive (status ok? pid) (wait pid nohang) (values pid ok? status)))) - - (set! wait - (lambda (#!optional pid-or-process nohang) - (unless (or (not pid-or-process) - (scsh-process? pid-or-process) - (number? pid-or-process)) - (error 'process-wait - "Not a scsh-type process object or pid" - pid-or-process)) - ;; We need to make a copy when waiting for #f, because we - ;; can't predict which pid we'll receive, and the SIGCHLD - ;; handler will drop the pid from the pending list. - (let ((pending-before - (if pid-or-process - #f - (snapshot-scsh-pending-process))) - (p (if (and pid-or-process (number? pid-or-process)) - (scsh-pending-process-ref/default pid-or-process #f) - pid-or-process))) - (if (and p (scsh-process-exit-status p)) - (values (scsh-process-exit-status p) - (scsh-process-ok? p) - (scsh-process-pid p)) - (handle-exceptions exn - (if (and p (scsh-process-exit-status p)) ; Signal might've occurred - (values (scsh-process-exit-status p) - (scsh-process-ok? p) - (scsh-process-pid p)) - (abort exn)) - (let lp () - (receive (pid ok? status) - (posix-process-wait - (if p (scsh-process-pid p) pid-or-process) - ;; When we have p, "nohang" is ignored because - ;; the thread will hang on the condition var - ;; rather than letting the entire process hang. - (if p #t nohang)) - (cond - ((zero? pid) - (if nohang - (values #f #f #f) - (let ((m (make-mutex))) - (mutex-unlock! m (scsh-process-child-condition p)) - (if (not (scsh-process-exit-status p)) - (lp) ; could be forcibly unblocked - (values (scsh-process-exit-status p) - (scsh-process-ok? p) - (scsh-process-pid p)))))) - (else - (and-let* ((p (or p (pending-before pid)))) - (scsh-process-exit-status-set! p status) - (scsh-process-ok?-set! p ok?) - (condition-variable-broadcast! - (scsh-process-child-condition p))) - - (remove-scsh-pending-process! pid) - (values status ok? pid)))))))))) - - (set-signal-handler! - signal/chld - ;; This workaround fixes the "signal-hander" type in the types.db of 4.8.0 - (let-syntax ((workaround - (cond-expand - (chicken-4.8 - (syntax-rules () - ((_ val) (the (or boolean (procedure (fixnum) . *)) val)))) - (else (syntax-rules () ((_ val) val)))))) - (let* ((old-handler (workaround (signal-handler signal/chld))) - (rst #f) ;; restart scan if true - (handler - ;; Run the signal handler in another thread. This is needed - ;; because the current thread may be waiting on a condition - ;; variable, and we can't wake ourselves up. - (thread-start! - (lambda () - (do () (#f) - (set! rst #f) - (scsh-pending-process-fold - (lambda (pid p i) - (and - p - (not (scsh-process-exit-status p)) - (receive (pid ok? status) - (posix-process-wait pid #t) - (if (and (not (zero? pid)) p) - (begin - (scsh-process-exit-status-set! p status) - (scsh-process-ok?-set! p ok?) - (condition-variable-broadcast! - (scsh-process-child-condition p)) - ;; The GC can clean it up - (remove-scsh-pending-process! pid)))))) - #f) - (unless rst (thread-suspend! (current-thread)))))) - )) - (lambda (signal) - (set! rst #t) - (thread-resume! handler) - (when old-handler (old-handler signal))))))) - -(define (signal-process proc sig) - (process-signal (scsh-process-pid proc) sig)) - -(define process-sleep sleep) +(define (wait #!optional pid-or-process nohang) + (unless (or (not pid-or-process) + (process? pid-or-process) + (number? pid-or-process)) + (error 'process-wait + "Not a process object or pid" + pid-or-process)) + ;; We need to make a copy when waiting for #f, because we + ;; can't predict which pid we'll receive, and the SIGCHLD + ;; handler will drop the pid from the pending list. + (let ((pending-before + (if pid-or-process + #f + (snapshot-scsh-pending-process)))) + (handle-exceptions exn + ;; Signal might've occurred, our sigchld handler may have waited already + ;; which would cause an error here. Assume that this means the process + ;; exit information has been populated and that if that is the case, + ;; that is the only error that can occur. + (if (and (process? pid-or-process) + (process-exit-status pid-or-process)) + (values (process-exit-status pid-or-process) + (process-returned-normally? pid-or-process) + (process-id pid-or-process)) + (abort exn)) + (let lp () + (receive (pid ok? status) + (process-wait + pid-or-process + ;; When we have pid-or-process, "nohang" is ignored + ;; because the thread will hang on the condition var + ;; rather than letting the entire process hang. + (if pid-or-process #t nohang)) + (cond + ((zero? pid) + (if nohang + (values #f #f #f) + (let* ((m (make-mutex)) + (proc+condition (and pending-before + (pending-before (if (number? pid-or-process) + pid-or-process + (process-id pid-or-process))))) + (proc (if (process? pid-or-process) + pid-or-process + (car proc+condition)))) + (when proc+condition + (mutex-unlock! m (cdr proc+condition))) + (if (or (number? pid-or-process) + (not (process-exit-status proc))) + (lp) ; could be forcibly unblocked + (begin + (remove-scsh-pending-process! pid) + (values (process-exit-status proc) + (process-returned-normally? proc) + (process-id proc))))))) + (else + (and-let* (pending-before + pid-or-process + (proc+condition (pending-before (if (number? pid-or-process) + pid-or-process + (process-id pid-or-process))))) + (condition-variable-broadcast! + (cdr proc+condition))) + + (remove-scsh-pending-process! pid) + (values status ok? pid)))))))) + +(set-signal-handler! + signal/chld + (let* ((old-handler (signal-handler signal/chld)) + (rst #f) ;; restart scan if true + (handler + ;; Run the signal handler in another thread. This is needed + ;; because the current thread may be waiting on a condition + ;; variable, and we can't wake ourselves up. + (thread-start! + (lambda () + (do () (#f) + (set! rst #f) + (scsh-pending-process-fold + (lambda (pid proc+condition i) + (and + proc+condition + (not (process-exit-status (car proc+condition))) + (not (zero? pid)) + (receive (pid ok? status) + (process-wait (car proc+condition) #t) + (unless (zero? pid) + (condition-variable-broadcast! + (cdr proc+condition)) + (remove-scsh-pending-process! pid))))) + #f) + (unless rst (thread-suspend! (current-thread)))))) + )) + (lambda (signal) + (set! rst #t) + (thread-resume! handler) + (when old-handler (old-handler signal))))) + +(define signal-process process-signal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Execution and forking helpers ;; @@ -271,26 +255,20 @@ (lambda () (let* ((maybe-reinstall-deadlock-workaround! (lambda () - (cond-expand - (has-thread-killer - (unless continue-threads? (install-deadlock-workaround!))) - (else (void))))) + (unless continue-threads? (install-deadlock-workaround!)))) (thunk (and thunk (lambda () (clear-scsh-pending-processes!) (maybe-reinstall-deadlock-workaround!) (unless sigchld-was-masked? (signal-unmask! signal/chld)) (thunk)))) - (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)))))) - (cond ((zero? pid) - (clear-scsh-pending-processes!) - (maybe-reinstall-deadlock-workaround!) - #f) - (else (add-scsh-pending-process! pid))))) + (process (process-fork thunk (not continue-threads?)))) + (if process + (add-scsh-pending-process! process) + (begin + (clear-scsh-pending-processes!) + (maybe-reinstall-deadlock-workaround!) + #f)))) (lambda () (unless sigchld-was-masked? (signal-unmask! signal/chld)))))) diff --git a/tests/run.scm b/tests/run.scm index b5fa419..85a6b11 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -1,27 +1,18 @@ +;;(include "../scsh-process.scm") (module scsh-tests () -(import scheme) - -(cond-expand - (chicken-5 (import (chicken base) (chicken port) (chicken condition) - (chicken io) (chicken file) (chicken file posix) - (chicken process signal) - (chicken fixnum) ;; Why is this needed?! - srfi-18 test) - #;(include "../scsh-process.scm") - (import scsh-process) - - (define (read-all #!optional file-or-port) - (cond ((string? file-or-port) - (with-input-from-file file-or-port read-string)) - (file-or-port (read-string #f file-or-port)) - (else (read-string)))) - ) - (else (import chicken) - #;(include "../scsh-process.scm") - (use scsh-process) - (use test utils extras ports files posix - srfi-13 srfi-18 (only setup-api version>=?)))) +(import (scheme base) (scheme write) (scheme read) + (chicken base) (chicken port) (chicken condition) + (chicken io) (chicken file) (chicken file posix) + (chicken process signal) + srfi-18 test) +(import scsh-process) + +(define (read-all #!optional file-or-port) + (cond ((string? file-or-port) + (with-input-from-file file-or-port read-string)) + (file-or-port (read-string #f file-or-port)) + (else (read-string)))) (test-begin "scsh-process") @@ -149,19 +140,16 @@ (test "run/string with begin form" "hi, there\n" (run/string (pipe (begin (print "hi, there")) (cat)))) - (when (cond-expand - (chicken-5 #t) - (else (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 ((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 ((the-outfile "outfile")) (test "Subprocess writing to a file" @@ -245,6 +233,8 @@ (|| (false) (epf (sh -c "echo hi && false") (- 1)))))) (test-group "finalization" + ;; Ensure the automatic reaping thread has a chance to run + (thread-yield!) ;; 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. |