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 (eval-when (:compile-toplevel :load-toplevel :execute)
23 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
24 (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
25 (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
27 (defun wait3 (&optional do-not-hang check-for-stopped)
28 "Return any available status information on child process. "
29 (multiple-value-bind (pid status)
30 (c-wait3 (logior (if do-not-hang
37 (cond ((or (minusp pid)
40 ((eql (ldb (byte 8 0) status)
44 (ldb (byte 8 8) status)))
45 ((zerop (ldb (byte 7 0) status))
48 (ldb (byte 8 8) status)))
50 (let ((signal (ldb (byte 7 0) status)))
52 (if (or (eql signal sb-unix:sigstop)
53 (eql signal sb-unix:sigtstp)
54 (eql signal sb-unix:sigttin)
55 (eql signal sb-unix:sigttou))
59 (not (zerop (ldb (byte 1 7) status)))))))))
61 ;;;; process control stuff
63 (defvar *active-processes* nil
64 "List of process structures for all active processes.")
67 pid ; PID of child process
68 %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
69 exit-code ; either exit code or signal
70 core-dumped ; T if a core image was dumped
71 pty ; stream to child's pty, or NIL
72 input ; stream to child's input, or NIL
73 output ; stream from child's output, or NIL
74 error ; stream from child's error output, or NIL
75 status-hook ; closure to call when PROC changes status
76 plist ; a place for clients to stash things
77 cookie) ; list of the number of pipes from the subproc
79 (defmethod print-object ((process process) stream)
80 (print-unreadable-object (process stream :type t)
84 (process-status process)))
87 (defun process-status (proc)
88 "Return the current status of process. The result is one of :RUNNING,
89 :STOPPED, :EXITED, or :SIGNALED."
90 (get-processes-status-changes)
91 (process-%status proc))
93 (defun process-wait (proc &optional check-for-stopped)
94 "Wait for PROC to quit running for some reason. Returns PROC."
96 (case (process-status proc)
99 (when check-for-stopped
102 (when (zerop (car (process-cookie proc)))
104 (sb-sys:serve-all-events 1))
108 ;;; Find the current foreground process group id.
109 (defun find-current-foreground-process (proc)
110 (sb-alien:with-alien ((result sb-c-call:int))
113 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
115 (sb-alien:alien-sap (sb-alien:addr result)))
117 (error "TIOCPGRP ioctl failed: ~S"
118 (sb-unix:get-unix-error-msg error)))
122 (defun process-kill (proc signal &optional (whom :pid))
123 "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If
124 whom is :process-group, use the killpg Unix system call. If whom is
125 :pty-process-group deliver the signal to whichever process group is currently
127 (let ((pid (ecase whom
128 ((:pid :process-group)
132 (find-current-foreground-process proc)))))
138 (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (process-pty proc))
141 (sb-unix:unix-signal-number signal))))
142 ((:process-group #-hpux :pty-process-group)
143 (sb-unix:unix-killpg pid signal))
145 (sb-unix:unix-kill pid signal)))
148 ((and (eql pid (process-pid proc))
149 (= (sb-unix:unix-signal-number signal) sb-unix:sigcont))
150 (setf (process-%status proc) :running)
151 (setf (process-exit-code proc) nil)
152 (when (process-status-hook proc)
153 (funcall (process-status-hook proc) proc))
158 (defun process-alive-p (proc)
159 "Return T if the process is still alive, NIL otherwise."
160 (let ((status (process-status proc)))
161 (if (or (eq status :running)
162 (eq status :stopped))
166 (defun process-close (proc)
167 "Close all streams connected to PROC and stop maintaining the status slot."
168 (macrolet ((frob (stream abort)
169 `(when ,stream (close ,stream :abort ,abort))))
170 (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
171 (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
172 (frob (process-output proc) nil)
173 (frob (process-error proc) nil))
174 (sb-sys:without-interrupts
175 (setf *active-processes* (delete proc *active-processes*)))
178 ;;; the handler for sigchld signals that RUN-PROGRAM establishes
179 (defun sigchld-handler (ignore1 ignore2 ignore3)
180 (declare (ignore ignore1 ignore2 ignore3))
181 (get-processes-status-changes))
183 (defun get-processes-status-changes ()
185 (multiple-value-bind (pid what code core)
189 (let ((proc (find pid *active-processes* :key #'process-pid)))
191 (setf (process-%status proc) what)
192 (setf (process-exit-code proc) code)
193 (setf (process-core-dumped proc) core)
194 (when (process-status-hook proc)
195 (funcall (process-status-hook proc) proc))
196 (when (or (eq what :exited)
198 (sb-sys:without-interrupts
199 (setf *active-processes*
200 (delete proc *active-processes*)))))))))
202 ;;;; RUN-PROGRAM and close friends
204 (defvar *close-on-error* nil
205 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
206 (defvar *close-in-parent* nil
207 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
208 (defvar *handlers-installed* nil
209 "List of handlers installed by RUN-PROGRAM.")
214 (sg-ispeed sb-c-call:char) ; input speed
215 (sg-ospeed sb-c-call:char) ; output speed
216 (sg-erase sb-c-call:char) ; erase character
217 (sg-kill sb-c-call:char) ; kill character
218 (sg-flags sb-c-call:short))) ; mode flags
222 (sg-four sb-c-call:int)
223 (sg-chars (array sb-c-call:char 4))
224 (sg-flags sb-c-call:int)))
226 ;;; Find a pty that is not in use. Return three values: the file
227 ;;; descriptor for the master side of the pty, the file descriptor for
228 ;;; the slave side of the pty, and the name of the tty device for the
231 (dolist (char '(#\p #\q))
233 (let* ((master-name (format nil "/dev/pty~C~X" char digit))
234 (master-fd (sb-unix:unix-open master-name
238 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
239 (slave-fd (sb-unix:unix-open slave-name
243 ;; comment from classic CMU CL:
244 ;; Maybe put a vhangup here?
246 ;; FIXME: It seems as though this logic should be in
247 ;; OPEN-PTY, not FIND-A-PTY (both from the comments
248 ;; documenting DEFUN FIND-A-PTY, and from the
249 ;; connotations of the function names).
251 ;; FIXME: It would be nice to have a note, and/or a pointer
252 ;; to some reference material somewhere, explaining
253 ;; why we need this on *BSD and not on Linux.
255 (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb)))
256 (let ((sap (sb-alien:alien-sap stuff)))
257 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap)
258 (setf (sb-alien:slot stuff 'sg-flags)
259 ;; This is EVENP|ODDP, the same numeric code
260 ;; both on FreeBSD and on OpenBSD. -- WHN 20000929
262 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap)
263 (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap)
264 (setf (sb-alien:slot stuff 'sg-flags)
265 (logand (sb-alien:slot stuff 'sg-flags)
266 ;; This is ~ECHO, the same numeric
267 ;; code both on FreeBSD and on OpenBSD.
270 (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap)))
271 (return-from find-a-pty
275 (sb-unix:unix-close master-fd))))))
276 (error "could not find a pty"))
278 (defun open-pty (pty cookie)
283 (push master *close-on-error*)
284 (push slave *close-in-parent*)
286 (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
288 (error "could not SB-UNIX:UNIX-DUP ~D: ~S"
289 master (sb-unix:get-unix-error-msg errno)))
290 (push new-fd *close-on-error*)
291 (copy-descriptor-to-stream new-fd pty cookie)))
293 (sb-sys:make-fd-stream master :input t :output t)))))
295 (defmacro round-bytes-to-words (n)
296 `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
298 (defun string-list-to-c-strvec (string-list)
299 ;; Make a pass over STRING-LIST to calculate the amount of memory
300 ;; needed to hold the strvec.
301 (let ((string-bytes 0)
302 ;; We need an extra for the null, and an extra 'cause exect
303 ;; clobbers argv[-1].
304 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
305 (declare (fixnum string-bytes vec-bytes))
306 (dolist (s string-list)
307 (check-type s simple-string)
308 (incf string-bytes (round-bytes-to-words (1+ (length s)))))
309 ;; Now allocate the memory and fill it in.
310 (let* ((total-bytes (+ string-bytes vec-bytes))
311 (vec-sap (sb-sys:allocate-system-memory total-bytes))
312 (string-sap (sap+ vec-sap vec-bytes))
313 (i #-alpha 4 #+alpha 8))
314 (declare (type (and unsigned-byte fixnum) total-bytes i)
315 (type sb-sys:system-area-pointer vec-sap string-sap))
316 (dolist (s string-list)
317 (declare (simple-string s))
318 (let ((n (length s)))
319 ;; Blast the string into place.
320 (sb-kernel:copy-to-system-area (the simple-string s)
321 (* sb-vm:vector-data-offset
324 (* (1+ n) sb-vm:byte-bits))
325 ;; Blast the pointer to the string into place.
326 (setf (sap-ref-sap vec-sap i) string-sap)
327 (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
328 (incf i #-alpha 4 #+alpha 8)))
329 ;; Blast in the last null pointer.
330 (setf (sap-ref-sap vec-sap i) (int-sap 0))
331 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
333 (defmacro with-c-strvec ((var str-list) &body body)
334 (let ((sap (gensym "SAP-"))
335 (size (gensym "SIZE-")))
336 `(multiple-value-bind
338 (string-list-to-c-strvec ,str-list)
342 (sb-sys:deallocate-system-memory ,sap ,size)))))
344 (sb-alien:def-alien-routine spawn sb-c-call:int
345 (program sb-c-call:c-string)
346 (argv (* sb-c-call:c-string))
347 (envp (* sb-c-call:c-string))
348 (pty-name sb-c-call:c-string)
349 (stdin sb-c-call:int)
350 (stdout sb-c-call:int)
351 (stderr sb-c-call:int))
353 ;;; RUN-PROGRAM uses fork() and execve() to run a different program.
354 ;;; Strange stuff happens to keep the Unix state of the world
357 ;;; The child process needs to get its input from somewhere, and send
358 ;;; its output (both standard and error) to somewhere. We have to do
359 ;;; different things depending on where these somewheres really are.
361 ;;; For input, there are five options:
362 ;;; -- T: Just leave fd 0 alone. Pretty simple.
363 ;;; -- "file": Read from the file. We need to open the file and
364 ;;; pull the descriptor out of the stream. The parent should close
365 ;;; this stream after the child is up and running to free any
366 ;;; storage used in the parent.
367 ;;; -- NIL: Same as "file", but use "/dev/null" as the file.
368 ;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use
369 ;;; SB-SYS:MAKE-FD-STREAM to create the output stream on the
370 ;;; writeable descriptor, and pass the readable descriptor to
371 ;;; the child. The parent must close the readable descriptor for
372 ;;; EOF to be passed up correctly.
373 ;;; -- a stream: If it's a fd-stream, just pull the descriptor out
374 ;;; of it. Otherwise make a pipe as in :STREAM, and copy
375 ;;; everything across.
377 ;;; For output, there are five options:
378 ;;; -- T: Leave descriptor 1 alone.
379 ;;; -- "file": dump output to the file.
380 ;;; -- NIL: dump output to /dev/null.
381 ;;; -- :STREAM: return a stream that can be read from.
382 ;;; -- a stream: if it's a fd-stream, use the descriptor in it.
383 ;;; Otherwise, copy stuff from output to stream.
385 ;;; For error, there are all the same options as output plus:
386 ;;; -- :OUTPUT: redirect to the same place as output.
388 ;;; RUN-PROGRAM returns a PROCESS structure for the process if
389 ;;; the fork worked, and NIL if it did not.
390 (defun run-program (program args
391 &key env (wait t) pty input
392 if-input-does-not-exist output (if-output-exists :error)
393 (error :output) (if-error-exists :error) status-hook)
394 "RUN-PROGRAM creates a new process and runs the unix progam in the
395 file specified by the simple-string program. Args are the standard
396 arguments that can be passed to a Unix program, for no arguments
397 use NIL (which means just the name of the program is passed as arg 0).
399 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
400 Common Lisp Users Manual for details about the PROCESS structure.
402 The keyword arguments have the following meanings:
404 An A-LIST mapping keyword environment variables to simple-string
407 If non-NIL (default), wait until the created process finishes. If
408 NIL, continue running Lisp until the program finishes.
410 Either T, NIL, or a stream. Unless NIL, the subprocess is established
411 under a PTY. If :pty is a stream, all output to this pty is sent to
412 this stream, otherwise the PROCESS-PTY slot is filled in with a stream
413 connected to pty that can read output and write input.
415 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
416 input for the current process is inherited. If NIL, /dev/null
417 is used. If a pathname, the file so specified is used. If a stream,
418 all the input is read from that stream and send to the subprocess. If
419 :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
420 its output to the process. Defaults to NIL.
421 :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
423 :ERROR to generate an error
424 :CREATE to create an empty file
425 NIL (the default) to return NIL from RUN-PROGRAM
427 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
428 output for the current process is inherited. If NIL, /dev/null
429 is used. If a pathname, the file so specified is used. If a stream,
430 all the output from the process is written to this stream. If
431 :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
432 be read to get the output. Defaults to NIL.
433 :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
435 :ERROR (the default) to generate an error
436 :SUPERSEDE to supersede the file with output from the program
437 :APPEND to append output from the program to the file
438 NIL to return NIL from RUN-PROGRAM, without doing anything
439 :ERROR and :IF-ERROR-EXISTS
440 Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
441 specified as :OUTPUT in which case all error output is routed to the
442 same place as normal output.
444 This is a function the system calls whenever the status of the
445 process changes. The function takes the process as an argument."
447 ;; Make sure that the interrupt handler is installed.
448 (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler)
449 ;; Make sure that all the args are okay.
450 (unless (every #'simple-string-p args)
451 (error "All arguments to program must be simple strings: ~S" args))
452 ;; Prepend the program to the argument list.
453 (push (namestring program) args)
454 ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
455 ;; cleanup info. Also, establish proc at this level so we can
457 (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
459 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
462 (error "no such program: ~S" program))
465 (get-descriptor-for input cookie :direction :input
466 :if-does-not-exist if-input-does-not-exist)
468 (stdout output-stream)
469 (get-descriptor-for output cookie :direction :output
470 :if-exists if-output-exists)
472 (stderr error-stream)
473 (if (eq error :output)
474 (values stdout output-stream)
475 (get-descriptor-for error cookie :direction :output
476 :if-exists if-error-exists))
477 (multiple-value-bind (pty-name pty-stream)
478 (open-pty pty cookie)
479 ;; Make sure we are not notified about the child
480 ;; death before we have installed the PROCESS
481 ;; structure in *ACTIVE-PROCESSES*.
482 (sb-sys:without-interrupts
483 (with-c-strvec (argv args)
485 (envp (mapcar #'(lambda (entry)
488 (symbol-name (car entry))
494 (spawn pfile argv envp pty-name
495 stdin stdout stderr))))
496 (when (< child-pid 0)
497 (error "could not fork child process: ~S"
498 (sb-unix:get-unix-error-msg)))
499 (setf proc (make-process :pid child-pid
503 :output output-stream
505 :status-hook status-hook
507 (push proc *active-processes*))))))))))
508 (dolist (fd *close-in-parent*)
509 (sb-unix:unix-close fd))
511 (dolist (fd *close-on-error*)
512 (sb-unix:unix-close fd))
513 (dolist (handler *handlers-installed*)
514 (sb-sys:remove-fd-handler handler))))
515 (when (and wait proc)
519 ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
521 ;;; Installs a handler for any input that shows up on the file descriptor.
522 ;;; The handler reads the data and writes it to the stream.
524 (defun copy-descriptor-to-stream (descriptor stream cookie)
526 (let ((string (make-string 256))
529 (sb-sys:add-fd-handler
531 :input #'(lambda (fd)
532 (declare (ignore fd))
537 (result readable/errno)
538 (sb-unix:unix-select (1+ descriptor)
542 (error "could not select on sub-process: ~S"
543 (sb-unix:get-unix-error-msg
547 (sb-alien:with-alien ((buf (sb-alien:array
552 (sb-unix:unix-read descriptor
555 (cond ((or (and (null count)
556 (eql errno sb-unix:eio))
558 (sb-sys:remove-fd-handler handler)
561 (sb-unix:unix-close descriptor)
564 (sb-sys:remove-fd-handler handler)
567 (error "could not read input from sub-process: ~S"
568 (sb-unix:get-unix-error-msg errno)))
570 (sb-kernel:copy-from-system-area
572 string (* sb-vm:vector-data-offset
574 (* count sb-vm:byte-bits))
575 (write-string string stream
576 :end count)))))))))))
578 ;;; Find a file descriptor to use for object given the direction.
579 ;;; Returns the descriptor. If object is :STREAM, returns the created
580 ;;; stream as the second value.
581 (defun get-descriptor-for (object
587 ;; No new descriptor is needed.
593 (sb-unix:unix-open "/dev/null"
595 (:input sb-unix:o_rdonly)
596 (:output sb-unix:o_wronly)
600 (error "could not open \"/dev/null\": ~S"
601 (sb-unix:get-unix-error-msg errno)))
602 (push fd *close-in-parent*)
609 (error "could not create pipe: ~S"
610 (sb-unix:get-unix-error-msg write-fd)))
613 (push read-fd *close-in-parent*)
614 (push write-fd *close-on-error*)
615 (let ((stream (sb-sys:make-fd-stream write-fd :output t)))
616 (values read-fd stream)))
618 (push read-fd *close-on-error*)
619 (push write-fd *close-in-parent*)
620 (let ((stream (sb-sys:make-fd-stream read-fd :input t)))
621 (values write-fd stream)))
623 (sb-unix:unix-close read-fd)
624 (sb-unix:unix-close write-fd)
625 (error "Direction must be either :INPUT or :OUTPUT, not ~S."
627 ((or (pathnamep object) (stringp object))
628 (with-open-stream (file (apply #'open object keys))
631 (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
633 (push fd *close-in-parent*)
636 (error "could not duplicate file descriptor: ~S"
637 (sb-unix:get-unix-error-msg errno)))))))
638 ((sb-sys:fd-stream-p object)
639 (values (sb-sys:fd-stream-fd object) nil))
643 ;; FIXME: We could use a better way of setting up
644 ;; temporary files, both here and in LOAD-FOREIGN.
647 (error "could not open a temporary file in /tmp"))
648 (let* ((name (format nil "/tmp/.run-program-~D" count))
649 (fd (sb-unix:unix-open name
650 (logior sb-unix:o_rdwr
654 (sb-unix:unix-unlink name)
656 (let ((newline (string #\Newline)))
660 (read-line object nil nil)
663 (sb-unix:unix-write fd line 0 (length line))
666 (sb-unix:unix-write fd newline 0 1)))))
667 (sb-unix:unix-lseek fd 0 sb-unix:l_set)
668 (push fd *close-in-parent*)
669 (return (values fd nil))))))
671 (multiple-value-bind (read-fd write-fd)
674 (error "could not create pipe: ~S"
675 (sb-unix:get-unix-error-msg write-fd)))
676 (copy-descriptor-to-stream read-fd object cookie)
677 (push read-fd *close-on-error*)
678 (push write-fd *close-in-parent*)
679 (values write-fd nil)))))
681 (error "invalid option to RUN-PROGRAM: ~S" object))))