X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/08b3caa982199bd7939d9d6877203ada5d0083b5..1ddd96f5cf0b06846edd03d6b225c31206cee0b7:/lisp/proced.el diff --git a/lisp/proced.el b/lisp/proced.el index fa99eb25d0..94ea579ebd 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1,8 +1,8 @@ ;;; proced.el --- operate on system processes like dired -;; Copyright (C) 2008 Free Software Foundation, Inc. +;; Copyright (C) 2008-2011 Free Software Foundation, Inc. -;; Author: Roland Winkler +;; Author: Roland Winkler ;; Keywords: Processes, Unix ;; This file is part of GNU Emacs. @@ -22,118 +22,38 @@ ;;; Commentary: -;; Proced makes an Emacs buffer containing a listing of the current system -;; processes (using ps(1)). You can use the normal Emacs commands -;; to move around in this buffer, and special Proced commands to operate -;; on the processes listed. +;; 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. See `proced-mode' for getting started. ;; ;; To do: -;; - decompose ps(1) output into columns (for `proced-header-alist') -;; How can we identify columns that may contain whitespace -;; and that can be either right or left justified? -;; Use a "grammar table"? -;; - sort the "cooked" values used in the output format fields -;; if ps(1) doesn't support the requested sorting scheme -;; - filter by user name or other criteria -;; - automatic update of process list +;; - 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: +(require 'time-date) ; for `with-decoded-time-value' + (defgroup proced nil "Proced mode." :group 'processes :group 'unix :prefix "proced-") -;; FIXME: a better approach instead of PID-COLUMN would be based -;; on `proced-header-alist' once we have a reliable scheme to set this variable -(defcustom proced-command-alist - (cond ((memq system-type '(berkeley-unix)) - '(("user" ("ps" "-uxgww") 2) - ("user-running" ("ps" "-uxrgww") 2) - ("all" ("ps" "-auxgww") 2) - ("all-running" ("ps" "-auxrgww") 2))) - ((memq system-type '(gnu gnu/linux)) ; BSD syntax - `(("user" ("ps" "uxwww") 2) - ("user-running" ("ps" "uxrwww") 2) - ("all" ("ps" "auxwww") 2) - ("all-running" ("ps" "auxrwww") 2) - ("emacs" ("ps" "--pid" ,(number-to-string (emacs-pid)) - "--ppid" ,(number-to-string (emacs-pid)) - "uwww") 2))) - ((memq system-type '(darwin)) - `(("user" ("ps" "-u" ,(number-to-string (user-uid))) 2) - ("all" ("ps" "-Au") 2))) - (t ; standard UNIX syntax; doesn't allow to list running processes only - `(("user" ("ps" "-fu" ,(number-to-string (user-uid))) 2) - ("all" ("ps" "-ef") 2)))) - "Alist of commands to get list of processes. -Each element has the form (NAME COMMAND PID-COLUMN). -NAME is a shorthand name to select the type of listing. -COMMAND is a list (COMMAND-NAME ARG1 ARG2 ...), -where COMMAND-NAME is the command to generate the listing (usually \"ps\"). -ARG1, ARG2, ... are arguments passed to COMMAND-NAME to generate -a particular listing. These arguments differ under various operating systems. -PID-COLUMN is the column number (starting from 1) of the process ID." - :group 'proced - :type '(repeat (group (string :tag "name") - (cons (string :tag "command") - (repeat (string :tag "option"))) - (integer :tag "PID column")))) - -(defcustom proced-command (if (zerop (user-real-uid)) "all" "user") - "Name of process listing. -Must be the car of an element of `proced-command-alist'." - :group 'proced - :type '(string :tag "name")) -(make-variable-buffer-local 'proced-command) - -;; Should we incorporate in NAME that sorting can be done in ascending -;; or descending order? Then we couldn't associate NAME anymore with one -;; of the headers in the output of ps(1). -;; FIXME: A sorting scheme without options or with an option being a symbol -;; should be implemented in elisp -(defcustom proced-sorting-schemes-alist - (cond ((memq system-type '(gnu gnu/linux)) ; GNU long options - '(("%CPU" "--sort" "-pcpu") ; descending order - ("%MEM" "--sort" "-pmem") ; descending order - ("COMMAND" "--sort" "args") - ("PID" "--sort" "pid") - ("PGID,PID" "--sort" "pgid,pid") - ("PPID,PID" "--sort" "ppid,pid") - ("RSS" "--sort" "rss,pid") ; equal RSS's are rare - ("STAT,PID" "--sort" "stat,pid") - ("START" "--sort" "start_time") - ("TIME" "--sort" "cputime") - ("TTY,PID" "--sort" "tty,pid") - ("UID,PID" "--sort" "uid,pid") - ("USER,PID" "--sort" "user,pid") - ("VSZ,PID" "--sort" "vsz,pid")))) - "Alist of sorting schemes. -Each element is a list (NAME OPTION1 OPTION2 ...). -NAME denotes the sorting scheme. It is the name of a header or a -comma-separated sequence of headers in the output of ps(1). -OPTION1, OPTION2, ... are options defining the sorting scheme." - :group 'proced - :type '(repeat (cons (string :tag "name") - (repeat (string :tag "option"))))) - -(defcustom proced-sorting-scheme nil - "Proced sorting type. -Must be the car of an element of `proced-sorting-schemes-alist' or nil." - :group 'proced - :type `(choice ,@(append '((const nil)) ; sorting type may be nil - (mapcar (lambda (item) - (list 'const (car item))) - proced-sorting-schemes-alist)))) -(make-variable-buffer-local 'proced-sorting-scheme) - -(defcustom proced-goal-header-re "\\b\\(CMD\\|COMMAND\\)\\b" - "If non-nil, regexp that defines the `proced-goal-column'." - :group 'proced - :type '(choice (const :tag "none" nil) - (regexp :tag "regexp"))) - (defcustom proced-signal-function 'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying @@ -143,22 +63,327 @@ the external command (usually \"kill\")." (string :tag "command"))) (defcustom proced-signal-list - '(("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)")) + '( ;; 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)") + ;; 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)")) "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 +;; `proced-grammar-alist' system-dependent. +;; (If proced runs like top(1) we want it to be fast.) +;; +;; If it is impossible / unlikely that an attribute has the same value +;; for two processes, then sorting can be based on one ordinary (fast) +;; predicate like `<'. Otherwise, a list of proced predicates can be used +;; to refine the sort. +;; +;; It would be neat if one could temporarily override the following +;; predefined rules. +(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)) + (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) + ((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)) + (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)) + (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)) + ;; + ;; attributes defined by proced (see `proced-process-attributes') + (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 REFINER). + +Symbol KEY is the car of a process attribute. + +String NAME appears in the header line. + +FORMAT specifies the format for displaying the attribute values. It can +be a string passed to `format'. It can be a function called with one +argument, the value of the attribute. 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 +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 +right-justified otherwise. + +PREDICATE is the predicate for sorting and filtering the process listing +based on attribute KEY. PREDICATE takes two arguments P1 and P2, +the corresponding attribute values of two processes. PREDICATE should +return 'equal if P1 has same rank like P2. Any other non-nil value says +that P1 is \"less than\" P2, or nil if not. +If PREDICATE is nil the attribute cannot be sorted. + +PREDICATE defines an ascending sort order. REVERSE is non-nil if the sort +order is descending. + +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 sort order for the corresponding +processes. If it evaluates to 'equal the PREDICATE of KEY2 is evaluated, etc. + +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. + +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 `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 +;; transparent to define a new derived attribute, so that formatting and +;; sorting can use them consistently. (Are there exceptions to this rule? +;; Would it be advantageous to have yet more general methods available?) +;; Sorting can also be based on attributes that are invisible in the listing. + +(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 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 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 "")))))) + +(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'." + :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? +(defcustom proced-filter-alist + `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))) + (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")) + (state . "\\`[Rr]\\'")) + (all) + (all-running (state . "\\`[Rr]\\'")) + (emacs (fun-all . (lambda (list) + (proced-filter-children list ,(emacs-pid)))))) + "Alist of process filters. +The car of each element is a symbol, the name of the filter. +The cdr is a list of elementary filters that are applied to every process. +A process is displayed if it passes all elementary filters of a selected +filter. + +An elementary filter can be one of the following: +\(KEY . REGEXP) If value of attribute KEY matches REGEXP, + accept this process. +\(KEY . FUN) Apply function FUN to attribute KEY. Accept this process, + if FUN returns non-nil. +\(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." + :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'." + :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) + +(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'." + :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'." + :group 'proced + :type '(choice (const :tag "none" nil) + (symbol :tag "key"))) + +(defcustom proced-auto-update-interval 5 + "Time interval in seconds for auto updating Proced buffers." + :group 'proced + :type 'integer) + +(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-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 +cons pairs, see `proced-process-attributes'.") +(make-variable-buffer-local 'proced-process-alist) + +(defvar proced-sort-internal nil + "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 @@ -166,119 +391,178 @@ the external command (usually \"kill\")." (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. Important: the match ends just after the marker.") -(defvar proced-goal-column nil - "Proced goal column. Initialized based on `proced-goal-header-re'.") -(make-variable-buffer-local 'proced-goal-column) +(defvar proced-header-line nil + "Headers in Proced buffer as a string.") +(make-variable-buffer-local 'proced-header-line) + +(defvar proced-temp-alist nil + "Temporary alist (internal variable).") + +(defvar proced-process-tree nil + "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-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.") + +(defconst proced-header-help-echo + "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: 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 "n" 'proced-next-line) - (define-key km "p" 'proced-previous-line) - (define-key km "\C-n" 'proced-next-line) - (define-key km "\C-p" 'proced-previous-line) - (define-key km "\C-?" 'proced-previous-line) - (define-key km [down] 'proced-next-line) - (define-key km [up] 'proced-previous-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 "\C-p" 'previous-line) + (define-key km "\C-?" 'previous-line) + (define-key km [down] 'next-line) + (define-key km [up] 'previous-line) ;; marking - (define-key km "d" 'proced-mark) ; Dired compatibility + (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) (define-key km "U" 'proced-unmark-all) (define-key km "t" 'proced-toggle-marks) + (define-key km "C" 'proced-mark-children) + (define-key km "P" 'proced-mark-parents) + ;; filtering + (define-key km "f" 'proced-filter-interactive) + (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 "sp" 'proced-sort-pid) (define-key km "ss" 'proced-sort-start) - (define-key km "sS" 'proced-sort) + (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 "h" 'proced-hide-processes) + (define-key km "o" 'proced-omit-processes) (define-key km "x" 'proced-send-signal) ; Dired compatibility (define-key km "k" 'proced-send-signal) ; kill processes ;; misc - (define-key km "l" 'proced-listing-type) - (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" - '("Proced" - ["Mark" proced-mark t] - ["Unmark" proced-unmark t] - ["Mark All" proced-mark-all t] - ["Unmark All" proced-unmark-all t] - ["Toggle Marks" proced-unmark-all t] + `("Proced" + ["Mark" proced-mark + :help "Mark Current Process"] + ["Unmark" proced-unmark + :help "Unmark Current Process"] + ["Mark All" proced-mark-all + :help "Mark All Processes"] + ["Unmark All" proced-unmark-all + :help "Unmark All Process"] + ["Toggle Marks" proced-toggle-marks + :help "Marked Processes Become Unmarked, and Vice Versa"] + ["Mark Children" proced-mark-children + :help "Mark Current Process and its Children"] + ["Mark Parents" proced-mark-parents + :help "Mark Current Process and its Parents"] "--" - ["Sort" proced-sort t] - ["Sort by %CPU" proced-sort-pcpu (proced-sorting-scheme-p "%CPU")] - ["Sort by %MEM" proced-sort-pmem (proced-sorting-scheme-p "%MEM")] - ["Sort by PID" proced-sort-pid (proced-sorting-scheme-p "PID")] - ["Sort by START" proced-sort-start (proced-sorting-scheme-p "START")] - ["Sort by TIME" proced-sort-time (proced-sorting-scheme-p "TIME")] + ("Filters" + :help "Select Filter for Process Listing" + ,@(mapcar (lambda (el) + (let ((filter (car el))) + `[,(symbol-name filter) + (proced-filter-interactive ',filter) + :style radio + :selected (eq proced-filter ',filter)])) + proced-filter-alist)) + ("Sorting" + :help "Select Sort Scheme" + ["Sort..." proced-sort-interactive + :help "Sort Process List"] + "--" + ["Sort by %CPU" proced-sort-pcpu] + ["Sort by %MEM" proced-sort-pmem] + ["Sort by PID" proced-sort-pid] + ["Sort by START" proced-sort-start] + ["Sort by TIME" proced-sort-time] + ["Sort by USER" proced-sort-user]) + ("Formats" + :help "Select Format for Process Listing" + ,@(mapcar (lambda (el) + (let ((format (car el))) + `[,(symbol-name format) + (proced-format-interactive ',format) + :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"] "--" - ["Hide Marked Processes" proced-hide-processes t] + ["Omit Marked Processes" proced-omit-processes + :help "Omit Marked Processes in Process Listing."] "--" - ["Revert" revert-buffer t] - ["Send signal" proced-send-signal t] - ["Change listing" proced-listing-type t])) - -(defconst proced-help-string - "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit (type ? for more help)" - "Help string for proced.") - -(defvar proced-header-line nil - "Headers in Proced buffer as a string.") -(make-variable-buffer-local 'proced-header-line) - -(defvar proced-header-alist nil - "Alist of headers in Proced buffer. -Each element is of the form (NAME START END JUSTIFY). -NAME is name of header in the output of ps(1). -START and END are column numbers starting from 0. -END is t if there is no end column for that field. -JUSTIFY is 'left or 'right for left or right-justified output of ps(1).") -(make-variable-buffer-local 'proced-header-alist) - -(defvar proced-sorting-schemes-re nil - "Regexp to match valid sorting schemes.") -(make-variable-buffer-local 'proced-sorting-schemes-re) + ["Revert" revert-buffer + :help "Revert Process Listing"] + ["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"])) ;; helper functions (defun proced-marker-regexp () @@ -290,26 +574,73 @@ JUSTIFY is 'left or 'right for left or right-justified output of ps(1).") "Display success message for ACTION performed for COUNT processes." (message "%s %s process%s" action count (if (= 1 count) "" "es"))) +;; Unlike dired, we do not define our own commands for vertical motion. +;; If `goal-column' is set, `next-line' and `previous-line' are fancy +;; commands to satisfy our modest needs. If `proced-goal-attribute' +;; and/or `goal-column' are not set, `next-line' and `previous-line' +;; are really what we need to preserve the column of point. +;; We use `proced-move-to-goal-column' for "non-interactive" cases only +;; to get a well-defined position of point. + (defun proced-move-to-goal-column () - "Move to `proced-goal-column' if non-nil." + "Move to `goal-column' if non-nil. Return position of point." (beginning-of-line) - (if proced-goal-column - (forward-char proced-goal-column) - (forward-char 2))) - -;; FIXME: a better approach would be based on `proced-header-alist' -;; once we have a reliable scheme to set this variable -(defsubst proced-skip-regexp () - "Regexp to skip in process listing to find PID column." - (apply 'concat (make-list (1- (nth 2 (assoc proced-command - proced-command-alist))) - "\\s-+\\S-+"))) - -(define-derived-mode proced-mode nil "Proced" - "Mode for displaying UNIX system processes and sending signals to them. -Type \\[proced-mark-process] to mark a process for later commands. + (unless (eobp) + (if goal-column + (forward-char goal-column) + (forward-char 2))) + (point)) + +(defun proced-header-line () + "Return header line for Proced buffer." + (list (propertize " " 'display '(space :align-to 0)) + (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. +Return nil if point is not on a process line." + (save-excursion + (beginning-of-line) + (if (looking-at "^. .") + (get-text-property (match-end 0) 'proced-pid)))) + +;; proced mode + +(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-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) @@ -319,49 +650,67 @@ Type \\[proced-send-signal] to send signals to marked processes. (add-hook 'post-command-hook 'force-mode-line-update nil t) (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))) - -;; Proced mode is suitable only for specially formatted data. -(put 'proced-mode 'mode-class 'special) + '(proced-font-lock-keywords t nil nil beginning-of-line)) + (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-mark-process] 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)) - + (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 + (proced-update t))) (pop-to-buffer buffer) - (message (substitute-command-keys - "type \\[quit-window] to quit, \\[proced-help] for help"))))) - -(defun proced-next-line (arg) - "Move down lines then position at `proced-goal-column'. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "p") - (forward-line arg) - (proced-move-to-goal-column)) - -(defun proced-previous-line (arg) - "Move up lines then position at `proced-goal-column'. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "p") - (forward-line (- arg)) - (proced-move-to-goal-column)) + (proced-update t) + (message + (substitute-command-keys + "Type \\\\[quit-window] to quit, \\[proced-help] for help"))))) + +(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-auto-update-flag) + (proced-update t t))))) + +(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-auto-update-flag + (cond ((eq arg 'toggle) (not proced-auto-update-flag)) + (arg (> (prefix-numeric-value arg) 0)) + (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." @@ -381,7 +730,7 @@ Optional prefix ARG says how many lines to move; default is one line." (proced-do-mark nil (- (or count 1)))) (defun proced-do-mark (mark &optional count) - "Mark the current (or next ARG) processes using MARK." + "Mark the current (or next COUNT) processes using MARK." (or count (setq count 1)) (let ((backward (< count 0)) buffer-read-only) @@ -392,24 +741,6 @@ Optional prefix ARG says how many lines to move; default is one line." (proced-insert-mark mark backward)) (proced-move-to-goal-column))) -(defun proced-mark-all () - "Mark all processes." - (interactive) - (proced-do-mark-all t)) - -(defun proced-unmark-all () - "Unmark all processes." - (interactive) - (proced-do-mark-all nil)) - -(defun proced-do-mark-all (mark) - "Mark all processes using MARK." - (let (buffer-read-only) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (proced-insert-mark mark))))) - (defun proced-toggle-marks () "Toggle marks: marked processes become unmarked, and vice versa." (interactive) @@ -434,253 +765,1105 @@ Otherwise move one line forward after inserting the mark." (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 the region." + (interactive) + (proced-do-mark-all t)) + +(defun proced-unmark-all () + "Unmark all processes. +If `transient-mark-mode' is turned on and the region is active, +unmark the region." + (interactive) + (proced-do-mark-all nil)) + +(defun proced-do-mark-all (mark) + "Mark all processes using MARK. +If `transient-mark-mode' is turned on and the region is active, +mark the region." + (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 + ;; of region. This appears most consistent with + ;; `proced-move-to-goal-column'. + (progn (setq end (save-excursion + (goto-char (region-end)) + (unless (looking-at "^") (forward-line)) + (point))) + (goto-char (region-beginning)) + (unless (looking-at "^") (beginning-of-line))) + (goto-char (point-min)) + (setq end (point-max))) + (while (< (point) end) + (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. +Also mark process PPID unless prefix OMIT-PPID is non-nil." + (interactive (list (proced-pid-at-point) current-prefix-arg)) + (proced-mark-process-alist + (proced-filter-children proced-process-alist ppid omit-ppid))) + +(defun proced-mark-parents (cpid &optional omit-cpid) + "Mark parent processes of process CPID. +Also mark CPID unless prefix OMIT-CPID is non-nil." + (interactive (list (proced-pid-at-point) current-prefix-arg)) + (proced-mark-process-alist + (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) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (assq (proced-pid-at-point) process-alist) + (insert proced-marker-char) + (delete-char 1) + (setq count (1+ count))) + (forward-line))))) + (unless quiet + (proced-success-message "Marked" count)))) + ;; Mostly analog of `dired-do-kill-lines'. ;; However, for negative args the target lines of `dired-do-kill-lines' ;; include the current line, whereas `dired-mark' for negative args operates -;; on the preceding lines. Here we are consistent with `dired-mark'. -(defun proced-hide-processes (&optional arg quiet) - "Hide marked processes. -With prefix ARG, hide that many lines starting with the current line. -\(A negative argument hides backward.) +;; on the preceding lines. Here we are consistent with `dired-mark'. +(defun proced-omit-processes (&optional arg quiet) + "Omit marked processes. +With prefix ARG, omit that many lines starting with the current line. +\(A negative argument omits backward.) +If `transient-mark-mode' is turned on and the region is active, +omit the processes in region. If QUIET is non-nil suppress status message. -Returns count of hidden lines." +Returns count of omitted lines." (interactive "P") (let ((mark-re (proced-marker-regexp)) (count 0) buffer-read-only) - (save-excursion - (if arg - ;; Hide ARG lines starting with the current line. - (delete-region (line-beginning-position) - (save-excursion - (if (<= 0 arg) - (setq count (- arg (forward-line arg))) - (setq count (min (1- (line-number-at-pos)) - (abs arg))) - (forward-line (- count))) - (point))) - ;; Hide marked lines - (while (and (not (eobp)) - (re-search-forward mark-re nil t)) - (delete-region (match-beginning 0) - (save-excursion (forward-line) (point))) - (setq count (1+ count))))) + (cond ((use-region-p) ;; Omit active region + (let ((lines (count-lines (region-beginning) (region-end)))) + (save-excursion + (goto-char (region-beginning)) + (while (< count lines) + (proced-omit-process) + (setq count (1+ count)))))) + ((not arg) ;; Omit marked lines + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) + (re-search-forward mark-re nil t)) + (proced-omit-process) + (setq count (1+ count))))) + ((< 0 arg) ;; Omit forward + (while (and (not (eobp)) (< count arg)) + (proced-omit-process) + (setq count (1+ count)))) + ((< arg 0) ;; Omit backward + (while (and (not (bobp)) (< count (- arg))) + (forward-line -1) + (proced-omit-process) + (setq count (1+ count))))) (unless (zerop count) (proced-move-to-goal-column)) - (unless quiet (proced-success-message "Hid" count)) + (unless quiet (proced-success-message "Omitted" count)) count)) -(defun proced-listing-type (command) - "Select `proced' listing type COMMAND from `proced-command-alist'." +(defun proced-omit-process () + "Omit process from listing point is on. +Update `proced-process-alist' accordingly." + (setq proced-process-alist + (assq-delete-all (proced-pid-at-point) proced-process-alist)) + (delete-region (line-beginning-position) + (save-excursion (forward-line) (point)))) + +;;; Filtering + +(defun proced-filter (process-alist filter-list) + "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) + (let (new-alist) + (cond ( ;; apply function to entire process list + (eq (car filter) 'fun-all) + (setq new-alist (funcall (cdr filter) process-alist))) + ( ;; apply predicate to each list of attributes + (eq (car filter) 'function) + (dolist (process process-alist) + (if (funcall (car filter) (cdr process)) + (push process new-alist)))) + (t ;; apply predicate to specified attribute + (let ((fun (if (stringp (cdr filter)) + `(lambda (val) + (string-match ,(cdr filter) val)) + (cdr filter))) + value) + (dolist (process process-alist) + (setq value (cdr (assq (car filter) (cdr process)))) + (if (and value (funcall fun value)) + (push process new-alist)))))) + (setq process-alist new-alist))) + process-alist) + +(defun proced-filter-interactive (scheme) + "Filter Proced buffer using SCHEME. +When called interactively, an empty string means nil, i.e., no filtering. +Set variable `proced-filter' to SCHEME. Revert listing." (interactive - (list (completing-read "Listing type: " proced-command-alist nil t))) - (setq proced-command command) - (proced-update)) + (let ((scheme (completing-read "Filter: " + proced-filter-alist nil t))) + (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-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-temp-alist (proced-children-alist process-alist)) + new-alist) + (dolist (pid (proced-children-pids ppid)) + (push (assq pid process-alist) new-alist)) + (if omit-ppid + (assq-delete-all ppid new-alist) + new-alist))) + +;;; 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-temp-alist)))) + (if cpids + (cons ppid (apply 'append (mapcar 'proced-children-pids cpids))) + (list ppid)))) + +(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 + +;; 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)) + (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.")))) + +;; Proced predicates for sorting and filtering are based on a three-valued +;; logic: +;; 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. + +(defun proced-< (num1 num2) + "Return t if NUM1 less than NUM2. +Return `equal' if NUM1 equals NUM2. Return nil if NUM1 greater than NUM2." + (if (= num1 num2) + 'equal + (< num1 num2))) + +(defun proced-string-lessp (s1 s2) + "Return t if string S1 is less than S2 in lexicographic order. +Return `equal' if S1 and S2 have identical contents. +Return nil otherwise." + (if (string= s1 s2) + 'equal + (string-lessp s1 s2))) + +(defun proced-time-lessp (t1 t2) + "Return t if time value T1 is less than time value T2. +Return `equal' if T1 equals T2. Return nil otherwise." + (with-decoded-time-value ((high1 low1 micro1 t1) + (high2 low2 micro2 t2)) + (cond ((< high1 high2)) + ((< high2 high1) nil) + ((< low1 low2)) + ((< low2 low1) nil) + ((< micro1 micro2)) + ((< micro2 micro1) nil) + (t 'equal)))) -;; adopted from `ruler-mode-space' -(defsubst proced-header-space (width) - "Return a single space string of WIDTH times the normal character width." - (propertize " " 'display (list 'space :width width))) +;;; Sorting -;; header line: code inspired by `ruler-mode-ruler' -(defun proced-header-line () - "Return header line for Proced buffer." - (list (propertize " " 'display '(space :align-to 0)) - (replace-regexp-in-string - "%" "%%" (substring proced-header-line (window-hscroll))))) +(defsubst proced-xor (b1 b2) + "Return the logical exclusive or of args B1 and B2." + (and (or b1 b2) + (not (and b1 b2)))) + +(defun proced-sort-p (p1 p2) + "Predicate for sorting processes P1 and P2." + (if (not (cdr proced-sort-internal)) + ;; only one predicate: fast scheme + (let* ((sorter (car proced-sort-internal)) + (k1 (cdr (assq (car sorter) (cdr p1)))) + (k2 (cdr (assq (car sorter) (cdr p2))))) + ;; if the attributes are undefined, we should really abort sorting + (if (and k1 k2) + (proced-xor (funcall (nth 1 sorter) k1 k2) + (nth 2 sorter)))) + (let ((sort-list proced-sort-internal) sorter predicate k1 k2) + (catch 'done + (while (setq sorter (pop sort-list)) + (setq k1 (cdr (assq (car sorter) (cdr p1))) + k2 (cdr (assq (car sorter) (cdr p2))) + predicate + (if (and k1 k2) + (funcall (nth 1 sorter) k1 k2))) + (if (not (eq predicate 'equal)) + (throw 'done (proced-xor predicate (nth 2 sorter))))) + (eq t predicate))))) + +(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) + (nth 6 (assq sorter proced-grammar-alist)))) + ((symbolp sorter) (list sorter)) + (t (error "Sorter undefined %s" sorter))))) + (if proced-sort-internal + (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 arg) + "Sort Proced buffer using SCHEME. +When called interactively, an empty string means nil, i.e., no sorting. -(defun proced-update (&optional quiet) - "Update the `proced' process information. Preserves point and marks." - ;; This is the main function that generates and updates the process listing. - (interactive) - (or quiet (message "Updating process information...")) - (let* ((command (cadr (assoc proced-command proced-command-alist))) - (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)")) - (old-pos (if (save-excursion - (beginning-of-line) - (looking-at (concat "^[* ]" regexp))) - (cons (match-string-no-properties 1) - (current-column)))) - buffer-read-only mp-list) +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* (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 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-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 arg) + (message "No sorter defined here.")))))) + +;;; Formating + +(defun proced-format-time (time) + "Format time interval TIME." + (let* ((ftime (float-time time)) + (days (truncate ftime 86400)) + (ftime (mod ftime 86400)) + (hours (truncate ftime 3600)) + (ftime (mod ftime 3600)) + (minutes (truncate ftime 60)) + (seconds (mod ftime 60))) + (cond ((< 0 days) + (format "%d-%02d:%02d:%02d" days hours minutes seconds)) + ((< 0 hours) + (format "%02d:%02d:%02d" hours minutes seconds)) + (t + (format "%02d:%02d" minutes seconds))))) + +(defun proced-format-start (start) + "Format time START. +The return string is always 6 characters wide." + (let ((d-start (decode-time start)) + (d-current (decode-time))) + (cond ( ;; process started in previous years + (< (nth 5 d-start) (nth 5 d-current)) + (format-time-string " %Y" start)) + ;; process started today + ((and (= (nth 3 d-start) (nth 3 d-current)) + (= (nth 4 d-start) (nth 4 d-current))) + (format-time-string " %H:%M" start)) + (t ;; process started this year + (format-time-string "%b %e" start))))) + +(defun proced-format-ttname (ttname) + "Format attribute TTNAME, omitting path \"/dev/\"." + ;; Does this work for all systems? + (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 " ") (unknown "?") + (sort-key (if (consp proced-sort) (car proced-sort) proced-sort)) + header-list grammar) + ;; Loop over all attributes + (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))) + ((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 + (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 "+" "-")) + 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)) + (dolist (process process-alist) + (end-of-line) + (setq value (cdr (assq key (cdr process)))) + (insert (if value + (apply 'propertize (funcall fun value) fprops) + (format (concat "%" (number-to-string (nth 3 grammar)) "s") + unknown)) + whitespace) + (forward-line)) + (push (format (concat "%" (number-to-string (nth 3 grammar)) "s") + (apply 'propertize (nth 1 grammar) hprops)) + header-list)) + + ( ;; last field left-justified + (and (not format) (eq 'left (nth 3 grammar))) + (dolist (process process-alist) + (end-of-line) + (setq value (cdr (assq key (cdr process)))) + (insert (if value (apply 'propertize (funcall fun value) fprops) + unknown)) + (forward-line)) + (push (apply 'propertize (nth 1 grammar) hprops) header-list)) + + (t ;; calculated field width + (let ((width (length (nth 1 grammar))) + field-list value) + (dolist (process process-alist) + (setq value (cdr (assq key (cdr process)))) + (if value + (setq value (apply 'propertize (funcall fun value) fprops) + width (max width (length value)) + field-list (cons value 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)) + header-list) + (dolist (value (nreverse field-list)) + (end-of-line) + (insert (format afmt value) whitespace) + (forward-line)))))))) + + ;; final cleanup + (goto-char (point-min)) + (dolist (process process-alist) + ;; We use the text property `proced-pid' to store in each line + ;; the corresponding pid + (put-text-property (point) (line-end-position) 'proced-pid (car process)) + (forward-line)) + ;; Set header line + (setq proced-header-line + (mapconcat 'identity (nreverse header-list) whitespace)) + (if (string-match "[ \t]+$" proced-header-line) + (setq proced-header-line (substring proced-header-line 0 + (match-beginning 0)))) + ;; (delete-trailing-whitespace) (goto-char (point-min)) + (while (re-search-forward "[ \t\r]+$" nil t) + (delete-region (match-beginning 0) (match-end 0))))) + +(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))) + ;; 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 (&optional pid-list) + "Return alist of attributes for each system process. +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. +With prefix REVERT non-nil, revert listing. +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 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 + (point) 'proced-key)) + 0) + (current-column))))) + buffer-read-only mp-list) ;; remember marked processes (whatever the mark was) - (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t) - (push (cons (match-string-no-properties 2) + (goto-char (point-min)) + (while (re-search-forward "^\\(\\S-\\)" nil t) + (push (cons (save-match-data (proced-pid-at-point)) (match-string-no-properties 1)) mp-list)) - ;; generate new listing + + ;; generate listing (erase-buffer) - (apply 'call-process (car command) nil t nil - (append (cdr command) (cdr (assoc proced-sorting-scheme - proced-sorting-schemes-alist)))) + (proced-format proced-process-alist proced-format) (goto-char (point-min)) (while (not (eobp)) (insert " ") (forward-line)) - ;; (delete-trailing-whitespace) - (goto-char (point-min)) - (while (re-search-forward "[ \t\r]+$" nil t) - (delete-region (match-beginning 0) (match-end 0))) - (goto-char (point-min)) - (let ((lep (line-end-position))) - (setq proced-header-line (buffer-substring-no-properties (point) lep)) - (setq proced-header-alist nil) - ;; FIXME: handle left/right justification properly - (while (re-search-forward "\\([^ \t\n]+\\)[ \t]*\\($\\)?" lep t) - (push (list (match-string-no-properties 1) - ;; take the column number starting from zero - (- (match-beginning 0) (point-min)) - (or (not (not (match-beginning 2))) - (- (match-end 0) (point-min))) - 'left) - proced-header-alist))) - (let ((temp (regexp-opt (mapcar 'car proced-header-alist) t))) - (setq proced-sorting-schemes-re - (concat "\\`" temp "\\(," temp "\\)*\\'"))) - ;; remove header line from ps(1) output - (goto-char (point-min)) - (delete-region (point) - (save-excursion (forward-line) (point))) - (set-buffer-modified-p nil) - ;; set `proced-goal-column' - (if proced-goal-header-re - (let ((hlist proced-header-alist) header) - (while (setq header (pop hlist)) - (if (string-match proced-goal-header-re (car header)) - (setq proced-goal-column - (if (eq 'left (nth 3 header)) - (nth 1 header) (nth 2 header)) - hlist nil))))) - ;; restore process marks - (if mp-list - (save-excursion - (goto-char (point-min)) - (let (mark) - (while (re-search-forward (concat "^" regexp) nil t) - (if (setq mark (assoc (match-string-no-properties 1) mp-list)) - (save-excursion - (beginning-of-line) - (insert (cdr mark)) - (delete-char 1))))))) - ;; restore buffer position (if possible) + (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 (and grammar + (not (zerop (buffer-size))) + (string-match (regexp-quote (nth 1 grammar)) + proced-header-line)) + (if (nth 3 grammar) + (match-beginning 0) + (match-end 0))))) + + ;; 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 (and old-pos - (re-search-forward - (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>") - nil t)) - (progn - (beginning-of-line) - (forward-char (cdr old-pos))) - (proced-move-to-goal-column)) + (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)) + (insert (cdr mark)) + (delete-char 1) + (beginning-of-line)) + (when (eq (car old-pos) pid) + (if (nth 1 old-pos) + (let ((limit (line-end-position)) pos) + (while (and (not new-pos) + (setq pos (next-property-change (point) nil limit))) + (goto-char pos) + (when (eq (nth 1 old-pos) + (get-text-property (point) 'proced-key)) + (forward-char (min (nth 2 old-pos) + (- (next-property-change (point)) + (point)))) + (setq new-pos (point)))) + (unless new-pos + ;; 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) + (goto-char (point-min)) + (proced-move-to-goal-column))) ;; update modeline - ;; Does the long mode-name clutter the modeline? - (setq mode-name (concat "Proced: " proced-command - (if proced-sorting-scheme - (concat " by " proced-sorting-scheme) - ""))) + ;; 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 (consp proced-sort) (car proced-sort) + proced-sort)) + (grammar (assq key proced-grammar-alist))) + (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 "Updating process information...done.")))) - -(defun proced-revert (&rest args) - "Analog of `revert-buffer'." - (proced-update)) + (message (if revert "Updating process information...done." + "Updating process display...done."))))) -;; 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-revert (&rest _args) + "Reevaluate the process listing based on the currently running processes. +Preserves point and marks." + (proced-update t)) (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 (concat (proced-marker-regexp) - (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$")) - process-list) + (let ((regexp (proced-marker-regexp)) + process-alist) ;; collect marked processes (save-excursion (goto-char (point-min)) (while (re-search-forward regexp nil t) - (push (cons (match-string-no-properties 1) - ;; How much info should we collect here? Would it be - ;; better to collect only the PID (to avoid ambiguities) - ;; and the command name? - (substring (match-string-no-properties 0) 2)) - process-list))) - (setq process-list (nreverse process-list)) - (if (not process-list) - (message "No processes marked") - (unless signal - ;; Display marked processes (code taken from `dired-mark-pop-up'). - (let ((bufname " *Marked Processes*") - (header proced-header-line)) ; inherit header line - (with-current-buffer (get-buffer-create bufname) - (setq truncate-lines t - proced-header-line header - header-line-format '(:eval (proced-header-line))) - (add-hook 'post-command-hook 'force-mode-line-update nil t) + (push (cons (proced-pid-at-point) + ;; How much info should we collect here? + (buffer-substring-no-properties + (+ 2 (line-beginning-position)) + (line-end-position))) + process-alist))) + (setq process-alist + (if process-alist + (nreverse process-alist) + ;; take current process + (list (cons (proced-pid-at-point) + (buffer-substring-no-properties + (+ 2 (line-beginning-position)) + (line-end-position)))))) + (unless signal + ;; Display marked processes (code taken from `dired-mark-pop-up'). + (let ((bufname " *Marked Processes*") ; use leading space in buffer name + ; to make this buffer ephemeral + (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) + (let ((inhibit-read-only t)) (erase-buffer) - (dolist (process process-list) + (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 - (let* ((completion-ignore-case t) - (pnum (if (= 1 (length process-list)) - "1 process" - (format "%d processes" (length process-list)))) - ;; 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) - err-list) - (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-list) + (delete-char -1) + (goto-char (point-min))) + (save-window-excursion + ;; 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)))) + (completion-extra-properties + '(:annotation-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) + (condition-case err (if (zerop (funcall - proced-signal-function - (string-to-number (car process)) signal)) + proced-signal-function (car process) signal)) (setq count (1+ count)) - (push (cdr process) err-list)))) - ;; use external system call - (let ((signal (concat "-" (if (numberp signal) - (number-to-string signal) signal)))) - (dolist (process process-list) - (if (zerop (call-process - proced-signal-function nil 0 nil - signal (car process))) - (setq count (1+ count)) - (push (cdr process) err-list))))) - (if err-list - ;; FIXME: that's not enough to display the errors. - (message "%s: %s" signal err-list) - (proced-success-message "Sent signal to" count))) - ;; final clean-up - (run-hooks 'proced-after-send-signal-hook))))) + (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 nil + (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 () + "Pop up a buffer with error log output from Proced. +A group of errors from a single command ends with a formfeed. +Thus, use \\[backward-page] to find the beginning of a group of errors." + (interactive) + (if (get-buffer proced-log-buffer) + (save-selected-window + ;; move `proced-log-buffer' to the front of the buffer list + (select-window (display-buffer (get-buffer proced-log-buffer))) + (setq truncate-lines t) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (goto-char (point-max)) + (forward-line -1) + (backward-page 1) + (recenter 0)))) + +;; similar to `dired-log' +(defun proced-log (log &rest args) + "Log a message or the contents of a buffer. +If LOG is a string and there are more args, it is formatted with +those ARGS. Usually the LOG string ends with a \\n. +End each bunch of errors with (proced-log t signal): +this inserts the current time, buffer and signal at the start of the page, +and \f (formfeed) at the end." + (let ((obuf (current-buffer))) + (with-current-buffer (get-buffer-create proced-log-buffer) + (goto-char (point-max)) + (let (buffer-read-only) + (cond ((stringp log) + (insert (if args + (apply 'format log args) + log))) + ((bufferp log) + (insert-buffer-substring log)) + ((eq t log) + (backward-page 1) + (unless (bolp) + (insert "\n")) + (insert (current-time-string) + "\tBuffer `" (buffer-name obuf) "', " + (format "signal `%s'\n" (car args))) + (goto-char (point-max)) + (insert "\f\n"))))))) + +;; similar to `dired-log-summary' +(defun proced-log-summary (signal string) + "State a summary of SIGNAL's failures, in echo area and log buffer. +STRING is an overall summary of the failures." + (message "Signal %s: %s--type ? for details" signal string) + ;; Log a summary describing a bunch of errors. + (proced-log (concat "\n" string "\n")) + (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) (describe-mode) (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) @@ -688,62 +1871,6 @@ buffer. You can use it to recover marks." (message "Change in Proced buffer undone. Killed processes cannot be recovered by Emacs.")) -;;; Sorting -(defun proced-sort (scheme) - "Sort Proced buffer using SCHEME. -When called interactively, an empty string means nil, i.e., no sorting." - (interactive - (list (let* ((completion-ignore-case t) - ;; restrict completion list to applicable sorting schemes - (completion-list - (apply 'append - (mapcar (lambda (x) - (if (string-match proced-sorting-schemes-re - (car x)) - (list (car x)))) - proced-sorting-schemes-alist))) - (scheme (completing-read "Sorting type: " - completion-list nil t))) - (if (string= "" scheme) nil scheme)))) - (if (proced-sorting-scheme-p scheme) - (progn - (setq proced-sorting-scheme scheme) - (proced-update)) - (error "Proced sorting scheme %s not applicable" scheme))) - -(defun proced-sorting-scheme-p (scheme) - "Return non-nil if SCHEME is an applicable sorting scheme. -SCHEME must be a string or nil." - (or (not scheme) - (and (string-match proced-sorting-schemes-re scheme) - (assoc scheme proced-sorting-schemes-alist)))) - -(defun proced-sort-pcpu () - "Sort Proced buffer by percentage CPU time (%CPU)." - (interactive) - (proced-sort "%CPU")) - -(defun proced-sort-pmem () - "Sort Proced buffer by percentage memory usage (%MEM)." - (interactive) - (proced-sort "%MEM")) - -(defun proced-sort-pid () - "Sort Proced buffer by PID." - (interactive) - (proced-sort "PID")) - -(defun proced-sort-start () - "Sort Proced buffer by time the command started (START)." - (interactive) - (proced-sort "START")) - -(defun proced-sort-time () - "Sort Proced buffer by cumulative CPU time (TIME)." - (interactive) - (proced-sort "TIME")) - (provide 'proced) -;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af -;;; proced.el ends here. +;;; proced.el ends here