Elisp implementation of list-processes

[Bob Rogers <rogers-emacs@rgrjr.dyndns.org>]

   From: Stefan Monnier <monnier@IRO.UMontreal.CA>
   Date: Sun, 28 Nov 2010 13:49:36 -0500

   . . .

   BTW, rather than add a hook to this piece of C code, I'd much rather
   move this piece of code to Elisp first.  There is no good reason for it
   to be written in C.  If it can't currently be written in Elisp because
   of some missing Elisp primitives, then they should be added.

	   Stefan

A nearly complete Elisp implementation of Flist_processes is included
below; feedback welcome.  It should produce the identical output (except
for using buttons for buffer names), though I haven't tested it on the
more exotic kinds of processes.  The only thing I couldn't do was the
following snippet from the very end:

	if (exited)
	  {
	    status_notify (NULL);
	    redisplay_preserve_echo_area (13);
	  }

status_notify is a static function in process.c, used to clean up when
we find exited processes.  It is unclear to me whether
redisplay_preserve_echo_area is really necessary.  In any case, a small
DEFUN would seem to be in order.  Not sure what to call it, though;
"status_notify" is not very informative.  Perhaps "process-clean-up"?

   The only other question is:  Where should it go?  It is called from
save-buffers-kill-emacs in files.el (the only other use is in
lisp/eshell/esh-proc.el), but files.el is already pretty crowded.  On
the other hand, autoloading it for something so basic might be
problematic.  Suggestions?

					-- Bob Rogers
					   http://www.rgrjr.com/

------------------------------------------------------------------------
;;;; Elisp implementation of list-processes.

(defun list-proc-insert-line (minspace underline-p &rest labels-and-indents)
  (let ((tail labels-and-indents))
    (while tail
      (let ((item (pop tail)))
	(cond ((null item)
		;; Ignore the next.
		(pop tail))
	      ((integerp item)
		(indent-to item minspace))
	      (underline-p
		(insert (make-string (length item) ?-)))
	      ((bufferp item)
		(let ((name (buffer-name item)))
		  (if (not name)
		      (insert "(Killed)")
		      (insert-button (buffer-name item)
				     'action 'list-proc-button-select-buffer
				     'help-echo "mouse-2, RET: Select this buffer"
				     'buffer-name (buffer-name item)))))
	      (t
		(insert item))))))
  (insert "\n"))

(defun list-proc-button-select-buffer (button)
  ;; Select the buffer named by the buffer-name property of the button.
  (let* ((buffer-name (button-get button 'buffer-name))
	 (buffer (and buffer-name (get-buffer buffer-name))))
    (when buffer
      (switch-to-buffer buffer))))

(defun list-proc-make-command (proc)
  ;; Return a string that describes the process-command of PROC.  This is just
  ;; the list of command words for a normal subprocess, and a description for
  ;; network and serial connections.
  (let ((status (process-status proc))
	(proc-type (process-type proc))
	(command (process-command proc)))
    (cond ((eq status 'listen)
	    ;; It's a listening server socket.
	    (let ((port (plist-get (process-plist proc) :service))
		  (type (if (process-datagram-address proc)
			    "datagram" "stream")))
	      (cond ((integerp port)
		      (setq port (number-to-string port)))
		    ((null port)
		      (setq port (format-network-address
				   (plist-get (process-plist proc) :local)))))
	      (concat "(network " type " server on " port ")")))
	  ((eq proc-type 'network)
	    (let ((host (plist-get (process-plist proc) :host))
		  (type (if (process-datagram-address proc)
			    "datagram" "stream")))
	      (unless (stringp host)
		(setq host (plist-get (process-plist proc) :service))
		(when (integerp host)
		  (setq host (format "%d" host))))
	      (when (null host)
		(setq host (format-network-address
			     (plist-get (process-plist proc) :remote))))
	      (concat "(network " type " connection to "
		      (if (stringp host) host "?") ")")))
	  ((eq proc-type 'serial)
	    (let ((port (plist-get (process-plist proc) :port))
		  (speed (plist-get (process-plist proc) :speed)))
	      (concat "(serial port "
		      (if (stringp port) port "?")
		      (if (integerp speed)
			  (format " at %d b/s" speed)
			  "")
		      ")")))
	  (t
	    (mapconcat 'identity command " ")))))

(defun list-proc-make-status (proc)
  ;; Return a string describing the PROC's process-status.
  (let ((status (process-status proc)))
    (when (consp status)
      (setq status (car status)))
    (let ((result (cond ((eq status 'signal)
			  (symbol-name status))
			((member (process-type proc) '(network serial))
			  (cond ((eq status 'exit) "closed")
				((eq (process-command proc) t) "stopped")
				((eq status 'run) "open")
				(t (symbol-name status))))
			(t
			  (symbol-name status)))))
      (if (eq status 'exit)
	  (let ((code (cadr (process-status proc))))
	    (format "%s %d" result code))
	  result))))

(defun el-list-processes (&optional query-only)
  "Display a list of all processes.
If optional argument QUERY-ONLY is non-nil, only processes with
the query-on-exit flag set will be listed.
Any process listed as exited or signaled is actually eliminated
after the listing is made."
  (interactive)	       		  
  (with-current-buffer (get-buffer-create "*Process List*")
    (let ((w-proc 4)
	  (w-buffer 6)
	  (w-tty 0)
	  (filtered-processes nil))

      ;; Compute field widths.
      (dolist (proc (process-list))
	(let ((type (process-type proc))
	      (name (process-name proc))
	      (tty-name (process-tty-name proc))
	      (buffer (process-buffer proc)))
	  (when (and type
		     (or (not query-only)
			 (process-query-on-exit-flag proc)))
	    (push proc filtered-processes)
	    (if (and name (> (length name) w-proc))
		(setq w-proc (length name)))
	    (if buffer
		(let* ((buf-name (buffer-name buffer))
		       (len (if buf-name
				(length buf-name)
				;; "(Killed)"
				8)))
		  (if (> len w-buffer)
		      (setq w-buffer len))))
	    (if (and tty-name (> (length tty-name) w-tty))
		(setq w-tty (length tty-name))))))

      ;; Print headings.
      (let* ((i-status (+ w-proc 1))
	     (i-buffer (+ i-status 9))
	     (i-tty nil)
	     (i-command (+ i-buffer w-buffer 1))
	     (minspace 1)
	     (buffer-read-only nil)
	     (buffer-undo-list t))
	(when (> w-tty 0)
	  (setq i-tty i-command
		i-command (+ i-tty w-tty 1)))
	(setq truncate-lines t)
	(erase-buffer)
	(dolist (underline-p '(nil t))
	  (list-proc-insert-line minspace underline-p "Proc"
				 i-status "Status"
				 i-buffer "Buffer"
				 i-tty "Tty"
				 i-command "Command"))

	;; Generate content.
	(dolist (proc filtered-processes)
	  (list-proc-insert-line minspace nil (process-name proc)
				 i-status (list-proc-make-status proc)
				 i-buffer (or (process-buffer proc) "(none)")
				 i-tty (or (process-tty-name proc) "")
				 i-command (list-proc-make-command proc)))

	;; Done.
	(goto-char (point-min))
	(set-buffer-modified-p nil)
	(display-buffer (current-buffer))))))