mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-01 01:40:21 +02:00
Code Activity

Merge commit '17330398d5'

Browse source
This commit is contained in:
Andy Wingo 2013-11-28 16:15:51 +01:00
commit ae9c16e895
1 changed files with 20 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

43
module/ice-9/popen.scm
View file

@ -74,27 +74,26 @@ port to the process is created: it should be the value of
(hashq-remove! port/pid-table port) (hashq-remove! port/pid-table port)
pid)) pid))
(define (close-process port/pid) (define (close-process port pid)
(close-port (car port/pid)) (close-port port)
(cdr (waitpid (cdr port/pid)))) (cdr (waitpid pid)))
;; for the background cleanup handler: just clean up without reporting ;; for the background cleanup handler: just clean up without reporting
;; errors. also avoids blocking the process: if the child isn't ready ;; 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 ;; to be collected, puts it back into the guardian's live list so it
;; can be tried again the next time the cleanup runs. ;; 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 (catch 'system-error
(lambda () (lambda ()
(close-port (car port/pid))) (close-port port))
(lambda args #f)) (lambda args #f))
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(let ((pid/status (waitpid (cdr port/pid) WNOHANG))) (let ((pid/status (waitpid pid WNOHANG)))
(cond ((= (car pid/status) 0) (when (zero? (car pid/status))
;; not ready for collection ;; not ready for collection
(pipe-guardian (car port/pid)) (pipe-guardian port)
(hashq-set! port/pid-table (hashq-set! port/pid-table port pid))))
(car port/pid) (cdr port/pid))))))
(lambda args #f))) (lambda args #f)))
(define (close-pipe p) (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 to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value." information on how to interpret this value."
(let ((pid (fetch-pid p))) (let ((pid (fetch-pid p)))
(if (not pid) (unless pid (error "close-pipe: pipe not in table"))
(error "close-pipe: pipe not in table")) (close-process p pid)))
(close-process (cons p pid))))
(define reap-pipes (define (reap-pipes)
(lambda () (let loop ()
(let loop ((p (pipe-guardian))) (let ((p (pipe-guardian)))
(cond (p (when p
;; maybe removed already by close-pipe. ;; maybe removed already by close-pipe.
(let ((pid (fetch-pid p))) (let ((pid (fetch-pid p)))
(if pid (when pid (close-process-quietly p pid)))
(close-process-quietly (cons p pid)))) (loop)))))
(loop (pipe-guardian)))))))
(add-hook! after-gc-hook reap-pipes) (add-hook! after-gc-hook reap-pipes)