;; - interactive temporary customizability of flags in `proced-grammar-alist'
;; - allow "sudo kill PID", "renice PID"
;;
-;; Wishlist
-;; - tree view like pstree(1)
+;; Thoughts and Ideas
+;; - Currently, `system-process-attributes' returns the list of
+;; command-line arguments of a process as one concatenated string.
+;; This format is compatible with `shell-command'. Also, under
+;; MS-Windows, the command-line arguments are actually stored as a
+;; single string, so that it is impossible to reverse-engineer it back
+;; into separate arguments. Alternatively, `system-process-attributes'
+;; could (try to) return a list of strings that correspond to individual
+;; command-line arguments. Then one could feed such a list of
+;; command-line arguments into `call-process' or `start-process'.
+;; Are there real-world applications when such a feature would be useful?
+;; What about something like `proced-restart-pid'?
;;; Code:
(group "GROUP" nil left proced-string-lessp nil (group user pid) (nil t nil))
(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) (nil t nil))
+ (ppid "PPID" "%d" right proced-< nil (ppid pid)
+ ((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))
(ttname "TTY" proced-format-ttname left proced-string-lessp nil (ttname pid) (nil t nil))
(args "ARGS" proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
;;
;; attributes defined by proced (see `proced-process-attributes')
- (pid "PID" "%d" right proced-< nil (pid) (t t nil))
+ (pid "PID" "%d" right proced-< nil (pid)
+ ((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)))
+ (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
- (KEY NAME FORMAT JUSTIFY PREDICATE REVERSE SORT-SCHEME REFINE-FLAGS).
+ (KEY NAME FORMAT JUSTIFY PREDICATE REVERSE SORT-SCHEME REFINER).
Symbol KEY is the car of a process attribute.
String NAME appears in the header line.
-FORMAT specifies the format for displaying the attribute values.
-It can be a string passed to `format'. It can be a function called
-with one argument, the value of the attribute. Nil means take as is.
+FORMAT specifies the format for displaying the attribute values. It can
+be a string passed to `format'. It can be a function called with one
+argument, the value of the attribute. The value nil means take as is.
If JUSTIFY is an integer, its modulus gives the width of the attribute
values formatted with FORMAT. If JUSTIFY is positive, NAME appears
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.
-REVERSE is non-nil if the sort order is opposite to the order defined
-by PREDICATE.
+PREDICATE defines an ascending sort order. REVERSE is non-nil if the sort
+order is descending.
SORT-SCHEME is a list (KEY1 KEY2 ...) defining a hierarchy of rules
for sorting the process listing. KEY1, KEY2, ... are KEYs appearing as cars
If it yields non-equal, it defines the sort order for the corresponding
processes. If it evaluates to 'equal the PREDICATE of KEY2 is evaluated, etc.
-REFINE-FLAGS is a list (LESS-B EQUAL-B LARGER-B) used by the command
+REFINER can be a list of flags (LESS-B EQUAL-B LARGER-B) used by the command
`proced-refine' (see there) to refine the listing based on attribute KEY.
This command compares the value of attribute KEY of every process with
the value of attribute KEY of the process at the position of point
using PREDICATE.
If PREDICATE yields non-nil, the process is accepted if LESS-B is non-nil.
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."
+If PREDICATE yields nil, the process is accepted if LARGER-B is non-nil.
+
+REFINER can also be a cons pair (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.
+
+If REFINER is nil no refinement is done."
:group 'proced
:type '(repeat (list :tag "Attribute"
(symbol :tag "Key")
(const :tag "left" left)
(const :tag "right" right)
(integer :tag "width"))
- (function :tag "Predicate")
- (boolean :tag "Reverse Sort Order")
+ (choice :tag "Predicate"
+ (const :tag "None" nil)
+ (function :tag "Function"))
+ (boolean :tag "Descending Sort Order")
(repeat :tag "Sort Scheme" (symbol :tag "Key"))
- (list :tag "Refine Flags"
- (boolean :tag "Less")
- (boolean :tag "Equal")
- (boolean :tag "Larger")))))
+ (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"))))))
(defcustom proced-custom-attributes nil
"List of functions defining custom attributes.
;; 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)
- (medium user pid pcpu pmem vsize rss ttname state start time args)
- (long user euid group pid pri nice pcpu pmem vsize rss ttname state
- start time args)
- (verbose user euid group egid pid ppid pgrp sess comm pri nice pcpu pmem
+ '((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 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))
+ start time utime stime ctime cutime cstime etime (args comm)))
"Alist of formats of listing.
The car of each element is a symbol, the name of the format.
-The cdr is a list of keys appearing in `proced-grammar-alist'."
+The cdr is a list of attribute keys appearing in `proced-grammar-alist'.
+An element of this list may also be a list of attribute keys that specifies
+alternatives. If the first attribute is absent for a process, use the second
+one, etc."
:group 'proced
:type '(alist :key-type (symbol :tag "Format Name")
- :value-type (repeat :tag "Keys" (symbol :tag ""))))
+ :value-type (repeat :tag "Keys"
+ (choice (symbol :tag "")
+ (repeat :tag "Alternative Keys"
+ (symbol :tag ""))))))
(defcustom proced-format 'short
"Current format of Proced listing.
(repeat :tag "Key List" (symbol :tag "Key"))))
(make-variable-buffer-local 'proced-format)
+(defcustom proced-descend t
+ "Non-nil if proced listing is sorted in descending order."
+ :group 'proced
+ :type '(boolean :tag "Descending Sort Order"))
+(make-variable-buffer-local 'proced-descend)
+
(defcustom proced-goal-attribute 'args
"If non-nil, key of the attribute that defines the `goal-column'."
:group 'proced
:type '(choice (const :tag "none" nil)
(symbol :tag "key")))
-(defcustom proced-timer-interval 5
+(defcustom proced-auto-update-interval 5
"Time interval in seconds for auto updating Proced buffers."
:group 'proced
:type 'integer)
-(defcustom proced-timer-flag nil
+(defcustom proced-auto-update-flag nil
"Non-nil for auto update of a Proced buffer.
-Can be changed interactively via `proced-toggle-timer-flag'."
+Can be changed interactively via `proced-toggle-auto-update'."
+ :group 'proced
+ :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-timer-flag)
+(make-variable-buffer-local 'proced-tree-flag)
;; Internal variables
+(defvar proced-available (not (null (list-system-processes)))
+ "Non-nil means Proced is known to work on this system.")
+
(defvar proced-process-alist nil
"Alist of processes displayed by Proced.
The car of each element is the PID, and the cdr is a list of
(make-variable-buffer-local 'proced-process-alist)
(defvar proced-sort-internal nil
- "Sort scheme for listing (internal format).")
+ "Sort scheme for listing (internal format).
+It is a list of lists (KEY PREDICATE REVERSE).")
(defvar proced-marker-char ?* ; the answer is 42
- "In proced, the current mark character.")
+ "In Proced, the current mark character.")
;; Faces and font-lock code taken from dired,
;; but face variables are deprecated for new code.
(defface proced-mark
'((t (:inherit font-lock-constant-face)))
- "Face used for proced marks."
+ "Face used for Proced marks."
:group 'proced-faces)
(defface proced-marked
"Headers in Proced buffer as a string.")
(make-variable-buffer-local 'proced-header-line)
+(defvar proced-temp-alist nil
+ "Temporary alist (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-timer nil
- "Stores if Proced timer is already installed.")
+(defvar proced-auto-update-timer nil
+ "Stores if Proced auto update timer is already installed.")
(defvar proced-log-buffer "*Proced log*"
"Name of Proced Log buffer.")
(defconst proced-help-string
"(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit (type ? for more help)"
- "Help string for proced.")
+ "Help string for Proced.")
(defconst proced-header-help-echo
"mouse-1, mouse-2: sort by attribute %s%s (%s)"
(defvar proced-mode-map
(let ((km (make-sparse-keymap)))
;; moving
- (define-key km " " 'proced-next-line)
+ (define-key km " " 'next-line)
(define-key km "n" 'next-line)
(define-key km "p" 'previous-line)
(define-key km "\C-n" 'next-line)
;; 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
(define-key km [remap undo] 'proced-undo)
(define-key km [remap advertised-undo] 'proced-undo)
km)
- "Keymap for proced commands.")
+ "Keymap for Proced commands.")
(easy-menu-define
proced-menu proced-mode-map "Proced Menu"
: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."]
"--"
["Revert" revert-buffer
:help "Revert Process Listing"]
- ["Auto Update" proced-toggle-timer-flag
- :style radio
- :selected (eval proced-timer-flag)
+ ["Auto Update" proced-toggle-auto-update
+ :style toggle
+ :selected (eval proced-auto-update-flag)
:help "Auto Update of Proced Buffer"]
["Send signal" proced-send-signal
:help "Send Signal to Marked Processes"]))
to change the sort scheme. The current sort scheme is indicated in the
mode line, using \"+\" or \"-\" for ascending or descending sort order.
-An existing Proced listing can be refined by typing \\[proced-refine]
-with point on the attribute of a process. If point is on the attribute ATTR,
-this compares the value of ATTR of every process with the value of ATTR
-of the process at the position of point. See `proced-refine' for details.
+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'.
The attribute-specific rules for formatting, filtering, sorting, and refining
(set (make-local-variable 'revert-buffer-function) 'proced-revert)
(set (make-local-variable 'font-lock-defaults)
'(proced-font-lock-keywords t nil nil beginning-of-line))
- (if (and (not proced-timer) proced-timer-interval)
- (setq proced-timer
- (run-at-time t proced-timer-interval 'proced-timer))))
+ (if (and (not proced-auto-update-timer) proced-auto-update-interval)
+ (setq proced-auto-update-timer
+ (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)
If invoked with optional ARG the window displaying the process
information will be displayed but not selected.
-See `proced-mode' for a descreption of features available in Proced buffers."
+See `proced-mode' for a description of features available in Proced buffers."
(interactive "P")
+ (unless proced-available
+ (error "Proced is not available on this system"))
(let ((buffer (get-buffer-create "*Proced*")) new)
(set-buffer buffer)
(setq new (zerop (buffer-size)))
(substitute-command-keys
"Type \\<proced-mode-map>\\[quit-window] to quit, \\[proced-help] for help")))))
-(defun proced-timer ()
+(defun proced-auto-update-timer ()
"Auto-update Proced buffers using `run-at-time'."
(dolist (buf (buffer-list))
(with-current-buffer buf
(if (and (eq major-mode 'proced-mode)
- proced-timer-flag)
+ proced-auto-update-flag)
(proced-update t t)))))
-(defun proced-toggle-timer-flag (arg)
+(defun proced-toggle-auto-update (arg)
"Change whether this Proced buffer is updated automatically.
With prefix ARG, update this buffer automatically if ARG is positive,
-otherwise do not update. Sets the variable `proced-timer-flag'.
-The time interval for updates is specified via `proced-timer-interval'."
+otherwise do not update. Sets the variable `proced-auto-update-flag'.
+The time interval for updates is specified via `proced-auto-update-interval'."
(interactive (list (or current-prefix-arg 'toggle)))
- (setq proced-timer-flag
- (cond ((eq arg 'toggle) (not proced-timer-flag))
+ (setq proced-auto-update-flag
+ (cond ((eq arg 'toggle) (not proced-auto-update-flag))
(arg (> (prefix-numeric-value arg) 0))
- (t (not proced-timer-flag))))
- (message "`proced-timer-flag' set to %s" proced-timer-flag))
+ (t (not proced-auto-update-flag))))
+ (message "Proced auto update %s"
+ (if proced-auto-update-flag "enabled" "disabled")))
(defun proced-mark (&optional count)
"Mark the current (or next COUNT) processes."
(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)
(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 ...).
-PPID is a parent PID. PID1, PID2, ... are the child processes of PPID.
-The list of children does not include grandchildren."
- (let (children-list ppid cpids)
- (dolist (process process-alist children-list)
- (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)))))))
+(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))))
+ (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))
(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-temp-alist (proced-children-alist process-alist))
new-alist)
(dolist (pid (proced-children-pids ppid))
(push (assq pid process-alist) new-alist))
(assq-delete-all ppid new-alist)
new-alist)))
-;; helper function
+;;; Process tree
+
+(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 of PROCESS-ALIST.
+The list of children does not include grandchildren."
+ ;; 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 (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-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-temp-alist))))
(if cpids
(cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
(list ppid))))
-(defun proced-filter-parents (process-alist pid &optional omit-pid)
- "For PROCESS-ALIST return list of parent processes of PID.
-This list includes CPID unless OMIT-CPID 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))
- parent-list))
+(defun proced-process-tree (process-alist)
+ "Return process tree for PROCESS-ALIST.
+It is an alist of alists where the car of each alist is a parent process
+and the cdr is a list of child processes according to the ppid attribute
+of these processes.
+The process tree inherits the sorting order of PROCESS-ALIST."
+ (let ((proced-temp-alist (proced-children-alist process-alist))
+ pid-alist proced-process-tree)
+ (while (setq pid-alist (pop proced-temp-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-temp-alist))
+ ;; Unprocessed part of process tree that needs to be
+ ;; analyzed recursively.
+ (progn
+ (setq proced-temp-alist
+ (assq-delete-all cpid proced-temp-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)
+ "Toggle the display of the process listing 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'.
+
+The process tree is generated from the selected processes in the
+Proced buffer (that is, the processes in `proced-process-alist').
+All processes that do not have a parent process in this list
+according to their ppid attribute become the root of a process tree.
+Each parent process is followed by its child processes.
+The process tree inherits the chosen sorting order of the process listing,
+that is, child processes of the same parent process are sorted using
+the selected sorting order."
+ (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)
+ "Rearrange PROCESS-ALIST as process tree.
+If `proced-tree-flag' is non-nil, rearrange PROCESS-ALIST such that
+every processes is followed by its child processes. Each process
+gets a tree attribute that specifies the depth of the process in the tree.
+A root process is a process with no parent within PROCESS-ALIST according
+to its value of the ppid attribute. It has depth 0.
+
+If `proced-tree-flag' is nil, remove the tree attribute.
+Return the rearranged process list."
+ (if proced-tree-flag
+ ;; add tree attribute
+ (let ((process-tree (proced-process-tree process-alist))
+ (proced-tree-indent 0)
+ (proced-temp-alist process-alist)
+ proced-process-tree pt)
+ (while (setq pt (pop process-tree))
+ (proced-tree-insert pt))
+ (nreverse proced-process-tree))
+ ;; remove tree attribute
+ (let ((process-alist process-alist))
+ (while process-alist
+ (setcar process-alist
+ (assq-delete-all 'tree (car process-alist)))
+ (pop process-alist)))
+ process-alist))
+
+(defun proced-tree-insert (process-tree)
+ "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))
+ (cdr pprocess))
+ proced-process-tree)
+ (if (cdr process-tree)
+ (let ((proced-tree-indent (1+ proced-tree-indent)))
+ (mapc 'proced-tree-insert (cdr process-tree))))))
;; Refining
"Refine Proced listing by comparing with the attribute value at point.
Optional EVENT is the location of the Proced field.
-If point is on the attribute ATTR, this command compares the value of ATTR
-of every process with the value of ATTR of the process at the position
-of point. One can select processes for which the value of ATTR is
-\"less than\", \"equal\", and / or \"larger\" than ATTR of the process
-point is on.
+Refinement is controlled by the REFINER defined for each attribute ATTR
+in `proced-grammar-alist'.
+
+If REFINER is a list of flags and point is on a process's value of ATTR,
+this command compares the value of ATTR of every process with the value
+of ATTR of the process at the position of point.
The predicate for the comparison of two ATTR values is defined
in `proced-grammar-alist'. For each return value of the predicate
-a refine flag is defined in `proced-grammar-alist'. A process is included
-in the new listing if the refine flag for the return value of the predicate
-is non-nil.
+a refine flag is defined in `proced-grammar-alist'. One can select
+processes for which the value of ATTR is \"less than\", \"equal\",
+and / or \"larger\" than ATTR of the process point is on. A process
+is included in the new listing if the refine flag for the corresponding
+return value of the predicate is non-nil.
The help-echo string for `proced-refine' uses \"+\" or \"-\" to indicate
-the current values of the refine flags.
+the current values of these refine flags.
-This command refines an already existing process listing based initially
-on the variable `proced-filter'. It does not change this variable.
-It does not revert the listing. If you frequently need a certain refinement,
-consider defining a new filter in `proced-filter-alist'."
+If REFINER is a cons pair (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.
+
+This command refines an already existing process listing generated initially
+based on the value of the variable `proced-filter'. It does not change
+this variable. It does not revert the listing. If you frequently need
+a certain refinement, consider defining a new filter in `proced-filter-alist'."
(interactive (list last-input-event))
(if event (posn-set-point (event-end event)))
(let ((key (get-text-property (point) 'proced-key))
(pid (get-text-property (point) 'proced-pid)))
(if (and key pid)
(let* ((grammar (assq key proced-grammar-alist))
- (predicate (nth 4 grammar))
- (refiner (nth 7 grammar))
- (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
- val new-alist)
- (when ref
- (dolist (process proced-process-alist)
- (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
- (if (cond ((not val) (nth 2 refiner))
- ((eq val 'equal) (nth 1 refiner))
- (val (car refiner)))
- (push process new-alist)))
- (setq proced-process-alist new-alist)
+ (refiner (nth 7 grammar)))
+ (when refiner
+ (cond ((functionp (car refiner))
+ (setq proced-process-alist (funcall (car refiner) pid)))
+ ((consp refiner)
+ (let ((predicate (nth 4 grammar))
+ (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
+ val new-alist)
+ (dolist (process proced-process-alist)
+ (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
+ (if (cond ((not val) (nth 2 refiner))
+ ((eq val 'equal) (nth 1 refiner))
+ (val (car refiner)))
+ (push process new-alist)))
+ (setq proced-process-alist new-alist))))
;; Do not revert listing.
(proced-update)))
(message "No refiner defined here."))))
(throw 'done (proced-xor predicate (nth 2 sorter)))))
(eq t predicate)))))
-(defun proced-sort (process-alist sorter)
+(defun proced-sort (process-alist sorter descend)
"Sort PROCESS-ALIST using scheme SORTER.
+SORTER is a scheme like `proced-sort'.
+DESCEND is non-nil if the first element of SORTER is sorted
+in descending order.
Return the sorted process list."
;; translate SORTER into a list of lists (KEY PREDICATE REVERSE)
(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)
((symbolp sorter) (list sorter))
(t (error "Sorter undefined %s" sorter)))))
(if proced-sort-internal
- (sort process-alist 'proced-sort-p)
+ (progn
+ ;; splice DESCEND into the list
+ (setcar proced-sort-internal
+ (list (caar proced-sort-internal)
+ (nth 1 (car proced-sort-internal)) descend))
+ (sort process-alist 'proced-sort-p))
process-alist))
-(defun proced-sort-interactive (scheme &optional revert)
+(defun proced-sort-interactive (scheme &optional arg)
"Sort Proced buffer using SCHEME.
When called interactively, an empty string means nil, i.e., no sorting.
-With prefix REVERT non-nil revert listing.
+
+Prefix ARG controls sort order:
+- If prefix ARG is positive (negative), sort in ascending (descending) order.
+- If ARG is nil or 'no-arg and SCHEME is equal to the previous sorting scheme,
+ reverse the sorting order.
+- If ARG is nil or 'no-arg and SCHEME differs from the previous sorting scheme,
+ adopt the sorting order defined for SCHEME in `proced-grammar-alist'.
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))
- current-prefix-arg)))
- ;; only update if necessary
- (when (or (not (eq proced-sort scheme)) revert)
- (setq proced-sort scheme)
- (proced-update revert)))
-
-(defun proced-sort-pcpu (&optional revert)
- "Sort Proced buffer by percentage CPU time (%CPU)."
- (interactive "P")
- (proced-sort-interactive 'pcpu revert))
-
-(defun proced-sort-pmem (&optional revert)
- "Sort Proced buffer by percentage memory usage (%MEM)."
- (interactive "P")
- (proced-sort-interactive 'pmem))
-
-(defun proced-sort-pid (&optional revert)
- "Sort Proced buffer by PID."
- (interactive "P")
- (proced-sort-interactive 'pid revert))
-
-(defun proced-sort-start (&optional revert)
- "Sort Proced buffer by time the command started (START)."
- (interactive "P")
- (proced-sort-interactive 'start revert))
-
-(defun proced-sort-time (&optional revert)
- "Sort Proced buffer by CPU time (TIME)."
- (interactive "P")
- (proced-sort-interactive 'time revert))
-
-(defun proced-sort-user (&optional revert)
- "Sort Proced buffer by USER."
- (interactive "P")
- (proced-sort-interactive 'user revert))
-
-(defun proced-sort-header (event &optional revert)
+ ;; like 'toggle in `define-derived-mode'
+ (or current-prefix-arg 'no-arg))))
+
+ (setq proced-descend
+ ;; If `proced-sort-interactive' is called repeatedly for the same
+ ;; sort key, the sort order is reversed.
+ (cond ((and (eq arg 'no-arg) (equal proced-sort scheme))
+ (not proced-descend))
+ ((eq arg 'no-arg)
+ (nth 5 (assq (if (consp scheme) (car scheme) scheme)
+ proced-grammar-alist)))
+ (arg (< (prefix-numeric-value arg) 0))
+ ((equal proced-sort scheme)
+ (not proced-descend))
+ (t (nth 5 (assq (if (consp scheme) (car scheme) scheme)
+ proced-grammar-alist))))
+ proced-sort scheme)
+ (proced-update))
+
+(defun proced-sort-pcpu (&optional arg)
+ "Sort Proced buffer by percentage CPU time (%CPU).
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'pcpu arg))
+
+(defun proced-sort-pmem (&optional arg)
+ "Sort Proced buffer by percentage memory usage (%MEM).
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'pmem arg))
+
+(defun proced-sort-pid (&optional arg)
+ "Sort Proced buffer by PID.
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'pid arg))
+
+(defun proced-sort-start (&optional arg)
+ "Sort Proced buffer by time the command started (START).
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'start arg))
+
+(defun proced-sort-time (&optional arg)
+ "Sort Proced buffer by CPU time (TIME).
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'time arg))
+
+(defun proced-sort-user (&optional arg)
+ "Sort Proced buffer by USER.
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list (or current-prefix-arg 'no-arg)))
+ (proced-sort-interactive 'user arg))
+
+(defun proced-sort-header (event &optional arg)
"Sort Proced listing based on an attribute.
EVENT is a mouse event with starting position in the header line.
-It is converted in the corresponding attribute key.
-This command updates the variable `proced-sort'."
- (interactive "e\nP")
+It is converted to the corresponding attribute key.
+This command updates the variable `proced-sort'.
+Prefix ARG controls sort order, see `proced-sort-interactive'."
+ (interactive (list last-input-event (or last-prefix-arg 'no-arg)))
(let ((start (event-start event))
col key)
(save-selected-window
(when (and (<= 0 col) (< col (length proced-header-line)))
(setq key (get-text-property col 'proced-key proced-header-line))
(if key
- (proced-sort-interactive key revert)
+ (proced-sort-interactive key arg)
(message "No sorter defined here."))))))
;;; Formating
(defun proced-format-time (time)
- "Format time intervall TIME."
+ "Format time interval TIME."
(let* ((ftime (float-time time))
(days (truncate ftime 86400))
(ftime (mod ftime 86400))
(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.
Replace newline characters by \"^J\" (two characters)."
"Display PROCESS-ALIST using FORMAT."
(if (symbolp format)
(setq format (cdr (assq format proced-format-alist))))
+
+ ;; Not all systems give us all attributes. We take `emacs-pid' as a
+ ;; representative process PID. If FORMAT contains a list of alternative
+ ;; attributes, we take the first attribute that is non-nil for `emacs-pid'.
+ ;; If none of the alternatives is non-nil, the attribute is ignored
+ ;; in the listing.
+ (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)
+ (push fmt new-format))
+ (while (setq fmi (pop fmt))
+ (when (assq fmi standard-attributes)
+ (push fmi new-format)
+ (setq fmt nil)))))
+ (setq format (nreverse new-format)))
+
(insert (make-string (length process-alist) ?\n))
- (let ((whitespace " ") header-list grammar)
+ (let ((whitespace " ") (unknown "?")
+ (sort-key (if (consp proced-sort) (car proced-sort) proced-sort))
+ header-list grammar)
;; Loop over all attributes
- (while (setq grammar (pop format))
- (if (symbolp grammar)
- (setq grammar (assq grammar proced-grammar-alist)))
+ (while (setq grammar (assq (pop format) proced-grammar-alist))
(let* ((key (car grammar))
(fun (cond ((stringp (nth 2 grammar))
`(lambda (arg) (format ,(nth 2 grammar) arg)))
;; 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 `(proced-key ,key mouse-face highlight
- help-echo ,(format proced-header-help-echo
- (if (nth 5 grammar) "-" "+")
- (nth 1 grammar)
- (if (nth 5 grammar) "descending" "ascending"))))
- (fprops `(proced-key ,key mouse-face highlight
- help-echo ,(format proced-field-help-echo
+ (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))
+ `(proced-key ,key mouse-face highlight
+ help-echo ,(format "mouse-2, RET: %s"
+ (cdr refiner))))
+ ((consp refiner)
+ `(proced-key ,key mouse-face highlight
+ help-echo ,(format "mouse-2, RET: refine by attribute %s %s"
(nth 1 grammar)
(mapconcat (lambda (s)
(if s "+" "-"))
- (nth 7 grammar) ""))))
+ refiner ""))))))
value)
;; highlight the header of the sort column
- (if (eq key proced-sort)
+ (if (eq key sort-key)
(setq hprops (append '(face proced-sort-header) hprops)))
(goto-char (point-min))
(cond ( ;; fixed width of output field
(setq value (cdr (assq key (cdr process))))
(insert (if value
(apply 'propertize (funcall fun value) fprops)
- (make-string (abs (nth 3 grammar)) ?\s))
+ (format (concat "%" (number-to-string (nth 3 grammar)) "s")
+ unknown))
whitespace)
(forward-line))
(push (format (concat "%" (number-to-string (nth 3 grammar)) "s")
(dolist (process process-alist)
(end-of-line)
(setq value (cdr (assq key (cdr process))))
- (if value (insert (apply 'propertize (funcall fun value) fprops)))
+ (insert (if value (apply 'propertize (funcall fun value) fprops)
+ unknown))
(forward-line))
(push (apply 'propertize (nth 1 grammar) hprops) header-list))
(setq value (apply 'propertize (funcall fun value) fprops)
width (max width (length value))
field-list (cons value field-list))
- (push "" field-list)))
+ (push unknown field-list)
+ (setq width (max width (length unknown)))))
(let ((afmt (concat "%" (if (eq 'left (nth 3 grammar)) "-" "")
(number-to-string width) "s")))
(push (format afmt (apply 'propertize (nth 1 grammar) hprops))
;; generate listing
-(defun proced-process-attributes ()
+(defun proced-process-attributes (&optional pid-list)
"Return alist of attributes for each system process.
-This alist can be customized via `proced-custom-attributes'."
- (mapcar (lambda (pid)
- (let* ((attributes (system-process-attributes pid))
- (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)))
- (cons pid attributes)))
- (list-system-processes)))
+This alist can be customized via `proced-custom-attributes'.
+Optional arg PID-LIST is a list of PIDs of system process that are analyzed.
+If no attributes are known for a process (possibly because it already died)
+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)
+ (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))))))
(defun proced-update (&optional revert quiet)
- "Update the `proced' process information. Preserves point and marks.
+ "Update the Proced process information. Preserves point and marks.
With prefix REVERT non-nil, revert listing.
Suppress status information if QUIET is nil."
;; This is the main function that generates and updates the process listing.
(setq proced-process-alist (proced-process-attributes)))
;; filtering and sorting
(setq proced-process-alist
- (proced-sort (proced-filter proced-process-alist
- proced-filter) proced-sort))
+ (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.
(concat ": " (symbol-name proced-filter))
"")
(if proced-sort
- (let* ((key (if (listp proced-sort) (car proced-sort)
+ (let* ((key (if (consp proced-sort) (car proced-sort)
proced-sort))
(grammar (assq key proced-grammar-alist)))
- (concat " by " (if (nth 5 grammar) "-" "+")
+ (concat " by " (if proced-descend "-" "+")
(nth 1 grammar)))
"")))
(force-mode-line-update)
"Updating process display...done.")))))
(defun proced-revert (&rest args)
- "Analog of `revert-buffer'."
+ "Reevaluate the process listing based on the currently running processes.
+Preserves point and marks."
(proced-update t))
;; I do not want to reinvent the wheel. Should we rename `dired-pop-to-buffer'
(proced-log t signal))
(defun proced-help ()
- "Provide help for the `proced' user."
+ "Provide help for the Proced user."
(interactive)
(proced-why)
(if (eq last-command 'proced-help)
(message proced-help-string)))
(defun proced-undo ()
- "Undo in a proced buffer.
-This doesn't recover killed processes, it just undoes changes in the proced
+ "Undo in a Proced buffer.
+This doesn't recover killed processes, it just undoes changes in the Proced
buffer. You can use it to recover marks."
(interactive)
(let (buffer-read-only)