diff options
-rw-r--r-- | module/ice-9/popen.scm | 86 |
1 files changed, 52 insertions, 34 deletions
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index f8668cd51..48a52e6c1 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -1,6 +1,7 @@ ;; popen emulation, for non-stdio based ports. -;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, +;;;; 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -18,6 +19,8 @@ ;;;; (define-module (ice-9 popen) + :use-module (ice-9 threads) + :use-module (srfi srfi-9) :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe open-output-pipe open-input-output-pipe)) @@ -25,6 +28,11 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_popen")) +(define-record-type <pipe-info> + (make-pipe-info pid) + pipe-info? + (pid pipe-info-pid set-pipe-info-pid!)) + (define (make-rw-port read-port write-port) (make-soft-port (vector @@ -40,7 +48,10 @@ (define pipe-guardian (make-guardian)) ;; a weak hash-table to store the process ids. +;; XXX use of this table is deprecated. It is no longer used here, and +;; is populated for backward compatibility only (since it is exported). (define port/pid-table (make-weak-key-hash-table 31)) +(define port/pid-table-mutex (make-mutex)) (define (open-pipe* mode command . args) "Executes the program @var{command} with optional arguments @@ -56,9 +67,19 @@ port to the process is created: it should be the value of (make-rw-port read-port write-port)) read-port write-port - (%make-void-port mode)))) - (pipe-guardian port) - (hashq-set! port/pid-table port pid) + (%make-void-port mode))) + (pipe-info (make-pipe-info pid))) + + ;; Guard the pipe-info instead of the port, so that we can still + ;; call 'waitpid' even if 'close-port' is called (which clears + ;; the port entry). + (pipe-guardian pipe-info) + (%set-port-property! port 'popen-pipe-info pipe-info) + + ;; XXX populate port/pid-table for backward compatibility. + (with-mutex port/pid-table-mutex + (hashq-set! port/pid-table port pid)) + port)))) (define (open-pipe command mode) @@ -69,48 +90,45 @@ port to the process is created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}." (open-pipe* mode "/bin/sh" "-c" command)) -(define (fetch-pid port) - (let ((pid (hashq-ref port/pid-table port))) - (hashq-remove! port/pid-table port) - pid)) +(define (fetch-pipe-info port) + (%port-property port 'popen-pipe-info)) (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) - (catch 'system-error - (lambda () - (close-port port)) - (lambda args #f)) - (catch 'system-error - (lambda () - (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) "Closes the pipe created by @code{open-pipe}, then waits for the process to terminate and returns its status value, @xref{Processes, waitpid}, for information on how to interpret this value." - (let ((pid (fetch-pid p))) - (unless pid (error "close-pipe: pipe not in table")) - (close-process p pid))) + (let ((pipe-info (fetch-pipe-info p))) + (unless pipe-info + (error "close-pipe: port not created by (ice-9 popen)")) + (let ((pid (pipe-info-pid pipe-info))) + (unless pid + (error "close-pipe: pid has already been cleared")) + ;; clear the pid to avoid repeated calls to 'waitpid'. + (set-pipe-info-pid! pipe-info #f) + (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))) + (let ((pipe-info (pipe-guardian))) + (when pipe-info + (let ((pid (pipe-info-pid pipe-info))) + ;; maybe 'close-pipe' was already called. + (when pid + ;; 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. + (catch 'system-error + (lambda () + (let ((pid/status (waitpid pid WNOHANG))) + (if (zero? (car pid/status)) + (pipe-guardian pipe-info) ; not ready for collection + (set-pipe-info-pid! pipe-info #f)))) + (lambda args #f)))) (loop))))) (add-hook! after-gc-hook reap-pipes) |