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

Last change on this file since 14879 was 14879, checked in by mevenson, 21 months ago

EXT:OS-{UNIX,WINDOWS}-P now provide a pre-ASDF runtime check on hosting platform

File size: 12.5 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       (cond
174         ((ext:os-unix-p)
175          "/dev/null")
176         ((ext:os-windows-p) 
177          "nul")
178         (t
179          (error "Don't know how to set up null stream on this platform."))))))
180
181(defun setup-input-redirection (process-builder value if-does-not-exist)
182  (let ((redirect (if (eq value T)
183                      +inherit+
184                      (let ((file (coerce-to-file value)))
185                        (when value
186                          (if (eq if-does-not-exist :create)
187                              (open value :direction :probe :if-does-not-exist :create)
188                              (unless (probe-file value)
189                                (ecase if-does-not-exist
190                                  (:error (error "Input file ~S does not exist." value))
191                                  ((NIL) (return-from setup-input-redirection))))))
192                        (java:jstatic "from" "java.lang.ProcessBuilder$Redirect" file)))))
193    (java:jcall "redirectInput" process-builder redirect))
194  T)
195
196(defun setup-output-redirection (process-builder value errorp if-does-exist)
197  (let ((redirect (if (eq value T)
198                      +inherit+
199                      (let ((file (coerce-to-file value))
200                            appendp)
201                        (when (and value (probe-file value))
202                          (ecase if-does-exist
203                            (:error (error "Output file ~S does already exist." value))
204                            (:supersede
205                             (with-open-file (f value
206                                                :direction :output
207                                                :if-exists if-does-exist)))
208                            (:append (setf appendp T))
209                            ((NIL) (return-from setup-output-redirection))))
210                        (if appendp
211                            (java:jstatic "appendTo" "java.lang.ProcessBuilder$Redirect" file)
212                            (java:jstatic "to" "java.lang.ProcessBuilder$Redirect" file))))))
213    (if errorp
214        (java:jcall "redirectError" process-builder redirect)
215        (java:jcall "redirectOutput" process-builder redirect)))
216  T)
217
218;;; The process structure.
219(defstruct (process (:constructor %make-process (jprocess)))
220  jprocess %input %output %error)
221
222(defun make-process (proc inputp outputp errorp)
223  (let ((process (%make-process proc)))
224    (when inputp
225      (setf (process-%input process) (%make-process-input-stream proc)))
226    (when outputp
227      (setf (process-%output process) (%make-process-output-stream proc)))
228    (when errorp
229      (setf (process-%error process) (%make-process-error-stream proc)))
230    process))
231
232(defun process-input (process)
233  (process-%input process))
234
235(defun process-output (process)
236  (process-%output process))
237
238(defun process-error (process)
239  (process-%error process))
240
241(defun process-alive-p (process)
242  "Return t if process is still alive, nil otherwise."
243  (%process-alive-p (process-jprocess process)))
244
245(defun process-wait (process)
246  "Wait for process to quit running for some reason."
247  (%process-wait (process-jprocess process)))
248
249(defun process-exit-code (instance)
250  "The exit code of a process."
251  (%process-exit-code (process-jprocess instance)))
252
253(defun process-kill (process)
254  "Kills the process."
255  (%process-kill (process-jprocess process)))
256
257(defun process-pid (process)
258  "Return the process ID."
259  (%process-pid (process-jprocess process)))
260
261;;; Low-level functions. For now they're just a refactoring of the
262;;; initial implementation with direct jnew & jcall forms in the
263;;; code. As per Ville's suggestion, these should really be implemented
264;;; as primitives.
265(defun %make-process-builder (program args)
266  (java:jnew "java.lang.ProcessBuilder"
267             (java:jnew-array-from-list "java.lang.String" (cons program args))))
268
269(defun %process-builder-environment (pb)
270  (java:jcall "environment" pb))
271
272(defun %process-builder-env-put (env-map key value)
273  (java:jcall "put" env-map key value))
274
275(defun %process-builder-env-clear (env-map)
276  (java:jcall "clear" env-map))
277
278(defun %process-builder-start (pb)
279  (java:jcall "start" pb))
280
281(defun %make-process-input-stream (proc)
282  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
283             (java:jcall "getOutputStream" proc) ;;not a typo!
284             'character))
285
286(defun %make-process-output-stream (proc)
287  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
288             (java:jcall "getInputStream" proc) ;;not a typo|
289             'character))
290
291(defun %make-process-error-stream (proc)
292  (java:jnew "org.armedbear.lisp.Stream" 'system-stream
293             (java:jcall "getErrorStream" proc)
294             'character))
295
296(defun %process-alive-p (jprocess)
297  (not (ignore-errors (java:jcall "exitValue" jprocess))))
298
299(defun %process-wait (jprocess)
300  (java:jcall "waitFor" jprocess))
301
302(defun %process-exit-code (jprocess)
303  (ignore-errors (java:jcall "exitValue" jprocess)))
304
305(defun %process-pid (jprocess)
306  (if (ext:os-unix-p)
307      ;; TODO: memoize this
308      (let ((field (java:jcall "getDeclaredField" (java:jclass "java.lang.UNIXProcess") "pid")))
309        (java:jcall "setAccessible" field java:+true+)
310        (java:jcall "get" field jprocess))
311      (error "Can't retrieve PID on this platform.")))
312
313(defun %process-kill (jprocess)
314  (java:jcall "destroy" jprocess))
Note: See TracBrowser for help on using the repository browser.