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

Last change on this file since 15041 was 15041, checked in by mevenson, 13 months ago

Restore compilation on Java 6

JSR-223 is always present so usage in <file:build.xml> is deprecated.

Fix compilation for SYS:RUN-PROGRAM on Java 6. Not expected to be
working very well. The general strategy is to undeprecate
SYS:RUN-SHELL-COMMAND is some manner that uses the Java 6 NIO plus
thread pools to drain IO.

Conditionalize on runtime platform of parts of our RUN-PROGRAM
implementation.

Stub implementation of NIO async processor to drain queue.

TODO: figure out how why "cat /etc/passwd" doesn't ever give output?

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