Changeset 11125 for trunk/source/level-1


Ignore:
Timestamp:
Oct 17, 2008, 12:54:06 PM (11 years ago)
Author:
gz
Message:

From working-0711 branch:

  • ensure that GET-USER-HOME-DIR actually does return NIL on failure
  • RUN-PROGRAM, RUN-EXTERNAL-PROCESS: move more error-checking to RUN-PROGRAM, try to ensure that the semaphore used to indicate process creation is signalled in all cases. Handle fork failure by optionally signalling an error.
  • Restore check for errors in signal-external-process (got lost in r10515)
  • More verbose error message in %acquire-shared-resource
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/linux-files.lisp

    r11081 r11125  
    200200               (cond ((< len 0) (%errno-disp len))
    201201                     ((< len bufsize)
     202                      (setf (%get-unsigned-byte buf len) 0)
    202203                      (values (get-foreign-namestring buf) len))
    203204                     (t (values nil len)))))))
     
    521522                       (if inheritable #$TRUE #$FALSE)
    522523                       #$DUPLICATE_SAME_ACCESS)))
    523                        
     524
    524525
    525526(defun fd-fsync (fd)
     
    782783  #-windows-target
    783784  (rlet ((pwd :passwd)
    784          (result :address))
     785         (result :address pwd))
    785786    (do* ((buflen 512 (* 2 buflen)))
    786787         ()
     
    798799                                :int)))
    799800          (if (eql 0 err)
    800             (return (get-foreign-namestring (pref pwd :passwd.pw_dir)))
     801            (return (let* ((rp (%get-ptr result)))
     802                      (unless (%null-ptr-p rp)
     803                        (get-foreign-namestring (pref rp :passwd.pw_dir)))))
    801804            (unless (eql err #$ERANGE)
    802805              (return nil))))))))
     
    11981201                   (setq terminated t)))))))))
    11991202     
    1200 (defun run-external-process (proc in-fd out-fd error-fd &optional env)
    1201   ;; type-check the env variable
    1202   (dolist (pair env)
    1203     (destructuring-bind (var . val) pair
    1204       (assert (typep var '(or string symbol character)))
    1205       (assert (typep val 'string))))
    1206   (call-with-string-vector
    1207    #'(lambda (argv)
    1208        (let* ((child-pid (#_fork)))
    1209          (declare (fixnum child-pid))
    1210          (cond ((zerop child-pid)
    1211                 ;; Running in the child; do an exec
    1212                 (dolist (pair env)
    1213                   (setenv (string (car pair)) (cdr pair)))
    1214                 (without-interrupts
    1215                  (exec-with-io-redirection
    1216                   in-fd out-fd error-fd argv)))
    1217                ((> child-pid 0)
    1218                 ;; Running in the parent: success
    1219                 (setf (external-process-pid proc) child-pid)
    1220                 (add-external-process proc)
    1221                 (signal-semaphore (external-process-signal proc))
    1222                 (monitor-external-process proc))
    1223                (t
    1224                 ;; Fork failed
    1225                 (setf (external-process-%status proc) :error
    1226                       (external-process-%exit-code proc) (%get-errno))
    1227                 (signal-semaphore (external-process-signal proc))))))
    1228    (external-process-args proc)))
    1229 
    1230                
     1203(defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
     1204  (let* ((signaled nil))
     1205    (unwind-protect
     1206         (let* ((child-pid (#_fork)))
     1207           (declare (fixnum child-pid))
     1208           (cond ((zerop child-pid)
     1209                  ;; Running in the child; do an exec
     1210                  (setq signaled t)
     1211                  (dolist (pair env)
     1212                    (setenv (string (car pair)) (cdr pair)))
     1213                  (without-interrupts
     1214                    (exec-with-io-redirection
     1215                     in-fd out-fd error-fd argv)))
     1216                 ((> child-pid 0)
     1217                  ;; Running in the parent: success
     1218                  (setf (external-process-pid proc) child-pid)
     1219                  (add-external-process proc)
     1220                  (signal-semaphore (external-process-signal proc))
     1221                  (setq signaled t)
     1222                  (monitor-external-process proc))
     1223                 (t
     1224                  ;; Fork failed
     1225                  (setf (external-process-%status proc) :error
     1226                        (external-process-%exit-code proc) (%get-errno))
     1227                  (signal-semaphore (external-process-signal proc))
     1228                  (setq signaled t))))
     1229      (unless signaled
     1230        (setf (external-process-%status proc) :error
     1231              (external-process-%exit-code proc) -1)
     1232        (signal-semaphore (external-process-signal proc))))))
     1233
     1234(defparameter *silently-ignore-catastrophic-failure-in-run-program*
     1235  #+ccl-0711 t #-ccl-0711 nil
     1236  "If NIL, signal an error if run-program is unable to start the program.
     1237If non-NIL, treat failure to start the same as failure from the program
     1238itself, by setting the status and exit-code fields.")
     1239
    12311240(defun run-program (program args &key
    12321241                            (wait t) pty
     
    12351244                            (error :output) (if-error-exists :error)
    12361245                            status-hook (element-type 'character)
    1237                             env)
     1246                            env
     1247                            (silently-ignore-catastrophic-failures
     1248                             *silently-ignore-catastrophic-failure-in-run-program*))
    12381249  "Invoke an external program as an OS subprocess of lisp."
    12391250  (declare (ignore pty))
    12401251  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
    12411252    (error "Program args must all be simple strings : ~s" args))
     1253  (dolist (pair env)
     1254    (destructuring-bind (var . val) pair
     1255      (check-type var (or string symbol character))
     1256      (check-type val string)))
    12421257  (push (native-untranslated-namestring program) args)
    12431258  (let* ((token (list 0))
     
    12681283           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    12691284             (get-descriptor-for output proc close-in-parent close-on-error
    1270                                 :direction :output
     1285                                :direction :output
    12711286                                 :if-exists if-output-exists
    12721287                                 :element-type element-type))
     
    12781293                                   :if-exists if-error-exists
    12791294                                   :element-type element-type)))
    1280            (setf (external-process-input proc) in-stream
     1295           (setf (external-process-input proc) in-stream
    12811296                 (external-process-output proc) out-stream
    12821297                 (external-process-error proc) error-stream)
    1283            (process-run-function
    1284             (list :name
    1285                   (format nil "Monitor thread for external process ~a" args)
    1286                   :stack-size (ash 128 10)
    1287                   :vstack-size (ash 128 10)
    1288                   :tstack-size (ash 128 10))
    1289             #'run-external-process proc in-fd out-fd error-fd env)
    1290            (wait-on-semaphore (external-process-signal proc))
    1291            )
     1298           (call-with-string-vector
     1299            #'(lambda (argv)
     1300                (process-run-function
     1301                 (list :name
     1302                       (format nil "Monitor thread for external process ~a" args)
     1303                       :stack-size (ash 128 10)
     1304                       :vstack-size (ash 128 10)
     1305                       :tstack-size (ash 128 10))
     1306                 #'run-external-process proc in-fd out-fd error-fd argv env)
     1307                (wait-on-semaphore (external-process-signal proc)))
     1308            args))
    12921309      (dolist (fd close-in-parent) (fd-close fd))
    12931310      (unless (external-process-pid proc)
     
    12951312      (when (and wait (external-process-pid proc))
    12961313        (with-interrupts-enabled
    1297             (wait-on-semaphore (external-process-completed proc)))))
    1298     (and (or (external-process-pid proc)
    1299              (if (eq (external-process-%status proc) :error)
    1300                (error "Fork failed in ~s: ~s" proc (%strerror (external-process-%exit-code proc)))))
    1301              (external-process-%status proc)) proc))
    1302 
     1314          (wait-on-semaphore (external-process-completed proc)))))
     1315    (unless (external-process-pid proc)
     1316      ;; something is wrong
     1317      (if (eq (external-process-%status proc) :error)
     1318        ;; Fork failed
     1319        (unless silently-ignore-catastrophic-failures
     1320          (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc))
     1321        ;; Currently can't happen.
     1322        (error "Bug: fork failed but status field not set?")))
     1323    proc))
    13031324
    13041325
     
    13691390  "Send the specified signal to the specified external process.  (Typically,
    13701391it would only be useful to call this function if the EXTERNAL-PROCESS was
    1371 created with :WAIT NIL.) Return T if successful; signal an error otherwise."
     1392created with :WAIT NIL.) Return T if successful; NIL if the process wasn't
     1393created successfully, and signal an error otherwise."
    13721394  (require-type proc 'external-process)
    13731395  (let* ((pid (external-process-pid proc)))
    13741396    (when pid
    1375       (int-errno-call (#_kill pid signal)))))
     1397      (let ((error (int-errno-call (#_kill pid signal))))
     1398        (or (eql error 0)
     1399            (%errno-disp error))))))
    13761400
    13771401) ; #-windows-target (progn
     
    17421766    (let* ((request (make-shared-resource-request *current-process*)))
    17431767      (when verbose
    1744         (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;;~%~%"
    1745                 *current-process* (shared-resource-name resource)))
     1768        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%"
     1769                *current-process* (shared-resource-name resource)
     1770                (process-serial-number *current-process*)))
    17461771      (with-lock-grabbed ((shared-resource-lock resource))
    17471772        (append-dll-node request (shared-resource-requestors resource)))
Note: See TracChangeset for help on using the changeset viewer.