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

Last change on this file since 14871 was 14871, checked in by Mark Evenson, 6 years ago

Better support for uiop/run-program::%run-program (pipping)

File size: 12.4 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
32(in-package "SYSTEM")
33
34(require "JAVA")
35
36(export '(run-program process process-p process-input process-output
37          process-error process-alive-p process-wait process-exit-code
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>.
43;;;
44;;; This implementation uses the JVM facilities for running external
45;;; processes.
46;;; <http://download.oracle.com/javase/6/docs/api/java/lang/ProcessBuilder.html>.
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)
51  "Run PROGRAM with ARGS in with ENVIRONMENT variables.
52
53Possibly WAIT for subprocess to exit.
54
55Optionally CLEAR-ENVIRONMENT of the subprocess of any non specified values.
56
57Creates a new process running the the PROGRAM.
58
59ARGS are a list of strings to be passed to the program as arguments.
60
61For no arguments, use nil which means that just the name of the
62program is passed as arg 0.
63
64Returns a process structure containing the JAVA-OBJECT wrapped Process
65object, and the PROCESS-INPUT, PROCESS-OUTPUT, and PROCESS-ERROR streams.
66
67c.f. http://download.oracle.com/javase/6/docs/api/java/lang/Process.html
68
69Notes about Unix environments (as in the :environment):
70
71    * The ABCL implementation of run-program, like SBCL, Perl and many
72      other programs, copies the Unix environment by default.
73
74    * Running Unix programs from a setuid process, or in any other
75      situation where the Unix environment is under the control of
76      someone else, is a mother lode of security problems. If you are
77      contemplating doing this, read about it first. (The Perl
78      community has a lot of good documentation about this and other
79      security issues in script-like programs.
80
81The &key arguments have the following meanings:
82
83:environment
84    An alist of STRINGs (name . value) describing new
85    environment values that replace existing ones.
86
87:clear-environment
88    If non-NIL, the current environment is cleared before the
89    values supplied by :environment are inserted.
90
91:wait
92    If non-NIL, which is the default, wait until the created process
93    finishes. If NIL, continue running Lisp until the program
94    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.
133"
134  (let* ((program-namestring (namestring (pathname program)))
135         (process-builder (%make-process-builder program-namestring args)))
136    (let ((env-map (%process-builder-environment process-builder)))
137      (when clear-environment
138        (%process-builder-env-clear env-map))
139      (when environment
140        (dolist (entry environment)
141          (%process-builder-env-put env-map
142                                    (princ-to-string (car entry))
143                                    (princ-to-string (cdr entry))))))
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
201                             (with-open-file (f value
202                                                :direction :output
203                                                :if-exists if-does-exist)))
204                            (:append (setf appendp T))
205                            ((NIL) (return-from setup-output-redirection))))
206                        (if appendp
207                            (java:jstatic "appendTo" "java.lang.ProcessBuilder$Redirect" file)
208                            (java:jstatic "to" "java.lang.ProcessBuilder$Redirect" file))))))
209    (if errorp
210        (java:jcall "redirectError" process-builder redirect)
211        (java:jcall "redirectOutput" process-builder redirect)))
212  T)
213
214;;; The process structure.
215(defstruct (process (:constructor %make-process (jprocess)))
216  jprocess %input %output %error)
217
218(defun make-process (proc inputp outputp errorp)
219  (let ((process (%make-process proc)))
220    (when inputp
221      (setf (process-%input process) (%make-process-input-stream proc)))
222    (when outputp
223      (setf (process-%output process) (%make-process-output-stream proc)))
224    (when errorp
225      (setf (process-%error process) (%make-process-error-stream proc)))
226    process))
227
228(defun process-input (process)
229  (process-%input process))
230
231(defun process-output (process)
232  (process-%output process))
233
234(defun process-error (process)
235  (process-%error process))
236
237(defun process-alive-p (process)
238  "Return t if process is still alive, nil otherwise."
239  (%process-alive-p (process-jprocess process)))
240
241(defun process-wait (process)
242  "Wait for process to quit running for some reason."
243  (%process-wait (process-jprocess process)))
244
245(defun process-exit-code (instance)
246  "The exit code of a process."
247  (%process-exit-code (process-jprocess instance)))
248
249(defun process-kill (process)
250  "Kills the process."
251  (%process-kill (process-jprocess process)))
252
253(defun process-pid (process)
254  "Return the process ID."
255  (%process-pid (process-jprocess process)))
256
257;;; Low-level functions. For now they're just a refactoring of the
258;;; initial implementation with direct jnew & jcall forms in the
259;;; code. As per Ville's suggestion, these should really be implemented
260;;; as primitives.
261(defun %make-process-builder (program args)
262  (java:jnew "java.lang.ProcessBuilder"
263             (java:jnew-array-from-list "java.lang.String" (cons program args))))
264
265(defun %process-builder-environment (pb)
266  (java:jcall "environment" pb))
267
268(defun %process-builder-env-put (env-map key value)
269  (java:jcall "put" env-map key value))
270
271(defun %process-builder-env-clear (env-map)
272  (java:jcall "clear" env-map))
273
274(defun %process-builder-start (pb)
275  (java:jcall "start" pb))
276
277(defun %make-process-input-stream (proc)
278  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
279             (java:jcall "getOutputStream" proc) ;;not a typo!
280             'character))
281
282(defun %make-process-output-stream (proc)
283  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
284             (java:jcall "getInputStream" proc) ;;not a typo|
285             'character))
286
287(defun %make-process-error-stream (proc)
288  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
289             (java:jcall "getErrorStream" proc)
290             'character))
291
292(defun %process-alive-p (jprocess)
293  (not (ignore-errors (java:jcall "exitValue" jprocess))))
294
295(defun %process-wait (jprocess)
296  (java:jcall "waitFor" jprocess))
297
298(defun %process-exit-code (jprocess)
299  (ignore-errors (java:jcall "exitValue" jprocess)))
300
301#+unix
302(defconstant +pid-field+
303  (let ((field (java:jcall "getDeclaredField" (java:jclass "java.lang.UNIXProcess") "pid")))
304    (java:jcall "setAccessible" field java:+true+)
305    field))
306
307(defun %process-pid (jprocess)
308  #+unix (java:jcall "get" +pid-field+ jprocess)
309  #-unix (error "Can't retrieve PID on this platform."))
310
311(defun %process-kill (jprocess)
312  (java:jcall "destroy" jprocess))
Note: See TracBrowser for help on using the repository browser.