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.
18 ;;;; Import wait3(2) from Unix.
20 (sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int
21 (status sb-c-call:int :out)
22 (options sb-c-call:int)
23 (rusage sb-c-call:int))
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
27 (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
28 (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
30 (defun wait3 (&optional do-not-hang check-for-stopped)
31 "Return any available status information on child process. "
32 (multiple-value-bind (pid status)
33 (c-wait3 (logior (if do-not-hang
40 (cond ((or (minusp pid)
43 ((eql (ldb (byte 8 0) status)
47 (ldb (byte 8 8) status)))
48 ((zerop (ldb (byte 7 0) status))
51 (ldb (byte 8 8) status)))
53 (let ((signal (ldb (byte 7 0) status)))
55 (if (or (eql signal sb-unix:sigstop)
56 (eql signal sb-unix:sigtstp)
57 (eql signal sb-unix:sigttin)
58 (eql signal sb-unix:sigttou))
62 (not (zerop (ldb (byte 1 7) status)))))))))
64 ;;;; process control stuff
66 (defvar *active-processes* nil
67 "List of process structures for all active processes.")
70 pid ; PID of child process
71 %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
72 exit-code ; either exit code or signal
73 core-dumped ; T if a core image was dumped
74 pty ; stream to child's pty, or NIL
75 input ; stream to child's input, or NIL
76 output ; stream from child's output, or NIL
77 error ; stream from child's error output, or NIL
78 status-hook ; closure to call when PROC changes status
79 plist ; a place for clients to stash things
80 cookie) ; list of the number of pipes from the subproc
82 (defmethod print-object ((process process) stream)
83 (print-unreadable-object (process stream :type t)
87 (process-status process)))
90 (defun process-status (proc)
91 "Return the current status of process. The result is one of :RUNNING,
92 :STOPPED, :EXITED, or :SIGNALED."
93 (get-processes-status-changes)
94 (process-%status proc))
96 (defun process-wait (proc &optional check-for-stopped)
97 "Wait for PROC to quit running for some reason. Returns PROC."
99 (case (process-status proc)
102 (when check-for-stopped
105 (when (zerop (car (process-cookie proc)))
107 (sb-sys:serve-all-events 1))
111 ;;; Find the current foreground process group id.
112 (defun find-current-foreground-process (proc)
113 (sb-alien:with-alien ((result sb-c-call:int))
116 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
118 (sb-alien:alien-sap (sb-alien:addr result)))
120 (error "TIOCPGRP ioctl failed: ~S"
121 (sb-unix:get-unix-error-msg error)))
125 (defun process-kill (proc signal &optional (whom :pid))
126 "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If
127 whom is :process-group, use the killpg Unix system call. If whom is
128 :pty-process-group deliver the signal to whichever process group is currently
130 (let ((pid (ecase whom
131 ((:pid :process-group)
135 (find-current-foreground-process proc)))))
141 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
144 (sb-unix:unix-signal-number signal))))
145 ((:process-group #-hpux :pty-process-group)
146 (sb-unix:unix-killpg pid signal))
148 (sb-unix:unix-kill pid signal)))
151 ((and (eql pid (process-pid proc))
152 (= (sb-unix:unix-signal-number signal) sb-unix:sigcont))
153 (setf (process-%status proc) :running)
154 (setf (process-exit-code proc) nil)
155 (when (process-status-hook proc)
156 (funcall (process-status-hook proc) proc))
161 (defun process-alive-p (proc)
162 "Return T if the process is still alive, NIL otherwise."
163 (let ((status (process-status proc)))
164 (if (or (eq status :running)
165 (eq status :stopped))
169 (defun process-close (proc)
170 "Close all streams connected to PROC and stop maintaining the status slot."
171 (macrolet ((frob (stream abort)
172 `(when ,stream (close ,stream :abort ,abort))))
173 (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
174 (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
175 (frob (process-output proc) nil)
176 (frob (process-error proc) nil))
177 (sb-sys:without-interrupts
178 (setf *active-processes* (delete proc *active-processes*)))
181 ;;; the handler for sigchld signals that RUN-PROGRAM establishes
182 (defun sigchld-handler (ignore1 ignore2 ignore3)
183 (declare (ignore ignore1 ignore2 ignore3))
184 (get-processes-status-changes))
186 (defun get-processes-status-changes ()
188 (multiple-value-bind (pid what code core)
192 (let ((proc (find pid *active-processes* :key #'process-pid)))
194 (setf (process-%status proc) what)
195 (setf (process-exit-code proc) code)
196 (setf (process-core-dumped proc) core)
197 (when (process-status-hook proc)
198 (funcall (process-status-hook proc) proc))
199 (when (or (eq what :exited)
201 (sb-sys:without-interrupts
202 (setf *active-processes*
203 (delete proc *active-processes*)))))))))
205 ;;;; RUN-PROGRAM and close friends
207 (defvar *close-on-error* nil
208 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
209 (defvar *close-in-parent* nil
210 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
211 (defvar *handlers-installed* nil
212 "List of handlers installed by RUN-PROGRAM.")
217 (sg-ispeed sb-c-call:char) ; input speed
218 (sg-ospeed sb-c-call:char) ; output speed
219 (sg-erase sb-c-call:char) ; erase character
220 (sg-kill sb-c-call:char) ; kill character
221 (sg-flags sb-c-call:short))) ; mode flags
225 (sg-four sb-c-call:int)
226 (sg-chars (array sb-c-call:char 4))
227 (sg-flags sb-c-call:int)))
229 ;;; Find a pty that is not in use. Return three values: the file
230 ;;; descriptor for the master side of the pty, the file descriptor for
231 ;;; the slave side of the pty, and the name of the tty device for the
234 (dolist (char '(#\p #\q))
236 (let* ((master-name (format nil "/dev/pty~C~X" char digit))
237 (master-fd (sb-unix:unix-open master-name
241 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
242 (slave-fd (sb-unix:unix-open slave-name
246 ;; comment from classic CMU CL:
247 ;; Maybe put a vhangup here?
249 ;; FIXME: It seems as though this logic should be in
250 ;; OPEN-PTY, not FIND-A-PTY (both from the comments
251 ;; documenting DEFUN FIND-A-PTY, and from the
252 ;; connotations of the function names).
254 ;; FIXME: It would be nice to have a note, and/or a pointer
255 ;; to some reference material somewhere, explaining
256 ;; why we need this on *BSD and not on Linux.
258 (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb)))
259 (let ((sap (sb-alien:alien-sap stuff)))
260 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap)
261 (setf (sb-alien:slot stuff 'sg-flags)
262 ;; This is EVENP|ODDP, the same numeric code
263 ;; both on FreeBSD and on OpenBSD. -- WHN 20000929
265 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap)
266 (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap)
267 (setf (sb-alien:slot stuff 'sg-flags)
268 (logand (sb-alien:slot stuff 'sg-flags)
269 ;; This is ~ECHO, the same numeric
270 ;; code both on FreeBSD and on OpenBSD.
273 (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap)))
274 (return-from find-a-pty
278 (sb-unix:unix-close master-fd))))))
279 (error "could not find a pty"))
281 (defun open-pty (pty cookie)
286 (push master *close-on-error*)
287 (push slave *close-in-parent*)
289 (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
291 (error "could not SB-UNIX:UNIX-DUP ~D: ~S"
292 master (sb-unix:get-unix-error-msg errno)))
293 (push new-fd *close-on-error*)
294 (copy-descriptor-to-stream new-fd pty cookie)))
296 (sb-sys:make-fd-stream master :input t :output t)))))
298 (defmacro round-bytes-to-words (n)
299 `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
301 (defun string-list-to-c-strvec (string-list)
302 ;; Make a pass over STRING-LIST to calculate the amount of memory
303 ;; needed to hold the strvec.
304 (let ((string-bytes 0)
305 ;; We need an extra for the null, and an extra 'cause exect
306 ;; clobbers argv[-1].
307 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
308 (declare (fixnum string-bytes vec-bytes))
309 (dolist (s string-list)
310 (check-type s simple-string)
311 (incf string-bytes (round-bytes-to-words (1+ (length s)))))
312 ;; Now allocate the memory and fill it in.
313 (let* ((total-bytes (+ string-bytes vec-bytes))
314 (vec-sap (sb-sys:allocate-system-memory total-bytes))
315 (string-sap (sap+ vec-sap vec-bytes))
316 (i #-alpha 4 #+alpha 8))
317 (declare (type (and unsigned-byte fixnum) total-bytes i)
318 (type sb-sys:system-area-pointer vec-sap string-sap))
319 (dolist (s string-list)
320 (declare (simple-string s))
321 (let ((n (length s)))
322 ;; Blast the string into place.
323 (sb-kernel:copy-to-system-area (the simple-string s)
324 (* sb-vm:vector-data-offset
327 (* (1+ n) sb-vm:byte-bits))
328 ;; Blast the pointer to the string into place.
329 (setf (sap-ref-sap vec-sap i) string-sap)
330 (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
331 (incf i #-alpha 4 #+alpha 8)))
332 ;; Blast in the last null pointer.
333 (setf (sap-ref-sap vec-sap i) (int-sap 0))
334 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
336 (defmacro with-c-strvec ((var str-list) &body body)
337 (let ((sap (gensym "SAP-"))
338 (size (gensym "SIZE-")))
339 `(multiple-value-bind
341 (string-list-to-c-strvec ,str-list)
345 (sb-sys:deallocate-system-memory ,sap ,size)))))
347 (sb-alien:def-alien-routine spawn sb-c-call:int
348 (program sb-c-call:c-string)
349 (argv (* sb-c-call:c-string))
350 (envp (* sb-c-call:c-string))
351 (pty-name sb-c-call:c-string)
352 (stdin sb-c-call:int)
353 (stdout sb-c-call:int)
354 (stderr sb-c-call:int))
356 ;;; RUN-PROGRAM uses fork() and execve() to run a different program.
357 ;;; Strange stuff happens to keep the Unix state of the world
360 ;;; The child process needs to get its input from somewhere, and send
361 ;;; its output (both standard and error) to somewhere. We have to do
362 ;;; different things depending on where these somewheres really are.
364 ;;; For input, there are five options:
365 ;;; -- T: Just leave fd 0 alone. Pretty simple.
366 ;;; -- "file": Read from the file. We need to open the file and
367 ;;; pull the descriptor out of the stream. The parent should close
368 ;;; this stream after the child is up and running to free any
369 ;;; storage used in the parent.
370 ;;; -- NIL: Same as "file", but use "/dev/null" as the file.
371 ;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use
372 ;;; SB-SYS:MAKE-FD-STREAM to create the output stream on the
373 ;;; writeable descriptor, and pass the readable descriptor to
374 ;;; the child. The parent must close the readable descriptor for
375 ;;; EOF to be passed up correctly.
376 ;;; -- a stream: If it's a fd-stream, just pull the descriptor out
377 ;;; of it. Otherwise make a pipe as in :STREAM, and copy
378 ;;; everything across.
380 ;;; For output, there are five options:
381 ;;; -- T: Leave descriptor 1 alone.
382 ;;; -- "file": dump output to the file.
383 ;;; -- NIL: dump output to /dev/null.
384 ;;; -- :STREAM: return a stream that can be read from.
385 ;;; -- a stream: if it's a fd-stream, use the descriptor in it.
386 ;;; Otherwise, copy stuff from output to stream.
388 ;;; For error, there are all the same options as output plus:
389 ;;; -- :OUTPUT: redirect to the same place as output.
391 ;;; RUN-PROGRAM returns a PROCESS structure for the process if
392 ;;; the fork worked, and NIL if it did not.
393 (defun run-program (program args
394 &key env (wait t) pty input
395 if-input-does-not-exist output (if-output-exists :error)
396 (error :output) (if-error-exists :error) status-hook)
397 "RUN-PROGRAM creates a new process and runs the unix progam in the
398 file specified by the simple-string program. Args are the standard
399 arguments that can be passed to a Unix program, for no arguments
400 use NIL (which means just the name of the program is passed as arg 0).
402 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
403 Common Lisp Users Manual for details about the PROCESS structure.
405 The keyword arguments have the following meanings:
407 An A-LIST mapping keyword environment variables to simple-string
410 If non-NIL (default), wait until the created process finishes. If
411 NIL, continue running Lisp until the program finishes.
413 Either T, NIL, or a stream. Unless NIL, the subprocess is established
414 under a PTY. If :pty is a stream, all output to this pty is sent to
415 this stream, otherwise the PROCESS-PTY slot is filled in with a stream
416 connected to pty that can read output and write input.
418 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
419 input for the current process is inherited. If NIL, /dev/null
420 is used. If a pathname, the file so specified is used. If a stream,
421 all the input is read from that stream and send to the subprocess. If
422 :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
423 its output to the process. Defaults to NIL.
424 :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
426 :ERROR to generate an error
427 :CREATE to create an empty file
428 NIL (the default) to return NIL from RUN-PROGRAM
430 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
431 output for the current process is inherited. If NIL, /dev/null
432 is used. If a pathname, the file so specified is used. If a stream,
433 all the output from the process is written to this stream. If
434 :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
435 be read to get the output. Defaults to NIL.
436 :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
438 :ERROR (the default) to generate an error
439 :SUPERSEDE to supersede the file with output from the program
440 :APPEND to append output from the program to the file
441 NIL to return NIL from RUN-PROGRAM, without doing anything
442 :ERROR and :IF-ERROR-EXISTS
443 Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
444 specified as :OUTPUT in which case all error output is routed to the
445 same place as normal output.
447 This is a function the system calls whenever the status of the
448 process changes. The function takes the process as an argument."
450 ;; Make sure that the interrupt handler is installed.
451 (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler)
452 ;; Make sure that all the args are okay.
453 (unless (every #'simple-string-p args)
454 (error "All arguments to program must be simple strings: ~S" args))
455 ;; Prepend the program to the argument list.
456 (push (namestring program) args)
457 ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
458 ;; cleanup info. Also, establish proc at this level so we can
460 (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
462 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
465 (error "no such program: ~S" program))
468 (get-descriptor-for input cookie :direction :input
469 :if-does-not-exist if-input-does-not-exist)
471 (stdout output-stream)
472 (get-descriptor-for output cookie :direction :output
473 :if-exists if-output-exists)
475 (stderr error-stream)
476 (if (eq error :output)
477 (values stdout output-stream)
478 (get-descriptor-for error cookie :direction :output
479 :if-exists if-error-exists))
480 (multiple-value-bind (pty-name pty-stream)
481 (open-pty pty cookie)
482 ;; Make sure we are not notified about the child
483 ;; death before we have installed the PROCESS
484 ;; structure in *ACTIVE-PROCESSES*.
485 (sb-sys:without-interrupts
486 (with-c-strvec (argv args)
488 (envp (mapcar #'(lambda (entry)
491 (symbol-name (car entry))
497 (spawn pfile argv envp pty-name
498 stdin stdout stderr))))
499 (when (< child-pid 0)
500 (error "could not fork child process: ~S"
501 (sb-unix:get-unix-error-msg)))
502 (setf proc (make-process :pid child-pid
506 :output output-stream
508 :status-hook status-hook
510 (push proc *active-processes*))))))))))
511 (dolist (fd *close-in-parent*)
512 (sb-unix:unix-close fd))
514 (dolist (fd *close-on-error*)
515 (sb-unix:unix-close fd))
516 (dolist (handler *handlers-installed*)
517 (sb-sys:remove-fd-handler handler))))
518 (when (and wait proc)
522 ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
524 ;;; Installs a handler for any input that shows up on the file descriptor.
525 ;;; The handler reads the data and writes it to the stream.
527 (defun copy-descriptor-to-stream (descriptor stream cookie)
529 (let ((string (make-string 256))
532 (sb-sys:add-fd-handler
534 :input #'(lambda (fd)
535 (declare (ignore fd))
540 (result readable/errno)
541 (sb-unix:unix-select (1+ descriptor)
545 (error "could not select on sub-process: ~S"
546 (sb-unix:get-unix-error-msg
550 (sb-alien:with-alien ((buf (sb-alien:array
555 (sb-unix:unix-read descriptor
558 (cond ((or (and (null count)
559 (eql errno sb-unix:eio))
561 (sb-sys:remove-fd-handler handler)
564 (sb-unix:unix-close descriptor)
567 (sb-sys:remove-fd-handler handler)
570 (error "could not read input from sub-process: ~S"
571 (sb-unix:get-unix-error-msg errno)))
573 (sb-kernel:copy-from-system-area
575 string (* sb-vm:vector-data-offset
577 (* count sb-vm:byte-bits))
578 (write-string string stream
579 :end count)))))))))))
581 ;;; Find a file descriptor to use for object given the direction.
582 ;;; Returns the descriptor. If object is :STREAM, returns the created
583 ;;; stream as the second value.
584 (defun get-descriptor-for (object
590 ;; No new descriptor is needed.
596 (sb-unix:unix-open "/dev/null"
598 (:input sb-unix:o_rdonly)
599 (:output sb-unix:o_wronly)
603 (error "could not open \"/dev/null\": ~S"
604 (sb-unix:get-unix-error-msg errno)))
605 (push fd *close-in-parent*)
612 (error "could not create pipe: ~S"
613 (sb-unix:get-unix-error-msg write-fd)))
616 (push read-fd *close-in-parent*)
617 (push write-fd *close-on-error*)
618 (let ((stream (sb-sys:make-fd-stream write-fd :output t)))
619 (values read-fd stream)))
621 (push read-fd *close-on-error*)
622 (push write-fd *close-in-parent*)
623 (let ((stream (sb-sys:make-fd-stream read-fd :input t)))
624 (values write-fd stream)))
626 (sb-unix:unix-close read-fd)
627 (sb-unix:unix-close write-fd)
628 (error "Direction must be either :INPUT or :OUTPUT, not ~S."
630 ((or (pathnamep object) (stringp object))
631 (with-open-stream (file (apply #'open object keys))
634 (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
636 (push fd *close-in-parent*)
639 (error "could not duplicate file descriptor: ~S"
640 (sb-unix:get-unix-error-msg errno)))))))
641 ((sb-sys:fd-stream-p object)
642 (values (sb-sys:fd-stream-fd object) nil))
646 ;; FIXME: We could use a better way of setting up
647 ;; temporary files, both here and in LOAD-FOREIGN.
650 (error "could not open a temporary file in /tmp"))
651 (let* ((name (format nil "/tmp/.run-program-~D" count))
652 (fd (sb-unix:unix-open name
653 (logior sb-unix:o_rdwr
657 (sb-unix:unix-unlink name)
659 (let ((newline (string #\Newline)))
663 (read-line object nil nil)
666 (sb-unix:unix-write fd line 0 (length line))
669 (sb-unix:unix-write fd newline 0 1)))))
670 (sb-unix:unix-lseek fd 0 sb-unix:l_set)
671 (push fd *close-in-parent*)
672 (return (values fd nil))))))
674 (multiple-value-bind (read-fd write-fd)
677 (error "could not create pipe: ~S"
678 (sb-unix:get-unix-error-msg write-fd)))
679 (copy-descriptor-to-stream read-fd object cookie)
680 (push read-fd *close-on-error*)
681 (push write-fd *close-in-parent*)
682 (values write-fd nil)))))
684 (error "invalid option to RUN-PROGRAM: ~S" object))))