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

  ViewVC Help
Powered by ViewVC 1.1.5