Changeset 9829


Ignore:
Timestamp:
Jun 26, 2008, 2:09:36 AM (11 years ago)
Author:
gb
Message:

RUN-PROGRAM, RUN-EXTERNAL-PROCESS: move more error-checking to RUN-PROGRAM.
Recognize fork failure in RUN-EXTERNAL-PROCESS; try to ensure that the
semaphore used to indicate process creation is signaled in all cases.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r9790 r9829  
    884884                   (setq terminated t)))))))))
    885885     
    886 (defun run-external-process (proc in-fd out-fd error-fd &optional env)
    887   ;; type-check the env variable
    888   (dolist (pair env)
    889     (destructuring-bind (var . val) pair
    890       (assert (typep var '(or string symbol character)))
    891       (assert (typep val 'string))))
    892   (call-with-string-vector
    893    #'(lambda (argv)
    894        (let* ((child-pid (#_fork)))
    895          (declare (fixnum child-pid))
    896          (cond ((zerop child-pid)
    897                 ;; Running in the child; do an exec
    898                 (dolist (pair env)
    899                   (setenv (string (car pair)) (cdr pair)))
    900                 (without-interrupts
    901                  (exec-with-io-redirection
    902                   in-fd out-fd error-fd argv)))
    903                ((> child-pid 0)
    904                 ;; Running in the parent: success
    905                 (setf (external-process-pid proc) child-pid)
    906                 (add-external-process proc)
    907                 (signal-semaphore (external-process-signal proc))
    908                 (monitor-external-process proc)))))
    909    (external-process-args proc)))
     886(defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
     887  (let* ((signaled nil))
     888    (unwind-protect
     889         (let* ((child-pid (#_fork)))
     890           (declare (fixnum child-pid))
     891           (cond ((zerop child-pid)
     892                  ;; Running in the child; do an exec
     893                  (setq signaled t)
     894                  (dolist (pair env)
     895                    (setenv (string (car pair)) (cdr pair)))
     896                  (without-interrupts
     897                   (exec-with-io-redirection
     898                    in-fd out-fd error-fd argv)))
     899                 ((> child-pid 0)
     900                  ;; Running in the parent: success
     901                  (setf (external-process-pid proc) child-pid)
     902                  (add-external-process proc)
     903                  (signal-semaphore (external-process-signal proc))
     904                  (setq signaled t)
     905                  (monitor-external-process proc))
     906                 (t
     907                  ;; fork failed.
     908                  (setf (external-process-%status proc) :error
     909                        (external-process-%exit-code proc) (%get-errno))
     910                  (signal-semaphore (external-process-signal proc))
     911                  (setq signaled t))))
     912      (unless signaled
     913        (setf (external-process-%status proc) :error
     914              (external-process-%exit-code proc) -1)
     915        (signal-semaphore (external-process-signal proc))))))
    910916
    911917               
     
    921927  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
    922928    (error "Program args must all be simple strings : ~s" args))
     929  (dolist (pair env)
     930    (destructuring-bind (var . val) pair
     931      (assert (typep var '(or string symbol character)))
     932      (assert (typep val 'string))))
    923933  (push (native-untranslated-namestring program) args)
    924934  (let* ((token (list 0))
     
    962972                 (external-process-output proc) out-stream
    963973                 (external-process-error proc) error-stream)
    964            (process-run-function
    965             (format nil "Monitor thread for external process ~a" args)
    966                    
    967             #'run-external-process proc in-fd out-fd error-fd env)
    968            (wait-on-semaphore (external-process-signal proc))
    969            )
     974           (call-with-string-vector
     975            #'(lambda (argv)
     976                (process-run-function
     977                 (format nil "Monitor thread for external process ~a" args)
     978                 #'run-external-process proc in-fd out-fd error-fd argv env)
     979                (wait-on-semaphore (external-process-signal proc)))
     980              args)))
    970981      (dolist (fd close-in-parent) (fd-close fd))
    971982      (unless (external-process-pid proc)
     
    973984      (when (and wait (external-process-pid proc))
    974985        (with-interrupts-enabled
    975             (wait-on-semaphore (external-process-completed proc)))))
     986            (wait-on-semaphore (external-process-completed proc))))
    976987    (and (external-process-pid proc) proc)))
    977988
Note: See TracChangeset for help on using the changeset viewer.