(proced-grammar-alist): Allow predicate nil. New attribute tree.

(proced-format-alist): Use attribute tree.
(proced-tree-flag, proced-tree-indent): New variables.
(proced-children-alist): Renamed from proced-process-tree.  PPID
must refer to a process in process-alist.  Ignore PPIDs that equal
PID.  Children alist inherits sorting order from process-alist.
(proced-process-tree): New variable.  New function.
(proced-process-tree-internal, proced-toggle-tree)
(proced-tree, proced-tree-insert, proced-format-tree): New
functions.
(proced-mark-process-alist): Add docstring.
(proced-filter-parents): PPID must refer to a process in
process-alist.  Ignore PPIDs that equal PID.
(proced-sort): Throw error if attribute is not sortable.
(proced-sort-interactive): Restrict completion to sortable
attributes.
(proced-format): Include tree in standard attributes if
proced-tree-flag is non-nil.  Make header clickable only if
corresponding predicate is non-nil.
(proced-update): Use proced-tree.

1 files changed, 163 insertions, 35 deletions

diff --git a/lisp/proced.el b/lisp/proced.el
index 9590e921bf0..2004410a17b 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -137,7 +137,9 @@ the external command (usually \"kill\")."
     ;; 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)))
+    (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.
 
 Each element has the form
@@ -164,6 +166,7 @@ based on attribute KEY.  PREDICATE takes two arguments P1 and P2,
 the corresponding attribute values of two processes.  PREDICATE should
 return 'equal if P1 has same rank like P2.  Any other non-nil value says
 that P1 is \"less than\" P2, or nil if not.
+If PREDICATE is nil the attribute cannot be sorted.
 
 PREDICATE defines an ascending sort order.  REVERSE is non-nil if the sort
 order is descending.
@@ -201,17 +204,19 @@ If REFINER is nil no refinement is done."
                                (const :tag "left" left)
                                (const :tag "right" right)
                                (integer :tag "width"))
-                       (function :tag "Predicate")
+                       (choice :tag "Predicate"
+                               (const :tag "None" nil)
+                               (function :tag "Function"))
                        (boolean :tag "Descending Sort Order")
                        (repeat :tag "Sort Scheme" (symbol :tag "Key"))
                        (choice :tag "Refiner"
+                               (const :tag "None" nil)
                                (list :tag "Refine Flags"
                                      (boolean :tag "Less")
                                      (boolean :tag "Equal")
                                      (boolean :tag "Larger"))
                                (cons (function :tag "Refinement Function")
-                                     (string :tag "Help echo"))
-                               (const :tag "None" nil)))))
+                                     (string :tag "Help echo"))))))
 
 (defcustom proced-custom-attributes nil
   "List of functions defining custom attributes.
@@ -232,11 +237,11 @@ If the function returns nil, the value is ignored."
 ;; Sorting can also be based on attributes that are invisible in the listing.
 
 (defcustom proced-format-alist
-  '((short user pid pcpu pmem start time (args comm))
-    (medium user pid pcpu pmem vsize rss ttname state start time (args comm))
-    (long user euid group pid pri nice pcpu pmem vsize rss ttname state
+  '((short user pid tree pcpu pmem start time (args comm))
+    (medium user pid tree pcpu pmem vsize rss ttname state start time (args comm))
+    (long user euid group pid tree pri nice pcpu pmem vsize rss ttname state
           start time (args comm))
-    (verbose user euid group egid pid ppid pgrp sess pri nice pcpu pmem
+    (verbose user euid group egid pid ppid tree pgrp sess pri nice pcpu pmem
              state thcount vsize rss ttname tpgid minflt majflt cminflt cmajflt
              start time utime stime ctime cutime cstime etime (args comm)))
   "Alist of formats of listing.
@@ -343,6 +348,12 @@ Can be changed interactively via `proced-toggle-auto-update'."
   :type 'boolean)
 (make-variable-buffer-local 'proced-auto-update-flag)
 
+(defcustom proced-tree-flag nil
+  "Non-nil for display of Proced-buffer as process tree."
+  :group 'proced
+  :type 'boolean)
+(make-variable-buffer-local 'proced-tree-flag)
+
 ;; Internal variables
 
 (defvar proced-available (not (null (list-system-processes)))
@@ -391,8 +402,14 @@ Important: the match ends just after the marker.")
   "Headers in Proced buffer as a string.")
 (make-variable-buffer-local 'proced-header-line)
 
+(defvar proced-children-alist nil
+  "Children alist of process listing (internal variable).")
+
 (defvar proced-process-tree nil
-  "Process tree of listing (internal variable).")
+  "Proced process tree (internal variable).")
+
+(defvar proced-tree-indent nil
+  "Internal variable for indentation of Proced process tree.")
 
 (defvar proced-auto-update-timer nil
   "Stores if Proced auto update timer is already installed.")
@@ -456,6 +473,7 @@ Important: the match ends just after the marker.")
     ;; similar to `Buffer-menu-sort-by-column'
     (define-key km [header-line mouse-1] 'proced-sort-header)
     (define-key km [header-line mouse-2] 'proced-sort-header)
+    (define-key km "T" 'proced-toggle-tree)
     ;; formatting
     (define-key km "F"  'proced-format-interactive)
     ;; operate
@@ -519,6 +537,10 @@ Important: the match ends just after the marker.")
                      :style radio
                      :selected (eq proced-format ',format)]))
                proced-format-alist))
+    ["Tree Display" proced-toggle-tree
+     :style toggle
+     :selected (eval proced-tree-flag)
+     :help "Display Proced Buffer as Process Tree"]
     "--"
     ["Omit Marked Processes" proced-omit-processes
      :help "Omit Marked Processes in Process Listing."]
@@ -595,6 +617,9 @@ Type \\[proced-sort-interactive] or click on a header in the header line
 to change the sort scheme.  The current sort scheme is indicated in the
 mode line, using \"+\" or \"-\" for ascending or descending sort order.
 
+Type \\[proced-toggle-tree] to toggle whether the listing is
+displayed as process tree.
+
 An existing Proced listing can be refined by typing \\[proced-refine].
 Refining an existing listing does not update the variable `proced-filter'.
 
@@ -768,6 +793,8 @@ Also mark CPID unless prefix OMIT-CPID is non-nil."
    (proced-filter-parents proced-process-alist cpid omit-cpid)))
 
 (defun proced-mark-process-alist (process-alist &optional quiet)
+  "Mark processes in PROCESS-ALIST.
+If QUIET is non-nil suppress status message."
   (let ((count 0))
     (if process-alist
         (let (buffer-read-only)
@@ -876,26 +903,104 @@ Set variable `proced-filter' to SCHEME.  Revert listing."
     (setq proced-filter scheme)
     (proced-update t)))
 
-(defun proced-process-tree (process-alist)
-  "Return process tree for PROCESS-ALIST.
-The process tree is an alist with elements (PPID PID1 PID2 ...).
+(defun proced-children-alist (process-alist)
+  "Return children alist for PROCESS-ALIST.
+The children alist has elements (PPID PID1 PID2 ...).
 PPID is a parent PID.  PID1, PID2, ... are the child processes of PPID.
+The children alist inherits the sorting order from PROCESS-ALIST.
 The list of children does not include grandchildren."
-  (let (children-list ppid cpids)
-    (dolist (process process-alist children-list)
+  ;; The PPIDs inherit the sorting order of PROCESS-ALIST.
+  (let ((process-tree (mapcar (lambda (a) (list (car a))) process-alist))
+        ppid)
+    (dolist (process process-alist)
       (setq ppid (cdr (assq 'ppid (cdr process))))
-      (if ppid
-          (setq children-list
-                (if (setq cpids (assq ppid children-list))
-                    (cons (cons ppid (cons (car process) (cdr cpids)))
-                          (assq-delete-all ppid children-list))
-                  (cons (list ppid (car process))
-                        children-list)))))))
+      (if (and ppid
+               ;; Ignore a PPID that equals PID.
+               (/= ppid (car process))
+               ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
+               (assq ppid process-alist))
+          (let ((temp-alist process-tree) elt)
+            (while (setq elt (pop temp-alist))
+              (when (eq ppid (car elt))
+                (setq temp-alist nil)
+                (setcdr elt (cons (car process) (cdr elt))))))))
+    ;; The child processes inherit the sorting order of PROCESS-ALIST.
+    (setq process-tree
+          (mapcar (lambda (a) (cons (car a) (nreverse (cdr a))))
+                  process-tree))))
+
+(defun proced-process-tree (process-alist)
+  "Return process tree for PROCESS-ALIST."
+  (let ((proced-children-alist (proced-children-alist process-alist))
+        pid-alist proced-process-tree)
+    (while (setq pid-alist (pop proced-children-alist))
+      (push (proced-process-tree-internal pid-alist) proced-process-tree))
+    (nreverse proced-process-tree)))
+
+(defun proced-process-tree-internal (pid-alist)
+  "Helper function for `proced-process-tree'."
+  (let ((cpid-list (cdr pid-alist)) cpid-alist cpid)
+    (while (setq cpid (car cpid-list))
+      (if (setq cpid-alist (assq cpid proced-children-alist))
+          ;; Unprocessed part of process tree that needs to be
+          ;; analyzed recursively.
+          (progn
+            (setq proced-children-alist
+                  (assq-delete-all cpid proced-children-alist))
+            (setcar cpid-list (proced-process-tree-internal cpid-alist)))
+        ;; We already processed this subtree and take it "as is".
+        (setcar cpid-list (assq cpid proced-process-tree))
+        (setq proced-process-tree
+              (assq-delete-all cpid proced-process-tree)))
+      (pop cpid-list)))
+  pid-alist)
+
+(defun proced-toggle-tree (arg)
+  "Change whether this Proced buffer is displayed as process tree.
+With prefix ARG, display as process tree if ARG is positive, otherwise
+do not display as process tree.  Sets the variable `proced-tree-flag'."
+  (interactive (list (or current-prefix-arg 'toggle)))
+  (setq proced-tree-flag
+        (cond ((eq arg 'toggle) (not proced-tree-flag))
+              (arg (> (prefix-numeric-value arg) 0))
+              (t (not proced-tree-flag))))
+  (proced-update)
+  (message "Proced process tree display %s"
+           (if proced-tree-flag "enabled" "disabled")))
+
+(defun proced-tree (process-alist)
+  "Display Proced buffer as process tree if `proced-tree-flag' is non-nil.
+If `proced-tree-flag' is non-nil, convert PROCESS-ALIST into a linear
+process tree with a time attribute.  Otherwise, remove the tree attribute."
+  (if proced-tree-flag
+      ;; add tree attribute
+      (let ((process-tree (proced-process-tree process-alist))
+            (proced-tree-indent 0)
+            proced-process-tree pt)
+        (while (setq pt (pop process-tree))
+          (proced-tree-insert pt))
+        (nreverse proced-process-tree))
+    (let (new-alist)
+      ;; remove tree attribute
+      (dolist (process process-alist)
+        (push (assq-delete-all 'tree process) new-alist))
+      (nreverse new-alist))))
+
+(defun proced-tree-insert (process-tree)
+  "Helper function for `proced-tree'."
+  (let ((pprocess (assq (car process-tree) proced-process-alist)))
+    (push (append (list (car pprocess))
+                  (list (cons 'tree proced-tree-indent))
+                  (cdr pprocess))
+          proced-process-tree)
+    (if (cdr process-tree)
+        (let ((proced-tree-indent (1+ proced-tree-indent)))
+          (mapc 'proced-tree-insert (cdr process-tree))))))
 
 (defun proced-filter-children (process-alist ppid &optional omit-ppid)
   "For PROCESS-ALIST return list of child processes of PPID.
 This list includes PPID unless OMIT-PPID is non-nil."
-  (let ((proced-process-tree (proced-process-tree process-alist))
+  (let ((proced-children-alist (proced-children-alist process-alist))
         new-alist)
     (dolist (pid (proced-children-pids ppid))
       (push (assq pid process-alist) new-alist))
@@ -903,10 +1008,9 @@ This list includes PPID unless OMIT-PPID is non-nil."
         (assq-delete-all ppid new-alist)
       new-alist)))
 
-;; helper function
 (defun proced-children-pids (ppid)
   "Return list of children PIDs of PPID (including PPID)."
-  (let ((cpids (cdr (assq ppid proced-process-tree))))
+  (let ((cpids (cdr (assq ppid proced-children-alist))))
     (if cpids
         (cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
       (list ppid))))
@@ -914,9 +1018,16 @@ This list includes PPID unless OMIT-PPID is non-nil."
 (defun proced-filter-parents (process-alist pid &optional omit-pid)
   "For PROCESS-ALIST return list of parent processes of PID.
 This list includes PID unless OMIT-PID is non-nil."
-  (let ((parent-list (unless omit-pid (list (assq pid process-alist)))))
-    (while (setq pid (cdr (assq 'ppid (cdr (assq pid process-alist)))))
-      (push (assq pid process-alist) parent-list))
+  (let ((parent-list (unless omit-pid (list (assq pid process-alist))))
+        (process (assq pid process-alist))
+        ppid)
+    (while (and (setq ppid (cdr (assq 'ppid (cdr process))))
+                ;; Ignore a PPID that equals PID.
+                (/= ppid pid)
+                ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
+                (setq process (assq ppid process-alist)))
+      (setq pid ppid)
+      (push process parent-list))
     parent-list))
 
 ;; Refining
@@ -1055,6 +1166,8 @@ Return the sorted process list."
   (setq proced-sort-internal
         (mapcar (lambda (arg)
                   (let ((grammar (assq arg proced-grammar-alist)))
+                    (unless (nth 4 grammar)
+                      (error "Attribute %s not sortable" (car grammar)))
                     (list arg (nth 4 grammar) (nth 5 grammar))))
                 (cond ((listp sorter) sorter)
                       ((and (symbolp sorter)
@@ -1084,8 +1197,12 @@ Prefix ARG controls sort order:
 Set variable `proced-sort' to SCHEME.  The current sort scheme is displayed
 in the mode line, using \"+\" or \"-\" for ascending or descending order."
   (interactive
-   (let ((scheme (completing-read "Sort attribute: "
-                                  proced-grammar-alist nil t)))
+   (let* (choices
+          (scheme (completing-read "Sort attribute: "
+                                   (dolist (grammar proced-grammar-alist choices)
+                                     (if (nth 4 grammar)
+                                         (push (list (car grammar)) choices)))
+                                   nil t)))
      (list (if (string= "" scheme) nil (intern scheme))
            ;; like 'toggle in `define-derived-mode'
            (or current-prefix-arg 'no-arg))))
@@ -1200,6 +1317,10 @@ The return string is always 6 characters wide."
   (substring ttname (if (string-match "\\`/dev/" ttname)
                         (match-end 0) 0)))
 
+(defun proced-format-tree (tree)
+  "Format attribute TREE."
+  (concat (make-string tree ?\s) (number-to-string tree)))
+
 ;; Proced assumes that every process occupies only one line in the listing.
 (defun proced-format-args (args)
   "Format attribute ARGS.
@@ -1219,6 +1340,7 @@ Replace newline characters by \"^J\" (two characters)."
   (let ((standard-attributes
          (car (proced-process-attributes (list (emacs-pid)))))
         new-format fmi)
+    (if proced-tree-flag (push (cons 'tree 0) standard-attributes))
     (dolist (fmt format)
       (if (symbolp fmt)
           (if (assq fmt standard-attributes)
@@ -1246,12 +1368,14 @@ Replace newline characters by \"^J\" (two characters)."
              ;; field the corresponding key.
              ;; Of course, the sort predicate appearing in help-echo
              ;; is only part of the story.  But it gives the main idea.
-             (hprops (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
-                       `(proced-key ,key mouse-face highlight
-                                    help-echo ,(format proced-header-help-echo
-                                                       (if descend "-" "+")
-                                                       (nth 1 grammar)
-                                                       (if descend "descending" "ascending")))))
+             (hprops
+              (if (nth 4 grammar)
+                  (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
+                    `(proced-key ,key mouse-face highlight
+                                 help-echo ,(format proced-header-help-echo
+                                                    (if descend "-" "+")
+                                                    (nth 1 grammar)
+                                                    (if descend "descending" "ascending"))))))
              (refiner (nth 7 grammar))
              (fprops
               (cond ((functionp (car refiner))
@@ -1395,6 +1519,10 @@ Suppress status information if QUIET is nil."
         (proced-sort (proced-filter proced-process-alist proced-filter)
                      proced-sort proced-descend))
 
+  ;; display as process tree?
+  (setq proced-process-alist
+        (proced-tree proced-process-alist))
+
   ;; It is useless to keep undo information if we revert, filter, or
   ;; refine the listing so that `proced-process-alist' has changed.
   ;; We could keep the undo information if we only re-sort the buffer.