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

  ViewVC Help
Powered by ViewVC 1.1.5