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

  ViewVC Help
Powered by ViewVC 1.1.5