Commit b2b86603 authored by Elias Pipping's avatar Elias Pipping
Browse files

Add and use process-info class

Allows for type checking and in-place changes via setf
parent 1c195eda
Loading
Loading
Loading
Loading
+61 −48
Original line number Diff line number Diff line
@@ -408,6 +408,14 @@ argument to pass to the internal RUN-PROGRAM"
      (integer raw-exit-code) ; negative: signal
      (t -1)))

  (defclass process-info ()
    ((process :initform nil)
     (input-stream :initform nil)
     (output-stream :initform nil)
     (bidir-stream :initform nil)
     (error-output-stream :initform nil)
     (exit-code :initform nil)))

  (defun %run-program (command
                       &rest keys
                       &key input (if-input-does-not-exist :error)
@@ -420,8 +428,7 @@ argument to pass to the internal RUN-PROGRAM"
It spawns a subprocess that runs the specified COMMAND (a list of program and arguments).
INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer,
to be normalized by %NORMALIZE-IO-SPECIFIER.
It returns a process-info plist with possible keys:
     PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
It returns a process-info object."
    ;; NB: these implementations have Unix vs Windows set at compile-time.
    (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists))
    #-(or cmucl ecl mkcl sbcl)
@@ -478,53 +485,54 @@ It returns a process-info plist with possible keys:
                #+sbcl `(:search t)
                #-sbcl keys
                #+sbcl (if directory keys (remove-plist-key :directory keys))))))
           (process-info-r ()))
      (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
           (process-info (make-instance 'process-info)))
      (flet ((prop (key value)
               (setf (slot-value process-info key) value)))
        #+allegro
        (cond
          (wait (prop :exit-code (first process*)))
          (wait (prop 'exit-code (first process*)))
          (separate-streams
           (destructuring-bind (in out err pid) process*
             (prop :process pid)
             (when (eq input :stream) (prop :input-stream in))
             (when (eq output :stream) (prop :output-stream out))
             (when (eq error-output :stream) (prop :error-stream err))))
             (prop 'process pid)
             (when (eq input :stream) (prop 'input-stream in))
             (when (eq output :stream) (prop 'output-stream out))
             (when (eq error-output :stream) (prop 'error-stream err))))
          (t
           (prop :process (third process*))
           (prop 'process (third process*))
           (let ((x (first process*)))
             (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
               (0)
               (1 (prop :input-stream x))
               (2 (prop :output-stream x))
               (3 (prop :bidir-stream x))))
               (1 (prop 'input-stream x))
               (2 (prop 'output-stream x))
               (3 (prop 'bidir-stream x))))
           (when (eq error-output :stream)
             (prop :error-stream (second process*)))))
             (prop 'error-stream (second process*)))))
        #+clisp
        (cond
          (wait (prop :exit-code (clisp-exit-code (first process*))))
          (wait (prop 'exit-code (clisp-exit-code (first process*))))
          (t
           (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))
             (0)
             (1 (prop :input-stream (first process*)))
             (2 (prop :output-stream (first process*)))
             (3 (prop :bidir-stream (pop process*))
              (prop :input-stream (pop process*))
              (prop :output-stream (pop process*))))))
             (1 (prop 'input-stream (first process*)))
             (2 (prop 'output-stream (first process*)))
             (3 (prop 'bidir-stream (pop process*))
              (prop 'input-stream (pop process*))
              (prop 'output-stream (pop process*))))))
        #+(or clozure cmucl sbcl scl)
        (progn
          (prop :process process*)
          (prop 'process process*)
          (when (eq input :stream)
            (prop :input-stream
            (prop 'input-stream
                  #+clozure (ccl:external-process-input-stream process*)
                  #+(or cmucl scl) (ext:process-input process*)
                  #+sbcl (sb-ext:process-input process*)))
          (when (eq output :stream)
            (prop :output-stream
            (prop 'output-stream
                  #+clozure (ccl:external-process-output-stream process*)
                  #+(or cmucl scl) (ext:process-output process*)
                  #+sbcl (sb-ext:process-output process*)))
          (when (eq error-output :stream)
            (prop :error-output-stream
            (prop 'error-output-stream
                  #+clozure (ccl:external-process-error-stream process*)
                  #+(or cmucl scl) (ext:process-error process*)
                  #+sbcl (sb-ext:process-error process*))))
@@ -533,24 +541,24 @@ It returns a process-info plist with possible keys:
          (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
            (cond
              ((zerop mode))
              ((null process*) (prop :exit-code -1))
              (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream))))
          (when code (prop :exit-code code))
          (when process (prop :process process)))
              ((null process*) (prop 'exit-code -1))
              (t (prop (case mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) stream))))
          (when code (prop 'exit-code code))
          (when process (prop 'process process)))
        #+lispworks
        (if wait
            (prop :exit-code (first process*))
            (prop 'exit-code (first process*))
            (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0))))
              (if (zerop mode)
                  (prop :process (first process*))
                  (prop 'process (first process*))
                  (destructuring-bind (x err pid) process*
                    (prop :process pid)
                    (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x)
                    (when (eq error-output :stream) (prop :error-stream err))))))
        (nreverse process-info-r))))
                    (prop 'process pid)
                    (prop (ecase mode (1 'input-stream) (2 'output-stream) (3 'bidir-stream)) x)
                    (when (eq error-output :stream) (prop 'error-stream err))))))
        process-info)))

  (defun %process-info-pid (process-info)
    (let ((process (getf process-info :process)))
    (let ((process (slot-value process-info 'process)))
      (declare (ignorable process))
      #+(or allegro lispworks) process
      #+clasp (si:external-process-pid process)
@@ -563,8 +571,8 @@ It returns a process-info plist with possible keys:
      (error "~S not implemented" '%process-info-pid)))

  (defun %wait-process-result (process-info)
    (or (getf process-info :exit-code)
        (let ((process (getf process-info :process)))
    (or (slot-value process-info 'exit-code)
        (let ((process (slot-value process-info 'process)))
          (when process
            ;; 1- wait
            #+clozure (ccl::external-process-wait process)
@@ -579,10 +587,10 @@ It returns a process-info plist with possible keys:
            #+(or cmucl scl) (ext:process-exit-code process)
            #+(or clasp ecl) (nth-value 1 (ext:external-process-wait process t))
            #+lispworks
            (if-let ((stream (or (getf process-info :input-stream)
                                 (getf process-info :output-stream)
                                 (getf process-info :bidir-stream)
                                 (getf process-info :error-stream))))
            (if-let ((stream (or (slot-value process-info 'input-stream)
                                 (slot-value process-info 'output-stream)
                                 (slot-value process-info 'bidir-stream)
                                 (slot-value process-info 'error-stream))))
              (system:pipe-exit-status stream :wait t)
              (if-let ((f (find-symbol* :pid-exit-status :system nil)))
                (funcall f process :wait t)))
@@ -720,9 +728,9 @@ It returns a process-info plist with possible keys:
                           :error-output (if (eq error-output :output) :output reduced-error-output)
                           keys)))
              (labels ((get-stream (stream-name &optional fallbackp)
                         (or (getf process-info stream-name)
                         (or (slot-value process-info stream-name)
                             (when fallbackp
                               (getf process-info :bidir-stream))))
                               (slot-value process-info 'bidir-stream))))
                       (run-activity (activity stream-name &optional fallbackp)
                         (if-let (stream (get-stream stream-name fallbackp))
                           (funcall activity stream)
@@ -732,11 +740,16 @@ It returns a process-info plist with possible keys:
                (unwind-protect
                     (ecase activity
                       ((nil))
                       (:input (run-activity input-activity :input-stream t))
                       (:output (run-activity output-activity :output-stream t))
                       (:error-output (run-activity error-output-activity :error-output-stream)))
                  (loop :for (() val) :on process-info :by #'cddr
                        :when (streamp val) :do (ignore-errors (close val)))
                       (:input (run-activity input-activity 'input-stream t))
                       (:output (run-activity output-activity 'output-stream t))
                       (:error-output (run-activity error-output-activity 'error-output-stream)))
                  (dolist (stream
                            (cons (slot-value process-info 'error-output-stream)
                                  (if-let (bidir-stream (slot-value process-info 'bidir-stream))
                                          (list bidir-stream)
                                          (list (slot-value process-info 'input-stream)
                                                (slot-value process-info 'output-stream)))))
                    (when stream (close stream)))
                  (setf exit-code
                        (%check-result (%wait-process-result process-info)
                                       :command command :process process-info