system()

[Miles Bader <miles@cogsci.edinburgh.ac.uk>]

Someone here wanted a function like unix system(), but unfortunately, the
obvious use of run-program doesn't handle user-interrupts "correctly" (that
is, they interrupt the waiting lisp instead of the program), and certain programs
just don't work (I suppose because they get SIGTT{IN,OU} or something).

Appended is the process group hackery (oh what fun) and system function I
used to get around this problem.  Is unwind-protect safe in a :before-execve
hook?

-Miles

--
Miles Bader  --  HCRC, University of Edinburgh  --  Miles.Bader@ed.ac.uk
Ich bin ein Virus. Mach' mit und kopiere mich in Deine .signature.
94% of everything is grunge


(in-package :MACH) ; should be unix!
(export '(tcsetpgrp tcgetpgrp tty-process-group))

;;; tc[sg]etpgrp are posix names

(defun tcsetpgrp (fd pgrp)
  "Set the tty-process-group for the unix file-descriptor FD to PGRP."
  (system:with-stack-alien (byref (unsigned-byte 32) (system:long-words 1))
    (setf (system:alien-access (system:alien-value byref)) pgrp)
    (unix-ioctl fd
		tiocspgrp
		(system:alien-sap (system:alien-value byref)))))

(defun tcgetpgrp (fd)
  "Get the tty-process-group for the unix file-descriptor FD."
  (system:with-stack-alien (byref (unsigned-byte 32) (system:long-words 1))
    (and (unix-ioctl fd
		     tiocgpgrp
		     (system:alien-sap (system:alien-value byref)))
	 (system:alien-access (system:alien-value byref)))))

(defun tty-process-group (&optional fd)
  "Get the tty-process-group for the unix file-descriptor FD.  If not supplied,
  FD defaults to /dev/tty."
  (if fd
      (tcgetpgrp fd)
      (multiple-value-bind (tty-fd errno)
	  (unix-open "/dev/tty" o_rdwr 0)
	(cond (tty-fd
	       (prog1
		   (tcgetpgrp tty-fd)
		 (unix-close tty-fd)))
	      (t
	       (list tty-fd errno))))))

(defun %set-tty-process-group (pgrp &optional fd)
  "Set the tty-process-group for the unix file-descriptor FD to PGRP.  If not
  supplied, FD defaults to /dev/tty."
  (let ((old-sigs
	 (unix-sigblock
	  (sigmask :sigttou :sigttin :sigtstp :sigchld))))
    (declare (type (unsigned-byte 32) old-sigs))
    (unwind-protect
	(if fd
	    (tcsetpgrp fd pgrp)
	    (multiple-value-bind (tty-fd errno)
		(unix-open "/dev/tty" o_rdwr 0)
	      (cond (tty-fd
		     (prog1
			 (tcsetpgrp tty-fd pgrp)
		       (unix-close tty-fd)))
		    (t
		     (list tty-fd errno)))))
      (unix-sigsetmask old-sigs))))
  
(defsetf tty-process-group (&optional fd) (pgrp)
  "Set the tty-process-group for the unix file-descriptor FD to PGRP.  If not
  supplied, FD defaults to /dev/tty."
  `(%set-tty-process-group ,pgrp ,fd))

;;; ----------------
(in-package :EXTENSIONS)
(export '(system *default-interactive-shell*))

(defvar *default-interactive-shell* "csh")

;;; This should be an anonymous lambda, but I liked the name.
(defun assume-control ()
  (let ((pid (mach:unix-getpid)))
    (mach:unix-setpgrp pid pid)
    (setf (tty-process-group) pid)))

(defun system (&optional cmd
	       &key (input t) (output t) (error t) 
	            (env *environment-list*)
	            if-input-does-not-exist (if-output-exists :error)
		    (if-error-exists :error))
  "Execute CMD (which defaults to an interactive shell) in a subshell.  The
  keyword arguments have the same meaning as for RUN-PROGRAM (although by
  default, the command inherits all the standard file descriptors)."
  (let* ((pgrp (mach:unix-getpgrp (mach:unix-getpid))))
    (let ((proc
	   (run-program "/bin/sh"
			`("-c"
			  ,(or cmd
			       (let ((shell
				      (or (cdr (assoc :shell
						      *environment-list*))
					  *default-interactive-shell*)))
				 (concatenate 'string shell " -i"))))
			:input input
			:output output
			:error error
			:env env
			:if-input-does-not-exist if-input-does-not-exist
			:if-output-exists if-output-exists
			:if-error-exists if-error-exists
			:before-execve #'assume-control
			:wait nil)))

      (unwind-protect
	  (progn
	    ;; _ensure_ our child has the tty (this is redundant, since the
	    ;; child does it as well, but a comment in bash says that posix
	    ;; recommends doing it here too).
	    (setf (tty-process-group) (process-pid proc))
	    (process-wait proc))
	;; get the tty back!
	(setf (tty-process-group) pgrp))

      proc)))