/[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.21 - (show annotations)
Sat Feb 8 15:20:26 1997 UTC (17 years, 2 months ago) by pw
Branch: MAIN
Changes since 1.20: +3 -2 lines
Move misplaced hpux conditional that caused undefined symbol warning on non-hpux boxes.
1 ;;; -*- Package: Extensions; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; 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 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/run-program.lisp,v 1.21 1997/02/08 15:20:26 pw Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; RUN-PROGRAM and friends. Facility for running unix programs from inside
13 ;;; 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 (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
36 (eval-when (load eval compile)
37 (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
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 (if (or (eql signal unix:sigstop)
67 (eql signal unix:sigtstp)
68 (eql signal unix:sigttin)
69 (eql signal unix:sigttou))
70 :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 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 )
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 (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 (system:serve-all-events 1))
125 proc)
126
127
128 #-hpux
129 ;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal
130 ;;;
131 ;;; Finds the current foreground process group id.
132 ;;;
133 (defun find-current-foreground-process (proc)
134 (alien:with-alien ((result c-call:int))
135 (multiple-value-bind
136 (wonp error)
137 (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
138 unix:TIOCGPGRP
139 (alien:alien-sap (alien:addr result)))
140 (unless wonp
141 (error "TIOCPGRP ioctl failed: ~S"
142 (unix:get-unix-error-msg error)))
143 result))
144 (process-pid proc))
145
146
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 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 (let ((pid (ecase whom
157 ((:pid :process-group)
158 (process-pid proc))
159 (:pty-process-group
160 #-hpux
161 (find-current-foreground-process proc)))))
162 (multiple-value-bind
163 (okay errno)
164 (case whom
165 #+hpux
166 (:pty-process-group
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 ((:process-group #-hpux :pty-process-group)
172 (unix:unix-killpg pid signal))
173 (t
174 (unix:unix-kill pid signal)))
175 (cond ((not okay)
176 (values nil errno))
177 ((and (eql pid (process-pid proc))
178 (= (unix:unix-signal-number signal) unix:sigcont))
179 (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
187
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 ;;; This is the handler for sigchld signals that RUN-PROGRAM establishes.
219 ;;;
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 #-irix
264 (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 (master-fd (unix:unix-open master-name
270 unix:o_rdwr
271 #o666)))
272 (when master-fd
273 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
274 (slave-fd (unix:unix-open slave-name
275 unix:o_rdwr
276 #o666)))
277 (when slave-fd
278 ; Maybe put a vhangup here?
279 (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 (lognot 8))) ; ~ECHO
288 (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
289 (return-from find-a-pty
290 (values master-fd
291 slave-fd
292 slave-name)))
293 (unix:unix-close master-fd))))))
294 (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 (error "Could not find a pty."))
328
329 ;;; OPEN-PTY -- internal
330 ;;;
331 (defun open-pty (pty cookie)
332 (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 (multiple-value-bind (new-fd errno) (unix:unix-dup master)
340 (unless new-fd
341 (error "Could not UNIX:UNIX-DUP ~D: ~A"
342 master (unix:get-unix-error-msg errno)))
343 (push new-fd *close-on-error*)
344 (copy-descriptor-to-stream new-fd pty cookie)))
345 (values name
346 (system:make-fd-stream master :input t :output t)))))
347
348
349 (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 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
360 (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 (i #-alpha 4 #+alpha 8))
370 (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 (incf i #-alpha 4 #+alpha 8)))
386 ;; Blast in last null pointer
387 (setf (sap-ref-sap vec-sap i) (int-sap 0))
388 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
389
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 ;;; RUN-PROGRAM -- public
413 ;;;
414 ;;; 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 ;;;
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 (error :output) (if-error-exists :error) status-hook)
452 "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 is used. If a pathname, the file so specified is used. If a stream,
476 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 output for the current process is inherited. If NIL, /dev/null
487 is used. If a pathname, the file so specified is used. If a stream,
488 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 specified as :output in which case all error output is routed to the
500 same place as normal output.
501 :status-hook -
502 This is a function the system calls whenever the status of the
503 process changes. The function takes the process as an argument."
504
505 ;; Make sure the interrupt handler is installed.
506 (system:enable-interrupt unix:sigchld #'sigchld-handler)
507 ;; 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 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
517 (cookie (list 0)))
518 (unless pfile
519 (error "No such program: ~S" program))
520 (multiple-value-bind
521 (stdin input-stream)
522 (get-descriptor-for input cookie :direction :input
523 :if-does-not-exist if-input-does-not-exist)
524 (multiple-value-bind
525 (stdout output-stream)
526 (get-descriptor-for output cookie :direction :output
527 :if-exists if-output-exists)
528 (multiple-value-bind
529 (stderr error-stream)
530 (if (eq error :output)
531 (values stdout output-stream)
532 (get-descriptor-for error cookie :direction :output
533 :if-exists if-error-exists))
534 (multiple-value-bind (pty-name pty-stream)
535 (open-pty pty cookie)
536 ;; 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 (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 (push proc *active-processes*))))))))))
564 (dolist (fd *close-in-parent*)
565 (unix:unix-close fd))
566 (unless proc
567 (dolist (fd *close-on-error*)
568 (unix:unix-close fd))
569 (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 (defun copy-descriptor-to-stream (descriptor stream cookie)
581 (incf (car cookie))
582 (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 (unless handler
590 (return))
591 (multiple-value-bind
592 (result readable/errno)
593 (unix:unix-select (1+ descriptor) (ash 1 descriptor)
594 0 0 0)
595 (cond ((null result)
596 (error "Could not select on sub-process: ~A"
597 (unix:get-unix-error-msg readable/errno)))
598 ((zerop result)
599 (return))))
600 (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
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 (defun get-descriptor-for (object cookie &rest keys &key direction
633 &allow-other-keys)
634 (cond ((eq object t)
635 ;; No new descriptor is needed.
636 (values -1 nil))
637 ((eq object nil)
638 ;; Use /dev/null.
639 (multiple-value-bind
640 (fd errno)
641 (unix:unix-open "/dev/null"
642 (case direction
643 (:input unix:o_rdonly)
644 (:output unix:o_wronly)
645 (t unix:o_rdwr))
646 #o666)
647 (unless fd
648 (error "Could not open \"/dev/null\": ~A"
649 (unix:get-unix-error-msg errno)))
650 (push fd *close-in-parent*)
651 (values fd nil)))
652 ((eq object :stream)
653 (multiple-value-bind
654 (read-fd write-fd)
655 (unix:unix-pipe)
656 (unless read-fd
657 (error "Could not create pipe: ~A"
658 (unix:get-unix-error-msg write-fd)))
659 (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 (unix:unix-close read-fd)
672 (unix:unix-close write-fd)
673 (error "Direction must be either :INPUT or :OUTPUT, not ~S"
674 direction)))))
675 ((or (pathnamep object) (stringp object))
676 (with-open-stream (file (apply #'open object keys))
677 (multiple-value-bind
678 (fd errno)
679 (unix:unix-dup (system:fd-stream-fd file))
680 (cond (fd
681 (push fd *close-in-parent*)
682 (values fd nil))
683 (t
684 (error "Could not duplicate file descriptor: ~A"
685 (unix:get-unix-error-msg errno)))))))
686 ((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 (fd (unix:unix-open name
696 (logior unix:o_rdwr
697 unix:o_creat
698 unix:o_excl)
699 #o666)))
700 (unix:unix-unlink name)
701 (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 (unix:unix-write fd line 0 (length line))
710 (if no-cr
711 (return)
712 (unix:unix-write fd newline 0 1)))))
713 (unix:unix-lseek fd 0 unix:l_set)
714 (push fd *close-in-parent*)
715 (return (values fd nil))))))
716 (:output
717 (multiple-value-bind (read-fd write-fd)
718 (unix:unix-pipe)
719 (unless read-fd
720 (error "Cound not create pipe: ~A"
721 (unix:get-unix-error-msg write-fd)))
722 (copy-descriptor-to-stream read-fd object cookie)
723 (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