1 ;;;; RUN-PROGRAM and friends, a facility for running Unix programs
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;;; Import wait3(2) from Unix.
17 (sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int
18 (status sb-c-call:int :out)
19 (options sb-c-call:int)
20 (rusage sb-c-call:int))
22 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
23 (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
24 (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)
26 (defun wait3 (&optional do-not-hang check-for-stopped)
27 "Return any available status information on child process. "
28 (multiple-value-bind (pid status)
29 (c-wait3 (logior (if do-not-hang
36 (cond ((or (minusp pid)
39 ((eql (ldb (byte 8 0) status)
43 (ldb (byte 8 8) status)))
44 ((zerop (ldb (byte 7 0) status))
47 (ldb (byte 8 8) status)))
49 (let ((signal (ldb (byte 7 0) status)))
51 (if (or (eql signal sb-unix:sigstop)
52 (eql signal sb-unix:sigtstp)
53 (eql signal sb-unix:sigttin)
54 (eql signal sb-unix:sigttou))
58 (not (zerop (ldb (byte 1 7) status)))))))))
60 ;;;; process control stuff
62 (defvar *active-processes* nil
63 "List of process structures for all active processes.")
66 pid ; PID of child process
67 %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
68 exit-code ; either exit code or signal
69 core-dumped ; T if a core image was dumped
70 pty ; stream to child's pty, or NIL
71 input ; stream to child's input, or NIL
72 output ; stream from child's output, or NIL
73 error ; stream from child's error output, or NIL
74 status-hook ; closure to call when PROC changes status
75 plist ; a place for clients to stash things
76 cookie) ; list of the number of pipes from the subproc
78 (defmethod print-object ((process process) stream)
79 (print-unreadable-object (process stream :type t)
83 (process-status process)))
86 (defun process-status (proc)
87 "Return the current status of process. The result is one of :RUNNING,
88 :STOPPED, :EXITED, or :SIGNALED."
89 (get-processes-status-changes)
90 (process-%status proc))
92 (defun process-wait (proc &optional check-for-stopped)
93 "Wait for PROC to quit running for some reason. Returns PROC."
95 (case (process-status proc)
98 (when check-for-stopped
101 (when (zerop (car (process-cookie proc)))
103 (sb-sys:serve-all-events 1))
107 ;;; Find the current foreground process group id.
108 (defun find-current-foreground-process (proc)
109 (sb-alien:with-alien ((result sb-c-call:int))
112 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
114 (sb-alien:alien-sap (sb-alien:addr result)))
116 (error "TIOCPGRP ioctl failed: ~S"
117 (sb-unix:get-unix-error-msg error)))
121 (defun process-kill (proc signal &optional (whom :pid))
122 "Hand SIGNAL to PROC. If WHOM is :PID, use the kill Unix system call. If
123 WHOM is :PROCESS-GROUP, use the killpg Unix system call. If WHOM is
124 :PTY-PROCESS-GROUP deliver the signal to whichever process group is
125 currently in the foreground."
126 (let ((pid (ecase whom
127 ((:pid :process-group)
131 (find-current-foreground-process proc)))))
137 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
140 (sb-unix:unix-signal-number signal))))
141 ((:process-group #-hpux :pty-process-group)
142 (sb-unix:unix-killpg pid signal))
144 (sb-unix:unix-kill pid signal)))
147 ((and (eql pid (process-pid proc))
148 (= (sb-unix:unix-signal-number signal) sb-unix:sigcont))
149 (setf (process-%status proc) :running)
150 (setf (process-exit-code proc) nil)
151 (when (process-status-hook proc)
152 (funcall (process-status-hook proc) proc))
157 (defun process-alive-p (proc)
158 "Return T if the process is still alive, NIL otherwise."
159 (let ((status (process-status proc)))
160 (if (or (eq status :running)
161 (eq status :stopped))
165 (defun process-close (proc)
166 "Close all streams connected to PROC and stop maintaining the status slot."
167 (macrolet ((frob (stream abort)
168 `(when ,stream (close ,stream :abort ,abort))))
169 (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
170 (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
171 (frob (process-output proc) nil)
172 (frob (process-error proc) nil))
173 (sb-sys:without-interrupts
174 (setf *active-processes* (delete proc *active-processes*)))
177 ;;; the handler for sigchld signals that RUN-PROGRAM establishes
178 (defun sigchld-handler (ignore1 ignore2 ignore3)
179 (declare (ignore ignore1 ignore2 ignore3))
180 (get-processes-status-changes))
182 (defun get-processes-status-changes ()
184 (multiple-value-bind (pid what code core)
188 (let ((proc (find pid *active-processes* :key #'process-pid)))
190 (setf (process-%status proc) what)
191 (setf (process-exit-code proc) code)
192 (setf (process-core-dumped proc) core)
193 (when (process-status-hook proc)
194 (funcall (process-status-hook proc) proc))
195 (when (or (eq what :exited)
197 (sb-sys:without-interrupts
198 (setf *active-processes*
199 (delete proc *active-processes*)))))))))
201 ;;;; RUN-PROGRAM and close friends
203 (defvar *close-on-error* nil
204 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
205 (defvar *close-in-parent* nil
206 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
207 (defvar *handlers-installed* nil
208 "List of handlers installed by RUN-PROGRAM.")
213 (sg-ispeed sb-c-call:char) ; input speed
214 (sg-ospeed sb-c-call:char) ; output speed
215 (sg-erase sb-c-call:char) ; erase character
216 (sg-kill sb-c-call:char) ; kill character
217 (sg-flags sb-c-call:short))) ; mode flags
221 (sg-four sb-c-call:int)
222 (sg-chars (array sb-c-call:char 4))
223 (sg-flags sb-c-call:int)))
225 ;;; Find a pty that is not in use. Return three values: the file
226 ;;; descriptor for the master side of the pty, the file descriptor for
227 ;;; the slave side of the pty, and the name of the tty device for the
230 (dolist (char '(#\p #\q))
232 (let* ((master-name (format nil "/dev/pty~C~X" char digit))
233 (master-fd (sb-unix:unix-open master-name
237 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
238 (slave-fd (sb-unix:unix-open slave-name
242 ;; comment from classic CMU CL:
243 ;; Maybe put a vhangup here?
245 ;; FIXME: It seems as though this logic should be in
246 ;; OPEN-PTY, not FIND-A-PTY (both from the comments
247 ;; documenting DEFUN FIND-A-PTY, and from the
248 ;; connotations of the function names).
250 ;; FIXME: It would be nice to have a note, and/or a pointer
251 ;; to some reference material somewhere, explaining
252 ;; why we need this on *BSD and not on Linux.
254 (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb)))
255 (let ((sap (sb-alien:alien-sap stuff)))
256 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap)
257 (setf (sb-alien:slot stuff 'sg-flags)
258 ;; This is EVENP|ODDP, the same numeric code
259 ;; both on FreeBSD and on OpenBSD. -- WHN 20000929
261 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap)
262 (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap)
263 (setf (sb-alien:slot stuff 'sg-flags)
264 (logand (sb-alien:slot stuff 'sg-flags)
265 ;; This is ~ECHO, the same numeric
266 ;; code both on FreeBSD and on OpenBSD.
269 (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap)))
270 (return-from find-a-pty
274 (sb-unix:unix-close master-fd))))))
275 (error "could not find a pty"))
277 (defun open-pty (pty cookie)
282 (push master *close-on-error*)
283 (push slave *close-in-parent*)
285 (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
287 (error "could not SB-UNIX:UNIX-DUP ~D: ~S"
288 master (sb-unix:get-unix-error-msg errno)))
289 (push new-fd *close-on-error*)
290 (copy-descriptor-to-stream new-fd pty cookie)))
292 (sb-sys:make-fd-stream master :input t :output t)))))
294 (defmacro round-bytes-to-words (n)
295 `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
297 (defun string-list-to-c-strvec (string-list)
298 ;; Make a pass over STRING-LIST to calculate the amount of memory
299 ;; needed to hold the strvec.
300 (let ((string-bytes 0)
301 ;; We need an extra for the null, and an extra 'cause exect
302 ;; clobbers argv[-1].
303 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
304 (declare (fixnum string-bytes vec-bytes))
305 (dolist (s string-list)
306 (check-type s simple-string)
307 (incf string-bytes (round-bytes-to-words (1+ (length s)))))
308 ;; Now allocate the memory and fill it in.
309 (let* ((total-bytes (+ string-bytes vec-bytes))
310 (vec-sap (sb-sys:allocate-system-memory total-bytes))
311 (string-sap (sap+ vec-sap vec-bytes))
312 (i #-alpha 4 #+alpha 8))
313 (declare (type (and unsigned-byte fixnum) total-bytes i)
314 (type sb-sys:system-area-pointer vec-sap string-sap))
315 (dolist (s string-list)
316 (declare (simple-string s))
317 (let ((n (length s)))
318 ;; Blast the string into place.
319 (sb-kernel:copy-to-system-area (the simple-string s)
320 (* sb-vm:vector-data-offset
323 (* (1+ n) sb-vm:byte-bits))
324 ;; Blast the pointer to the string into place.
325 (setf (sap-ref-sap vec-sap i) string-sap)
326 (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
327 (incf i #-alpha 4 #+alpha 8)))
328 ;; Blast in the last null pointer.
329 (setf (sap-ref-sap vec-sap i) (int-sap 0))
330 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
332 (defmacro with-c-strvec ((var str-list) &body body)
333 (let ((sap (gensym "SAP-"))
334 (size (gensym "SIZE-")))
335 `(multiple-value-bind
337 (string-list-to-c-strvec ,str-list)
341 (sb-sys:deallocate-system-memory ,sap ,size)))))
343 (sb-alien:def-alien-routine spawn sb-c-call:int
344 (program sb-c-call:c-string)
345 (argv (* sb-c-call:c-string))
346 (envp (* sb-c-call:c-string))
347 (pty-name sb-c-call:c-string)
348 (stdin sb-c-call:int)
349 (stdout sb-c-call:int)
350 (stderr sb-c-call:int))
352 ;;; RUN-PROGRAM uses fork() and execve() to run a different program.
353 ;;; Strange stuff happens to keep the Unix state of the world
356 ;;; The child process needs to get its input from somewhere, and send
357 ;;; its output (both standard and error) to somewhere. We have to do
358 ;;; different things depending on where these somewheres really are.
360 ;;; For input, there are five options:
361 ;;; -- T: Just leave fd 0 alone. Pretty simple.
362 ;;; -- "file": Read from the file. We need to open the file and
363 ;;; pull the descriptor out of the stream. The parent should close
364 ;;; this stream after the child is up and running to free any
365 ;;; storage used in the parent.
366 ;;; -- NIL: Same as "file", but use "/dev/null" as the file.
367 ;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use
368 ;;; SB-SYS:MAKE-FD-STREAM to create the output stream on the
369 ;;; writeable descriptor, and pass the readable descriptor to
370 ;;; the child. The parent must close the readable descriptor for
371 ;;; EOF to be passed up correctly.
372 ;;; -- a stream: If it's a fd-stream, just pull the descriptor out
373 ;;; of it. Otherwise make a pipe as in :STREAM, and copy
374 ;;; everything across.
376 ;;; For output, there are five options:
377 ;;; -- T: Leave descriptor 1 alone.
378 ;;; -- "file": dump output to the file.
379 ;;; -- NIL: dump output to /dev/null.
380 ;;; -- :STREAM: return a stream that can be read from.
381 ;;; -- a stream: if it's a fd-stream, use the descriptor in it.
382 ;;; Otherwise, copy stuff from output to stream.
384 ;;; For error, there are all the same options as output plus:
385 ;;; -- :OUTPUT: redirect to the same place as output.
387 ;;; RUN-PROGRAM returns a PROCESS structure for the process if
388 ;;; the fork worked, and NIL if it did not.
389 (defun run-program (program args
390 &key env (wait t) pty input
391 if-input-does-not-exist output (if-output-exists :error)
392 (error :output) (if-error-exists :error) status-hook)
393 "RUN-PROGRAM creates a new process and runs the unix progam in the
394 file specified by the simple-string program. Args are the standard
395 arguments that can be passed to a Unix program, for no arguments
396 use NIL (which means just the name of the program is passed as arg 0).
398 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
399 Common Lisp Users Manual for details about the PROCESS structure.
401 The keyword arguments have the following meanings:
403 An A-LIST mapping keyword environment variables to simple-string
406 If non-NIL (default), wait until the created process finishes. If
407 NIL, continue running Lisp until the program finishes.
409 Either T, NIL, or a stream. Unless NIL, the subprocess is established
410 under a PTY. If :pty is a stream, all output to this pty is sent to
411 this stream, otherwise the PROCESS-PTY slot is filled in with a stream
412 connected to pty that can read output and write input.
414 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
415 input for the current process is inherited. If NIL, /dev/null
416 is used. If a pathname, the file so specified is used. If a stream,
417 all the input is read from that stream and send to the subprocess. If
418 :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
419 its output to the process. Defaults to NIL.
420 :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
422 :ERROR to generate an error
423 :CREATE to create an empty file
424 NIL (the default) to return NIL from RUN-PROGRAM
426 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
427 output for the current process is inherited. If NIL, /dev/null
428 is used. If a pathname, the file so specified is used. If a stream,
429 all the output from the process is written to this stream. If
430 :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
431 be read to get the output. Defaults to NIL.
432 :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
434 :ERROR (the default) to generate an error
435 :SUPERSEDE to supersede the file with output from the program
436 :APPEND to append output from the program to the file
437 NIL to return NIL from RUN-PROGRAM, without doing anything
438 :ERROR and :IF-ERROR-EXISTS
439 Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
440 specified as :OUTPUT in which case all error output is routed to the
441 same place as normal output.
443 This is a function the system calls whenever the status of the
444 process changes. The function takes the process as an argument."
446 ;; Make sure that the interrupt handler is installed.
447 (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler)
448 ;; Make sure that all the args are okay.
449 (unless (every #'simple-string-p args)
450 (error "All arguments to program must be simple strings: ~S" args))
451 ;; Prepend the program to the argument list.
452 (push (namestring program) args)
453 ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
454 ;; cleanup info. Also, establish proc at this level so we can
456 (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
458 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
461 (error "no such program: ~S" program))
464 (get-descriptor-for input cookie :direction :input
465 :if-does-not-exist if-input-does-not-exist)
467 (stdout output-stream)
468 (get-descriptor-for output cookie :direction :output
469 :if-exists if-output-exists)
471 (stderr error-stream)
472 (if (eq error :output)
473 (values stdout output-stream)
474 (get-descriptor-for error cookie :direction :output
475 :if-exists if-error-exists))
476 (multiple-value-bind (pty-name pty-stream)
477 (open-pty pty cookie)
478 ;; Make sure we are not notified about the child
479 ;; death before we have installed the PROCESS
480 ;; structure in *ACTIVE-PROCESSES*.
481 (sb-sys:without-interrupts
482 (with-c-strvec (argv args)
484 (envp (mapcar #'(lambda (entry)
487 (symbol-name (car entry))
493 (spawn pfile argv envp pty-name
494 stdin stdout stderr))))
495 (when (< child-pid 0)
496 (error "could not fork child process: ~S"
497 (sb-unix:get-unix-error-msg)))
498 (setf proc (make-process :pid child-pid
502 :output output-stream
504 :status-hook status-hook
506 (push proc *active-processes*))))))))))
507 (dolist (fd *close-in-parent*)
508 (sb-unix:unix-close fd))
510 (dolist (fd *close-on-error*)
511 (sb-unix:unix-close fd))
512 (dolist (handler *handlers-installed*)
513 (sb-sys:remove-fd-handler handler))))
514 (when (and wait proc)
518 ;;; Install a handler for any input that shows up on the file
519 ;;; descriptor. The handler reads the data and writes it to the
521 (defun copy-descriptor-to-stream (descriptor stream cookie)
523 (let ((string (make-string 256))
526 (sb-sys:add-fd-handler
528 :input #'(lambda (fd)
529 (declare (ignore fd))
534 (result readable/errno)
535 (sb-unix:unix-select (1+ descriptor)
539 (error "could not select on sub-process: ~S"
540 (sb-unix:get-unix-error-msg
544 (sb-alien:with-alien ((buf (sb-alien:array
549 (sb-unix:unix-read descriptor
552 (cond ((or (and (null count)
553 (eql errno sb-unix:eio))
555 (sb-sys:remove-fd-handler handler)
558 (sb-unix:unix-close descriptor)
561 (sb-sys:remove-fd-handler handler)
564 (error "could not read input from sub-process: ~S"
565 (sb-unix:get-unix-error-msg errno)))
567 (sb-kernel:copy-from-system-area
569 string (* sb-vm:vector-data-offset
571 (* count sb-vm:byte-bits))
572 (write-string string stream
573 :end count)))))))))))
575 ;;; Find a file descriptor to use for object given the direction.
576 ;;; Returns the descriptor. If object is :STREAM, returns the created
577 ;;; stream as the second value.
578 (defun get-descriptor-for (object
584 ;; No new descriptor is needed.
590 (sb-unix:unix-open "/dev/null"
592 (:input sb-unix:o_rdonly)
593 (:output sb-unix:o_wronly)
597 (error "could not open \"/dev/null\": ~S"
598 (sb-unix:get-unix-error-msg errno)))
599 (push fd *close-in-parent*)
606 (error "could not create pipe: ~S"
607 (sb-unix:get-unix-error-msg write-fd)))
610 (push read-fd *close-in-parent*)
611 (push write-fd *close-on-error*)
612 (let ((stream (sb-sys:make-fd-stream write-fd :output t)))
613 (values read-fd stream)))
615 (push read-fd *close-on-error*)
616 (push write-fd *close-in-parent*)
617 (let ((stream (sb-sys:make-fd-stream read-fd :input t)))
618 (values write-fd stream)))
620 (sb-unix:unix-close read-fd)
621 (sb-unix:unix-close write-fd)
622 (error "Direction must be either :INPUT or :OUTPUT, not ~S."
624 ((or (pathnamep object) (stringp object))
625 (with-open-stream (file (apply #'open object keys))
628 (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
630 (push fd *close-in-parent*)
633 (error "could not duplicate file descriptor: ~S"
634 (sb-unix:get-unix-error-msg errno)))))))
635 ((sb-sys:fd-stream-p object)
636 (values (sb-sys:fd-stream-fd object) nil))
640 ;; FIXME: We could use a better way of setting up
641 ;; temporary files, both here and in LOAD-FOREIGN.
644 (error "could not open a temporary file in /tmp"))
645 (let* ((name (format nil "/tmp/.run-program-~D" count))
646 (fd (sb-unix:unix-open name
647 (logior sb-unix:o_rdwr
651 (sb-unix:unix-unlink name)
653 (let ((newline (string #\Newline)))
657 (read-line object nil nil)
660 (sb-unix:unix-write fd line 0 (length line))
663 (sb-unix:unix-write fd newline 0 1)))))
664 (sb-unix:unix-lseek fd 0 sb-unix:l_set)
665 (push fd *close-in-parent*)
666 (return (values fd nil))))))
668 (multiple-value-bind (read-fd write-fd)
671 (error "could not create pipe: ~S"
672 (sb-unix:get-unix-error-msg write-fd)))
673 (copy-descriptor-to-stream read-fd object cookie)
674 (push read-fd *close-on-error*)
675 (push write-fd *close-in-parent*)
676 (values write-fd nil)))))
678 (error "invalid option to RUN-PROGRAM: ~S" object))))