Changeset 14853


Ignore:
Timestamp:
09/02/16 21:31:09 (6 years ago)
Author:
Mark Evenson
Message:

Consolidated fixes for EXTENSIONS:RUN-PROGRAM (ferada)

Protect / autoload process slots.

Includes <https://github.com/Ferada/abcl/commit/14333f07d15c75bb0f0a234e4a7dc59e7cb32c52>.

From aad63c50a972282e981d290f699c49f5c28d75de Mon Sep 17 00:00:00 2001
Improvements to SYS:RUN-PROGRAM

[PATCH] Redirection for RUN-PROGRAM; add PROCESS-PID.
From aad63c50a972282e981d290f699c49f5c28d75de Mon Sep 17 00:00:00 2001
---

src/org/armedbear/lisp/Extensions.java | 2 +-
src/org/armedbear/lisp/run-program.lisp | 154 ++++++++++++++++++++++++++++----
2 files changed, 138 insertions(+), 18 deletions(-)

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/Extensions.java

    r14404 r14853  
    276276      try
    277277        {
    278           File file = File.createTempFile("abcl", null, null);
     278          File file = File.createTempFile("abcl", "", null);
    279279          if (file != null)
    280280            return new Pathname(file.getPath());
  • trunk/abcl/src/org/armedbear/lisp/run-program.lisp

    r14732 r14853  
    3636(export '(run-program process process-p process-input process-output
    3737          process-error process-alive-p process-wait process-exit-code
    38           process-kill))
    39 
    40 ;;; Vaguely inspired by sb-ext:run-program in SBCL. 
    41 ;;;
    42 ;;; See <http://www.sbcl.org/manual/Running-external-programs.html>. 
     38          process-kill process-pid))
     39
     40;;; Vaguely inspired by sb-ext:run-program in SBCL.
     41;;;
     42;;; See <http://www.sbcl.org/manual/Running-external-programs.html>.
    4343;;;
    4444;;; This implementation uses the JVM facilities for running external
    4545;;; processes.
    4646;;; <http://download.oracle.com/javase/6/docs/api/java/lang/ProcessBuilder.html>.
    47 (defun run-program (program args &key environment (wait t) clear-environment)
     47(defun run-program (program args &key environment (wait t) clear-environment
     48                                      (input :stream) (output :stream) (error :stream)
     49                                      if-input-does-not-exist (if-output-exists :error)
     50                                      (if-error-exists :error) directory)
    4851  "Run PROGRAM with ARGS in with ENVIRONMENT variables.
    4952
     
    5457Creates a new process running the the PROGRAM.
    5558
    56 ARGS are a list of strings to be passed to the program as arguments. 
     59ARGS are a list of strings to be passed to the program as arguments.
    5760
    5861For no arguments, use nil which means that just the name of the
     
    7881The &key arguments have the following meanings:
    7982
    80 :environment 
     83:environment
    8184    An alist of STRINGs (name . value) describing new
    8285    environment values that replace existing ones.
    8386
    84 :clear-env
     87:clear-environment
    8588    If non-NIL, the current environment is cleared before the
    8689    values supplied by :environment are inserted.
    8790
    88 :wait 
     91:wait
    8992    If non-NIL, which is the default, wait until the created process
    9093    finishes. If NIL, continue running Lisp until the program
    9194    finishes.
     95
     96:input
     97    If T, I/O is inherited from the Java process. If NIL, /dev/null is used
     98    (nul on Windows). If a PATHNAME designator other than a stream is
     99    supplied, input will be read from that file. If set to :STREAM, a stream
     100    will be available via PROCESS-INPUT to read from. Defaults to :STREAM.
     101
     102:if-input-does-not-exist
     103    If :input points to a non-existing file, this may be set to :ERROR in
     104    order to signal an error, :CREATE to create and read from an empty file,
     105    or NIL to immediately NIL instead of creating the process.
     106    Defaults to NIL.
     107
     108:output
     109    If T, I/O is inherited from the Java process. If NIL, /dev/null is used
     110    (nul on Windows). If a PATHNAME designator other than a stream is
     111    supplied, output will be redirect to that file. If set to :STREAM, a
     112    stream will be available via PROCESS-OUTPUT to write to.
     113    Defaults to :STREAM.
     114
     115:if-output-exists
     116    If :output points to a non-existing file, this may be set to :ERROR in
     117    order to signal an error, :SUPERSEDE to supersede the existing file,
     118    :APPEND to append to it instead, or NIL to immediately NIL instead of
     119    creating the process. Defaults to :ERROR.
     120
     121:error
     122    Same as :output, but can also be :output, in which case the error stream
     123    is redirected to wherever the standard output stream goes.
     124    Defaults to :STREAM.
     125
     126:if-error-exists
     127    Same as :if-output-exists, but for the :error target.
     128
     129:directory
     130    If set will become the working directory for the new process, otherwise
     131    the working directory will be unchanged from the current Java process.
     132    Defaults to NIL.
    92133"
    93134  (let* ((program-namestring (namestring (pathname program)))
    94 
    95135         (process-builder (%make-process-builder program-namestring args)))
    96136    (let ((env-map (%process-builder-environment process-builder)))
    97137      (when clear-environment
    98         (%process-builder-env-clear env-map))           
     138        (%process-builder-env-clear env-map))
    99139      (when environment
    100140        (dolist (entry environment)
     
    102142                                    (princ-to-string (car entry))
    103143                                    (princ-to-string (cdr entry))))))
    104     (let ((process (make-process (%process-builder-start process-builder))))
    105       (when wait (process-wait process))
    106       process)))
     144    (let ((input-stream-p (eq input :stream))
     145          (output-stream-p (eq output :stream))
     146          (error-stream-p (eq error :stream)))
     147      (unless output-stream-p
     148        (unless (setup-output-redirection process-builder output NIL if-output-exists)
     149          (return-from run-program)))
     150      (if (eq error :output)
     151          (java:jcall "redirectErrorStream" process-builder T)
     152          (unless error-stream-p
     153            (unless (setup-output-redirection process-builder error T if-error-exists)
     154              (return-from run-program))))
     155      (unless input-stream-p
     156        (unless (setup-input-redirection process-builder input if-input-does-not-exist)
     157          (return-from run-program)))
     158      (when directory
     159        (java:jcall "directory" process-builder (java:jnew "java.io.File" (namestring directory))))
     160      (let ((process (make-process (%process-builder-start process-builder)
     161                                   input-stream-p output-stream-p error-stream-p)))
     162        (when wait (process-wait process))
     163        process))))
     164
     165(defconstant +inherit+
     166  (java:jfield "java.lang.ProcessBuilder$Redirect" "INHERIT"))
     167
     168(defun coerce-to-file (value)
     169  (java:jnew
     170   "java.io.File"
     171   (if value
     172       (namestring value)
     173       #+unix "/dev/null"
     174       #+windows "nul"
     175       #-(or unix windows) (error "Don't know how to set up null stream on this platform."))))
     176
     177(defun setup-input-redirection (process-builder value if-does-not-exist)
     178  (let ((redirect (if (eq value T)
     179                      +inherit+
     180                      (let ((file (coerce-to-file value)))
     181                        (when value
     182                          (if (eq if-does-not-exist :create)
     183                              (open value :direction :probe :if-does-not-exist :create)
     184                              (unless (probe-file value)
     185                                (ecase if-does-not-exist
     186                                  (:error (error "Input file ~S does not exist." value))
     187                                  ((NIL) (return-from setup-input-redirection))))))
     188                        (java:jstatic "from" "java.lang.ProcessBuilder$Redirect" file)))))
     189    (java:jcall "redirectInput" process-builder redirect))
     190  T)
     191
     192(defun setup-output-redirection (process-builder value errorp if-does-exist)
     193  (let ((redirect (if (eq value T)
     194                      +inherit+
     195                      (let ((file (coerce-to-file value))
     196                            appendp)
     197                        (when (and value (probe-file value))
     198                          (ecase if-does-exist
     199                            (:error (error "Output file ~S does already exist." value))
     200                            (:supersede (rename-file (make-temp-file) value))
     201                            (:append (setf appendp T))
     202                            ((NIL) (return-from setup-output-redirection))))
     203                        (if appendp
     204                            (java:jstatic "appendTo" "java.lang.ProcessBuilder$Redirect" file)
     205                            (java:jstatic "to" "java.lang.ProcessBuilder$Redirect" file))))))
     206    (if errorp
     207        (java:jcall "redirectError" process-builder redirect)
     208        (java:jcall "redirectOutput" process-builder redirect)))
     209  T)
    107210
    108211;;; The process structure.
    109212(defstruct (process (:constructor %make-process (jprocess)))
    110   jprocess input output error)
    111 
    112 (defun make-process (proc)
     213  jprocess %input %output %error)
     214
     215(defun make-process (proc inputp outputp errorp)
    113216  (let ((process (%make-process proc)))
    114     (setf (process-input process) (%make-process-input-stream proc))
    115     (setf (process-output process) (%make-process-output-stream proc))
    116     (setf (process-error process) (%make-process-error-stream proc))
     217    (when inputp
     218      (setf (%process-input process) (%make-process-input-stream proc)))
     219    (when outputp
     220      (setf (%process-output process) (%make-process-output-stream proc)))
     221    (when errorp
     222      (setf (%process-error process) (%make-process-error-stream proc)))
    117223    process))
     224
     225(defun process-input (process)
     226  (%process-input process))
     227
     228(defun process-output (process)
     229  (%process-output process))
     230
     231(defun process-error (process)
     232  (%process-error process))
    118233
    119234(defun process-alive-p (process)
     
    132247  "Kills the process."
    133248  (%process-kill (process-jprocess process)))
     249
     250(defun process-pid (process)
     251  "Return the process ID."
     252  (%process-pid (process-jprocess process)))
    134253
    135254;;; Low-level functions. For now they're just a refactoring of the
     
    177296  (ignore-errors (java:jcall "exitValue" jprocess)))
    178297
     298#+unix
     299(defconstant +pid-field+
     300  (let ((field (java:jcall "getDeclaredField" (java:jclass "java.lang.UNIXProcess") "pid")))
     301    (java:jcall "setAccessible" field java:+true+)
     302    field))
     303
     304(defun %process-pid (jprocess)
     305  #+unix (java:jcall "get" +pid-field+ jprocess)
     306  #-unix (error "Can't retrieve PID on this platform."))
     307
    179308(defun %process-kill (jprocess)
    180309  (java:jcall "destroy" jprocess))
Note: See TracChangeset for help on using the changeset viewer.