;;; proced.el --- operate on system processes like dired
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
;; Keywords: Processes, Unix
;; Proced makes an Emacs buffer containing a listing of the current
;; system processes. You can use the normal Emacs commands to move around
;; in this buffer, and special Proced commands to operate on the processes
-;; listed.
+;; listed. See `proced-mode' for getting started.
;;
;; To do:
-;; - use defcustom where appropriate
-;; - interactive temporary customizability of `proced-grammar-alist'
+;; - interactive temporary customizability of flags in `proced-grammar-alist'
;; - allow "sudo kill PID", "renice PID"
+;;
+;; Thoughts and Ideas
+;; - Currently, `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, `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:
;;
;; It would be neat if one could temporarily override the following
;; predefined rules.
-(defvar proced-grammar-alist
- '( ;; attributes defined in `system-process-attributes'
+(defcustom proced-grammar-alist
+ '( ;; attributes defined in `process-attributes'
(euid "EUID" "%d" right proced-< nil (euid pid) (nil t nil))
- (user "USER" "%s" left proced-string-lessp nil (user pid) (nil t nil))
+ (user "USER" nil left proced-string-lessp nil (user pid) (nil t nil))
(egid "EGID" "%d" right proced-< nil (egid euid pid) (nil t nil))
- (group "GROUP" "%s" left proced-string-lessp nil (group user pid) (nil t nil))
- (comm "COMMAND" "%s" left proced-string-lessp nil (comm pid) (nil t nil))
- (state "STAT" "%s" left proced-string-lessp nil (state pid) (nil t nil))
- (ppid "PPID" "%d" right proced-< nil (ppid pid) (nil t nil))
+ (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)
+ ((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))
(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))
(etime "ETIME" proced-format-time right proced-time-lessp t (etime pid) (nil t t))
(pcpu "%CPU" "%.1f" right proced-< t (pcpu pid) (nil t t))
(pmem "%MEM" "%.1f" right proced-< t (pmem pid) (nil t t))
- (args "ARGS" "%s" left proced-string-lessp nil (args 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))
- ;; 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)))
+ (pid "PID" "%d" right proced-< nil (pid)
+ ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
+ "refine to process children"))
+ ;; 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 FILTER-SCHEME).
+ (KEY NAME FORMAT JUSTIFY PREDICATE REVERSE SORT-SCHEME REFINER).
-KEY is the car of a process attribute.
+Symbol KEY is the car of a process attribute.
-NAME appears in the header line.
+String NAME appears in the header line.
-FORMAT specifies the format for displaying the attribute values.
-It is either a string passed to `format' or a function called with one
-argument, the value of the attribute.
+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
-vales formatted with FORMAT. If JUSTIFY is positive, NAME appears
+values formatted with FORMAT. If JUSTIFY is positive, NAME appears
right-justified, otherwise it appears left-justified. If JUSTIFY is 'left
or 'right, the field width is calculated from all field values in the listing.
If JUSTIFY is 'left, the field values are formatted left-justified and
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 ...) defing a hierarchy of rules
+SORT-SCHEME is a list (KEY1 KEY2 ...) defining a hierarchy of rules
for sorting the process listing. KEY1, KEY2, ... are KEYs appearing as cars
of `proced-grammar-alist'. First the PREDICATE of KEY1 is evaluated.
-If it yields non-equal, it defines the sorting order for the corresponding
+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.
-FILTER-SCHEME is a list (LESS-B EQUAL-B LARGER-B) used by the command
-`proced-filter-attribute' for filtering KEY (see there). 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.
+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.
-(defvar proced-custom-attributes nil
+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.
+
+If REFINER is nil no refinement is done."
+ :group 'proced
+ :type '(repeat (list :tag "Attribute"
+ (symbol :tag "Key")
+ (string :tag "Header")
+ (choice :tag "Format"
+ (const :tag "None" nil)
+ (string :tag "Format String")
+ (function :tag "Formatting Function"))
+ (choice :tag "Justification"
+ (const :tag "left" left)
+ (const :tag "right" right)
+ (integer :tag "width"))
+ (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 (function :tag "Refinement Function")
+ (string :tag "Help echo"))
+ (list :tag "Refine Flags"
+ (boolean :tag "Less")
+ (boolean :tag "Equal")
+ (boolean :tag "Larger"))))))
+
+(defcustom proced-custom-attributes nil
"List of functions defining custom attributes.
This variable extends the functionality of `proced-process-attributes'.
Each function is called with one argument, the list of attributes
of a system process. It returns a cons cell of the form (KEY . VALUE)
-like `system-process-attributes'.")
+like `process-attributes'. This cons cell is appended to the list
+returned by `proced-process-attributes'.
+If the function returns nil, the value is ignored."
+ :group 'proced
+ :type '(repeat (function :tag "Attribute")))
;; Formatting and sorting rules are defined "per attribute". If formatting
;; and / or sorting should use more than one attribute, it appears more
;; Would it be advantageous to have yet more general methods available?)
;; Sorting can also be based on attributes that are invisible in the listing.
-(defvar 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
+(defcustom proced-format-alist
+ '((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"
+ (choice (symbol :tag "")
+ (repeat :tag "Alternative Keys"
+ (symbol :tag ""))))))
-(defvar proced-format 'short
+(defcustom proced-format 'short
"Current format of Proced listing.
It can be the car of an element of `proced-format-alist'.
-It can also be a list of keys appearing in `proced-grammar-alist'.")
+It can also be a list of keys appearing in `proced-grammar-alist'."
+ :group 'proced
+ :type '(choice (symbol :tag "Format Name")
+ (repeat :tag "Keys" (symbol :tag ""))))
(make-variable-buffer-local 'proced-format)
;; FIXME: is there a better name for filter `user' that does not coincide
;; with an attribute key?
-(defvar proced-filter-alist
+(defcustom proced-filter-alist
`((user (user . ,(concat "\\`" (user-real-login-name) "\\'")))
(user-running (user . ,(concat "\\`" (user-real-login-name) "\\'"))
(state . "\\`[Rr]\\'"))
\(function . FUN) For each process, apply function FUN to list of attributes
of each. Accept the process if FUN returns non-nil.
\(fun-all . FUN) Apply function FUN to entire process list.
- FUN must return the filtered list.")
-
-(defvar proced-filter 'user
+ FUN must return the filtered list."
+ :group 'proced
+ :type '(repeat (cons :tag "Filter"
+ (symbol :tag "Filter Name")
+ (repeat :tag "Filters"
+ (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp)
+ (cons :tag "Key . Function" (symbol :tag "Key") function)
+ (cons :tag "Function" (const :tag "Key: function" function) function)
+ (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function))))))
+
+(defcustom proced-filter 'user
"Current filter of proced listing.
It can be the car of an element of `proced-filter-alist'.
It can also be a list of elementary filters as in the cdrs of the elements
-of `proced-filter-alist'.")
+of `proced-filter-alist'."
+ :group 'proced
+ :type '(choice (symbol :tag "Filter Name")
+ (repeat :tag "Filters"
+ (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp)
+ (cons :tag "Key . Function" (symbol :tag "Key") function)
+ (cons :tag "Function" (const :tag "Key: function" function) function)
+ (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function)))))
(make-variable-buffer-local 'proced-filter)
-(defvar proced-sort 'pcpu
- "Current sorting scheme for proced listing.
+(defcustom proced-sort 'pcpu
+ "Current sort scheme for proced listing.
It must be the KEY of an element of `proced-grammar-alist'.
It can also be a list of KEYs as in the SORT-SCHEMEs of the elements
-of `proced-grammar-alist'.")
-(make-variable-buffer-local 'proced-format)
+of `proced-grammar-alist'."
+ :group 'proced
+ :type '(choice (symbol :tag "Sort Scheme")
+ (repeat :tag "Key List" (symbol :tag "Key"))))
+(make-variable-buffer-local 'proced-sort)
+
+(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'."
:type '(choice (const :tag "none" nil)
(symbol :tag "key")))
-(defcustom proced-timer-interval 5
- "Time interval in seconds for updating Proced buffers."
+(defcustom proced-auto-update-interval 5
+ "Time interval in seconds for auto updating Proced buffers."
:group 'proced
:type 'integer)
-(defcustom proced-timer-flag nil
- "Non-nil for regular update of a Proced buffer.
-Can be changed interactively via `proced-toggle-timer-flag'."
+(defcustom proced-auto-update-flag nil
+ "Non-nil for auto update of a Proced buffer.
+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)
+
+(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)
+
+(defcustom proced-after-send-signal-hook nil
+ "Normal hook run after sending a signal to processes by `proced-send-signal'.
+May be used to revert the process listing."
+ :type 'hook
+ :options '(proced-revert)
+ :group 'proced)
;; 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 PIDs displayed by Proced.")
+ "Alist of processes displayed by Proced.
+The car of each element is the PID, and the cdr is a list of
+cons pairs, see `proced-process-attributes'.")
(make-variable-buffer-local 'proced-process-alist)
(defvar proced-sort-internal nil
- "Sorting 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.")
-;; face and font-lock code taken from dired
+;; Faces and font-lock code taken from dired,
+;; but face variables are deprecated for new code.
(defgroup proced-faces nil
"Faces used by Proced."
:group 'proced
(defface proced-mark
'((t (:inherit font-lock-constant-face)))
- "Face used for proced marks."
+ "Face used for Proced marks."
:group 'proced-faces)
-(defvar proced-mark-face 'proced-mark
- "Face name used for proced marks.")
(defface proced-marked
'((t (:inherit font-lock-warning-face)))
"Face used for marked processes."
:group 'proced-faces)
-(defvar proced-marked-face 'proced-marked
- "Face name used for marked processes.")
+
+(defface proced-sort-header
+ '((t (:inherit font-lock-keyword-face)))
+ "Face used for header of attribute used for sorting."
+ :group 'proced-faces)
(defvar proced-re-mark "^[^ \n]"
"Regexp matching a marked line.
"Headers in Proced buffer as a string.")
(make-variable-buffer-local 'proced-header-line)
-(defvar proced-log-buffer "*Proced log*"
- "Name of Proced Log buffer.")
+(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-timer nil
- "Stores if Proced timer is already installed.")
+(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.")
+
+(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-2: sort by attribute %s%s"
+ "mouse-1, mouse-2: sort by attribute %s%s (%s)"
"Help string shown when mouse is over a sortable header.")
(defconst proced-field-help-echo
- "mouse-2, RET: filter by attribute %s %s"
- "Help string shown when mouse is over a filterable field.")
+ "mouse-2, RET: refine by attribute %s %s"
+ "Help string shown when mouse is over a refinable field.")
(defvar proced-font-lock-keywords
- (list
- ;;
- ;; Proced marks.
- (list proced-re-mark '(0 proced-mark-face))
- ;;
- ;; Marked files.
- (list (concat "^[" (char-to-string proced-marker-char) "]")
- '(".+" (proced-move-to-goal-column) nil (0 proced-marked-face)))))
+ `(;; (Any) proced marks.
+ (,proced-re-mark . 'proced-mark)
+ ;; Processes marked with `proced-marker-char'
+ ;; Should we make sure that only certain attributes are font-locked?
+ (,(concat "^[" (char-to-string proced-marker-char) "]")
+ ".+" (proced-move-to-goal-column) nil (0 'proced-marked))))
(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)
(define-key km "P" 'proced-mark-parents)
;; filtering
(define-key km "f" 'proced-filter-interactive)
- (define-key km [mouse-2] 'proced-filter-attribute)
- (define-key km "\C-m" 'proced-filter-attribute)
+ (define-key km [mouse-2] 'proced-refine)
+ (define-key km "\C-m" 'proced-refine)
;; sorting
(define-key km "sc" 'proced-sort-pcpu)
(define-key km "sm" 'proced-sort-pmem)
(define-key km "sS" 'proced-sort-interactive)
(define-key km "st" 'proced-sort-time)
(define-key km "su" 'proced-sort-user)
+ ;; 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 "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.")
+ "Keymap for Proced commands.")
(easy-menu-define
proced-menu proced-mode-map "Proced Menu"
:selected (eq proced-filter ',filter)]))
proced-filter-alist))
("Sorting"
- :help "Select Sorting Scheme"
+ :help "Select Sort Scheme"
["Sort..." proced-sort-interactive
:help "Sort Process List"]
"--"
: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"]
- ["Regular Update" proced-toggle-timer-flag
- :style radio
- :selected (eval proced-timer-flag)
- :help "Regular Update of Proced buffer"]
+ ["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 get a well-defined position of point.
(defun proced-move-to-goal-column ()
- "Move to `goal-column' if non-nil."
+ "Move to `goal-column' if non-nil. Return position of point."
(beginning-of-line)
(unless (eobp)
(if goal-column
(forward-char goal-column)
- (forward-char 2))))
+ (forward-char 2)))
+ (point))
(defun proced-header-line ()
"Return header line for Proced buffer."
(list (propertize " " 'display '(space :align-to 0))
- (replace-regexp-in-string ;; preserve text properties
- "\\(%\\)" "\\1\\1" (substring proced-header-line (window-hscroll)))))
+ (if (<= (window-hscroll) (length proced-header-line))
+ (replace-regexp-in-string ;; preserve text properties
+ "\\(%\\)" "\\1\\1"
+ (substring proced-header-line (window-hscroll))))))
(defun proced-pid-at-point ()
"Return pid of system process at point.
;; 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-mode-map>\\[proced-mark] to mark a process for later commands.
+Type \\[proced] to start a Proced session. In a Proced buffer
+type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.
+The initial content of a listing is defined by the variable `proced-filter'
+and the variable `proced-format'.
+The variable `proced-filter' specifies which system processes are displayed.
+The variable `proced-format' specifies which attributes are displayed for
+each process. Type \\[proced-filter-interactive] and \\[proced-format-interactive]
+to change the values of `proced-filter' and `proced-format'.
+The current value of the variable `proced-filter' is indicated in the
+mode line.
+
+The sort order of Proced listings is defined by the variable `proced-sort'.
+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'.
+
+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)
(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))))
-
-;; Proced mode is suitable only for specially formatted data.
-(put 'proced-mode 'mode-class 'special)
+ (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))))
;;;###autoload
(defun proced (&optional arg)
- "Mode for displaying UNIX system processes and sending signals to them.
-Type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
-Type \\[proced-send-signal] to send signals to marked processes.
-
+ "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'.
-\\{proced-mode-map}"
+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)))
- (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")))))
-(defun proced-timer ()
- "Update Proced buffers regularly using `run-at-time'."
+(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)
- "Change whether this Proced buffer is updated regularly.
-With prefix ARG, update this buffer regularly 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'."
+(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-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")))
+
+;;; Mark
(defun proced-mark (&optional count)
"Mark the current (or next COUNT) processes."
(proced-insert-mark mark backward))
(proced-move-to-goal-column)))
+(defun proced-toggle-marks ()
+ "Toggle marks: marked processes become unmarked, and vice versa."
+ (interactive)
+ (let ((mark-re (proced-marker-regexp))
+ buffer-read-only)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (cond ((looking-at mark-re)
+ (proced-insert-mark nil))
+ ((looking-at " ")
+ (proced-insert-mark t))
+ (t
+ (forward-line 1)))))))
+
+(defun proced-insert-mark (mark &optional backward)
+ "If MARK is non-nil, insert `proced-marker-char'.
+If BACKWARD is non-nil, move one line backwards before inserting the mark.
+Otherwise move one line forward after inserting the mark."
+ (if backward (forward-line -1))
+ (insert (if mark proced-marker-char ?\s))
+ (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 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)
+ (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
(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)
- (let ((mark-re (proced-marker-regexp))
- buffer-read-only)
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- (cond ((looking-at mark-re)
- (proced-insert-mark nil))
- ((looking-at " ")
- (proced-insert-mark t))
- (t
- (forward-line 1)))))))
-
-(defun proced-insert-mark (mark &optional backward)
- "If MARK is non-nil, insert `proced-marker-char'.
-If BACKWARD is non-nil, move one line backwards before inserting the mark.
-Otherwise move one line forward after inserting the mark."
- (if backward (forward-line -1))
- (insert (if mark proced-marker-char ?\s))
- (delete-char 1)
- (unless backward (forward-line)))
+ (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.
(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)
;;; Filtering
(defun proced-filter (process-alist filter-list)
- "Apply FILTER-LIST to PROCESS-ALIST."
+ "Apply FILTER-LIST to PROCESS-ALIST.
+Return the filtered process list."
(if (symbolp filter-list)
(setq filter-list (cdr (assq filter-list proced-filter-alist))))
(dolist (filter filter-list)
(setq process-alist new-alist)))
process-alist)
-(defun proced-filter-interactive (scheme &optional revert)
+(defun proced-filter-interactive (scheme)
"Filter Proced buffer using SCHEME.
When called interactively, an empty string means nil, i.e., no filtering.
-With prefix REVERT non-nil revert listing."
+Set variable `proced-filter' to SCHEME. Revert listing."
(interactive
(let ((scheme (completing-read "Filter: "
proced-filter-alist nil t)))
- (list (if (string= "" scheme) nil (intern scheme))
- current-prefix-arg)))
- (setq proced-filter scheme)
- (proced-update revert))
+ (list (if (string= "" scheme) nil (intern scheme)))))
+ ;; only update if necessary
+ (unless (eq proced-filter scheme)
+ (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-depth 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-filter-attribute (&optional event)
- "Filter Proced listing based on the attribute at point.
-Optional EVENT is the location of the Proced field."
+(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-depth))
+ (cdr pprocess))
+ proced-process-tree)
+ (if (cdr process-tree)
+ (let ((proced-tree-depth (1+ proced-tree-depth)))
+ (mapc 'proced-tree-insert (cdr process-tree))))))
+
+;; Refining
+
+;; Filters are used to select the processes in a new listing.
+;; Refiners are used to narrow down further (interactively) the processes
+;; in an existing listing.
+
+(defun proced-refine (&optional event)
+ "Refine Proced listing by comparing with the attribute value at point.
+Optional EVENT is the location of the Proced field.
+
+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'. 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 these refine flags.
+
+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))
- (filter (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 filter))
- ((eq val 'equal) (nth 1 filter))
- (val (car filter)))
- (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 filter defined here."))))
+ (message "No refiner defined here."))))
;; Proced predicates for sorting and filtering are based on a three-valued
;; logic:
-;; Predicates takes two arguments P1 and P2, the corresponding attribute
-;; values of two processes. Predicate should return 'equal if P1 has
+;; Predicates take two arguments P1 and P2, the corresponding attribute
+;; values of two processes. Predicates 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.
(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.
-Return sorted process list."
+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."
- (interactive
- (let ((scheme (completing-read "Sorting type: "
- proced-grammar-alist nil t)))
- (list (if (string= "" scheme) nil (intern scheme))
- current-prefix-arg)))
- (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))
+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'.
-(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)
+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* (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))))
+
+ (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."
- (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
(select-window (posn-window start))
- (setq col (+ (1- (car (posn-col-row start)))
+ (setq col (+ (1- (car (posn-actual-col-row start)))
(window-hscroll)))
(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))
(format-time-string "%b %e" start)))))
(defun proced-format-ttname (ttname)
- "Format attribute TTNAME, omitting prefix \"/dev/\"."
+ "Format attribute TTNAME, omitting path \"/dev/\"."
;; Does this work for all systems?
- (format "%s" (substring ttname
- (if (string-match "\\`/dev/" ttname)
- (match-end 0) 0))))
+ (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)."
+ (replace-regexp-in-string "\n" "^J" args))
(defun proced-format (process-alist format)
"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 (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)
+ (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 (if (stringp (nth 2 grammar))
- `(lambda (arg) (format ,(nth 2 grammar) arg))
- (nth 2 grammar)))
+ (fun (cond ((stringp (nth 2 grammar))
+ `(lambda (arg) (format ,(nth 2 grammar) arg)))
+ ((not (nth 2 grammar)) 'identity)
+ ( t (nth 2 grammar))))
(whitespace (if format whitespace ""))
;; Text properties:
;; We use the text property `proced-key' to store in each
;; 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))))
- (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"
+ (nth 1 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 sort-key)
+ (setq hprops (append '(face proced-sort-header) hprops)))
(goto-char (point-min))
(cond ( ;; fixed width of output field
(numberp (nth 3 grammar))
(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))
(defun proced-format-interactive (scheme &optional revert)
"Format Proced buffer using SCHEME.
When called interactively, an empty string means nil, i.e., no formatting.
+Set variable `proced-format' to SCHEME.
With prefix REVERT non-nil revert listing."
(interactive
(let ((scheme (completing-read "Format: "
proced-format-alist nil t)))
(list (if (string= "" scheme) nil (intern scheme))
current-prefix-arg)))
- (setq proced-format scheme)
- (proced-update revert))
+ ;; only update if necessary
+ (when (or (not (eq proced-format scheme)) revert)
+ (setq proced-format scheme)
+ (proced-update revert)))
;; 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))))
- (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)
- (push (funcall fun attributes) 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 attr)
+ (dolist (pid (or pid-list (list-system-processes)) process-alist)
+ (when (setq attributes (process-attributes pid))
+ (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.
+ "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)))
(or quiet (message (if revert "Updating process information..."
"Updating process display...")))
- ;; If point is on a field, we try to return point to that field.
- ;; Otherwise we try to return to the same column
- (let ((old-pos (let ((key (get-text-property (point) 'proced-key)))
- (list (proced-pid-at-point) key
+ (if revert ;; evaluate all processes
+ (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-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.
+ ;; Would that be useful? Re-re-sorting is easy, too.
+ (if (consp buffer-undo-list)
+ (setq buffer-undo-list nil))
+ (let ((buffer-undo-list t)
+ ;; If point is on a field, we try to return point to that field.
+ ;; Otherwise we try to return to the same column
+ (old-pos (let ((pid (proced-pid-at-point))
+ (key (get-text-property (point) 'proced-key)))
+ (list pid key ; can both be nil
(if key
(if (get-text-property (1- (point)) 'proced-key)
(- (point) (previous-single-property-change
(while (re-search-forward "^\\(\\S-\\)" nil t)
(push (cons (save-match-data (proced-pid-at-point))
(match-string-no-properties 1)) mp-list))
- (when revert
- ;; all attributes of all processes
- (setq proced-process-alist (proced-process-attributes))
- ;; do not keep undo information
- (if (consp buffer-undo-list)
- (setq buffer-undo-list nil)))
- ;; filtering and sorting
- (setq proced-process-alist
- (proced-sort (proced-filter proced-process-alist
- proced-filter) proced-sort))
+
;; generate listing
(erase-buffer)
(proced-format proced-process-alist proced-format)
(forward-line))
(setq proced-header-line (concat " " proced-header-line))
(if revert (set-buffer-modified-p nil))
+
;; set `goal-column'
(let ((grammar (assq proced-goal-attribute proced-grammar-alist)))
(setq goal-column ;; set to nil if no match
(if (nth 3 grammar)
(match-beginning 0)
(match-end 0)))))
- ;; restore process marks and buffer position (if possible)
+
+ ;; Restore process marks and buffer position (if possible).
+ ;; Sometimes this puts point in the middle of the proced buffer
+ ;; where it is not interesting. Is there a better / more flexible solution?
(goto-char (point-min))
- (if (or mp-list old-pos)
- (let (pid mark new-pos)
+ (let (pid mark new-pos)
+ (if (or mp-list (car old-pos))
(while (not (eobp))
(setq pid (proced-pid-at-point))
(when (setq mark (assq pid mp-list))
(point))))
(setq new-pos (point))))
(unless new-pos
- (setq new-pos (if goal-column
- (+ (line-beginning-position) goal-column)
- (line-beginning-position)))))
+ ;; we found the process, but the field of point
+ ;; is not listed anymore
+ (setq new-pos (proced-move-to-goal-column))))
(setq new-pos (min (+ (line-beginning-position) (nth 2 old-pos))
(line-end-position)))))
- (forward-line))
- (if new-pos
- (goto-char new-pos)
- (proced-move-to-goal-column)))
- (proced-move-to-goal-column))
+ (forward-line)))
+ (if new-pos
+ (goto-char new-pos)
+ (goto-char (point-min))
+ (proced-move-to-goal-column)))
;; update modeline
- ;; Does the long mode-name clutter the modeline?
+ ;; Does the long `mode-name' clutter the modeline? It would be nice
+ ;; to have some other location for displaying the values of the various
+ ;; flags that affect the behavior of proced (flags one might want
+ ;; to change on the fly). Where??
(setq mode-name
(concat "Proced"
(if proced-filter
(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)
+ ;; 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."
"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'
-;; 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)
(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
(dolist (process process-alist)
(insert " " (cdr process) "\n"))
(save-window-excursion
- (dired-pop-to-buffer bufname) ; all we need
+ ;; Analogous to `dired-pop-to-buffer'
+ ;; Don't split window horizontally. (Bug#1806)
+ (let (split-width-threshold)
+ (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"
proced-signal-list
nil nil nil nil "TERM")))
(setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
- (match-string 1 tmp) tmp))))))
- ;; send signal
- (let ((count 0)
- failures)
- ;; Why not always use `signal-process'? See
- ;; http://lists.gnu.org/archive/html/emacs-devel/2008-03/msg02955.html
- (if (functionp proced-signal-function)
- ;; use built-in `signal-process'
- (let ((signal (if (stringp signal)
- (if (string-match "\\`[0-9]+\\'" signal)
- (string-to-number signal)
- (make-symbol signal))
- signal))) ; number
- (dolist (process process-alist)
- (condition-case err
- (if (zerop (funcall
- proced-signal-function (car process) signal))
- (setq count (1+ count))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures))
- (error ;; catch errors from failed signals
- (proced-log "%s\n" err)
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures)))))
- ;; use external system call
- (let ((signal (concat "-" (if (numberp signal)
- (number-to-string signal) signal))))
+ (match-string 1 tmp) tmp)))))))
+ ;; send signal
+ (let ((count 0)
+ failures)
+ ;; Why not always use `signal-process'? See
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2008-03/msg02955.html
+ (if (functionp proced-signal-function)
+ ;; use built-in `signal-process'
+ (let ((signal (if (stringp signal)
+ (if (string-match "\\`[0-9]+\\'" signal)
+ (string-to-number signal)
+ (make-symbol signal))
+ signal))) ; number
(dolist (process process-alist)
- (with-temp-buffer
- (condition-case err
- (if (zerop (call-process
- proced-signal-function nil t nil
- signal (number-to-string (car process))))
- (setq count (1+ count))
- (proced-log (current-buffer))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures))
- (error ;; catch errors from failed signals
- (proced-log (current-buffer))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures)))))))
- (if failures
- ;; Proced error message are not always very precise.
- ;; Can we issue a useful one-line summary in the
- ;; message area (using FAILURES) if only one signal failed?
- (proced-log-summary
- signal
- (format "%d of %d signal%s failed"
- (length failures) (length process-alist)
- (if (= 1 (length process-alist)) "" "s")))
- (proced-success-message "Sent signal to" count)))
- ;; final clean-up
- (run-hooks 'proced-after-send-signal-hook))))
+ (condition-case err
+ (if (zerop (funcall
+ proced-signal-function (car process) signal))
+ (setq count (1+ count))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures))
+ (error ; catch errors from failed signals
+ (proced-log "%s\n" err)
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures)))))
+ ;; use external system call
+ (let ((signal (concat "-" (if (numberp signal)
+ (number-to-string signal) signal))))
+ (dolist (process process-alist)
+ (with-temp-buffer
+ (condition-case err
+ (if (zerop (call-process
+ proced-signal-function nil t nil
+ signal (number-to-string (car process))))
+ (setq count (1+ count))
+ (proced-log (current-buffer))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures))
+ (error ; catch errors from failed signals
+ (proced-log (current-buffer))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures)))))))
+ (if failures
+ ;; Proced error message are not always very precise.
+ ;; Can we issue a useful one-line summary in the
+ ;; message area (using FAILURES) if only one signal failed?
+ (proced-log-summary
+ signal
+ (format "%d of %d signal%s failed"
+ (length failures) (length process-alist)
+ (if (= 1 (length process-alist)) "" "s")))
+ (proced-success-message "Sent signal to" count)))
+ ;; final clean-up
+ (run-hooks 'proced-after-send-signal-hook)))
;; similar to `dired-why'
(defun proced-why ()
(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)