source: trunk/abcl/src/org/armedbear/lisp/run-program.lisp

Last change on this file was 15486, checked in by Mark Evenson, 3 months ago

Fix SYS:PROCESS-PID with SYS:RUN-PROGRAM
(reported by Eric Timmons)

Fixes <https://abcl.org/trac/ticket/480>

File size: 16.6 KB
Line 
1;;; run-program.lisp
2;;;
3;;; Copyright (C) 2011 Alessio Stalla
4;;; $Id$
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31(in-package :system)
32
33(require :java)
34
35(defun not-java-6-p ()
36  (not (find :java-6 *features*)))
37
38(defun pre-java-11-p ()
39  (or (find :java-6 *features*)
40      (find :java-7 *features*)
41      (find :java-8 *features*)))
42
43(export '(run-program process process-p process-input process-output
44          process-error process-alive-p process-wait process-exit-code
45          process-kill process-pid))
46
47;;; Vaguely inspired by sb-ext:run-program in SBCL.
48;;;
49;;; See <http://www.sbcl.org/manual/Running-external-programs.html>.
50;;;
51;;; This implementation uses the JVM facilities for running external
52;;; processes.
53;;; <http://download.oracle.com/javase/6/docs/api/java/lang/ProcessBuilder.html>.
54(defun run-program (program args &key environment (wait t) clear-environment
55                                      (input :stream) (output :stream) (error :stream)
56                                      if-input-does-not-exist (if-output-exists :error)
57                                      (if-error-exists :error) directory)
58  "Run PROGRAM with ARGS in with ENVIRONMENT variables.
59
60Possibly WAIT for subprocess to exit.
61
62Optionally CLEAR-ENVIRONMENT of the subprocess of any non specified values.
63
64Creates a new process running the the PROGRAM.
65
66ARGS are a list of strings to be passed to the program as arguments.
67
68For no arguments, use nil which means that just the name of the
69program is passed as arg 0.
70
71Returns a process structure containing the JAVA-OBJECT wrapped Process
72object, and the PROCESS-INPUT, PROCESS-OUTPUT, and PROCESS-ERROR streams.
73
74c.f. http://download.oracle.com/javase/6/docs/api/java/lang/Process.html
75
76Notes about Unix environments (as in the :environment):
77
78    * The ABCL implementation of run-program, like SBCL, Perl and many
79      other programs, copies the Unix environment by default.
80
81    * Running Unix programs from a setuid process, or in any other
82      situation where the Unix environment is under the control of
83      someone else, is a mother lode of security problems. If you are
84      contemplating doing this, read about it first. (The Perl
85      community has a lot of good documentation about this and other
86      security issues in script-like programs.
87
88The &key arguments have the following meanings:
89
90:environment
91    An alist of STRINGs (name . value) describing new
92    environment values that replace existing ones.
93
94:clear-environment
95    If non-NIL, the current environment is cleared before the
96    values supplied by :environment are inserted.
97
98:wait
99    If non-NIL, which is the default, wait until the created process
100    finishes. If NIL, continue running Lisp until the program
101    finishes.
102
103:input
104    If T, I/O is inherited from the Java process. If NIL, /dev/null is used
105    (nul on Windows). If a PATHNAME designator other than a stream is
106    supplied, input will be read from that file. If set to :STREAM, a stream
107    will be available via PROCESS-INPUT to read from. Defaults to :STREAM.
108
109:if-input-does-not-exist
110    If :input points to a non-existing file, this may be set to :ERROR in
111    order to signal an error, :CREATE to create and read from an empty file,
112    or NIL to immediately NIL instead of creating the process.
113    Defaults to NIL.
114
115:output
116    If T, I/O is inherited from the Java process. If NIL, /dev/null is used
117    (nul on Windows). If a PATHNAME designator other than a stream is
118    supplied, output will be redirect to that file. If set to :STREAM, a
119    stream will be available via PROCESS-OUTPUT to write to.
120    Defaults to :STREAM.
121
122:if-output-exists
123    If :output points to a non-existing file, this may be set to :ERROR in
124    order to signal an error, :SUPERSEDE to supersede the existing file,
125    :APPEND to append to it instead, or NIL to immediately NIL instead of
126    creating the process. Defaults to :ERROR.
127
128:error
129    Same as :output, but can also be :output, in which case the error stream
130    is redirected to wherever the standard output stream goes.
131    Defaults to :STREAM.
132
133:if-error-exists
134    Same as :if-output-exists, but for the :error target.
135
136:directory
137    If set will become the working directory for the new process, otherwise
138    the working directory will be unchanged from the current Java process.
139    Defaults to NIL.
140"
141  (let* ((program-namestring (namestring (pathname program)))
142         (process-builder (%make-process-builder program-namestring args)))
143    (let ((env-map (%process-builder-environment process-builder)))
144      (when clear-environment
145        (%process-builder-env-clear env-map))
146      (when environment
147        (dolist (entry environment)
148          (%process-builder-env-put env-map
149                                    (princ-to-string (car entry))
150                                    (princ-to-string (cdr entry))))))
151    (let ((input-stream-p (eq input :stream))
152          (output-stream-p (eq output :stream))
153          (error-stream-p (eq error :stream))
154          output-redirection
155          input-redirection
156          error-redirection)
157      (unless output-stream-p
158        (unless (setf output-redirection
159                      (setup-output-redirection process-builder output NIL if-output-exists))
160          (return-from run-program)))
161      (if (eq error :output)
162          (java:jcall "redirectErrorStream" process-builder T)
163          (unless error-stream-p
164            (unless (setf error-redirection
165                          (setup-output-redirection process-builder error T if-error-exists))
166              (return-from run-program))))
167      (unless input-stream-p
168        (unless (setf input-redirection
169                      (setup-input-redirection process-builder input if-input-does-not-exist))
170          (return-from run-program)))
171      (when directory
172        (java:jcall "directory" process-builder (java:jnew "java.io.File" (namestring directory))))
173      (let ((process 
174             (if (not-java-6-p)
175                 (make-process (%process-builder-start process-builder)
176                               input-stream-p output-stream-p error-stream-p)
177                 (make-process (%process-builder-start process-builder)
178                               t t t))))
179        (when (find :java-1.6 *features*)
180          (when input-redirection
181            (let ((input (process-input process)))
182              (threads:make-thread (lambda () (from-file input-redirection input)))))
183          (when output-redirection
184            (let ((output (process-output process))
185                  (file (first output-redirection))
186                  (appendp (second output-redirection)))
187              (threads:make-thread (lambda () (to-file output file :append appendp)))))
188          (when error-redirection
189            (let ((error (process-error process))
190                  (file (first output-redirection))
191                  (appendp (second output-redirection)))
192              (threads:make-thread (lambda () (to-file error file :append appendp))))))
193        (when (or wait
194                  (not-java-6-p)
195                  (process-wait process))
196          process)))))
197
198(defconstant +inherit+
199  (ignore-errors
200    (java:jfield "java.lang.ProcessBuilder$Redirect" "INHERIT")))
201
202(defun coerce-to-file (value)
203  (java:jnew
204   "java.io.File"
205   (if value
206       (namestring value)
207       (cond
208         ((ext:os-unix-p)
209          "/dev/null")
210         ((ext:os-windows-p) 
211          "nul")
212         (t
213          (error "Don't know how to set up null stream on this platform."))))))
214
215(define-condition implementation-not-available (error)
216  ((missing :initarg :missing
217            :reader missing))
218  (:report (lambda (condition stream)
219             (format stream "This JVM is missing the ~a implementation." (missing condition)))))
220
221(defun setup-input-redirection (process-builder value if-does-not-exist)
222  "Returns boolean truth when input redirections has been successfully set up.
223
224As a second value, returns either nil if input should inherit from the
225parent process, or a java.io.File reference to the file to read input from."
226  (let ((redirect (if (eq value T)
227                      ;; Either inherit stdio or fail
228                      (if (not-java-6-p)
229                          +inherit+
230                          (signal 'implementation-not-available
231                                  :missing "Inheritance for subprocess of standard input"))
232                      ;; or read from a file
233                      (let ((file (coerce-to-file value)))
234                        (when value
235                          (if (eq if-does-not-exist :create)
236                              (open value :direction :probe :if-does-not-exist :create)
237                              (unless (probe-file value)
238                                (ecase if-does-not-exist
239                                  (:error
240                                   (error "Input file ~S does not already exist." value))
241                                  ((NIL)
242                                   (return-from setup-input-redirection))))))
243                        (if (not-java-6-p)
244                            (java:jstatic "from" "java.lang.ProcessBuilder$Redirect" file)
245                            file)))))
246    (when (not-java-6-p)
247      (java:jcall "redirectInput" process-builder redirect))
248    redirect))
249
250#|
251value
252  t   inherit from
253|#
254(defun setup-output-redirection (process-builder value errorp if-does-exist)
255  (let ((redirect (if (eq value T)
256                      (if (not-java-6-p)
257                          +inherit+
258                          (if errorp
259                              (signal 'implementation-not-available
260                                      :missing "Inheritance for subprocess of standard error")
261                              (signal 'implementation-not-available
262                                      :missing "Inheritance for subprocess of standard output")))
263                      (let ((file (coerce-to-file value))
264                            appendp)
265                        (when (and value (probe-file value))
266                          (ecase if-does-exist
267                            (:error (error "Output file ~S does already exist." value))
268                            (:supersede
269                             (with-open-file (f value
270                                                :direction :output
271                                                :if-exists if-does-exist)))
272                            (:append (setf appendp T))
273                            ((NIL) (return-from setup-output-redirection))))
274      (if (not-java-6-p)
275        (if appendp
276            (java:jstatic "appendTo" "java.lang.ProcessBuilder$Redirect" file)
277            (java:jstatic "to" "java.lang.ProcessBuilder$Redirect" file))
278        (list file appendp))))))
279    (when (not-java-6-p)
280      (if errorp
281    (java:jcall "redirectError" process-builder redirect)
282    (java:jcall "redirectOutput" process-builder redirect)))
283    redirect))
284
285;;; The process structure.
286(defstruct (process (:constructor %make-process (jprocess)))
287  jprocess %input %output %error)
288
289(defun make-process (proc inputp outputp errorp)
290  (let ((process (%make-process proc)))
291    (when inputp
292      (setf (process-%input process) (%make-process-input-stream proc)))
293    (when outputp
294      (setf (process-%output process) (%make-process-output-stream proc)))
295    (when errorp
296      (setf (process-%error process) (%make-process-error-stream proc)))
297    process))
298
299(defun process-input (process)
300  (process-%input process))
301
302(defun process-output (process)
303  (process-%output process))
304
305(defun process-error (process)
306  (process-%error process))
307
308(defun process-alive-p (process)
309  "Return t if process is still alive, nil otherwise."
310  (%process-alive-p (process-jprocess process)))
311
312(defun process-wait (process)
313  "Wait for process to quit running for some reason."
314  (%process-wait (process-jprocess process)))
315
316(defun process-exit-code (instance)
317  "The exit code of a process."
318  (%process-exit-code (process-jprocess instance)))
319
320(defun process-kill (process)
321  "Kills the process."
322  (%process-kill (process-jprocess process)))
323
324(defun process-pid (process)
325  "Return the process ID."
326  (%process-pid (process-jprocess process)))
327
328;;; Low-level functions. For now they're just a refactoring of the
329;;; initial implementation with direct jnew & jcall forms in the
330;;; code. As per Ville's suggestion, these should really be implemented
331;;; as primitives.
332(defun %make-process-builder (program args)
333  (java:jnew "java.lang.ProcessBuilder"
334             (java:jnew-array-from-list "java.lang.String" (cons program args))))
335
336(defun %process-builder-environment (pb)
337  (java:jcall "environment" pb))
338
339(defun %process-builder-env-put (env-map key value)
340  (java:jcall "put" env-map key value))
341
342(defun %process-builder-env-clear (env-map)
343  (java:jcall "clear" env-map))
344
345(defun %process-builder-start (pb)
346  (java:jcall "start" pb))
347
348(defun %make-process-input-stream (proc)
349  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
350             (java:jcall "getOutputStream" proc) ;;not a typo!
351             'character))
352
353(defun %make-process-output-stream (proc)
354  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
355             (java:jcall "getInputStream" proc) ;;not a typo|
356             'character))
357
358(defun %make-process-error-stream (proc)
359  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
360             (java:jcall "getErrorStream" proc)
361             'character))
362
363(defun %process-alive-p (jprocess)
364  (not (ignore-errors (java:jcall "exitValue" jprocess))))
365
366(defun %process-wait (jprocess)
367  (java:jcall "waitFor" jprocess))
368
369(defun %process-exit-code (jprocess)
370  (ignore-errors (java:jcall "exitValue" jprocess)))
371
372(defun %process-pid (jprocess)
373  (if (ext:os-unix-p)
374      (let* ((process-class
375               (java:jclass
376                (if (pre-java-11-p)
377                    "java.lang.UNIXProcess"
378                    "java.lang.ProcessImpl")))
379             (field
380               (java:jcall "getDeclaredField" process-class "pid")))
381        (java:jcall "setAccessible" field java:+true+)
382        (java:jcall "get" field jprocess))
383      (error "Can't retrieve PID on this platform.")))
384
385(defun %process-kill (jprocess)
386  (java:jcall "destroy" jprocess))
387
388(defun to-file (input java.io.file &key (append nil))
389  (declare (ignore append)) ;; FIXME
390  (let ((file (java:jcall "toString" java.io.file)))
391    (with-open-file (s file
392                       :direction :output
393                       :element-type (stream-element-type input))
394      (let ((buffer (make-array 8192 :element-type (stream-element-type input))))
395        (loop
396           :for bytes-read = (read-sequence buffer input)
397           :while (plusp bytes-read)
398           :do (write-sequence buffer s :end bytes-read)))))
399  (close input))
400
401(defun from-file (java.io.file output)
402  (let ((file (java:jcall "toString" java.io.file)))
403    (with-open-file (s file
404                       :direction :input
405                       :element-type (stream-element-type output))
406      (let ((buffer (make-array 8192 :element-type (stream-element-type output))))
407        (loop
408           :for bytes-read = (read-sequence buffer s)
409           :while (plusp bytes-read)
410           :do (write-sequence buffer output :end bytes-read))))
411    (close output)))
412 
413#|
414tests
415
416(uiop:run-program "uname -a" :output :string)
417
418(uiop:run-program "cat /etc/passwd" :output :string)
419
420|#
Note: See TracBrowser for help on using the repository browser.