diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-28 16:15:51 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-28 16:15:51 +0100 |
commit | ae9c16e89565f997936778a710d5addf1ec256c2 (patch) | |
tree | 3e09f05ea60edbf6cefc0d296be51e86292406c1 | |
parent | 9b95f3ced4f4cc4c7d0ffa59c530a2e1a17a19fc (diff) | |
parent | 17330398d50524058c2ef488bd21ac5ec9c8b6e8 (diff) | |
download | guile-ae9c16e89565f997936778a710d5addf1ec256c2.tar.gz |
Merge commit '17330398d50524058c2ef488bd21ac5ec9c8b6e8'
-rw-r--r-- | module/ice-9/popen.scm | 45 |
1 files changed, 21 insertions, 24 deletions
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index 7d0549eb9..f8668cd51 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -74,27 +74,26 @@ port to the process is created: it should be the value of (hashq-remove! port/pid-table port) pid)) -(define (close-process port/pid) - (close-port (car port/pid)) - (cdr (waitpid (cdr port/pid)))) +(define (close-process port pid) + (close-port port) + (cdr (waitpid pid))) ;; for the background cleanup handler: just clean up without reporting ;; errors. also avoids blocking the process: if the child isn't ready ;; to be collected, puts it back into the guardian's live list so it ;; can be tried again the next time the cleanup runs. -(define (close-process-quietly port/pid) +(define (close-process-quietly port pid) (catch 'system-error (lambda () - (close-port (car port/pid))) + (close-port port)) (lambda args #f)) (catch 'system-error (lambda () - (let ((pid/status (waitpid (cdr port/pid) WNOHANG))) - (cond ((= (car pid/status) 0) - ;; not ready for collection - (pipe-guardian (car port/pid)) - (hashq-set! port/pid-table - (car port/pid) (cdr port/pid)))))) + (let ((pid/status (waitpid pid WNOHANG))) + (when (zero? (car pid/status)) + ;; not ready for collection + (pipe-guardian port) + (hashq-set! port/pid-table port pid)))) (lambda args #f))) (define (close-pipe p) @@ -102,19 +101,17 @@ port to the process is created: it should be the value of to terminate and returns its status value, @xref{Processes, waitpid}, for information on how to interpret this value." (let ((pid (fetch-pid p))) - (if (not pid) - (error "close-pipe: pipe not in table")) - (close-process (cons p pid)))) - -(define reap-pipes - (lambda () - (let loop ((p (pipe-guardian))) - (cond (p - ;; maybe removed already by close-pipe. - (let ((pid (fetch-pid p))) - (if pid - (close-process-quietly (cons p pid)))) - (loop (pipe-guardian))))))) + (unless pid (error "close-pipe: pipe not in table")) + (close-process p pid))) + +(define (reap-pipes) + (let loop () + (let ((p (pipe-guardian))) + (when p + ;; maybe removed already by close-pipe. + (let ((pid (fetch-pid p))) + (when pid (close-process-quietly p pid))) + (loop))))) (add-hook! after-gc-hook reap-pipes) |