changeset 100847:883cbe72dc04

(proced-grammar-alist): Refiner can be a list (function help-echo) instead of a cons pair. (proced-post-display-hook): New variable. (proced-tree-depth): Renamed from proced-tree-indent. (proced-mode): Derive mode from special-mode. (proced-mode-map): Changed accordingly. (proced, proced-update): Run proced-post-display-hook. (proced-do-mark-all): Count processes for which mark has been updated. (proced-format): Check for ppid attribute. (proced-process-attributes): Take time and ctime attribute from system-process-attributes. (proced-send-signal): Doc fix. Collect properly the info on marked processes. Use fit-window-to-buffer instead of dired-pop-to-buffer.

--- a/lisp/proced.el	Sat Jan 03 11:17:47 2009 +0000
+++ b/lisp/proced.el	Sat Jan 03 12:18:53 2009 +0000
@@ -102,7 +102,7 @@
     (comm    "COMMAND" nil left proced-string-lessp nil (comm pid) (nil t nil))
     (state   "STAT"    nil left proced-string-lessp nil (state pid) (nil t nil))
     (ppid    "PPID"    "%d" right proced-< nil (ppid pid)
-             ((lambda (ppid) (proced-filter-parents proced-process-alist ppid)) .
+             ((lambda (ppid) (proced-filter-parents proced-process-alist ppid))
               "refine to process parents"))
     (pgrp    "PGRP"    "%d" right proced-< nil (pgrp euid pid) (nil t nil))
     (sess    "SESS"    "%d" right proced-< nil (sess pid) (nil t nil))
@@ -114,8 +114,10 @@
     (cmajflt "CMAJFLT" "%d" right proced-< nil (cmajflt pid) (nil t t))
     (utime   "UTIME"   proced-format-time right proced-time-lessp t (utime pid) (nil t t))
     (stime   "STIME"   proced-format-time right proced-time-lessp t (stime pid) (nil t t))
+    (time    "TIME"   proced-format-time right proced-time-lessp t (time pid) (nil t t))
     (cutime  "CUTIME"  proced-format-time right proced-time-lessp t (cutime pid) (nil t t))
     (cstime  "CSTIME"  proced-format-time right proced-time-lessp t (cstime pid) (nil t t))
+    (ctime   "CTIME"  proced-format-time right proced-time-lessp t (ctime pid) (nil t t))
     (pri     "PR"      "%d" right proced-< t (pri pid) (nil t t))
     (nice    "NI"      "%3d" 3 proced-< t (nice pid) (t t nil))
     (thcount "THCOUNT" "%d" right proced-< t (thcount pid) (nil t t))
@@ -129,12 +131,8 @@
     ;;
     ;; attributes defined by proced (see `proced-process-attributes')
     (pid     "PID"     "%d" right proced-< nil (pid)
-             ((lambda (ppid) (proced-filter-children proced-process-alist ppid)) .
+             ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
               "refine to process children"))
-    ;; time: sum of utime and stime
-    (time    "TIME"   proced-format-time right proced-time-lessp t (time pid) (nil t t))
-    ;; ctime: sum of cutime and cstime
-    (ctime   "CTIME"  proced-format-time right proced-time-lessp t (ctime pid) (nil t t))
     ;; process tree
     (tree    "TREE"   proced-format-tree left nil nil nil nil))
   "Alist of rules for handling Proced attributes.
@@ -183,7 +181,7 @@
 If PREDICATE yields 'equal, the process is accepted if EQUAL-B is non-nil.
 If PREDICATE yields nil, the process is accepted if LARGER-B is non-nil.
 
-REFINER can also be a cons pair (FUNCTION . HELP-ECHO).
+REFINER can also be a list (FUNCTION HELP-ECHO).
 FUNCTION is called with one argument, the PID of the process at the position
 of point.  The function must return a list of PIDs that is used for the refined
 listing.  HELP-ECHO is a string that is shown when mouse is over this field.
@@ -208,12 +206,12 @@
                        (repeat :tag "Sort Scheme" (symbol :tag "Key"))
                        (choice :tag "Refiner"
                                (const :tag "None" nil)
+                               (list (function :tag "Refinement Function")
+                                     (string :tag "Help echo"))
                                (list :tag "Refine Flags"
                                      (boolean :tag "Less")
                                      (boolean :tag "Equal")
-                                     (boolean :tag "Larger"))
-                               (cons (function :tag "Refinement Function")
-                                     (string :tag "Help echo"))))))
+                                     (boolean :tag "Larger"))))))
 
 (defcustom proced-custom-attributes nil
   "List of functions defining custom attributes.
@@ -351,6 +349,13 @@
   :type 'boolean)
 (make-variable-buffer-local 'proced-tree-flag)
 
+(defcustom proced-post-display-hook nil
+  "Normal hook run after displaying or updating a Proced buffer.
+May be used to adapt the window size via `fit-window-to-buffer'."
+  :type 'hook
+  :options '(fit-window-to-buffer)
+  :group 'proced)
+
 ;; Internal variables
 
 (defvar proced-available (not (null (list-system-processes)))
@@ -405,8 +410,8 @@
 (defvar proced-process-tree nil
   "Proced process tree (internal variable).")
 
-(defvar proced-tree-indent nil
-  "Internal variable for indentation of Proced process tree.")
+(defvar proced-tree-depth nil
+  "Internal variable for depth of Proced process tree.")
 
 (defvar proced-auto-update-timer nil
   "Stores if Proced auto update timer is already installed.")
@@ -478,12 +483,11 @@
     (define-key km "x" 'proced-send-signal) ; Dired compatibility
     (define-key km "k" 'proced-send-signal) ; kill processes
     ;; misc
-    (define-key km "g" 'revert-buffer)  ; Dired compatibility
     (define-key km "h" 'describe-mode)
     (define-key km "?" 'proced-help)
-    (define-key km "q" 'quit-window)
     (define-key km [remap undo] 'proced-undo)
     (define-key km [remap advertised-undo] 'proced-undo)
+    ;; Additional keybindings are inherited from `special-mode-map'
     km)
   "Keymap for Proced commands.")
 
@@ -594,7 +598,7 @@
 
 ;; proced mode
 
-(define-derived-mode proced-mode nil "Proced"
+(define-derived-mode proced-mode special-mode "Proced"
   "Mode for displaying UNIX system processes and sending signals to them.
 Type \\[proced] to start a Proced session.  In a Proced buffer
 type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
@@ -623,6 +627,9 @@
 The attribute-specific rules for formatting, filtering, sorting, and refining
 are defined in `proced-grammar-alist'.
 
+After displaying or updating a Proced buffer, Proced runs the normal hook
+`proced-post-display-hook'.
+
 \\{proced-mode-map}"
   (abbrev-mode 0)
   (auto-fill-mode 0)
@@ -638,14 +645,12 @@
             (run-at-time t proced-auto-update-interval
                          'proced-auto-update-timer))))
 
-;; Proced mode is suitable only for specially formatted data.
-(put 'proced-mode 'mode-class 'special)
-
 ;;;###autoload
 (defun proced (&optional arg)
   "Generate a listing of UNIX system processes.
 If invoked with optional ARG the window displaying the process
 information will be displayed but not selected.
+Runs the normal hook `proced-post-display-hook'.
 
 See `proced-mode' for a description of features available in Proced buffers."
   (interactive "P")
@@ -654,12 +659,21 @@
   (let ((buffer (get-buffer-create "*Proced*")) new)
     (set-buffer buffer)
     (setq new (zerop (buffer-size)))
-    (if new (proced-mode))
-    (if (or new arg)
-        (proced-update t))
+    (when new
+      (proced-mode)
+      ;; `proced-update' runs `proced-post-display-hook' only if the
+      ;; Proced buffer has been selected.  Yet the following call of
+      ;; `proced-update' is for an empty Proced buffer that has not
+      ;; yet been selected.  Therefore we need to call
+      ;; `proced-post-display-hook' below.
+      (proced-update t))
     (if arg
-	(display-buffer buffer)
+        (progn
+          (display-buffer buffer)
+          (with-current-buffer buffer
+            (run-hooks 'proced-post-display-hook)))
       (pop-to-buffer buffer)
+      (run-hooks 'proced-post-display-hook)
       (message
        (substitute-command-keys
         "Type \\<proced-mode-map>\\[quit-window] to quit, \\[proced-help] for help")))))
@@ -685,6 +699,8 @@
   (message "Proced auto update %s"
            (if proced-auto-update-flag "enabled" "disabled")))
 
+;;; Mark
+
 (defun proced-mark (&optional count)
   "Mark the current (or next COUNT) processes."
   (interactive "p")
@@ -714,43 +730,6 @@
       (proced-insert-mark mark backward))
     (proced-move-to-goal-column)))
 
-(defun proced-mark-all ()
-  "Mark all processes.
-If `transient-mark-mode' is turned on and the region is active,
-mark the region."
-  (interactive)
-  (proced-do-mark-all t))
-
-(defun proced-unmark-all ()
-  "Unmark all processes.
-If `transient-mark-mode' is turned on and the region is active,
-unmark the region."
-  (interactive)
-  (proced-do-mark-all nil))
-
-(defun proced-do-mark-all (mark)
-  "Mark all processes using MARK.
-If `transient-mark-mode' is turned on and the region is active,
-mark the region."
-  (let ((count 0) end buffer-read-only)
-    (save-excursion
-      (if (use-region-p)
-          ;; Operate even on those lines that are only partially a part
-          ;; of region.  This appears most consistent with
-          ;; `proced-move-to-goal-column'.
-          (progn (setq end (save-excursion
-                             (goto-char (region-end))
-                             (unless (looking-at "^") (forward-line))
-                             (point)))
-                 (goto-char (region-beginning))
-                 (unless (looking-at "^") (beginning-of-line)))
-        (goto-char (point-min))
-        (setq end (point-max)))
-      (while (< (point) end)
-        (setq count (1+ count))
-        (proced-insert-mark mark))
-      (proced-success-message "Marked" count))))
-
 (defun proced-toggle-marks ()
   "Toggle marks: marked processes become unmarked, and vice versa."
   (interactive)
@@ -775,6 +754,49 @@
   (delete-char 1)
   (unless backward (forward-line)))
 
+(defun proced-mark-all ()
+  "Mark all processes.
+If `transient-mark-mode' is turned on and the region is active,
+mark the region."
+  (interactive)
+  (proced-do-mark-all t))
+
+(defun proced-unmark-all ()
+  "Unmark all processes.
+If `transient-mark-mode' is turned on and the region is active,
+unmark the region."
+  (interactive)
+  (proced-do-mark-all nil))
+
+(defun proced-do-mark-all (mark)
+  "Mark all processes using MARK.
+If `transient-mark-mode' is turned on and the region is active,
+mark the region."
+  (let* ((count 0)
+         (proced-marker-char (if mark proced-marker-char ?\s))
+         (marker-re (proced-marker-regexp))
+         end buffer-read-only)
+    (save-excursion
+      (if (use-region-p)
+          ;; Operate even on those lines that are only partially a part
+          ;; of region.  This appears most consistent with
+          ;; `proced-move-to-goal-column'.
+          (progn (setq end (save-excursion
+                             (goto-char (region-end))
+                             (unless (looking-at "^") (forward-line))
+                             (point)))
+                 (goto-char (region-beginning))
+                 (unless (looking-at "^") (beginning-of-line)))
+        (goto-char (point-min))
+        (setq end (point-max)))
+      (while (< (point) end)
+        (unless (looking-at marker-re)
+          (setq count (1+ count))
+          (insert proced-marker-char)
+          (delete-char 1))
+        (forward-line))
+      (proced-success-message (if mark "Marked" "Unmarked") count))))
+
 (defun proced-mark-children (ppid &optional omit-ppid)
   "Mark child processes of process PPID.
 Also mark process PPID unless prefix OMIT-PPID is non-nil."
@@ -1026,7 +1048,7 @@
   (if proced-tree-flag
       ;; add tree attribute
       (let ((process-tree (proced-process-tree process-alist))
-            (proced-tree-indent 0)
+            (proced-tree-depth 0)
             (proced-temp-alist process-alist)
             proced-process-tree pt)
         (while (setq pt (pop process-tree))
@@ -1044,11 +1066,11 @@
   "Helper function for `proced-tree'."
   (let ((pprocess (assq (car process-tree) proced-temp-alist)))
     (push (append (list (car pprocess))
-                  (list (cons 'tree proced-tree-indent))
+                  (list (cons 'tree proced-tree-depth))
                   (cdr pprocess))
           proced-process-tree)
     (if (cdr process-tree)
-        (let ((proced-tree-indent (1+ proced-tree-indent)))
+        (let ((proced-tree-depth (1+ proced-tree-depth)))
           (mapc 'proced-tree-insert (cdr process-tree))))))
 
 ;; Refining
@@ -1361,7 +1383,9 @@
   (let ((standard-attributes
          (car (proced-process-attributes (list (emacs-pid)))))
         new-format fmi)
-    (if proced-tree-flag (push (cons 'tree 0) standard-attributes))
+    (if (and proced-tree-flag
+             (assq 'ppid standard-attributes))
+        (push (cons 'tree 0) standard-attributes))
     (dolist (fmt format)
       (if (symbolp fmt)
           (if (assq fmt standard-attributes)
@@ -1402,7 +1426,7 @@
               (cond ((functionp (car refiner))
                      `(proced-key ,key mouse-face highlight
                                   help-echo ,(format "mouse-2, RET: %s"
-                                                     (cdr refiner))))
+                                                     (nth 1 refiner))))
                     ((consp refiner)
                      `(proced-key ,key mouse-face highlight
                                   help-echo ,(format "mouse-2, RET: refine by attribute %s %s"
@@ -1504,30 +1528,21 @@
 the process is ignored."
   ;; Should we make it customizable whether processes with empty attribute
   ;; lists are ignored?  When would such processes be of interest?
-  (let (process-alist attributes)
+  (let (process-alist attributes attr)
     (dolist (pid (or pid-list (list-system-processes)) process-alist)
       (when (setq attributes (system-process-attributes pid))
-        (let ((utime (cdr (assq 'utime attributes)))
-              (stime (cdr (assq 'stime attributes)))
-              (cutime (cdr (assq 'cutime attributes)))
-              (cstime (cdr (assq 'cstime attributes)))
-              attr)
-          (setq attributes
-                (append (list (cons 'pid pid))
-                        (if (and utime stime)
-                            (list (cons 'time (time-add utime stime))))
-                        (if (and cutime cstime)
-                            (list (cons 'ctime (time-add cutime cstime))))
-                        attributes))
-          (dolist (fun proced-custom-attributes)
-            (if (setq attr (funcall fun attributes))
-                (push attr attributes)))
-          (push (cons pid attributes) process-alist))))))
+        (setq attributes (cons (cons 'pid pid) attributes))
+        (dolist (fun proced-custom-attributes)
+          (if (setq attr (funcall fun attributes))
+              (push attr attributes)))
+        (push (cons pid attributes) process-alist)))))
 
 (defun proced-update (&optional revert quiet)
   "Update the Proced process information.  Preserves point and marks.
 With prefix REVERT non-nil, revert listing.
-Suppress status information if QUIET is nil."
+Suppress status information if QUIET is nil.
+After updating a displayed Proced buffer run the normal hook
+`proced-post-display-hook'."
   ;; This is the main function that generates and updates the process listing.
   (interactive "P")
   (setq revert (or revert (not proced-process-alist)))
@@ -1643,6 +1658,8 @@
                                 (nth 1 grammar)))
                     "")))
     (force-mode-line-update)
+    ;; run `proced-post-display-hook' only for a displayed buffer.
+    (if (get-buffer-window) (run-hooks 'proced-post-display-hook))
     ;; done
     (or quiet (input-pending-p)
         (message (if revert "Updating process information...done."
@@ -1653,17 +1670,13 @@
 Preserves point and marks."
   (proced-update t))
 
-;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
-;; and move it to window.el so that proced and ibuffer can easily use it, too?
-;; What about functions like `appt-disp-window' that use
-;; `shrink-window-if-larger-than-buffer'?
-(autoload 'dired-pop-to-buffer "dired")
-
 (defun proced-send-signal (&optional signal)
   "Send a SIGNAL to the marked processes.
 If no process is marked, operate on current process.
 SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
-If SIGNAL is nil display marked processes and query interactively for SIGNAL."
+If SIGNAL is nil display marked processes and query interactively for SIGNAL.
+After sending the signal, this command runs the normal hook
+`proced-after-send-signal-hook'."
   (interactive)
   (let ((regexp (proced-marker-regexp))
         process-alist)
@@ -1673,7 +1686,9 @@
       (while (re-search-forward regexp nil t)
         (push (cons (proced-pid-at-point)
                     ;; How much info should we collect here?
-                    (substring (match-string-no-properties 0) 2))
+                    (buffer-substring-no-properties
+                     (+ 2 (line-beginning-position))
+                     (line-end-position)))
               process-alist)))
     (setq process-alist
           (if process-alist
@@ -1696,7 +1711,8 @@
           (dolist (process process-alist)
             (insert "  " (cdr process) "\n"))
           (save-window-excursion
-            (dired-pop-to-buffer bufname) ; all we need
+            (pop-to-buffer (current-buffer))
+            (fit-window-to-buffer (get-buffer-window) nil 1)
             (let* ((completion-ignore-case t)
                    (pnum (if (= 1 (length process-alist))
                              "1 process"
@@ -1729,7 +1745,7 @@
                         (setq count (1+ count))
                       (proced-log "%s\n" (cdr process))
                       (push (cdr process) failures))
-                  (error ;; catch errors from failed signals
+                  (error ; catch errors from failed signals
                    (proced-log "%s\n" err)
                    (proced-log "%s\n" (cdr process))
                    (push (cdr process) failures)))))
@@ -1746,7 +1762,7 @@
                       (proced-log (current-buffer))
                       (proced-log "%s\n" (cdr process))
                       (push (cdr process) failures))
-                  (error ;; catch errors from failed signals
+                  (error ; catch errors from failed signals
                    (proced-log (current-buffer))
                    (proced-log "%s\n" (cdr process))
                    (push (cdr process) failures)))))))