diff --git a/code/run-program.lisp b/code/run-program.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3668edab64b665bb3b5e58019c94112a4faee42e --- /dev/null +++ b/code/run-program.lisp @@ -0,0 +1,651 @@ +;;; -*- Package: Extensions; Log: code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; RUN-PROGRAM and friends. Factilty for running unix programs from inside +;;; a lisp. +;;; +;;; Written by Jim Healy and Bill Chiles, November 1987, using an earlier +;;; version written by David McDonald. +;;; +;;; Completely re-written by William Lott, July 1989 - January 1990. +;;; + +(in-package "EXTENSIONS") + +(export '(run-program process-status process-exit-code process-core-dumped + process-wait process-kill process-input process-output process-plist + process-pty process-error process-status-hook process-alive-p + process-close process-pid process-p)) + + +;;;; Import WAIT3 from unix. + +(ext:def-c-pointer *wait (unsigned-byte 32)) + +(ext:def-c-routine ("wait3" c-wait3) + (int) + (status *wait :out) + (options int) + (rusage int)) + +(eval-when (load eval compile) + (defconstant wait-wstopped #o177) + (defconstant wait-wnohang 1) + (defconstant wait-wuntraced 2)) + +(defun wait3 (&optional do-not-hang check-for-stopped) + "Return any available status information on child processed. " + (multiple-value-bind (pid status) + (c-wait3 (logior (if do-not-hang + wait-wnohang + 0) + (if check-for-stopped + wait-wuntraced + 0)) + 0) + (cond ((or (minusp pid) + (zerop pid)) + nil) + ((eql (ldb (byte 8 0) status) + wait-wstopped) + (values pid + :stopped + (ldb (byte 8 8) status))) + ((zerop (ldb (byte 7 0) status)) + (values pid + :exited + (ldb (byte 8 8) status))) + (t + (let ((signal (ldb (byte 7 0) status))) + (values pid + (if (or (eql signal mach:sigstop) + (eql signal mach:sigtstp) + (eql signal mach:sigttin) + (eql signal mach:sigttou)) + :stopped + :signaled) + signal + (not (zerop (ldb (byte 1 7) status))))))))) + + + +;;;; Process control stuff. + +(defvar *active-processes* nil + "List of process structures for all active processes.") + +(defstruct (process (:print-function %print-process)) + pid ; PID of child process. + %status ; Either :RUNNING, :STOPPED, :EXITED, or :SIGNALED. + exit-code ; Either exit code or signal + core-dumped ; T if a core image was dumped. + pty ; Stream to child's pty or nil. + input ; Stream to child's input or nil. + output ; Stream from child's output or nil. + error ; Stream from child's error output or nil. + status-hook ; Closure to call when PROC changes status. + plist ; Place for clients to stash tings. + ) + +(defun %print-process (proc stream depth) + (declare (ignore depth)) + (format stream "#<process ~D ~S>" + (process-pid proc) + (process-status proc))) + +;;; PROCESS-STATUS -- Public. +;;; +(defun process-status (proc) + "Return the current status of process. The result is one of :running, + :stopped, :exited, :signaled." + (get-processes-status-changes) + (process-%status proc)) + + +;;; PROCESS-WAIT -- Public. +;;; +(defun process-wait (proc &optional check-for-stopped) + "Wait for PROC to quit running for some reason. Returns PROC." + (loop + (unless (or (eq (process-status proc) :running) + (and check-for-stopped + (eq (process-status proc) :stopped))) + (return)) + (system:serve-all-events 1)) + proc) + +;;; FIND-CURRENT-FOREGROUND-PROCESS -- internal +;;; +;;; Finds the current foreground process group id. +;;; +(defun find-current-foreground-process (proc) + (mach:with-trap-arg-block mach::int1 pgrp + (multiple-value-bind + (wonp error) + (mach:unix-ioctl (system:fd-stream-fd (ext:process-pty proc)) + mach:TIOCGPGRP + (lisp::alien-value-sap mach::int1)) + (unless wonp + (error "TIOCPGRP ioctl failed: ~S" + (mach:get-unix-error-msg error))) + (system:alien-access (mach::int1-int (system:alien-value pgrp)))))) + +;;; PROCESS-KILL -- public +;;; +;;; Hand a process a signal. +;;; +(defun process-kill (proc signal &optional (whom :pid)) + "Hand SIGNAL to PROC. If whom is :pid, use the kill Unix system call. If + whom is :process-group, use the killpg Unix system call. If whom is + :pty-process-group deliver the signal to whichever process group is currently + in the foreground." + (let ((pid (ecase whom + ((:pid :process-group) + (process-pid proc)) + (:pty-process-group + (find-current-foreground-process proc))))) + (multiple-value-bind (okay errno) + (if (eq whom :pty-process-group) + (mach:unix-killpg pid signal) + (mach:unix-kill pid signal)) + (cond ((not okay) + (values nil errno)) + ((and (eql pid (process-pid proc)) + (= (unix-signal-number signal) mach:sigcont)) + (setf (process-%status proc) :running) + (setf (process-exit-code proc) nil) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + t) + (t + t))))) + +;;; PROCESS-ALIVE-P -- public +;;; +;;; Returns T if the process is still alive, NIL otherwise. +;;; +(defun process-alive-p (proc) + "Returns T if the process is still alive, NIL otherwise." + (let ((status (process-status proc))) + (if (or (eq status :running) + (eq status :stopped)) + t + nil))) + +;;; PROCESS-CLOSE -- public +;;; +;;; Close all the streams held open by PROC. +;;; +(defun process-close (proc) + "Close all streams connected to PROC and stop maintaining the status slot." + (macrolet ((frob (stream) + `(when ,stream (close ,stream)))) + (frob (process-pty proc)) + (frob (process-input proc)) + (frob (process-output proc)) + (frob (process-error proc)) + (system:without-interrupts + (setf *active-processes* (delete proc *active-processes*))) + proc)) + +;;; SIGCHLD-HANDLER -- Internal. +;;; +;;; This should be the handler for sigchld signals that RUN-PROGRAM establishes. +;;; +;;; Since interrupts are so broken in the current RT system, we don't turn on +;;; sigchld signals for now. We call this by hand whenever we need to check +;;; the status of a process. +;;; +(defun sigchld-handler (ignore1 ignore2 ignore3) + (declare (ignore ignore1 ignore2 ignore3)) + (get-processes-status-changes)) + +;;; GET-PROCESSES-STATUS-CHANGES -- Internal. +;;; +(defun get-processes-status-changes () + (loop + (multiple-value-bind (pid what code core) + (wait3 t t) + (unless pid + (return)) + (let ((proc (find pid *active-processes* :key #'process-pid))) + (when proc + (setf (process-%status proc) what) + (setf (process-exit-code proc) code) + (setf (process-core-dumped proc) core) + (when (process-status-hook proc) + (funcall (process-status-hook proc) proc)) + (when (or (eq what :exited) + (eq what :signaled)) + (system:without-interrupts + (setf *active-processes* + (delete proc *active-processes*))))))))) + + + +;;;; RUN-PROGRAM and close friends. + +(defvar *close-on-error* nil + "List of file descriptors to close when RUN-PROGRAM exits due to an error.") +(defvar *close-in-parent* nil + "List of file descriptors to close when RUN-PROGRAM returns in the parent.") +(defvar *handlers-installed* nil + "List of handlers installed by RUN-PROGRAM.") + + +;;; FIND-A-PTY -- internal +;;; +;;; Finds a pty that is not in use. Returns three values: the file descriptor +;;; for the master side of the pty, the file descriptor for the slave side of +;;; the pty, and the name of the tty device for the slave side. +;;; +(defun find-a-pty () + "Returns the master fd, the slave fd, and the name of the tty" + (dolist (char '(#\p #\q)) + (dotimes (digit 16) + (let* ((master-name (format nil "/dev/pty~C~X" char digit)) + (master-fd (mach:unix-open master-name + mach:o_rdwr + #o666))) + (when master-fd + (let* ((slave-name (format nil "/dev/tty~C~X" char digit)) + (slave-fd (mach:unix-open slave-name + mach:o_rdwr + #o666))) + (when slave-fd + ; Maybe put a vhangup here? + (mach:unix-ioctl slave-fd + mach:TIOCGETP + (system:alien-sap mach:sgtty)) + (setf (system:alien-access (mach::sgtty-flags mach:sgtty)) + #o6300) ; XTABS|EVENP|ODDP + (mach:unix-ioctl slave-fd + mach:TIOCSETP + (system:alien-sap mach:sgtty)) + (mach:unix-ioctl master-fd + mach:TIOCGETP + (system:alien-sap mach:sgtty)) + (setf (system:alien-access (mach::sgtty-flags mach:sgtty)) + (logand (system:alien-access (mach::sgtty-flags mach:sgtty)) + (lognot 8))) ; ~ECHO + (mach:unix-ioctl master-fd + mach:TIOCSETP + (system:alien-sap mach:sgtty)) + (return-from find-a-pty + (values master-fd + slave-fd + slave-name)))) + (mach:unix-close master-fd))))) + (error "Could not find a pty.")) + +;;; OPEN-PTY -- internal +;;; +(defun open-pty (pty) + (when pty + (multiple-value-bind + (master slave name) + (find-a-pty) + (push master *close-on-error*) + (push slave *close-in-parent*) + (when (streamp pty) + (multiple-value-bind (won new-fd) (mach:unix-dup master) + (unless won + (error "Could not MACH:UNIX-DUP ~D: ~A" + master (mach:get-unix-error-msg new-fd))) + (push new-fd *close-on-error*) + (copy-descriptor-to-stream new-fd pty))) + (values name + (system:make-fd-stream master :input t :output t))))) + +;;; SETUP-CHILD -- internal +;;; +;;; Execs the program after setting up the environment correctly. This +;;; routine never returns under any condition. +;;; +(defun setup-child (pfile args env stdin stdout stderr pty-name before-execve) + (unwind-protect + (handler-bind ((error #'(lambda (condition) + (declare (ignore condition)) + (mach:unix-exit 2)))) + ;; Put us in our own pgrp. + (mach:unix-setpgrp 0 (mach:unix-getpid)) + ;; If we want a pty, set it up. + (when pty-name + (let ((old-tty (mach:unix-open "/dev/tty" mach:o_rdwr 0))) + (when old-tty + (mach:unix-ioctl old-tty mach:TIOCNOTTY 0) + (mach:unix-close old-tty))) + (let ((new-tty (mach:unix-open pty-name mach:o_rdwr 0))) + (when new-tty + (mach:unix-dup2 new-tty 0) + (mach:unix-dup2 new-tty 1) + (mach:unix-dup2 new-tty 2)))) + ;; Setup the three standard descriptors. + (when stdin + (mach:unix-dup2 stdin 0)) + (when stdout + (mach:unix-dup2 stdout 1)) + (when stderr + (mach:unix-dup2 stderr 2)) + ;; Close all other descriptors. + (do ((fd (1- (mach:unix-getdtablesize)) + (1- fd))) + ((= fd 3)) + (mach:unix-close fd)) + ;; Do the before-execve + (when before-execve + (funcall before-execve)) + ;; Exec the program + (mach:unix-execve pfile args env)) + ;; If exec returns, we lose. + (mach:unix-exit 1))) + +;;; RUN-PROGRAM -- public +;;; +;;; RUN-PROGRAM uses fork and execve to run a different program. Strange stuff +;;; happens to keep the unix state of the world coherent. +;;; +;;; The child process needs to get it's input from somewhere, and send it's +;;; output (both standard and error) to somewhere. We have to do different +;;; things depending on where these somewheres really are. +;;; +;;; For input, there are five options: +;;; - T: Just leave fd 0 alone. Pretty simple. +;;; - "file": Read from the file. We need to open the file and pull the +;;; descriptor out of the stream. The parent should close this stream after +;;; the child is up and running to free any storage used in the parent. +;;; - NIL: Same as "file", but use "/dev/null" as the file. +;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream +;;; to create the output stream on the writeable descriptor, and pass the +;;; readable descriptor to the child. The parent must close the readable +;;; descriptor for EOF to be passed up correctly. +;;; - a stream: If it's a fd-stream, just pull the descriptor out of it. +;;; Otherwise make a pipe as in :STREAM, and copy everything across. +;;; +;;; For output, there are n options: +;;; - T: Leave descriptor 1 alone. +;;; - "file": dump output to the file. +;;; - NIL: dump output to /dev/null. +;;; - :STREAM: return a stream that can be read from. +;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy +;;; stuff from output to stream. +;;; +;;; For error, there are all the same options as output plus: +;;; - :OUTPUT: redirect to the same place as output. +;;; +;;; RUN-PROGRAM returns a process struct for the process if the fork worked, +;;; and NIL if it did not. +;;; +(defun run-program (program args + &key (env *environment-list*) (wait t) pty input + if-input-does-not-exist output (if-output-exists :error) + (error :output) (if-error-exists :error) status-hook + before-execve) + "Run-program creates a new process and runs the unix progam in the + file specified by the simple-string program. Args are the standard + arguments that can be passed to a Unix program, for no arguments + use NIL (which means just the name of the program is passed as arg 0). + + Run program will either return NIL or a PROCESS structure. See the CMU + Common Lisp Users Manual for details about the PROCESS structure. + + The keyword arguments have the following meanings: + :env - + An A-LIST mapping keyword environment variables to simple-string + values. + :wait - + If non-NIL (default), wait until the created process finishes. If + NIL, continue running Lisp until the program finishes. + :pty - + Either T, NIL, or a stream. Unless NIL, the subprocess is established + under a PTY. If :pty is a stream, all output to this pty is sent to + this stream, otherwise the PROCESS-PTY slot is filled in with a stream + connected to pty that can read output and write input. + :input - + Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard + input for the current process is inherited. If NIL, /dev/null + is used. If a pathname, the file so spesified is used. If a stream, + all the input is read from that stream and send to the subprocess. If + :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends + its output to the process. Defaults to NIL. + :if-input-does-not-exist (when :input is the name of a file) - + can be one of: + :error - generate an error. + :create - create an empty file. + nil (default) - return nil from run-program. + :output - + Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard + input for the current process is inherited. If NIL, /dev/null + is used. If a pathname, the file so spesified is used. If a stream, + all the output from the process is written to this stream. If + :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can + be read to get the output. Defaults to NIL. + :if-output-exists (when :input is the name of a file) - + can be one of: + :error (default) - generates an error if the file already exists. + :supersede - output from the program supersedes the file. + :append - output from the program is appended to the file. + nil - run-program returns nil without doing anything. + :error and :if-error-exists - + Same as :output and :if-output-exists, except that :error can also be + spesified as :output in which case all error output is routed to the + same place as normal output. + :status-hook - + This is a function the system calls whenever the status of the + process changes. The function takes the process as an argument. + :before-execve - + This is a function, without arguments, RUN-PROGRAM runs in the child + process just before turning it into the specified program." + + ;; Make sure the interrupt handler is installed. + ;(system:enable-interrupt mach:sigchld #'sigchld-handler) + ;; Make sure all the args are okay. + (unless (every #'simple-string-p args) + (error "All args to program must be simple strings -- ~S." args)) + ;; Pre-pend the program to the argument list. + (push (namestring program) args) + ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup + ;; info. Also, establish proc at this level so we can return it. + (let (*close-on-error* *close-in-parent* *handlers-installed* proc) + (unwind-protect + (let ((pfile (namestring (truename (merge-pathnames program "path:"))))) + (multiple-value-bind + (stdin input-stream) + (get-descriptor-for input :direction :input + :if-does-not-exist if-input-does-not-exist) + (multiple-value-bind + (stdout output-stream) + (get-descriptor-for output :direction :output + :if-exists if-output-exists) + (multiple-value-bind + (stderr error-stream) + (if (eq error :output) + (values stdout output-stream) + (get-descriptor-for error :direction :output + :if-exists if-error-exists)) + (multiple-value-bind (pty-name pty-stream) + (open-pty pty) + ;; Make sure we are not notified about the child death before + ;; we have installed the process struct in *active-processes* + (system:without-interrupts + (multiple-value-bind + (child-pid errno) + (mach:unix-fork) + (cond ((zerop child-pid) + ;; We are the child. Note: setup-child NEVER returns + (setup-child pfile args env stdin stdout stderr + pty-name before-execve)) + ((null child-pid) + ;; This should only happen if the bozo has too + ;; many running procs. + (error "Could not fork child process: ~A" + (mach:get-unix-error-msg errno))) + (t + ;; We are the parent. + (setf proc (make-process :pid child-pid + :%status :running + :pty pty-stream + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook)) + (push proc *active-processes*)))))))))) + (dolist (fd *close-in-parent*) + (mach:unix-close fd)) + (unless proc + (dolist (fd *close-on-error*) + (mach:unix-close fd)) + (dolist (handler *handlers-installed*) + (system:remove-fd-handler handler)))) + (when (and wait proc) + (process-wait proc)) + proc)) + +;;; COPY-DESCRIPTOR-TO-STREAM -- internal +;;; +;;; Installs a handler for any input that shows up on the file descriptor. +;;; The handler reads the data and writes it to the stream. +;;; +(defun copy-descriptor-to-stream (descriptor stream) + (let ((string (make-string 256)) + handler) + (setf handler + (system:add-fd-handler descriptor :input + #'(lambda (fd) + (declare (ignore fd)) + (loop + (multiple-value-bind + (result readable/errno) + (mach:unix-select (1+ descriptor) (ash 1 descriptor) + 0 0 0) + (cond ((null result) + (error "Could not select on sub-process: ~A" + (mach:get-unix-error-msg readable/errno))) + ((zerop result) + (return)))) + (multiple-value-bind + (count errno) + (mach:unix-read descriptor + string + (length string)) + (cond ((or (and (null count) + (eql errno mach:eio)) + (eql count 0)) + (system:remove-fd-handler handler) + (mach:unix-close descriptor) + (return)) + ((null count) + (system:remove-fd-handler handler) + (error "Could not read input from sub-process: ~A" + (mach:get-unix-error-msg errno))) + (t + (write-string string stream + :end count)))))))))) + +;;; GET-DESCRIPTOR-FOR -- internal +;;; +;;; Find a file descriptor to use for object given the direction. Returns +;;; the descriptor. If object is :STREAM, returns the created stream as the +;;; second value. +;;; +(defun get-descriptor-for (object &rest keys &key direction &allow-other-keys) + (cond ((eq object t) + ;; No new descriptor is needed. + (values nil nil)) + ((eq object nil) + ;; Use /dev/null. + (multiple-value-bind + (fd errno) + (mach:unix-open "/dev/null" + (case direction + (:input mach:o_rdonly) + (:output mach:o_wronly) + (t mach:o_rdwr)) + #o666) + (unless fd + (error "Could not open \"/dev/null\": ~A" + (mach:get-unix-error-msg errno))) + (push fd *close-in-parent*) + (values fd nil))) + ((eq object :stream) + (multiple-value-bind + (read-fd write-fd) + (mach:unix-pipe) + (unless read-fd + (error "Could not create pipe: ~A" + (mach:get-unix-error-msg write-fd))) + (case direction + (:input + (push read-fd *close-in-parent*) + (push write-fd *close-on-error*) + (let ((stream (system:make-fd-stream write-fd :output t))) + (values read-fd stream))) + (:output + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (let ((stream (system:make-fd-stream read-fd :input t))) + (values write-fd stream))) + (t + (mach:unix-close read-fd) + (mach:unix-close write-fd) + (error "Direction must be either :INPUT or :OUTPUT, not ~S" + direction))))) + ((stringp object) + (with-open-stream (file (apply #'open object keys)) + (multiple-value-bind (won fd) + (mach:unix-dup (system:fd-stream-fd file)) + (cond (won + (push fd *close-in-parent*) + (values fd nil)) + (t + (error "Could not duplicate file descriptor: ~A" + (mach:get-unix-error-msg fd))))))) + ((system:fd-stream-p object) + (values (system:fd-stream-fd object) nil)) + ((streamp object) + (ecase direction + (:input + (dotimes (count + 256 + (error "Could not open a temporary file in /tmp")) + (let* ((name (format nil "/tmp/.run-program-~D" count)) + (fd (mach:unix-open name + (logior mach:o_rdwr + mach:o_creat + mach:o_excl) + #o666))) + (mach:unix-unlink name) + (when fd + (let ((newline (string #\Newline))) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (mach:unix-write fd line 0 (length line)) + (if no-cr + (return) + (mach:unix-write fd newline 0 1))))) + (mach:unix-lseek fd 0 mach:l_set) + (push fd *close-in-parent*) + (return (values fd nil)))))) + (:output + (multiple-value-bind (read-fd write-fd) + (mach:unix-pipe) + (unless read-fd + (error "Cound not create pipe: ~A" + (mach:get-unix-error-msg write-fd))) + (copy-descriptor-to-stream read-fd object) + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (values write-fd nil))))) + (t + (error "Invalid option to run-program: ~S" object)))) + diff --git a/code/serve-event.lisp b/code/serve-event.lisp new file mode 100644 index 0000000000000000000000000000000000000000..ee453df6ff141842e34e9fad7596098405cc5c5c --- /dev/null +++ b/code/serve-event.lisp @@ -0,0 +1,365 @@ +;;; -*- Log: code.log; Package: LISP -*- + +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; SYSTEM:SERVE-EVENT, now in it's own file. +;;; +;;; Re-written by William Lott, July 1989 - January 1990. +;;; +;;; ********************************************************************** + +(in-package "SYSTEM") + +(export '(with-fd-handler add-fd-handler remove-fd-handler invalidate-descriptor + serve-event serve-all-events wait-until-fd-usable)) + +(in-package "LISP") + + + +;;;; MACH Message receiving noise. + +(defvar *in-server* NIL + "*In-server* is set to T when the SIGMSG interrupt has been enabled + in Server.") + +(defvar server-unique-object (cons 1 2) + "Object thrown by the message interrupt handler.") + +(defconstant server-message-size 4096) +(defalien server-message server-message (bytes server-message-size) 0) + +(define-alien-stack server-message server-message (bytes server-message-size)) + +(defrecord server-message + (msg mach:msg #.(record-size 'mach:msg))) + +;;; Grab-message-loop calls the appropiate handler for an IPC message. +(defun grab-message-loop () + (let ((done-any nil)) + (loop + (if (eql (server-grab-message) + mach:rcv-timed-out) + (return done-any) + (setf done-any t))))) + + +(defun server-grab-message () + (with-stack-alien (sm server-message) + (alien-bind ((msg (server-message-msg (alien-value sm)))) + (setf (alien-access (mach:msg-msgsize (alien-value msg))) + server-message-size) + (setf (alien-access (mach:msg-localport (alien-value msg))) + mach::port-enabled) + (let ((gr (mach:msg-receive (alien-value sm) mach::rcv-timeout 0))) + (when (eql gr mach:rcv-timed-out) + (return-from server-grab-message gr)) + (unless (eql gr mach:rcv-success) + (gr-error 'mach:msg-receive gr)) + (let* ((server-message (alien-value sm)) + (port (alien-access (mach:msg-localport (alien-value msg)))) + (id (alien-access (mach:msg-id (alien-value msg)))) + (x (gethash port *port-table*)) + (set (cdr x))) + (unless x + (error "~D is not known to server (operation: ~D)." port id)) + (let ((gr (funcall (gethash id (object-set-table set) + (object-set-default-handler set)) + (car x)))) + (unless (eql gr mach:kern-success) + (gr-error 'server gr))))))) + mach:kern-success) + + +;;;; File descriptor IO noise. + +(defstruct (handler + (:print-function %print-handler) + (:constructor make-handler (direction descriptor function))) + direction ; Either :input or :output + descriptor ; File descriptor this handler is tied to. + active ; T iff this handler is running. + function ; Function to call. + bogus ; T if this descriptor is bogus. + ) + +(defun %print-handler (handler stream depth) + (declare (ignore depth)) + (format stream "#<Handler for ~A on ~:[~;BOGUS ~]descriptor ~D: ~S>" + (handler-direction handler) + (handler-bogus handler) + (handler-descriptor handler) + (handler-function handler))) + +(defvar *descriptor-handlers* nil + "List of all the currently active handlers for file descriptors") + + +;;; ADD-FD-HANDLER -- public +;;; +;;; Add a new handler to *descriptor-handlers*. +;;; +(defun add-fd-handler (fd direction function) + "Arange to call FUNCTION whenever FD is usable. DIRECTION should be + either :INPUT or :OUTPUT. The value returned should be passed to + SYSTEM:REMOVE-FD-HANDLER when it is no longer needed." + (assert (member direction '(:input :output)) + (direction) + "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction) + (let ((handler (make-handler direction fd function))) + (push handler *descriptor-handlers*) + handler)) + +;;; REMOVE-FD-HANDLER -- public +;;; +;;; Remove an old handler from *descriptor-handlers*. +;;; +(defun remove-fd-handler (handler) + "Removes HANDLER from the list of active handlers." + (setf *descriptor-handlers* + (delete handler *descriptor-handlers* + :test #'eq))) + +;;; INVALIDATE-DESCRIPTOR -- public +;;; +;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em. +;;; +(defun invalidate-descriptor (fd) + "Remove any handers refering to fd. This should only be used when attempting + to recover from a detected inconsistancy." + (setf *descriptor-handlers* + (delete fd *descriptor-handlers* + :key #'handler-descriptor))) + +;;; WITH-FD-HANDLER -- Public. +;;; +;;; Add the handler to *descriptor-handlers* for the duration of BODY. +;;; +(defmacro with-fd-handler ((fd direction function) &rest body) + "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY. + DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to + use, and FUNCTION is the function to call whenever FD is usable." + (let ((handler (gensym))) + `(let (,handler) + (unwind-protect + (progn + (setf ,handler (add-fd-handler ,fd ,direction ,function)) + ,@body) + (when ,handler + (remove-fd-handler ,handler)))))) + +;;; WAIT-UNTIL-FD-USABLE -- Public. +;;; +;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is +;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will +;;; timeout at the correct time irrespective of how many events are handled in +;;; the meantime. +;;; +(defun wait-until-fd-usable (fd direction &optional timeout) + "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or + :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving + up." + (let (usable + (stop-at (if timeout + (multiple-value-bind (okay sec usec) + (mach:unix-gettimeofday) + (declare (ignore okay)) + (+ (* 1000000 timeout sec) usec))))) + (with-fd-handler (fd direction #'(lambda (fd) + (declare (ignore fd)) + (setf usable t))) + (loop + (serve-event timeout) + + (when usable + (return t)) + + (when timeout + (multiple-value-bind (okay sec usec) + (mach:unix-gettimeofday) + (declare (ignore okay)) + (let ((now (+ (* sec 1000000) usec))) + (if (> now stop-at) + (return nil) + (setq timeout + (/ (- stop-at now) + 1000000)))))))))) + +;;; CALC-MASKS -- Internal. +;;; +;;; Return the correct masks to use for UNIX-SELECT. The four return values +;;; are: fd count, read mask, write mask, and exception mask. The exception +;;; mask is currently unused. +;;; +(defun calc-masks () + (let ((count 0) + (read-mask 0) + (write-mask 0) + (except-mask 0)) + (dolist (handler *descriptor-handlers*) + (unless (or (handler-active handler) + (handler-bogus handler)) + (let ((fd (handler-descriptor handler))) + (case (handler-direction handler) + (:input + (setf read-mask (logior read-mask (ash 1 fd)))) + (:output + (setf write-mask (logior write-mask (ash 1 fd))))) + (if (> fd count) + (setf count fd))))) + (values (1+ count) + read-mask + write-mask + except-mask))) + +;;; HANDLER-DESCRIPTORS-ERROR -- Internal. +;;; +;;; First, get a list and mark bad file descriptors. Then signal an error +;;; offering a few restarts. +;;; +(defun handler-descriptors-error () + (let ((bogus-handlers nil)) + (dolist (handler *descriptor-handlers*) + (unless (or (handler-bogus handler) + (mach:unix-fstat (handler-descriptor handler))) + (setf (handler-bogus handler) t) + (push handler bogus-handlers))) + (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P." + bogus-handlers (length bogus-handlers)) + (remove-them () :report "Remove bogus handlers." + (setf *descriptor-handlers* + (delete-if #'handler-bogus *descriptor-handlers*))) + (retry-them () :report "Retry bogus handlers." + (dolist (handler bogus-handlers) + (setf (handler-bogus handler) nil))) + (continue () :report "Go on, leaving handlers marked as bogus.")))) + + + +;;;; Serve-all-events, serve-event, and friends. + +;;; SERVE-ALL-EVENTS -- public +;;; +;;; Wait for up to timeout seconds for an event to happen. Make sure all +;;; pending events are processed before returning. +;;; +(defun serve-all-events (&optional timeout) + "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If + SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout + 0 until all events have been served. SERVE-ALL-EVENTS returns T if + SERVE-EVENT did something and NIL if not." + (do ((res nil) + (sval (serve-event timeout) (serve-event 0))) + ((null sval) res) + (setq res t))) + +;;; SERVE-EVENT -- public +;;; +;;; Serve a single event. +;;; +(defun serve-event (&optional timeout) + "Receive on all ports and Xevents and dispatch to the appropriate handler + function. If timeout is specified, server will wait the specified time (in + seconds) and then return, otherwise it will wait until something happens. + Server returns T if something happened and NIL otherwise." + ;; First, check any X displays for any pending events. + (dolist (d/h ext::*display-event-handlers*) + (let ((d (car d/h))) + (when (xlib::event-listen d) + (handler-bind ((error #'(lambda (condx) + (declare (ignore condx)) + (flush-display-events d)))) + (funcall (cdr d/h) d)) + (return-from serve-event t)))) + ;; Next, wait for something to happen. + (multiple-value-bind + (value readable writeable) + (wait-for-event timeout) + ;; Now see what it was (if anything) + (cond ((eq value server-unique-object) + ;; The interrupt handler fired. + (grab-message-loop) + t) + ((numberp value) + (unless (zerop value) + ;; Check the descriptors. + (let ((result nil)) + (dolist (handler *descriptor-handlers*) + (when (not (zerop (logand (ash 1 (handler-descriptor handler)) + (case (handler-direction handler) + (:input readable) + (:output writeable))))) + (unwind-protect + (progn + ;; Doesn't work -- ACK + ;(setf (handler-active handler) t) + (funcall (handler-function handler) + (handler-descriptor handler))) + (setf (handler-active handler) nil)) + (macrolet ((frob (var) + `(setf ,var + (logand (lognot (ash 1 + (handler-descriptor + handler))) + ,var)))) + (case (handler-direction handler) + (:input (frob readable)) + (:output (frob writeable)))) + (setf result t))) + result))) + ((eql readable mach:eintr) + ;; We did an interrupt. + t) + (t + ;; One of the file descriptors is bad. + (handler-descriptors-error) + nil)))) + +;;; WAIT-FOR-EVENT -- internal +;;; +;;; Wait for something to happen. +;;; +(defun wait-for-event (&optional timeout) + "Wait for an something to show up on one of the file descriptors or a message + interupt to fire. Timeout is in seconds." + (let (old-mask) + (multiple-value-bind (timeout-sec timeout-usec) + (if timeout + (truncate (round (* timeout 1000000)) 1000000) + (values nil 0)) + (multiple-value-bind (count read-mask write-mask except-mask) + (calc-masks) + (catch 'server-catch + (unwind-protect + (progn + ;; Block message interrupts. + (multiple-value-bind + (noise mask) + (mach:unix-sigsetmask (mach:sigmask :sigmsg)) + (declare (ignore noise)) + (setf old-mask mask)) + ;; Check for any pending messages, because we are only signaled + ;; for newly arived messages. This must be done after the + ;; unix-sigsetmask. + (when (grab-message-loop) + (return-from wait-for-event t)) + ;; Indicate that we are in the server. + (let ((*in-server* t)) + ;; Establish the interrupt handlers. + (enable-interrupt mach:sigmsg #'ih-sigmsg) + ;; Enable all interrupts. + (mach:unix-sigsetmask 0) + ;; Do the select. + (mach:unix-select count read-mask write-mask except-mask + timeout-sec timeout-usec))) + ;; Restore interrupt handler state. + (mach:unix-sigsetmask (mach:sigmask :sigmsg)) + (default-interrupt mach:sigmsg) + (mach:unix-sigsetmask old-mask))))))) + +