[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs/lisp proced.el
|
From: |
Roland Winkler |
|
Subject: |
[Emacs-diffs] emacs/lisp proced.el |
|
Date: |
Sun, 28 Dec 2008 13:54:42 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Roland Winkler <winkler> 08/12/28 13:54:42
Modified files:
lisp : proced.el
Log message:
(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.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/proced.el?cvsroot=emacs&r1=1.27&r2=1.28
Patches:
Index: proced.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/proced.el,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -b -r1.27 -r1.28
--- proced.el 19 Dec 2008 21:53:28 -0000 1.27
+++ proced.el 28 Dec 2008 13:54:41 -0000 1.28
@@ -137,7 +137,9 @@
;; 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 @@
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 @@
(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 @@
;; 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 @@
: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 @@
"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 @@
;; 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 @@
: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 @@
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 @@
(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 @@
(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 @@
(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 @@
(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 @@
(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 @@
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 @@
(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 @@
(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 @@
;; 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))))
+ (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")))))
+ (if descend "descending"
"ascending"))))))
(refiner (nth 7 grammar))
(fprops
(cond ((functionp (car refiner))
@@ -1395,6 +1519,10 @@
(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.