list-processes reimplementation, and list/menu buffers

[Chong Yidong]

I took a look at the list-processes reimplementation.  It looks OK, but
there's no real reason we should display the same buffer contents as the
old list-processes.  Instead, it seems to make sense to provide
something similar to the list-packages and list-buffers interface.

I took some code from your emacs-process.el, and reworked it using the
list-packages code from package.el.  Unlike emacs-process.el, this
doesn't use the CL package, so it can be added to simple.el.


However, it would be cleaner to make a new `list-menu-mode' major mode,
usable for general "list of stuff" buffers.  Then both the list-packages
and list-processes can derive from that major mode.  With a bit more
work, list-buffers could use it too.  I will investigate this approach.



=== modified file 'lisp/simple.el'
*** lisp/simple.el      2011-03-31 04:24:03 +0000
--- lisp/simple.el      2011-04-04 00:16:17 +0000
***************
*** 2692,2697 ****
--- 2692,2851 ----
        (apply 'start-process name buffer program program-args))))
  
  
+ (defvar process-menu-mode-map
+   (let ((map (make-sparse-keymap)))
+     (define-key map "\C-k" 'process-menu-delete)
+     (define-key map " " 'next-line)
+     (define-key map "n" 'next-line)
+     (define-key map "p" 'previous-line)
+     (define-key map "g" 'revert-buffer)
+     map)
+   "Keymap for `process-menu-mode'.")
+ 
+ (defvar process-menu--query-only nil)
+ 
+ (define-derived-mode process-menu-mode special-mode "Process List"
+   "Major mode for the buffer created by `list-processes'."
+   (setq truncate-lines t)
+   (setq buffer-read-only t)
+   (set (make-local-variable 'revert-buffer-function) 'list-processes-revert)
+   (setq header-line-format
+       (mapconcat
+        (lambda (pair)
+          (let ((column (car pair))
+                (name (cdr pair)))
+            (concat
+             ;; Insert a space that aligns the button properly.
+             (propertize " " 'display (list 'space :align-to column)
+                         'face 'fixed-pitch)
+             name)))
+        '((0 . "")
+          (2 . "Process")
+          (16 . "Status")
+          (24 . "Buffer")
+          (40 . "TTY")
+          (54 . "Command"))
+        "")))
+ 
+ (defun process-menu-delete ()
+   (interactive)
+   (let ((proc (get-text-property (point) 'process-list-process)))
+     (if (null (processp proc))
+       (message "No process on this line.")
+       (if (y-or-n-p (format "Delete process %s? " (process-name proc)))
+         (progn
+           (delete-process proc)
+           (revert-buffer))
+       (message "Aborted")))))
+ 
+ (defun list-processes-revert (&optional arg noconfirm)
+   "Update the list of processes.
+ This function is the `revert-buffer-function' for Process List
+ buffers.  The arguments are ignored."
+   (interactive)
+   (list-processes process-menu--query-only (current-buffer)))
+ 
+ (defun process-menu-info (&optional query-only)
+   "Return a list of plist of process information.
+ Each list element has the form (PROCESS NAME STATUS BUFFER TTY COMMAND)."
+   (let (proc-list buf type contact)
+     (dolist (p (process-list))
+       (when (or (not query-only)
+               (process-query-on-exit-flag p))
+       (setq buf  (process-buffer p)
+             type (process-type p))
+       (push
+        (list p ; The process itself
+              (process-name p)                 ; Name
+              (symbol-name (process-status p)) ; Status
+              (and (buffer-live-p buf) buf)    ; Buffer
+              (process-tty-name p)             ; TTY
+              (cond                            ; Command
+               ((eq type 'network)
+                (setq contact (process-contact p t))
+                (format "(network %s %s)"
+                        (if (plist-get contact :type) "datagram" "network")
+                        (if (plist-get contact :server)
+                            (format "server on %s"
+                                    (plist-get contact :server))
+                          (format "connection to %s"
+                                  (plist-get contact :host)))))
+               ((eq type 'serial)
+                (setq contact (process-contact p t))
+                (format "(serial port %s%s)"
+                        (or (plist-get contact :port) "?")
+                        (let ((speed (plist-get contact :speed)))
+                          (if speed
+                              (format " at %s b/s" speed)
+                            ""))))
+               (t (mapconcat 'identity (process-command p) " "))))
+        proc-list)))
+     proc-list))
+ 
+ (defun list-processes (&optional query-only buffer)
+   "Display a list of all processes.
+ If optional argument QUERY-ONLY is non-nil, only processes with
+ the query-on-exit flag set are listed.
+ Any process listed as exited or signaled is actually eliminated
+ after the listing is made.
+ Optional argument BUFFER specifies a buffer to use, instead of
+ \"*Process List\".
+ The return value is always nil."
+   (interactive)
+   (let ((info (process-menu-info query-only))
+         (inhibit-read-only t)
+       (buf (or buffer (get-buffer-create "*Process List*")))
+         line)
+     (with-current-buffer buf
+       (setq line (line-number-at-pos))
+       (process-menu-mode)
+       (erase-buffer)
+       (set (make-local-variable 'process-menu--query-only) query-only)
+       (if info
+         (progn
+           (dolist (pinfo info)
+             (apply 'process-menu-insert pinfo))
+           ;; Leave point at the same line as before.
+           (goto-char (point-min))
+           (forward-line (1- line)))
+       (message "No processes exist"))
+       (set-buffer-modified-p nil))
+     (display-buffer buf))
+   nil)
+ 
+ (defun process-menu-insert (process name status buffer tty command)
+   (let (str)
+     (insert (propertize "  " 'process-list-process process))
+     (setq str name)
+     (insert
+      (propertize
+       (if (> (length str) 15)
+         (concat (substring str 0 12) "...")
+       str)
+       'help-echo name))
+     (indent-to 16 1)
+     (insert status)
+     (indent-to 24 1)
+     (if (null buffer)
+       (insert "--")
+       (setq str (buffer-name buffer))
+       (insert-text-button (if (> (length str) 15)
+                             (concat (substring str 0 12) "...")
+                           str)
+                         'face 'link
+                         'help-echo (concat "Visit buffer `"
+                                            (buffer-name buffer)
+                                            "'")
+                         'follow-link t
+                         'process-buffer buffer
+                         'action (lambda (button)
+                                   (display-buffer
+                                    (button-get button 'process-buffer)))))
+     (indent-to 40 1)
+     (insert tty)
+     (indent-to 54 1)
+     (insert command)))
+ 
  (defvar universal-argument-map
    (let ((map (make-sparse-keymap)))
      (define-key map [t] 'universal-argument-other-key)

=== modified file 'src/process.c'
*** src/process.c       2011-03-27 02:32:40 +0000
--- src/process.c       2011-04-04 00:12:35 +0000
***************
*** 1239,1486 ****
  
    return Qnil;
  }
- 
- static Lisp_Object
- list_processes_1 (Lisp_Object query_only)
- {
-   register Lisp_Object tail;
-   Lisp_Object proc, minspace;
-   register struct Lisp_Process *p;
-   char tembuf[300];
-   int w_proc, w_buffer, w_tty;
-   int exited = 0;
-   Lisp_Object i_status, i_buffer, i_tty, i_command;
- 
-   w_proc = 4;    /* Proc   */
-   w_buffer = 6;  /* Buffer */
-   w_tty = 0;     /* Omit if no ttys */
- 
-   for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
-     {
-       int i;
- 
-       proc = Fcdr (XCAR (tail));
-       p = XPROCESS (proc);
-       if (NILP (p->type))
-       continue;
-       if (!NILP (query_only) && p->kill_without_query)
-       continue;
-       if (STRINGP (p->name)
-         && ( i = SCHARS (p->name), (i > w_proc)))
-       w_proc = i;
-       if (!NILP (p->buffer))
-       {
-         if (NILP (BVAR (XBUFFER (p->buffer), name)))
-           {
-             if (w_buffer < 8)
-               w_buffer = 8;  /* (Killed) */
-           }
-         else if ((i = SCHARS (BVAR (XBUFFER (p->buffer), name)), (i > 
w_buffer)))
-           w_buffer = i;
-       }
-       if (STRINGP (p->tty_name)
-         && (i = SCHARS (p->tty_name), (i > w_tty)))
-       w_tty = i;
-     }
- 
-   XSETFASTINT (i_status, w_proc + 1);
-   XSETFASTINT (i_buffer, XFASTINT (i_status) + 9);
-   if (w_tty)
-     {
-       XSETFASTINT (i_tty, XFASTINT (i_buffer) + w_buffer + 1);
-       XSETFASTINT (i_command, XFASTINT (i_tty) + w_tty + 1);
-     }
-   else
-     {
-       i_tty = Qnil;
-       XSETFASTINT (i_command, XFASTINT (i_buffer) + w_buffer + 1);
-     }
- 
-   XSETFASTINT (minspace, 1);
- 
-   set_buffer_internal (XBUFFER (Vstandard_output));
-   BVAR (current_buffer, undo_list) = Qt;
- 
-   BVAR (current_buffer, truncate_lines) = Qt;
- 
-   write_string ("Proc", -1);
-   Findent_to (i_status, minspace); write_string ("Status", -1);
-   Findent_to (i_buffer, minspace); write_string ("Buffer", -1);
-   if (!NILP (i_tty))
-     {
-       Findent_to (i_tty, minspace); write_string ("Tty", -1);
-     }
-   Findent_to (i_command, minspace); write_string ("Command", -1);
-   write_string ("\n", -1);
- 
-   write_string ("----", -1);
-   Findent_to (i_status, minspace); write_string ("------", -1);
-   Findent_to (i_buffer, minspace); write_string ("------", -1);
-   if (!NILP (i_tty))
-     {
-       Findent_to (i_tty, minspace); write_string ("---", -1);
-     }
-   Findent_to (i_command, minspace); write_string ("-------", -1);
-   write_string ("\n", -1);
- 
-   for (tail = Vprocess_alist; CONSP (tail); tail = XCDR (tail))
-     {
-       Lisp_Object symbol;
- 
-       proc = Fcdr (XCAR (tail));
-       p = XPROCESS (proc);
-       if (NILP (p->type))
-       continue;
-       if (!NILP (query_only) && p->kill_without_query)
-       continue;
- 
-       Finsert (1, &p->name);
-       Findent_to (i_status, minspace);
- 
-       if (p->raw_status_new)
-       update_status (p);
-       symbol = p->status;
-       if (CONSP (p->status))
-       symbol = XCAR (p->status);
- 
-       if (EQ (symbol, Qsignal))
-       {
-         Lisp_Object tem;
-         tem = Fcar (Fcdr (p->status));
-         Fprinc (symbol, Qnil);
-       }
-       else if (NETCONN1_P (p) || SERIALCONN1_P (p))
-       {
-         if (EQ (symbol, Qexit))
-           write_string ("closed", -1);
-         else if (EQ (p->command, Qt))
-           write_string ("stopped", -1);
-         else if (EQ (symbol, Qrun))
-           write_string ("open", -1);
-         else
-           Fprinc (symbol, Qnil);
-       }
-       else if (SERIALCONN1_P (p))
-       {
-         write_string ("running", -1);
-       }
-       else
-       Fprinc (symbol, Qnil);
- 
-       if (EQ (symbol, Qexit))
-       {
-         Lisp_Object tem;
-         tem = Fcar (Fcdr (p->status));
-         if (XFASTINT (tem))
-           {
-             sprintf (tembuf, " %d", (int) XFASTINT (tem));
-             write_string (tembuf, -1);
-           }
-       }
- 
-       if (EQ (symbol, Qsignal) || EQ (symbol, Qexit) || EQ (symbol, Qclosed))
-       exited++;
- 
-       Findent_to (i_buffer, minspace);
-       if (NILP (p->buffer))
-       insert_string ("(none)");
-       else if (NILP (BVAR (XBUFFER (p->buffer), name)))
-       insert_string ("(Killed)");
-       else
-       Finsert (1, &BVAR (XBUFFER (p->buffer), name));
- 
-       if (!NILP (i_tty))
-       {
-         Findent_to (i_tty, minspace);
-         if (STRINGP (p->tty_name))
-           Finsert (1, &p->tty_name);
-       }
- 
-       Findent_to (i_command, minspace);
- 
-       if (EQ (p->status, Qlisten))
-       {
-         Lisp_Object port = Fplist_get (p->childp, QCservice);
-         if (INTEGERP (port))
-           port = Fnumber_to_string (port);
-         if (NILP (port))
-           port = Fformat_network_address (Fplist_get (p->childp, QClocal), 
Qnil);
-         sprintf (tembuf, "(network %s server on %s)\n",
-                  (DATAGRAM_CHAN_P (p->infd) ? "datagram" : "stream"),
-                  (STRINGP (port) ? SSDATA (port) : "?"));
-         insert_string (tembuf);
-       }
-       else if (NETCONN1_P (p))
-       {
-         /* For a local socket, there is no host name,
-            so display service instead.  */
-         Lisp_Object host = Fplist_get (p->childp, QChost);
-         if (!STRINGP (host))
-           {
-             host = Fplist_get (p->childp, QCservice);
-             if (INTEGERP (host))
-               host = Fnumber_to_string (host);
-           }
-         if (NILP (host))
-           host = Fformat_network_address (Fplist_get (p->childp, QCremote), 
Qnil);
-         sprintf (tembuf, "(network %s connection to %s)\n",
-                  (DATAGRAM_CHAN_P (p->infd) ? "datagram" : "stream"),
-                  (STRINGP (host) ? SSDATA (host) : "?"));
-         insert_string (tembuf);
-       }
-       else if (SERIALCONN1_P (p))
-       {
-         Lisp_Object port = Fplist_get (p->childp, QCport);
-         Lisp_Object speed = Fplist_get (p->childp, QCspeed);
-         insert_string ("(serial port ");
-         if (STRINGP (port))
-           insert_string (SSDATA (port));
-         else
-           insert_string ("?");
-         if (INTEGERP (speed))
-           {
-             sprintf (tembuf, " at %ld b/s", (long) XINT (speed));
-             insert_string (tembuf);
-           }
-         insert_string (")\n");
-       }
-       else
-       {
-         Lisp_Object tem = p->command;
-         while (1)
-           {
-             Lisp_Object tem1 = Fcar (tem);
-             if (NILP (tem1))
-               break;
-             Finsert (1, &tem1);
-             tem = Fcdr (tem);
-             if (NILP (tem))
-               break;
-             insert_string (" ");
-           }
-         insert_string ("\n");
-        }
-     }
-   if (exited)
-     {
-       status_notify (NULL);
-       redisplay_preserve_echo_area (13);
-     }
-   return Qnil;
- }
- 
- DEFUN ("list-processes", Flist_processes, Slist_processes, 0, 1, "P",
-        doc: /* 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.  */)
-   (Lisp_Object query_only)
- {
-   internal_with_output_to_temp_buffer ("*Process List*",
-                                      list_processes_1, query_only);
-   return Qnil;
- }
  
  DEFUN ("process-list", Fprocess_list, Sprocess_list, 0, 0, 0,
         doc: /* Return a list of all processes.  */)
--- 1239,1244 ----
***************
*** 7679,7685 ****
    defsubr (&Sprocess_contact);
    defsubr (&Sprocess_plist);
    defsubr (&Sset_process_plist);
-   defsubr (&Slist_processes);
    defsubr (&Sprocess_list);
    defsubr (&Sstart_process);
    defsubr (&Sserial_process_configure);
--- 7437,7442 ----