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 (load eval compile)
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
224 ;;; Find a pty that is not in use. Return three values: the file
225 ;;; descriptor for the master side of the pty, the file descriptor for
226 ;;; the slave side of the pty, and the name of the tty device for the
229 (dolist (char '(#\p #\q))
231 (let* ((master-name (format nil "/dev/pty~C~X" char digit))
232 (master-fd (sb-unix:unix-open master-name
236 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
237 (slave-fd (sb-unix:unix-open slave-name
241 ; Maybe put a vhangup here?
243 (sb-alien:with-alien ((stuff (sb-alien:struct sgttyb)))
244 (let ((sap (sb-alien:alien-sap stuff)))
245 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCGETP sap)
246 (setf (sb-alien:slot stuff 'sg-flags)
248 (sb-unix:unix-ioctl slave-fd sb-unix:TIOCSETP sap)
249 (sb-unix:unix-ioctl master-fd sb-unix:TIOCGETP sap)
250 (setf (sb-alien:slot stuff 'sg-flags)
251 (logand (sb-alien:slot stuff 'sg-flags)
253 (sb-unix:unix-ioctl master-fd sb-unix:TIOCSETP sap)))
254 (return-from find-a-pty
258 (sb-unix:unix-close master-fd))))))
259 (error "could not find a pty"))
261 (defun open-pty (pty cookie)
266 (push master *close-on-error*)
267 (push slave *close-in-parent*)
269 (multiple-value-bind (new-fd errno) (sb-unix:unix-dup master)
271 (error "could not SB-UNIX:UNIX-DUP ~D: ~S"
272 master (sb-unix:get-unix-error-msg errno)))
273 (push new-fd *close-on-error*)
274 (copy-descriptor-to-stream new-fd pty cookie)))
276 (sb-sys:make-fd-stream master :input t :output t)))))
278 (defmacro round-bytes-to-words (n)
279 `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
281 (defun string-list-to-c-strvec (string-list)
282 ;; Make a pass over STRING-LIST to calculate the amount of memory
283 ;; needed to hold the strvec.
284 (let ((string-bytes 0)
285 ;; We need an extra for the null, and an extra 'cause exect
286 ;; clobbers argv[-1].
287 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
288 (declare (fixnum string-bytes vec-bytes))
289 (dolist (s string-list)
290 (check-type s simple-string)
291 (incf string-bytes (round-bytes-to-words (1+ (length s)))))
292 ;; Now allocate the memory and fill it in.
293 (let* ((total-bytes (+ string-bytes vec-bytes))
294 (vec-sap (sb-sys:allocate-system-memory total-bytes))
295 (string-sap (sap+ vec-sap vec-bytes))
296 (i #-alpha 4 #+alpha 8))
297 (declare (type (and unsigned-byte fixnum) total-bytes i)
298 (type sb-sys:system-area-pointer vec-sap string-sap))
299 (dolist (s string-list)
300 (declare (simple-string s))
301 (let ((n (length s)))
302 ;; Blast the string into place.
303 (sb-kernel:copy-to-system-area (the simple-string s)
304 (* sb-vm:vector-data-offset
307 (* (1+ n) sb-vm:byte-bits))
308 ;; Blast the pointer to the string into place.
309 (setf (sap-ref-sap vec-sap i) string-sap)
310 (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
311 (incf i #-alpha 4 #+alpha 8)))
312 ;; Blast in the last null pointer.
313 (setf (sap-ref-sap vec-sap i) (int-sap 0))
314 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
316 (defmacro with-c-strvec ((var str-list) &body body)
317 (let ((sap (gensym "SAP-"))
318 (size (gensym "SIZE-")))
319 `(multiple-value-bind
321 (string-list-to-c-strvec ,str-list)
325 (sb-sys:deallocate-system-memory ,sap ,size)))))
327 (sb-alien:def-alien-routine spawn sb-c-call:int
328 (program sb-c-call:c-string)
329 (argv (* sb-c-call:c-string))
330 (envp (* sb-c-call:c-string))
331 (pty-name sb-c-call:c-string)
332 (stdin sb-c-call:int)
333 (stdout sb-c-call:int)
334 (stderr sb-c-call:int))
336 ;;; RUN-PROGRAM uses fork() and execve() to run a different program.
337 ;;; Strange stuff happens to keep the Unix state of the world
340 ;;; The child process needs to get its input from somewhere, and send
341 ;;; its output (both standard and error) to somewhere. We have to do
342 ;;; different things depending on where these somewheres really are.
344 ;;; For input, there are five options:
345 ;;; -- T: Just leave fd 0 alone. Pretty simple.
346 ;;; -- "file": Read from the file. We need to open the file and
347 ;;; pull the descriptor out of the stream. The parent should close
348 ;;; this stream after the child is up and running to free any
349 ;;; storage used in the parent.
350 ;;; -- NIL: Same as "file", but use "/dev/null" as the file.
351 ;;; -- :STREAM: Use Unix pipe() to create two descriptors. Use
352 ;;; SB-SYS:MAKE-FD-STREAM to create the output stream on the
353 ;;; writeable descriptor, and pass the readable descriptor to
354 ;;; the child. The parent must close the readable descriptor for
355 ;;; EOF to be passed up correctly.
356 ;;; -- a stream: If it's a fd-stream, just pull the descriptor out
357 ;;; of it. Otherwise make a pipe as in :STREAM, and copy
358 ;;; everything across.
360 ;;; For output, there are five options:
361 ;;; -- T: Leave descriptor 1 alone.
362 ;;; -- "file": dump output to the file.
363 ;;; -- NIL: dump output to /dev/null.
364 ;;; -- :STREAM: return a stream that can be read from.
365 ;;; -- a stream: if it's a fd-stream, use the descriptor in it.
366 ;;; Otherwise, copy stuff from output to stream.
368 ;;; For error, there are all the same options as output plus:
369 ;;; -- :OUTPUT: redirect to the same place as output.
371 ;;; RUN-PROGRAM returns a PROCESS structure for the process if
372 ;;; the fork worked, and NIL if it did not.
373 (defun run-program (program args
374 &key env (wait t) pty input
375 if-input-does-not-exist output (if-output-exists :error)
376 (error :output) (if-error-exists :error) status-hook)
377 "RUN-PROGRAM creates a new process and runs the unix progam in the
378 file specified by the simple-string program. Args are the standard
379 arguments that can be passed to a Unix program, for no arguments
380 use NIL (which means just the name of the program is passed as arg 0).
382 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
383 Common Lisp Users Manual for details about the PROCESS structure.
385 The keyword arguments have the following meanings:
387 An A-LIST mapping keyword environment variables to simple-string
390 If non-NIL (default), wait until the created process finishes. If
391 NIL, continue running Lisp until the program finishes.
393 Either T, NIL, or a stream. Unless NIL, the subprocess is established
394 under a PTY. If :pty is a stream, all output to this pty is sent to
395 this stream, otherwise the PROCESS-PTY slot is filled in with a stream
396 connected to pty that can read output and write input.
398 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
399 input for the current process is inherited. If NIL, /dev/null
400 is used. If a pathname, the file so specified is used. If a stream,
401 all the input is read from that stream and send to the subprocess. If
402 :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
403 its output to the process. Defaults to NIL.
404 :IF-INPUT-DOES-NOT-EXIST (when :INPUT is the name of a file)
406 :ERROR to generate an error
407 :CREATE to create an empty file
408 NIL (the default) to return NIL from RUN-PROGRAM
410 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
411 output for the current process is inherited. If NIL, /dev/null
412 is used. If a pathname, the file so specified is used. If a stream,
413 all the output from the process is written to this stream. If
414 :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
415 be read to get the output. Defaults to NIL.
416 :IF-OUTPUT-EXISTS (when :OUTPUT is the name of a file)
418 :ERROR (the default) to generate an error
419 :SUPERSEDE to supersede the file with output from the program
420 :APPEND to append output from the program to the file
421 NIL to return NIL from RUN-PROGRAM, without doing anything
422 :ERROR and :IF-ERROR-EXISTS
423 Same as :OUTPUT and :IF-OUTPUT-EXISTS, except that :ERROR can also be
424 specified as :OUTPUT in which case all error output is routed to the
425 same place as normal output.
427 This is a function the system calls whenever the status of the
428 process changes. The function takes the process as an argument."
430 ;; Make sure that the interrupt handler is installed.
431 (sb-sys:enable-interrupt sb-unix:sigchld #'sigchld-handler)
432 ;; Make sure that all the args are okay.
433 (unless (every #'simple-string-p args)
434 (error "All arguments to program must be simple strings: ~S" args))
435 ;; Prepend the program to the argument list.
436 (push (namestring program) args)
437 ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
438 ;; cleanup info. Also, establish proc at this level so we can
440 (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
442 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
445 (error "no such program: ~S" program))
448 (get-descriptor-for input cookie :direction :input
449 :if-does-not-exist if-input-does-not-exist)
451 (stdout output-stream)
452 (get-descriptor-for output cookie :direction :output
453 :if-exists if-output-exists)
455 (stderr error-stream)
456 (if (eq error :output)
457 (values stdout output-stream)
458 (get-descriptor-for error cookie :direction :output
459 :if-exists if-error-exists))
460 (multiple-value-bind (pty-name pty-stream)
461 (open-pty pty cookie)
462 ;; Make sure we are not notified about the child
463 ;; death before we have installed the PROCESS
464 ;; structure in *ACTIVE-PROCESSES*.
465 (sb-sys:without-interrupts
466 (with-c-strvec (argv args)
468 (envp (mapcar #'(lambda (entry)
471 (symbol-name (car entry))
477 (spawn pfile argv envp pty-name
478 stdin stdout stderr))))
479 (when (< child-pid 0)
480 (error "could not fork child process: ~S"
481 (sb-unix:get-unix-error-msg)))
482 (setf proc (make-process :pid child-pid
486 :output output-stream
488 :status-hook status-hook
490 (push proc *active-processes*))))))))))
491 (dolist (fd *close-in-parent*)
492 (sb-unix:unix-close fd))
494 (dolist (fd *close-on-error*)
495 (sb-unix:unix-close fd))
496 (dolist (handler *handlers-installed*)
497 (sb-sys:remove-fd-handler handler))))
498 (when (and wait proc)
502 ;;; COPY-DESCRIPTOR-TO-STREAM -- internal
504 ;;; Installs a handler for any input that shows up on the file descriptor.
505 ;;; The handler reads the data and writes it to the stream.
507 (defun copy-descriptor-to-stream (descriptor stream cookie)
509 (let ((string (make-string 256))
512 (sb-sys:add-fd-handler
514 :input #'(lambda (fd)
515 (declare (ignore fd))
520 (result readable/errno)
521 (sb-unix:unix-select (1+ descriptor)
525 (error "could not select on sub-process: ~S"
526 (sb-unix:get-unix-error-msg
530 (sb-alien:with-alien ((buf (sb-alien:array
535 (sb-unix:unix-read descriptor
538 (cond ((or (and (null count)
539 (eql errno sb-unix:eio))
541 (sb-sys:remove-fd-handler handler)
544 (sb-unix:unix-close descriptor)
547 (sb-sys:remove-fd-handler handler)
550 (error "could not read input from sub-process: ~S"
551 (sb-unix:get-unix-error-msg errno)))
553 (sb-kernel:copy-from-system-area
555 string (* sb-vm:vector-data-offset
557 (* count sb-vm:byte-bits))
558 (write-string string stream
559 :end count)))))))))))
561 ;;; Find a file descriptor to use for object given the direction.
562 ;;; Returns the descriptor. If object is :STREAM, returns the created
563 ;;; stream as the second value.
564 (defun get-descriptor-for (object
570 ;; No new descriptor is needed.
576 (sb-unix:unix-open "/dev/null"
578 (:input sb-unix:o_rdonly)
579 (:output sb-unix:o_wronly)
583 (error "could not open \"/dev/null\": ~S"
584 (sb-unix:get-unix-error-msg errno)))
585 (push fd *close-in-parent*)
592 (error "could not create pipe: ~S"
593 (sb-unix:get-unix-error-msg write-fd)))
596 (push read-fd *close-in-parent*)
597 (push write-fd *close-on-error*)
598 (let ((stream (sb-sys:make-fd-stream write-fd :output t)))
599 (values read-fd stream)))
601 (push read-fd *close-on-error*)
602 (push write-fd *close-in-parent*)
603 (let ((stream (sb-sys:make-fd-stream read-fd :input t)))
604 (values write-fd stream)))
606 (sb-unix:unix-close read-fd)
607 (sb-unix:unix-close write-fd)
608 (error "Direction must be either :INPUT or :OUTPUT, not ~S."
610 ((or (pathnamep object) (stringp object))
611 (with-open-stream (file (apply #'open object keys))
614 (sb-unix:unix-dup (sb-sys:fd-stream-fd file))
616 (push fd *close-in-parent*)
619 (error "could not duplicate file descriptor: ~S"
620 (sb-unix:get-unix-error-msg errno)))))))
621 ((sb-sys:fd-stream-p object)
622 (values (sb-sys:fd-stream-fd object) nil))
626 ;; FIXME: We could use a better way of setting up
627 ;; temporary files, both here and in LOAD-FOREIGN.
630 (error "could not open a temporary file in /tmp"))
631 (let* ((name (format nil "/tmp/.run-program-~D" count))
632 (fd (sb-unix:unix-open name
633 (logior sb-unix:o_rdwr
637 (sb-unix:unix-unlink name)
639 (let ((newline (string #\Newline)))
643 (read-line object nil nil)
646 (sb-unix:unix-write fd line 0 (length line))
649 (sb-unix:unix-write fd newline 0 1)))))
650 (sb-unix:unix-lseek fd 0 sb-unix:l_set)
651 (push fd *close-in-parent*)
652 (return (values fd nil))))))
654 (multiple-value-bind (read-fd write-fd)
657 (error "could not create pipe: ~S"
658 (sb-unix:get-unix-error-msg write-fd)))
659 (copy-descriptor-to-stream read-fd object cookie)
660 (push read-fd *close-on-error*)
661 (push write-fd *close-in-parent*)
662 (values write-fd nil)))))
664 (error "invalid option to RUN-PROGRAM: ~S" object))))