/[cmucl]/src/code/run-program.lisp
ViewVC logotype

Contents of /src/code/run-program.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (hide annotations)
Mon Sep 20 13:50:52 2010 UTC (3 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, cross-sol-x86-merged, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, cross-sol-x86-branch
Changes since 1.31: +24 -12 lines
Add support for external formats for RUN-PROGRAM, which now takes an
:EXTERNAL-FORMAT keyword argument to specify the format to use for any
streams that RUN-PROGRAM needs to create.

Patch from Paul Foley.
1 ram 1.1 ;;; -*- Package: Extensions; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;;
7     (ext:file-comment
8 rtoy 1.32 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/run-program.lisp,v 1.32 2010/09/20 13:50:52 rtoy Rel $")
9 ram 1.3 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12 wlott 1.4 ;;; RUN-PROGRAM and friends. Facility for running unix programs from inside
13 ram 1.1 ;;; a lisp.
14     ;;;
15     ;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier
16     ;;; version written by David McDonald.
17     ;;;
18     ;;; Completely re-written by William Lott, July 1989 - January 1990.
19     ;;;
20    
21     (in-package "EXTENSIONS")
22 rtoy 1.29 (intl:textdomain "cmucl")
23 ram 1.1
24     (export '(run-program process-status process-exit-code process-core-dumped
25     process-wait process-kill process-input process-output process-plist
26     process-pty process-error process-status-hook process-alive-p
27     process-close process-pid process-p))
28    
29    
30     ;;;; Import WAIT3 from unix.
31    
32 wlott 1.8 (alien:def-alien-routine ("wait3" c-wait3) c-call:int
33     (status c-call:int :out)
34     (options c-call:int)
35     (rusage c-call:int))
36 ram 1.1
37     (eval-when (load eval compile)
38 ram 1.17 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
39     (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
40     (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
41 ram 1.1
42     (defun wait3 (&optional do-not-hang check-for-stopped)
43 rtoy 1.30 "Return any available status information on child processed. "
44 ram 1.1 (multiple-value-bind (pid status)
45     (c-wait3 (logior (if do-not-hang
46     wait-wnohang
47     0)
48     (if check-for-stopped
49     wait-wuntraced
50     0))
51     0)
52     (cond ((or (minusp pid)
53     (zerop pid))
54     nil)
55     ((eql (ldb (byte 8 0) status)
56     wait-wstopped)
57     (values pid
58     :stopped
59     (ldb (byte 8 8) status)))
60     ((zerop (ldb (byte 7 0) status))
61     (values pid
62     :exited
63     (ldb (byte 8 8) status)))
64     (t
65     (let ((signal (ldb (byte 7 0) status)))
66     (values pid
67 wlott 1.8 (if (or (eql signal unix:sigstop)
68     (eql signal unix:sigtstp)
69     (eql signal unix:sigttin)
70     (eql signal unix:sigttou))
71 ram 1.1 :stopped
72     :signaled)
73     signal
74     (not (zerop (ldb (byte 1 7) status)))))))))
75    
76    
77    
78     ;;;; Process control stuff.
79    
80     (defvar *active-processes* nil
81 rtoy 1.30 "List of process structures for all active processes.")
82 ram 1.1
83     (defstruct (process (:print-function %print-process))
84 wlott 1.4 pid ; PID of child process.
85     %status ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED.
86     exit-code ; Either exit code or signal
87     core-dumped ; T if a core image was dumped.
88     pty ; Stream to child's pty or nil.
89     input ; Stream to child's input or nil.
90     output ; Stream from child's output or nil.
91     error ; Stream from child's error output or nil.
92     status-hook ; Closure to call when PROC changes status.
93     plist ; Place for clients to stash tings.
94     cookie ; List of the number of pipes from the subproc.
95 ram 1.1 )
96    
97     (defun %print-process (proc stream depth)
98     (declare (ignore depth))
99     (format stream "#<process ~D ~S>"
100     (process-pid proc)
101     (process-status proc)))
102    
103     ;;; PROCESS-STATUS -- Public.
104     ;;;
105     (defun process-status (proc)
106 rtoy 1.30 "Return the current status of process. The result is one of :running,
107 ram 1.1 :stopped, :exited, :signaled."
108 pw 1.25 (declare (type process proc))
109 ram 1.1 (get-processes-status-changes)
110     (process-%status proc))
111    
112    
113     ;;; PROCESS-WAIT -- Public.
114     ;;;
115     (defun process-wait (proc &optional check-for-stopped)
116 rtoy 1.30 "Wait for PROC to quit running for some reason. Returns PROC."
117 pw 1.25 (declare (type process proc))
118 ram 1.1 (loop
119 wlott 1.4 (case (process-status proc)
120     (:running)
121     (:stopped
122     (when check-for-stopped
123     (return)))
124     (t
125     (when (zerop (car (process-cookie proc)))
126     (return))))
127 ram 1.1 (system:serve-all-events 1))
128     proc)
129    
130 wlott 1.4
131 ram 1.19 #-hpux
132 ram 1.1 ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
133     ;;;
134     ;;; Finds the current foreground process group id.
135     ;;;
136     (defun find-current-foreground-process (proc)
137 wlott 1.8 (alien:with-alien ((result c-call:int))
138 ram 1.1 (multiple-value-bind
139     (wonp error)
140 wlott 1.8 (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
141     unix:TIOCGPGRP
142     (alien:alien-sap (alien:addr result)))
143 ram 1.1 (unless wonp
144 rtoy 1.31 (error (intl:gettext "TIOCPGRP ioctl failed: ~S")
145 wlott 1.8 (unix:get-unix-error-msg error)))
146 ram 1.19 result))
147     (process-pid proc))
148    
149 ram 1.1
150     ;;; PROCESS-KILL -- public
151     ;;;
152     ;;; Hand a process a signal.
153     ;;;
154     (defun process-kill (proc signal &optional (whom :pid))
155 rtoy 1.30 "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If
156 ram 1.19 whom is :process-group, use the killpg Unix system call. If whom is
157     :pty-process-group deliver the signal to whichever process group is currently
158     in the foreground."
159 pw 1.24 (declare (type process proc))
160 ram 1.1 (let ((pid (ecase whom
161     ((:pid :process-group)
162     (process-pid proc))
163     (:pty-process-group
164 ram 1.19 #-hpux
165 ram 1.1 (find-current-foreground-process proc)))))
166 ram 1.19 (multiple-value-bind
167     (okay errno)
168     (case whom
169 pw 1.21 #+hpux
170     (:pty-process-group
171 ram 1.19 (unix:unix-ioctl (system:fd-stream-fd (process-pty proc))
172     unix:TIOCSIGSEND
173     (system:int-sap
174 ram 1.20 (unix:unix-signal-number signal))))
175     ((:process-group #-hpux :pty-process-group)
176 ram 1.19 (unix:unix-killpg pid signal))
177     (t
178     (unix:unix-kill pid signal)))
179 ram 1.1 (cond ((not okay)
180     (values nil errno))
181     ((and (eql pid (process-pid proc))
182 wlott 1.9 (= (unix:unix-signal-number signal) unix:sigcont))
183 ram 1.1 (setf (process-%status proc) :running)
184     (setf (process-exit-code proc) nil)
185     (when (process-status-hook proc)
186     (funcall (process-status-hook proc) proc))
187     t)
188     (t
189     t)))))
190 ram 1.19
191 ram 1.1
192     ;;; PROCESS-ALIVE-P -- public
193     ;;;
194     ;;; Returns T if the process is still alive, NIL otherwise.
195     ;;;
196     (defun process-alive-p (proc)
197 rtoy 1.30 "Returns T if the process is still alive, NIL otherwise."
198 pw 1.25 (declare (type process proc))
199 ram 1.1 (let ((status (process-status proc)))
200     (if (or (eq status :running)
201     (eq status :stopped))
202     t
203     nil)))
204    
205     ;;; PROCESS-CLOSE -- public
206     ;;;
207     ;;; Close all the streams held open by PROC.
208     ;;;
209     (defun process-close (proc)
210 rtoy 1.30 "Close all streams connected to PROC and stop maintaining the status slot."
211 pw 1.25 (declare (type process proc))
212 pw 1.22 (macrolet ((frob (stream abort)
213     `(when ,stream (close ,stream :abort ,abort))))
214     (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process.
215     (frob (process-input proc) t) ; 'cause it will generate SIGPIPE.
216     (frob (process-output proc) nil)
217     (frob (process-error proc) nil))
218     (system:without-interrupts
219     (setf *active-processes* (delete proc *active-processes*)))
220     proc)
221 ram 1.1
222     ;;; SIGCHLD-HANDLER -- Internal.
223     ;;;
224 wlott 1.2 ;;; This is the handler for sigchld signals that RUN-PROGRAM establishes.
225 ram 1.1 ;;;
226     (defun sigchld-handler (ignore1 ignore2 ignore3)
227     (declare (ignore ignore1 ignore2 ignore3))
228     (get-processes-status-changes))
229    
230     ;;; GET-PROCESSES-STATUS-CHANGES -- Internal.
231     ;;;
232     (defun get-processes-status-changes ()
233     (loop
234     (multiple-value-bind (pid what code core)
235     (wait3 t t)
236     (unless pid
237     (return))
238     (let ((proc (find pid *active-processes* :key #'process-pid)))
239     (when proc
240     (setf (process-%status proc) what)
241     (setf (process-exit-code proc) code)
242     (setf (process-core-dumped proc) core)
243     (when (process-status-hook proc)
244     (funcall (process-status-hook proc) proc))
245     (when (or (eq what :exited)
246     (eq what :signaled))
247     (system:without-interrupts
248     (setf *active-processes*
249     (delete proc *active-processes*)))))))))
250    
251    
252    
253     ;;;; RUN-PROGRAM and close friends.
254    
255     (defvar *close-on-error* nil
256 rtoy 1.30 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
257 ram 1.1 (defvar *close-in-parent* nil
258 rtoy 1.30 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
259 ram 1.1 (defvar *handlers-installed* nil
260 rtoy 1.30 "List of handlers installed by RUN-PROGRAM.")
261 ram 1.1
262    
263     ;;; FIND-A-PTY -- internal
264     ;;;
265     ;;; Finds a pty that is not in use. Returns three values: the file descriptor
266     ;;; for the master side of the pty, the file descriptor for the slave side of
267     ;;; the pty, and the name of the tty device for the slave side.
268     ;;;
269 hallgren 1.16 #-irix
270 ram 1.1 (defun find-a-pty ()
271 rtoy 1.29 _N"Returns the master fd, the slave fd, and the name of the tty"
272 cshapiro 1.27 (multiple-value-bind (error master-fd slave-fd)
273     (unix:unix-openpty nil nil nil)
274     (when (zerop error)
275     #-glibc2
276     (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
277     (let ((sap (alien:alien-sap stuff)))
278     (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
279     (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
280     (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
281     (unix:unix-ioctl master-fd unix:TIOCGETP sap)
282     (setf (alien:slot stuff 'unix:sg-flags)
283     (logand (alien:slot stuff 'unix:sg-flags)
284     (lognot 8))) ; ~ECHO
285     (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
286     (return-from find-a-pty
287     (values master-fd
288     slave-fd
289     (unix:unix-ttyname slave-fd))))
290 rtoy 1.31 (error (intl:gettext "Could not find a pty."))))
291 hallgren 1.16
292     #+irix
293     (alien:def-alien-routine ("_getpty" c-getpty) c-call:c-string
294     (fildes c-call:int :out)
295     (oflag c-call:int)
296     (mode c-call:int)
297     (nofork c-call:int))
298    
299     #+irix
300     (defun find-a-pty ()
301 rtoy 1.29 _N"Returns the master fd, the slave fd, and the name of the tty"
302 hallgren 1.16 (multiple-value-bind (line master-fd)
303     (c-getpty (logior unix:o_rdwr unix:o_ndelay) #o600 0)
304     (let* ((slave-name line)
305     (slave-fd (unix:unix-open slave-name unix:o_rdwr #o666)))
306     (when slave-fd
307     ; Maybe put a vhangup here?
308 dtc 1.23 #-glibc2
309 hallgren 1.16 (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
310     (let ((sap (alien:alien-sap stuff)))
311     (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
312     (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
313     (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
314     (unix:unix-ioctl master-fd unix:TIOCGETP sap)
315     (setf (alien:slot stuff 'unix:sg-flags)
316     (logand (alien:slot stuff 'unix:sg-flags)
317     (lognot 8))) ; ~ECHO
318     (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
319     (return-from find-a-pty
320     (values master-fd
321     slave-fd
322     slave-name))))
323     (unix:unix-close master-fd))
324 rtoy 1.31 (error (intl:gettext "Could not find a pty.")))
325 ram 1.1
326     ;;; OPEN-PTY -- internal
327     ;;;
328 rtoy 1.32 (defun open-pty (pty cookie &optional (external-format :default))
329 ram 1.1 (when pty
330     (multiple-value-bind
331     (master slave name)
332     (find-a-pty)
333     (push master *close-on-error*)
334     (push slave *close-in-parent*)
335     (when (streamp pty)
336 wlott 1.11 (multiple-value-bind (new-fd errno) (unix:unix-dup master)
337     (unless new-fd
338 rtoy 1.31 (error (intl:gettext "Could not UNIX:UNIX-DUP ~D: ~A")
339 wlott 1.11 master (unix:get-unix-error-msg errno)))
340 ram 1.1 (push new-fd *close-on-error*)
341 wlott 1.4 (copy-descriptor-to-stream new-fd pty cookie)))
342 ram 1.1 (values name
343 rtoy 1.32 (system:make-fd-stream master :input t :output t
344     :external-format external-format)))))
345 ram 1.1
346    
347 wlott 1.13 (defmacro round-bytes-to-words (n)
348     `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
349    
350     (defun string-list-to-c-strvec (string-list)
351     ;;
352     ;; Make a pass over string-list to calculate the amount of memory
353     ;; needed to hold the strvec.
354     (let ((string-bytes 0)
355     ;; We need an extra for the null, and an extra 'cause exect clobbers
356     ;; argv[-1].
357 hallgren 1.15 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
358 wlott 1.13 (declare (fixnum string-bytes vec-bytes))
359     (dolist (s string-list)
360     (check-type s simple-string)
361     (incf string-bytes (round-bytes-to-words (1+ (length s)))))
362     ;;
363     ;; Now allocate the memory and fill it in.
364     (let* ((total-bytes (+ string-bytes vec-bytes))
365     (vec-sap (system:allocate-system-memory total-bytes))
366     (string-sap (sap+ vec-sap vec-bytes))
367 hallgren 1.15 (i #-alpha 4 #+alpha 8))
368 wlott 1.13 (declare (type (and unsigned-byte fixnum) total-bytes i)
369     (type system:system-area-pointer vec-sap string-sap))
370     (dolist (s string-list)
371     (declare (simple-string s))
372     (let ((n (length s)))
373     ;;
374     ;; Blast the string into place
375 rtoy 1.28 #-unicode
376 wlott 1.13 (kernel:copy-to-system-area (the simple-string s)
377     (* vm:vector-data-offset vm:word-bits)
378     string-sap 0
379     (* (1+ n) vm:byte-bits))
380 rtoy 1.28 #+unicode
381     (progn
382     ;; FIXME: Do we need to apply some kind of transformation
383     ;; to convert Lisp unicode strings to C strings? Utf-8?
384     (dotimes (k n)
385     (setf (sap-ref-8 string-sap k)
386     (logand #xff (char-code (aref s k)))))
387     (setf (sap-ref-8 string-sap n) 0))
388 wlott 1.13 ;;
389     ;; Blast the pointer to the string into place
390     (setf (sap-ref-sap vec-sap i) string-sap)
391     (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
392 hallgren 1.15 (incf i #-alpha 4 #+alpha 8)))
393 wlott 1.13 ;; Blast in last null pointer
394     (setf (sap-ref-sap vec-sap i) (int-sap 0))
395 hallgren 1.15 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
396 wlott 1.13
397    
398     (defmacro with-c-strvec ((var str-list) &body body)
399     (let ((sap (gensym "SAP-"))
400     (size (gensym "SIZE-")))
401     `(multiple-value-bind
402     (,sap ,var ,size)
403     (string-list-to-c-strvec ,str-list)
404     (unwind-protect
405     (progn
406     ,@body)
407     (system:deallocate-system-memory ,sap ,size)))))
408    
409     (alien:def-alien-routine spawn c-call:int
410     (program c-call:c-string)
411     (argv (* c-call:c-string))
412     (envp (* c-call:c-string))
413     (pty-name c-call:c-string)
414     (stdin c-call:int)
415     (stdout c-call:int)
416     (stderr c-call:int))
417    
418    
419 ram 1.1 ;;; RUN-PROGRAM -- public
420     ;;;
421 wlott 1.2 ;;; RUN-PROGRAM uses fork and execve to run a different program. Strange
422     ;;; stuff happens to keep the unix state of the world coherent.
423 ram 1.1 ;;;
424 emarsden 1.26 ;;; The child process needs to get its input from somewhere, and send its
425 ram 1.1 ;;; output (both standard and error) to somewhere. We have to do different
426     ;;; things depending on where these somewheres really are.
427     ;;;
428     ;;; For input, there are five options:
429     ;;; - T: Just leave fd 0 alone. Pretty simple.
430     ;;; - "file": Read from the file. We need to open the file and pull the
431     ;;; descriptor out of the stream. The parent should close this stream after
432     ;;; the child is up and running to free any storage used in the parent.
433     ;;; - NIL: Same as "file", but use "/dev/null" as the file.
434     ;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
435     ;;; to create the output stream on the writeable descriptor, and pass the
436     ;;; readable descriptor to the child. The parent must close the readable
437     ;;; descriptor for EOF to be passed up correctly.
438     ;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
439     ;;; Otherwise make a pipe as in :STREAM, and copy everything across.
440     ;;;
441     ;;; For output, there are n options:
442     ;;; - T: Leave descriptor 1 alone.
443     ;;; - "file": dump output to the file.
444     ;;; - NIL: dump output to /dev/null.
445     ;;; - :STREAM: return a stream that can be read from.
446     ;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
447     ;;; stuff from output to stream.
448     ;;;
449     ;;; For error, there are all the same options as output plus:
450     ;;; - :OUTPUT: redirect to the same place as output.
451     ;;;
452     ;;; RUN-PROGRAM returns a process struct for the process if the fork worked,
453     ;;; and NIL if it did not.
454     ;;;
455     (defun run-program (program args
456     &key (env *environment-list*) (wait t) pty input
457     if-input-does-not-exist output (if-output-exists :error)
458 rtoy 1.32 (error :output) (if-error-exists :error) status-hook
459     (external-format :default))
460 rtoy 1.30 "RUN-PROGRAM creates a new process and runs the unix program in the
461 emarsden 1.26 file specified by the simple-string PROGRAM. ARGS are the standard
462 ram 1.1 arguments that can be passed to a Unix program, for no arguments
463     use NIL (which means just the name of the program is passed as arg 0).
464    
465 emarsden 1.26 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
466 ram 1.1 Common Lisp Users Manual for details about the PROCESS structure.
467    
468     The keyword arguments have the following meanings:
469     :env -
470     An A-LIST mapping keyword environment variables to simple-string
471     values.
472     :wait -
473     If non-NIL (default), wait until the created process finishes. If
474     NIL, continue running Lisp until the program finishes.
475     :pty -
476     Either T, NIL, or a stream. Unless NIL, the subprocess is established
477     under a PTY. If :pty is a stream, all output to this pty is sent to
478     this stream, otherwise the PROCESS-PTY slot is filled in with a stream
479     connected to pty that can read output and write input.
480     :input -
481     Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
482     input for the current process is inherited. If NIL, /dev/null
483 wlott 1.4 is used. If a pathname, the file so specified is used. If a stream,
484 ram 1.1 all the input is read from that stream and send to the subprocess. If
485     :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
486     its output to the process. Defaults to NIL.
487     :if-input-does-not-exist (when :input is the name of a file) -
488     can be one of:
489     :error - generate an error.
490     :create - create an empty file.
491     nil (default) - return nil from run-program.
492     :output -
493     Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
494 wlott 1.13 output for the current process is inherited. If NIL, /dev/null
495 wlott 1.4 is used. If a pathname, the file so specified is used. If a stream,
496 ram 1.1 all the output from the process is written to this stream. If
497     :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
498     be read to get the output. Defaults to NIL.
499 emarsden 1.26 :if-output-exists (when :output is the name of a file) -
500 ram 1.1 can be one of:
501     :error (default) - generates an error if the file already exists.
502     :supersede - output from the program supersedes the file.
503     :append - output from the program is appended to the file.
504     nil - run-program returns nil without doing anything.
505     :error and :if-error-exists -
506     Same as :output and :if-output-exists, except that :error can also be
507 wlott 1.4 specified as :output in which case all error output is routed to the
508 ram 1.1 same place as normal output.
509     :status-hook -
510     This is a function the system calls whenever the status of the
511 rtoy 1.32 process changes. The function takes the process as an argument.
512     :external-format -
513     This is the external-format used for communication with the subprocess."
514 ram 1.1
515     ;; Make sure the interrupt handler is installed.
516 wlott 1.8 (system:enable-interrupt unix:sigchld #'sigchld-handler)
517 ram 1.1 ;; Make sure all the args are okay.
518     (unless (every #'simple-string-p args)
519 rtoy 1.31 (error (intl:gettext "All args to program must be simple strings -- ~S.") args))
520 rtoy 1.32 ;; Prepend the program to the argument list.
521 ram 1.1 (push (namestring program) args)
522     ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
523     ;; info. Also, establish proc at this level so we can return it.
524     (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
525     (unwind-protect
526 wlott 1.14 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
527 wlott 1.4 (cookie (list 0)))
528 wlott 1.14 (unless pfile
529 rtoy 1.31 (error (intl:gettext "No such program: ~S") program))
530 ram 1.1 (multiple-value-bind
531     (stdin input-stream)
532 wlott 1.4 (get-descriptor-for input cookie :direction :input
533 rtoy 1.32 :if-does-not-exist if-input-does-not-exist
534     :external-format external-format)
535 ram 1.1 (multiple-value-bind
536     (stdout output-stream)
537 wlott 1.4 (get-descriptor-for output cookie :direction :output
538 emarsden 1.26 :if-does-not-exist :create
539 rtoy 1.32 :if-exists if-output-exists
540     :external-format external-format)
541 ram 1.1 (multiple-value-bind
542     (stderr error-stream)
543     (if (eq error :output)
544     (values stdout output-stream)
545 wlott 1.4 (get-descriptor-for error cookie :direction :output
546 emarsden 1.26 :if-does-not-exist :create
547 rtoy 1.32 :if-exists if-error-exists
548     :external-format external-format))
549 ram 1.1 (multiple-value-bind (pty-name pty-stream)
550 rtoy 1.32 (open-pty pty cookie external-format)
551 ram 1.1 ;; Make sure we are not notified about the child death before
552     ;; we have installed the process struct in *active-processes*
553     (system:without-interrupts
554 wlott 1.13 (with-c-strvec (argv args)
555     (with-c-strvec
556     (envp (mapcar #'(lambda (entry)
557     (concatenate
558     'string
559     (symbol-name (car entry))
560     "="
561     (cdr entry)))
562     env))
563     (let ((child-pid
564     (without-gcing
565     (spawn pfile argv envp pty-name
566     stdin stdout stderr))))
567     (when (< child-pid 0)
568 rtoy 1.31 (error (intl:gettext "Could not fork child process: ~A")
569 wlott 1.13 (unix:get-unix-error-msg)))
570     (setf proc (make-process :pid child-pid
571     :%status :running
572     :pty pty-stream
573     :input input-stream
574     :output output-stream
575     :error error-stream
576     :status-hook status-hook
577     :cookie cookie))
578 ram 1.1 (push proc *active-processes*))))))))))
579     (dolist (fd *close-in-parent*)
580 wlott 1.8 (unix:unix-close fd))
581 ram 1.1 (unless proc
582     (dolist (fd *close-on-error*)
583 wlott 1.8 (unix:unix-close fd))
584 ram 1.1 (dolist (handler *handlers-installed*)
585     (system:remove-fd-handler handler))))
586     (when (and wait proc)
587     (process-wait proc))
588     proc))
589    
590     ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
591     ;;;
592     ;;; Installs a handler for any input that shows up on the file descriptor.
593     ;;; The handler reads the data and writes it to the stream.
594     ;;;
595 wlott 1.4 (defun copy-descriptor-to-stream (descriptor stream cookie)
596     (incf (car cookie))
597 ram 1.1 (let ((string (make-string 256))
598     handler)
599     (setf handler
600     (system:add-fd-handler descriptor :input
601     #'(lambda (fd)
602     (declare (ignore fd))
603     (loop
604 wlott 1.5 (unless handler
605     (return))
606 ram 1.1 (multiple-value-bind
607     (result readable/errno)
608 wlott 1.8 (unix:unix-select (1+ descriptor) (ash 1 descriptor)
609 ram 1.1 0 0 0)
610     (cond ((null result)
611 rtoy 1.31 (error (intl:gettext "Could not select on sub-process: ~A")
612 wlott 1.8 (unix:get-unix-error-msg readable/errno)))
613 ram 1.1 ((zerop result)
614     (return))))
615 wlott 1.10 (alien:with-alien ((buf (alien:array c-call:char 256)))
616     (multiple-value-bind
617     (count errno)
618     (unix:unix-read descriptor (alien-sap buf) 256)
619     (cond ((or (and (null count)
620     (eql errno unix:eio))
621     (eql count 0))
622     (system:remove-fd-handler handler)
623     (setf handler nil)
624     (decf (car cookie))
625     (unix:unix-close descriptor)
626     (return))
627     ((null count)
628     (system:remove-fd-handler handler)
629     (setf handler nil)
630     (decf (car cookie))
631 rtoy 1.31 (error (intl:gettext "Could not read input from sub-process: ~A")
632 wlott 1.10 (unix:get-unix-error-msg errno)))
633     (t
634 rtoy 1.28 #-unicode
635 wlott 1.10 (kernel:copy-from-system-area
636     (alien-sap buf) 0
637     string (* vm:vector-data-offset vm:word-bits)
638     (* count vm:byte-bits))
639 rtoy 1.28 #+unicode
640     (let ((sap (alien-sap buf)))
641     (dotimes (k count)
642     (setf (aref string k)
643     (code-char (sap-ref-8 sap k)))))
644 wlott 1.10 (write-string string stream
645     :end count)))))))))))
646 ram 1.1
647     ;;; GET-DESCRIPTOR-FOR -- internal
648     ;;;
649     ;;; Find a file descriptor to use for object given the direction. Returns
650     ;;; the descriptor. If object is :STREAM, returns the created stream as the
651     ;;; second value.
652     ;;;
653 wlott 1.4 (defun get-descriptor-for (object cookie &rest keys &key direction
654 rtoy 1.32 external-format
655 wlott 1.4 &allow-other-keys)
656 ram 1.1 (cond ((eq object t)
657     ;; No new descriptor is needed.
658 wlott 1.13 (values -1 nil))
659 ram 1.1 ((eq object nil)
660     ;; Use /dev/null.
661     (multiple-value-bind
662     (fd errno)
663 wlott 1.8 (unix:unix-open "/dev/null"
664 ram 1.1 (case direction
665 wlott 1.8 (:input unix:o_rdonly)
666     (:output unix:o_wronly)
667     (t unix:o_rdwr))
668 ram 1.1 #o666)
669     (unless fd
670 rtoy 1.31 (error (intl:gettext "Could not open \"/dev/null\": ~A")
671 wlott 1.8 (unix:get-unix-error-msg errno)))
672 ram 1.1 (push fd *close-in-parent*)
673     (values fd nil)))
674     ((eq object :stream)
675     (multiple-value-bind
676     (read-fd write-fd)
677 wlott 1.8 (unix:unix-pipe)
678 ram 1.1 (unless read-fd
679 rtoy 1.31 (error (intl:gettext "Could not create pipe: ~A")
680 wlott 1.8 (unix:get-unix-error-msg write-fd)))
681 ram 1.1 (case direction
682     (:input
683     (push read-fd *close-in-parent*)
684     (push write-fd *close-on-error*)
685 rtoy 1.32 (let ((stream (system:make-fd-stream write-fd :output t
686     :external-format
687     external-format)))
688 ram 1.1 (values read-fd stream)))
689     (:output
690     (push read-fd *close-on-error*)
691     (push write-fd *close-in-parent*)
692 rtoy 1.32 (let ((stream (system:make-fd-stream read-fd :input t
693     :external-format
694     external-format)))
695 ram 1.1 (values write-fd stream)))
696     (t
697 wlott 1.8 (unix:unix-close read-fd)
698     (unix:unix-close write-fd)
699 rtoy 1.31 (error (intl:gettext "Direction must be either :INPUT or :OUTPUT, not ~S")
700 ram 1.1 direction)))))
701 wlott 1.4 ((or (pathnamep object) (stringp object))
702 ram 1.1 (with-open-stream (file (apply #'open object keys))
703 wlott 1.11 (multiple-value-bind
704     (fd errno)
705     (unix:unix-dup (system:fd-stream-fd file))
706     (cond (fd
707 ram 1.1 (push fd *close-in-parent*)
708     (values fd nil))
709     (t
710 rtoy 1.31 (error (intl:gettext "Could not duplicate file descriptor: ~A")
711 wlott 1.11 (unix:get-unix-error-msg errno)))))))
712 ram 1.1 ((system:fd-stream-p object)
713     (values (system:fd-stream-fd object) nil))
714     ((streamp object)
715     (ecase direction
716     (:input
717     (dotimes (count
718     256
719 rtoy 1.31 (error (intl:gettext "Could not open a temporary file in /tmp")))
720 ram 1.1 (let* ((name (format nil "/tmp/.run-program-~D" count))
721 wlott 1.8 (fd (unix:unix-open name
722     (logior unix:o_rdwr
723     unix:o_creat
724     unix:o_excl)
725 ram 1.1 #o666)))
726 wlott 1.8 (unix:unix-unlink name)
727 ram 1.1 (when fd
728     (let ((newline (string #\Newline)))
729     (loop
730     (multiple-value-bind
731     (line no-cr)
732     (read-line object nil nil)
733     (unless line
734     (return))
735 wlott 1.8 (unix:unix-write fd line 0 (length line))
736 ram 1.1 (if no-cr
737     (return)
738 wlott 1.8 (unix:unix-write fd newline 0 1)))))
739     (unix:unix-lseek fd 0 unix:l_set)
740 ram 1.1 (push fd *close-in-parent*)
741     (return (values fd nil))))))
742     (:output
743     (multiple-value-bind (read-fd write-fd)
744 wlott 1.8 (unix:unix-pipe)
745 ram 1.1 (unless read-fd
746 rtoy 1.31 (error (intl:gettext "Cound not create pipe: ~A")
747 wlott 1.8 (unix:get-unix-error-msg write-fd)))
748 wlott 1.4 (copy-descriptor-to-stream read-fd object cookie)
749 ram 1.1 (push read-fd *close-on-error*)
750     (push write-fd *close-in-parent*)
751     (values write-fd nil)))))
752     (t
753 rtoy 1.31 (error (intl:gettext "Invalid option to run-program: ~S") object))))
754 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5