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

  ViewVC Help
Powered by ViewVC 1.1.5