;;; 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
;; listed. See `proced-mode' for getting started.
;;
;; To do:
-;; - use defcustom where appropriate
;; - 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, `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:
(defcustom proced-signal-list
'( ;; signals supported on all POSIX compliant systems
- ("HUP (1. Hangup)")
- ("INT (2. Terminal interrupt)")
- ("QUIT (3. Terminal quit)")
- ("ABRT (6. Process abort)")
- ("KILL (9. Kill - cannot be caught or ignored)")
- ("ALRM (14. Alarm Clock)")
- ("TERM (15. Termination)")
+ ("HUP" . " (1. Hangup)")
+ ("INT" . " (2. Terminal interrupt)")
+ ("QUIT" . " (3. Terminal quit)")
+ ("ABRT" . " (6. Process abort)")
+ ("KILL" . " (9. Kill - cannot be caught or ignored)")
+ ("ALRM" . " (14. Alarm Clock)")
+ ("TERM" . " (15. Termination)")
;; POSIX 1003.1-2001
;; Which systems do not support these signals so that we can
;; exclude them from `proced-signal-list'?
- ("CONT (Continue executing)")
- ("STOP (Stop executing / pause - cannot be caught or ignored)")
- ("TSTP (Terminal stop / pause)"))
+ ("CONT" . " (Continue executing)")
+ ("STOP" . " (Stop executing / pause - cannot be caught or ignored)")
+ ("TSTP" . " (Terminal stop / pause)"))
"List of signals, used for minibuffer completion."
:group 'proced
- :type '(repeat (string :tag "signal")))
+ :type '(repeat (cons (string :tag "signal name")
+ (string :tag "description"))))
;; For which attributes can we use a fixed width of the output field?
;; A fixed width speeds up formatting, yet it can make
;;
;; 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" nil 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" 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))
- (pgrp "PGRP" "%d" right proced-< nil (pgrp euid pid) (nil t nil))
- (sess "SESS" "%d" right proced-< nil (sess 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))
(tpgid "TPGID" "%d" right proced-< nil (tpgid pid) (nil t nil))
- (minflt "MINFLT" "%d" right proced-< nil (minflt pid) (nil t t))
- (majflt "MAJFLT" "%d" right proced-< nil (majflt pid) (nil t t))
- (cminflt "CMINFLT" "%d" right proced-< nil (cminflt pid) (nil t t))
- (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))
- (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))
- (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))
- (start "START" proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
- (vsize "VSIZE" "%d" right proced-< t (vsize pid) (nil t t))
+ (minflt "MinFlt" "%d" right proced-< nil (minflt pid) (nil t t))
+ (majflt "MajFlt" "%d" right proced-< nil (majflt pid) (nil t t))
+ (cminflt "CMinFlt" "%d" right proced-< nil (cminflt pid) (nil t t))
+ (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))
+ (start "Start" proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
+ (vsize "VSize" "%d" right proced-< t (vsize pid) (nil t t))
(rss "RSS" "%d" right proced-< t (rss pid) (nil t t))
- (etime "ETIME" proced-format-time right proced-time-lessp t (etime 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" proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
+ (pmem "%Mem" "%.1f" right proced-< t (pmem pid) (nil t t))
+ (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 REFINE-FLAGS).
+ (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 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.
-(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
+(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
+(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-timer-flag)
+(make-variable-buffer-local 'proced-auto-update-flag)
+
+(defcustom proced-tree-flag nil
+ "Non-nil for display of Proced buffer as process tree."
+ :group 'proced
+ :type 'boolean)
+(make-variable-buffer-local 'proced-tree-flag)
+
+(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 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.")
-;; 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-sort-header-face 'proced-sort-header
- "Face name used for header of attribute used for sorting.")
(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-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-timer nil
- "Stores if Proced 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)"
"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)
;; marking
(define-key km "d" 'proced-mark) ; Dired compatibility ("delete")
(define-key km "m" 'proced-mark)
+ (put 'proced-mark :advertised-binding "m")
(define-key km "u" 'proced-unmark)
(define-key km "\177" 'proced-unmark-backward)
(define-key km "M" 'proced-mark-all)
;; 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"
: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"]))
(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"
- "Mode for displaying UNIX system processes and sending signals to them.
-Type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
+(define-derived-mode proced-mode special-mode "Proced"
+ "Mode for displaying system processes and sending signals to them.
+Type \\[proced] to start a Proced session. In a Proced buffer
+type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.
The initial content of a listing is defined by the variable `proced-filter'
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
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)
"Generate a listing of UNIX system processes.
If invoked with optional ARG the window displaying the process
information will be displayed but not selected.
+Runs the normal hook `proced-post-display-hook'.
-See `proced-mode' for a 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)))
- (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 ()
+(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")))
+
+;;; 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)
(let ((scheme (completing-read "Filter: "
proced-filter-alist nil t)))
(list (if (string= "" scheme) nil (intern scheme)))))
- (setq proced-filter scheme)
- (proced-update t))
+ ;; 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-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
"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)))
- (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 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
(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))
(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 (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 (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"
+ (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 proced-sort)
- (setq hprops (append `(face ,proced-sort-header-face) hprops)))
+ (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))
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)))
(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.
(match-beginning 0)
(match-end 0)))))
- ;; restore process marks and buffer position (if possible)
- ;; FIXME: sometimes this puts point in the middle of the proced buffer
+ ;; 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))
(let (pid mark new-pos)
(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
(line-end-position))))))
(unless signal
;; Display marked processes (code taken from `dired-mark-pop-up').
- (let ((bufname " *Marked Processes*")
+ (let ((bufname "*Marked Processes*")
(header-line (substring-no-properties proced-header-line)))
(with-current-buffer (get-buffer-create bufname)
(setq truncate-lines t
proced-header-line header-line ; inherit header line
header-line-format '(:eval (proced-header-line)))
(add-hook 'post-command-hook 'force-mode-line-update nil t)
- (erase-buffer)
- (dolist (process process-alist)
- (insert " " (cdr process) "\n"))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (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"
(format "%d processes" (length process-alist))))
- ;; The following is an ugly hack. Is there a better way
- ;; to help people like me to remember the signals and
- ;; their meanings?
- (tmp (completing-read (concat "Send signal [" pnum
- "] (default TERM): ")
- 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))))
+ (completion-annotate-function
+ (lambda (s) (cdr (assoc s proced-signal-list)))))
+ (setq signal
+ (completing-read (concat "Send signal [" pnum
+ "] (default TERM): ")
+ proced-signal-list
+ nil nil nil nil "TERM")))))))
+ ;; 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)
(message "Change in Proced buffer undone.
Killed processes cannot be recovered by Emacs."))
+(defun proced-unload-function ()
+ "Unload the Proced library."
+ (save-current-buffer
+ (dolist (buf (buffer-list))
+ (set-buffer buf)
+ (when (eq major-mode 'proced-mode)
+ (funcall (or (default-value 'major-mode) 'fundamental-mode)))))
+ ;; continue standard unloading
+ nil)
+
(provide 'proced)
;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af