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

  ViewVC Help
Powered by ViewVC 1.1.5