1 .. not working .. not working .. not working .. not working ..
3 KLUDGE: This is CMU CL code which needs more porting before it can
4 work on SBCL. At the very least:
5 * Package references need to be renamed from the CMU CL "SYSTEM" style
6 to the SBCL "SB-SYS" style. Possibly some referenced symbols have
7 moved to new packages or been renamed, as well.
8 * The environment-handling needs to be updated to read directly from
9 the Unix environment, since SBCL, unlike CMU CL, doesn't maintain
11 * The DEFCONSTANT #+SVR4 stuff needs to be checked and cleaned up for
12 currently supported OSes, since SBCL doesn't use the :SVR4 feature.
13 * The conditional code for other stuff not supported by SBCL (e.g.
14 HPUX) should probably go away.
17 ;;;; support for running Unix programs from inside Lisp
19 ;;;; This software is part of the SBCL system. See the README file for
20 ;;;; more information.
22 ;;;; This software is derived from the CMU CL system, which was
23 ;;;; written at Carnegie Mellon University and released into the
24 ;;;; public domain. The software is in the public domain and is
25 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
26 ;;;; files for more information.
33 ;;;; Import wait3(2) from Unix.
35 (alien:def-alien-routine ("wait3" c-wait3) c-call:int
36 (status c-call:int :out)
40 (eval-when (load eval compile)
41 (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
42 (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
43 (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
45 (defun wait3 (&optional do-not-hang check-for-stopped)
46 "Return any available status information on child process."
47 (multiple-value-bind (pid status)
48 (c-wait3 (logior (if do-not-hang
55 (cond ((or (minusp pid)
58 ((eql (ldb (byte 8 0) status)
62 (ldb (byte 8 8) status)))
63 ((zerop (ldb (byte 7 0) status))
66 (ldb (byte 8 8) status)))
68 (let ((signal (ldb (byte 7 0) status)))
70 (if (or (eql signal unix:sigstop)
71 (eql signal unix:sigtstp)
72 (eql signal unix:sigttin)
73 (eql signal unix:sigttou))
77 (not (zerop (ldb (byte 1 7) status)))))))))
79 ;;;; stuff for process control
81 (defvar *active-processes* nil
82 "List of process structures for all active processes.")
84 (defstruct (process (:print-function %print-process))
85 pid ; PID of child process
86 %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
87 exit-code ; either exit code or signal
88 core-dumped ; T if a core image was dumped
89 pty ; stream to child's pty, or NIL
90 input ; stream to child's input, or NIL
91 output ; stream from child's output, or NIL
92 error ; stream from child's error output, or NIL
93 status-hook ; closure to call when PROC changes status
94 plist ; a place for clients to stash things
95 cookie ; list of the number of pipes from the subprocess
98 (defun %print-process (proc stream depth)
99 (declare (ignore depth))
100 (format stream "#<PROCESS ~D ~S>"
102 (process-status proc)))
104 (defun process-status (proc)
105 "Return the current status of process. The result is one of :RUNNING,
106 :STOPPED, :EXITED, or :SIGNALED."
107 (get-processes-status-changes)
108 (process-%status proc))
110 (defun process-wait (proc &optional check-for-stopped)
111 "Wait for PROC to quit running for some reason. Returns PROC."
113 (case (process-status proc)
116 (when check-for-stopped
119 (when (zerop (car (process-cookie proc)))
121 (system:serve-all-events 1))
124 ;;; Find the current foreground process group id.
125 (defun find-current-foreground-process (proc)
126 (alien:with-alien ((result c-call:int))
129 (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
131 (alien:alien-sap (alien:addr result)))
133 (error "TIOCPGRP ioctl failed: ~S"
134 (unix:get-unix-error-msg error)))
138 (defun process-kill (proc signal &optional (whom :pid))
139 "Send SIGNAL to PROC. If WHOM is :PID, then use the kill(2) Unix system
140 call. If WHOM is :PROCESS-GROUP, use the killpg(2) Unix system call.
141 If WHOM is :PTY-PROCESS-GROUP, then deliver the signal to whichever
142 process group is currently in the foreground."
143 (let ((pid (ecase whom
144 ((:pid :process-group)
148 (find-current-foreground-process proc)))))
154 (unix:unix-ioctl (system:fd-stream-fd (process-pty proc))
157 (unix:unix-signal-number signal))))
158 ((:process-group #-hpux :pty-process-group)
159 (unix:unix-killpg pid signal))
161 (unix:unix-kill pid signal)))
164 ((and (eql pid (process-pid proc))
165 (= (unix:unix-signal-number signal) unix:sigcont))
166 (setf (process-%status proc) :running)
167 (setf (process-exit-code proc) nil)
168 (when (process-status-hook proc)
169 (funcall (process-status-hook proc) proc))
174 (defun process-alive-p (proc)
175 "Return T if the process is still alive, NIL otherwise."
176 (let ((status (process-status proc)))
177 (if (or (eq status :running)
178 (eq status :stopped))
182 (defun process-close (proc)
183 "Close all streams connected to PROC and stop maintaining the status slot."
184 (macrolet ((frob (stream abort)
185 `(when ,stream (close ,stream :abort ,abort))))
186 (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
187 (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
188 (frob (process-output proc) nil)
189 (frob (process-error proc) nil))
190 (system:without-interrupts
191 (setf *active-processes* (delete proc *active-processes*)))
194 ;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes
195 (defun sigchld-handler (ignore1 ignore2 ignore3)
196 (declare (ignore ignore1 ignore2 ignore3))
197 (get-processes-status-changes))
199 (defun get-processes-status-changes ()
201 (multiple-value-bind (pid what code core)
205 (let ((proc (find pid *active-processes* :key #'process-pid)))
207 (setf (process-%status proc) what)
208 (setf (process-exit-code proc) code)
209 (setf (process-core-dumped proc) core)
210 (when (process-status-hook proc)
211 (funcall (process-status-hook proc) proc))
212 (when (or (eq what :exited)
214 (system:without-interrupts
215 (setf *active-processes*
216 (delete proc *active-processes*)))))))))
218 ;;;; RUN-PROGRAM and close friends
220 (defvar *close-on-error* nil
221 "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
222 (defvar *close-in-parent* nil
223 "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
224 (defvar *handlers-installed* nil
225 "List of handlers installed by RUN-PROGRAM.")
227 ;;; Find a pty that is not in use. Returns three values: the file
228 ;;; descriptor for the master side of the pty, the file descriptor for
229 ;;; the slave side of the pty, and the name of the tty device for the
232 "Returns the master fd, the slave fd, and the name of the tty"
233 (dolist (char '(#\p #\q))
235 (let* ((master-name (format nil "/dev/pty~C~X" char digit))
236 (master-fd (unix:unix-open master-name
240 (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
241 (slave-fd (unix:unix-open slave-name
245 ; Maybe put a vhangup here?
247 (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
248 (let ((sap (alien:alien-sap stuff)))
249 (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
250 (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
251 (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
252 (unix:unix-ioctl master-fd unix:TIOCGETP sap)
253 (setf (alien:slot stuff 'unix:sg-flags)
254 (logand (alien:slot stuff 'unix:sg-flags)
256 (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
257 (return-from find-a-pty
261 (unix:unix-close master-fd))))))
262 (error "could not find a pty"))
264 (defun open-pty (pty cookie)
269 (push master *close-on-error*)
270 (push slave *close-in-parent*)
272 (multiple-value-bind (new-fd errno) (unix:unix-dup master)
274 (error "could not UNIX:UNIX-DUP ~D: ~A"
275 master (unix:get-unix-error-msg errno)))
276 (push new-fd *close-on-error*)
277 (copy-descriptor-to-stream new-fd pty cookie)))
279 (system:make-fd-stream master :input t :output t)))))
281 (defmacro round-bytes-to-words (n)
282 `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
284 (defun string-list-to-c-strvec (string-list)
285 ;; Make a pass over STRING-LIST to calculate the amount of memory
286 ;; needed to hold the strvec.
287 (let ((string-bytes 0)
288 ;; We need an extra for the null, and an extra 'cause exect
289 ;; clobbers argv[-1].
290 (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
291 (declare (fixnum string-bytes vec-bytes))
292 (dolist (s string-list)
293 (check-type s simple-string)
294 (incf string-bytes (round-bytes-to-words (1+ (length s)))))
295 ;; Now allocate the memory and fill it in.
296 (let* ((total-bytes (+ string-bytes vec-bytes))
297 (vec-sap (system:allocate-system-memory total-bytes))
298 (string-sap (sap+ vec-sap vec-bytes))
299 (i #-alpha 4 #+alpha 8))
300 (declare (type (and unsigned-byte fixnum) total-bytes i)
301 (type system:system-area-pointer vec-sap string-sap))
302 (dolist (s string-list)
303 (declare (simple-string s))
304 (let ((n (length s)))
305 ;; Blast the string into place.
306 (kernel:copy-to-system-area (the simple-string s)
307 (* vm:vector-data-offset vm:word-bits)
309 (* (1+ n) vm:byte-bits))
310 ;; Blast the pointer to the string into place.
311 (setf (sap-ref-sap vec-sap i) string-sap)
312 (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
313 (incf i #-alpha 4 #+alpha 8)))
314 ;; Blast in the last null pointer.
315 (setf (sap-ref-sap vec-sap i) (int-sap 0))
316 (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
318 (defmacro with-c-strvec ((var str-list) &body body)
319 (let ((sap (gensym "SAP-"))
320 (size (gensym "SIZE-")))
321 `(multiple-value-bind
323 (string-list-to-c-strvec ,str-list)
327 (system:deallocate-system-memory ,sap ,size)))))
329 (alien:def-alien-routine spawn c-call:int
330 (program c-call:c-string)
331 (argv (* c-call:c-string))
332 (envp (* c-call:c-string))
333 (pty-name c-call:c-string)
338 ;;; RUN-PROGRAM uses fork and execve to run a different program.
339 ;;; Strange stuff happens to keep the unix state of the world
342 ;;; The child process needs to get it's input from somewhere, and send it's
343 ;;; output (both standard and error) to somewhere. We have to do different
344 ;;; things depending on where these somewheres really are.
346 ;;; For input, there are five options:
347 ;;; - T: Just leave fd 0 alone. Pretty simple.
348 ;;; - "file": Read from the file. We need to open the file and pull the
349 ;;; descriptor out of the stream. The parent should close this stream after
350 ;;; the child is up and running to free any storage used in the parent.
351 ;;; - NIL: Same as "file", but use "/dev/null" as the file.
352 ;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
353 ;;; to create the output stream on the writeable descriptor, and pass the
354 ;;; readable descriptor to the child. The parent must close the readable
355 ;;; descriptor for EOF to be passed up correctly.
356 ;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
357 ;;; Otherwise make a pipe as in :STREAM, and copy everything across.
359 ;;; For output, there are n options:
360 ;;; - T: Leave descriptor 1 alone.
361 ;;; - "file": dump output to the file.
362 ;;; - NIL: dump output to /dev/null.
363 ;;; - :STREAM: return a stream that can be read from.
364 ;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
365 ;;; stuff from output to stream.
367 ;;; For error, there are all the same options as output plus:
368 ;;; - :OUTPUT: redirect to the same place as output.
370 ;;; RUN-PROGRAM returns a process struct for the process if the fork
371 ;;; worked, and NIL if it did not.
372 (defun run-program (program args
374 (env *environment-list*)
378 if-input-does-not-exist
380 (if-output-exists :error)
382 (if-error-exists :error)
384 "RUN-PROGRAM creates a new process and runs the unix program in the
385 file specified by PROGRAM (a SIMPLE-STRING). ARGS are the standard
386 arguments that can be passed to a Unix program; for no arguments
387 use NIL (which means just the name of the program is passed as arg 0).
389 RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
390 Common Lisp Users Manual for details about the PROCESS structure.
392 The keyword arguments have the following meanings:
394 An alist mapping keyword environment variables to SIMPLE-STRING
397 If non-NIL (default), wait until the created process finishes. If
398 NIL, continue running Lisp until the program finishes.
400 Either T, NIL, or a stream. Unless NIL, the subprocess is established
401 under a PTY. If :pty is a stream, all output to this pty is sent to
402 this stream, otherwise the PROCESS-PTY slot is filled in with a stream
403 connected to pty that can read output and write input.
405 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
406 input for the current process is inherited. If NIL, /dev/null
407 is used. If a pathname, the file so specified is used. If a stream,
408 all the input is read from that stream and send to the subprocess. If
409 :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
410 its output to the process. Defaults to NIL.
411 :if-input-does-not-exist (when :input is the name of a file) -
413 :error - generate an error.
414 :create - create an empty file.
415 nil (default) - return nil from run-program.
417 Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
418 output for the current process is inherited. If NIL, /dev/null
419 is used. If a pathname, the file so specified is used. If a stream,
420 all the output from the process is written to this stream. If
421 :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
422 be read to get the output. Defaults to NIL.
423 :if-output-exists (when :input is the name of a file) -
425 :error (default) - generates an error if the file already exists.
426 :supersede - output from the program supersedes the file.
427 :append - output from the program is appended to the file.
428 nil - run-program returns nil without doing anything.
429 :error and :if-error-exists -
430 Same as :output and :if-output-exists, except that :error can also be
431 specified as :output in which case all error output is routed to the
432 same place as normal output.
434 This is a function the system calls whenever the status of the
435 process changes. The function takes the process as an argument."
437 ;; Make sure that the interrupt handler is installed.
438 (system:enable-interrupt unix:sigchld #'sigchld-handler)
439 ;; Make sure that all the args are okay.
440 (unless (every #'simple-string-p args)
441 ;; FIXME: should be some sort of TYPE-ERROR? or perhaps we should
442 ;; just be nice and call (COERCE FOO 'SIMPLE-STRING) on each of
443 ;; our arguments, since it's reasonable for the user to pass in
444 ;; (at least) non-SIMPLE STRING values.
445 (error "All args to program must be simple strings: ~S." args))
446 ;; Prepend the program to the argument list.
447 (push (namestring program) args)
448 ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
449 ;; cleanup info. Also, establish proc at this level so that we can
451 (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
453 (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
456 (error "no such program: ~S" program))
459 (get-descriptor-for input cookie
461 :if-does-not-exist if-input-does-not-exist)
463 (stdout output-stream)
464 (get-descriptor-for output cookie
466 :if-exists if-output-exists)
468 (stderr error-stream)
469 (if (eq error :output)
470 (values stdout output-stream)
471 (get-descriptor-for error cookie
473 :if-exists if-error-exists))
474 (multiple-value-bind (pty-name pty-stream)
475 (open-pty pty cookie)
476 ;; Make sure we are not notified about the child
477 ;; death before we have installed the process struct
478 ;; in *ACTIVE-PROCESSES*.
479 (system:without-interrupts
480 (with-c-strvec (argv args)
482 (envp (mapcar (lambda (entry)
485 (symbol-name (car entry))
491 (spawn pfile argv envp pty-name
492 stdin stdout stderr))))
493 (when (< child-pid 0)
494 (error "could not fork child process: ~A"
495 (unix:get-unix-error-msg)))
496 (setf proc (make-process :pid child-pid
500 :output output-stream
502 :status-hook status-hook
504 (push proc *active-processes*))))))))))
505 (dolist (fd *close-in-parent*)
506 (unix:unix-close fd))
508 (dolist (fd *close-on-error*)
509 (unix:unix-close fd))
510 (dolist (handler *handlers-installed*)
511 (system:remove-fd-handler handler))))
512 (when (and wait proc)
516 ;;; Install a handler for any input that shows up on the file
517 ;;; descriptor. The handler reads the data and writes it to the stream.
518 (defun copy-descriptor-to-stream (descriptor stream cookie)
520 (let ((string (make-string 256))
523 (system:add-fd-handler descriptor :input
525 (declare (ignore fd))
530 (result readable/errno)
531 (unix:unix-select (1+ descriptor) (ash 1 descriptor)
534 (error "could not select on sub-process: ~A"
535 (unix:get-unix-error-msg readable/errno)))
538 (alien:with-alien ((buf (alien:array c-call:char 256)))
541 (unix:unix-read descriptor (alien-sap buf) 256)
542 (cond ((or (and (null count)
543 (eql errno unix:eio))
545 (system:remove-fd-handler handler)
548 (unix:unix-close descriptor)
551 (system:remove-fd-handler handler)
554 (error "could not read input from sub-process: ~A"
555 (unix:get-unix-error-msg errno)))
557 (kernel:copy-from-system-area
559 string (* vm:vector-data-offset vm:word-bits)
560 (* count vm:byte-bits))
561 (write-string string stream
562 :end count)))))))))))
564 ;;; Find a file descriptor to use for object given the direction.
565 ;;; Return the descriptor. If object is :STREAM, return the created
566 ;;; stream as the second value.
567 (defun get-descriptor-for (object
573 ;; No new descriptor is needed.
579 (unix:unix-open "/dev/null"
581 (:input unix:o_rdonly)
582 (:output unix:o_wronly)
586 (error "could not open \"/dev/null\": ~A"
587 (unix:get-unix-error-msg errno)))
588 (push fd *close-in-parent*)
595 (error "could not create pipe: ~A"
596 (unix:get-unix-error-msg write-fd)))
599 (push read-fd *close-in-parent*)
600 (push write-fd *close-on-error*)
601 (let ((stream (system:make-fd-stream write-fd :output t)))
602 (values read-fd stream)))
604 (push read-fd *close-on-error*)
605 (push write-fd *close-in-parent*)
606 (let ((stream (system:make-fd-stream read-fd :input t)))
607 (values write-fd stream)))
609 (unix:unix-close read-fd)
610 (unix:unix-close write-fd)
611 (error "direction must be either :INPUT or :OUTPUT, not ~S"
613 ((or (pathnamep object) (stringp object))
614 (with-open-stream (file (apply #'open object keys))
617 (unix:unix-dup (system:fd-stream-fd file))
619 (push fd *close-in-parent*)
622 (error "could not duplicate file descriptor: ~A"
623 (unix:get-unix-error-msg errno)))))))
624 ((system:fd-stream-p object)
625 (values (system:fd-stream-fd object) nil))
631 (error "could not open a temporary file in /tmp"))
632 (let* ((name (format nil "/tmp/.run-program-~D" count))
633 (fd (unix:unix-open name
638 (unix:unix-unlink name)
640 (let ((newline (string #\Newline)))
644 (read-line object nil nil)
647 (unix:unix-write fd line 0 (length line))
650 (unix:unix-write fd newline 0 1)))))
651 (unix:unix-lseek fd 0 unix:l_set)
652 (push fd *close-in-parent*)
653 (return (values fd nil))))))
655 (multiple-value-bind (read-fd write-fd)
658 (error "could not create pipe: ~A"
659 (unix:get-unix-error-msg write-fd)))
660 (copy-descriptor-to-stream read-fd object cookie)
661 (push read-fd *close-on-error*)
662 (push write-fd *close-in-parent*)
663 (values write-fd nil)))))
665 (error "invalid option to RUN-PROGRAM: ~S" object))))