X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ecae6af979abcbb5b45c33ee05ceb297678ec9a0..6f1b43a0ad8ed8e231f168fcd135376414cb56cc:/lisp/proced.el diff --git a/lisp/proced.el b/lisp/proced.el index daeadae5af..77247eef34 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -22,107 +22,28 @@ ;;; 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: -;; - 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" +;; +;; Wishlist +;; - tree view like pstree(1) ;;; Code: +(require 'time-date) ; for `with-decoded-time-value' + (defgroup proced nil "Proced mode." :group 'processes :group 'unix :prefix "proced-") -(defcustom proced-procname-column-regexp "\\b\\(CMD\\|COMMAND\\)\\b" - "If non-nil, regexp that defines the `proced-procname-column'." - :group 'proced - :type '(choice (const :tag "none" nil) - (regexp :tag "regexp"))) - -(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")))) - -;; Should we incorporate in NAME if sorting is done in descending order? -(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 and 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-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) - (defcustom proced-signal-function 'signal-process "Name of signal function. It can be an elisp function (usually `signal-process') or a string specifying @@ -132,193 +53,570 @@ the external command (usually \"kill\")." (string :tag "command"))) (defcustom proced-signal-list - '(("HUP (1. Hangup)") + '( ;; 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)") + ("KILL (9. Kill - cannot be caught or ignored)") ("ALRM (14. Alarm Clock)") - ("TERM (15. Termination)")) + ("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"))) +;; 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 `system-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) (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)) + (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)) + (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) (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))) + "Alist of rules for handling Proced attributes. + +Each element has the form + + (KEY NAME FORMAT JUSTIFY PREDICATE REVERSE SORT-SCHEME REFINE-FLAGS). + +Symbol KEY is the car of a process attribute. + +String NAME appears in the header line. + +FORMAT specifies the format for displaying the attribute values. +It can be a string passed to `format'. It can be a function called +with one argument, the value of the attribute. Nil means take as is. + +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. + +REVERSE is non-nil if the sort order is opposite to the order defined +by PREDICATE. + +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. + +REFINE-FLAGS is a list (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." + :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")) + (function :tag "Predicate") + (boolean :tag "Reverse Sort Order") + (repeat :tag "Sort Scheme" (symbol :tag "Key")) + (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'. 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 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 + state thcount vsize rss ttname tpgid minflt majflt cminflt cmajflt + start time utime stime ctime cutime cstime etime args)) + "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'." + :group 'proced + :type '(alist :key-type (symbol :tag "Format Name") + :value-type (repeat :tag "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 "\\`" (user-real-login-name) "\\'"))) + (user-running (user . ,(concat "\\`" (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-format) + +(defcustom proced-goal-attribute 'args + "If non-nil, key of the attribute that defines the `goal-column'." + :group 'proced + :type '(choice (const :tag "none" nil) + (symbol :tag "key"))) + +(defcustom proced-timer-interval 5 + "Time interval in seconds for auto updating Proced buffers." + :group 'proced + :type 'integer) + +(defcustom proced-timer-flag nil + "Non-nil for auto update of a Proced buffer. +Can be changed interactively via `proced-toggle-timer-flag'." + :group 'proced + :type 'boolean) +(make-variable-buffer-local 'proced-timer-flag) + +;; Internal variables + +(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).") + (defvar proced-marker-char ?* ; the answer is 42 "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 :group 'faces) -(defface proced-header - '((t (:inherit font-lock-type-face))) - "Face used for proced headers." - :group 'proced-faces) -(defvar proced-header-face 'proced-header - "Face name used for proced headers.") - (defface proced-mark '((t (:inherit font-lock-constant-face))) "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-header-regexp "\\`.*$" - "Regexp matching a header line.") +(defvar proced-header-line nil + "Headers in Proced buffer as a string.") +(make-variable-buffer-local 'proced-header-line) + +(defvar proced-process-tree nil + "Process tree of listing (internal variable).") + +(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.") + +(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.") -(defvar proced-procname-column nil - "Proced command column. -Initialized based on `proced-procname-column-regexp'.") -(make-variable-buffer-local 'proced-procname-column) +(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 - ;; - ;; Process listing headers. - (list proced-header-regexp '(0 proced-header-face)) - ;; - ;; Proced marks. - (list proced-re-mark '(0 proced-mark-face)) - ;; - ;; Marked files. - (list (concat "^[" (char-to-string proced-marker-char) "]") - '(".+" (proced-move-to-procname) 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))) - (define-key km " " 'next-line) + ;; moving + (define-key km " " 'proced-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 "h" 'describe-mode) - (define-key km "?" 'proced-help) - (define-key km "d" 'proced-mark) ; Dired compatibility + (define-key km [down] 'next-line) + (define-key km [up] 'previous-line) + ;; marking + (define-key km "d" 'proced-mark) ; Dired compatibility ("delete") (define-key km "m" 'proced-mark) - (define-key km "M" 'proced-mark-all) (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 "h" 'proced-hide-processes) - (define-key km "x" 'proced-send-signal) ; Dired compatibility - (define-key km "k" 'proced-send-signal) ; kill processes - (define-key km "l" 'proced-listing-type) - (define-key km "g" 'revert-buffer) ; Dired compatibility - (define-key km "q" 'quit-window) + (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) + ;; formatting + (define-key km "F" 'proced-format-interactive) + ;; operate + (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 "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) 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)) "--" - ["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.") - + ["Revert" revert-buffer + :help "Revert Process Listing"] + ["Auto Update" proced-toggle-timer-flag + :style radio + :selected (eval proced-timer-flag) + :help "Auto Update of Proced Buffer"] + ["Send signal" proced-send-signal + :help "Send Signal to Marked Processes"])) + +;; helper functions (defun proced-marker-regexp () "Return regexp matching `proced-marker-char'." + ;; `proced-marker-char' must appear in column zero (concat "^" (regexp-quote (char-to-string proced-marker-char)))) (defun proced-success-message (action count) "Display success message for ACTION performed for COUNT processes." (message "%s %s process%s" action count (if (= 1 count) "" "es"))) -(defun proced-move-to-procname () - "Move to the beginning of the process name on the current line. -Return the position of the beginning of the process name, or nil if none found." - (beginning-of-line) - (if proced-procname-column - (forward-char proced-procname-column) - (forward-char 2))) +;; 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. -(defsubst proced-skip-regexp () - "Regexp to skip in process listing." - (apply 'concat (make-list (1- (nth 2 (assoc proced-command - proced-command-alist))) - "\\s-+\\S-+"))) +(defun proced-move-to-goal-column () + "Move to `goal-column' if non-nil. Return position of point." + (beginning-of-line) + (unless (eobp) + (if goal-column + (forward-char goal-column) + (forward-char 2))) + (point)) + +(defun proced-header-line () + "Return header line for Proced buffer." + (list (propertize " " 'display '(space :align-to 0)) + (replace-regexp-in-string ;; preserve text properties + "\\(%\\)" "\\1\\1" (substring proced-header-line (window-hscroll))))) + +(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 nil "Proced" "Mode for displaying UNIX system processes and sending signals to them. -Type \\[proced-mark-process] to mark a process for later commands. +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. + +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. +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'. + \\{proced-mode-map}" (abbrev-mode 0) (auto-fill-mode 0) (setq buffer-read-only t - truncate-lines t) + truncate-lines t + header-line-format '(:eval (proced-header-line))) + (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-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) ;;;###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. -\\{proced-mode-map}" +See `proced-mode' for a descreption of features available in Proced buffers." (interactive "P") - (let ((buffer (get-buffer-create "*Process Info*")) new) + (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)) - + (proced-update t)) (if arg (display-buffer buffer) (pop-to-buffer buffer) - (message (substitute-command-keys - "type \\[quit-window] to quit, \\[proced-help] for help"))))) + (message + (substitute-command-keys + "Type \\\\[quit-window] to quit, \\[proced-help] for help"))))) + +(defun proced-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-update t t))))) + +(defun proced-toggle-timer-flag (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'." + (interactive (list (or current-prefix-arg 'toggle))) + (setq proced-timer-flag + (cond ((eq arg 'toggle) (not proced-timer-flag)) + (arg (> (prefix-numeric-value arg) 0)) + (t (not proced-timer-flag)))) + (message "`proced-timer-flag' set to %s" proced-timer-flag)) (defun proced-mark (&optional count) "Mark the current (or next COUNT) processes." @@ -338,37 +636,53 @@ information will be displayed but not selected. (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)) - (line (line-number-at-pos)) buffer-read-only) - ;; do nothing in the first line - (unless (= line 1) - (setq count (1+ (if (<= 0 count) count - (min (- line 2) (abs count))))) - (beginning-of-line) - (while (not (or (zerop (setq count (1- count))) (eobp))) - (proced-insert-mark mark backward)) - (proced-move-to-procname)))) + (setq count (1+ (if (<= 0 count) count + (min (1- (line-number-at-pos)) (abs count))))) + (beginning-of-line) + (while (not (or (zerop (setq count (1- count))) (eobp))) + (proced-insert-mark mark backward)) + (proced-move-to-goal-column))) (defun proced-mark-all () - "Mark all processes." + "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." + "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." - (let (buffer-read-only) + "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) (save-excursion - (goto-line 2) - (while (not (eobp)) - (proced-insert-mark mark))))) + (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) + (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." @@ -376,7 +690,7 @@ information will be displayed but not selected. (let ((mark-re (proced-marker-regexp)) buffer-read-only) (save-excursion - (goto-line 2) + (goto-char (point-min)) (while (not (eobp)) (cond ((looking-at mark-re) (proced-insert-mark nil)) @@ -394,211 +708,844 @@ Otherwise move one line forward after inserting the mark." (delete-char 1) (unless backward (forward-line))) +(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) + (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. - (let ((line (line-number-at-pos))) - ;; do nothing in the first line - (unless (= line 1) - (delete-region (line-beginning-position) - (save-excursion - (if (<= 0 arg) - (setq count (- arg (forward-line arg))) - (setq count (min (- line 2) (abs arg))) - (forward-line (- count))) - (point))))) - ;; Hide marked lines - (goto-line 2) - (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))))) - (unless (zerop count) (proced-move-to-procname)) - (unless quiet - (proced-success-message "Hid" 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 "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-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-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)) + 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))) + +;; helper function +(defun proced-children-pids (ppid) + "Return list of children PIDs of PPID (including PPID)." + (let ((cpids (cdr (assq ppid proced-process-tree)))) + (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)) + +;; 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. + +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. + +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. +The help-echo string for `proced-refine' uses \"+\" or \"-\" to indicate +the current values of the 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'." + (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) + ;; 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)))) -(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 plist) +;;; Sorting + +(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) + "Sort PROCESS-ALIST using scheme SORTER. +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))) + (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 + (sort process-alist 'proced-sort-p) + process-alist)) + +(defun proced-sort-interactive (scheme &optional revert) + "Sort Proced buffer using SCHEME. +When called interactively, an empty string means nil, i.e., no sorting. +With prefix REVERT non-nil revert listing. + +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))) + (list (if (string= "" scheme) nil (intern scheme)) + current-prefix-arg))) + ;; only update if necessary + (when (or (not (eq proced-sort scheme)) revert) + (setq proced-sort scheme) + (proced-update revert))) + +(defun proced-sort-pcpu (&optional revert) + "Sort Proced buffer by percentage CPU time (%CPU)." + (interactive "P") + (proced-sort-interactive 'pcpu revert)) + +(defun proced-sort-pmem (&optional revert) + "Sort Proced buffer by percentage memory usage (%MEM)." + (interactive "P") + (proced-sort-interactive 'pmem)) + +(defun proced-sort-pid (&optional revert) + "Sort Proced buffer by PID." + (interactive "P") + (proced-sort-interactive 'pid revert)) + +(defun proced-sort-start (&optional revert) + "Sort Proced buffer by time the command started (START)." + (interactive "P") + (proced-sort-interactive 'start revert)) + +(defun proced-sort-time (&optional revert) + "Sort Proced buffer by CPU time (TIME)." + (interactive "P") + (proced-sort-interactive 'time revert)) + +(defun proced-sort-user (&optional revert) + "Sort Proced buffer by USER." + (interactive "P") + (proced-sort-interactive 'user revert)) + +(defun proced-sort-header (event &optional revert) + "Sort Proced listing based on an attribute. +EVENT is a mouse event with starting position in the header line. +It is converted in the corresponding attribute key. +This command updates the variable `proced-sort'." + (interactive "e\nP") + (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 revert) + (message "No sorter defined here.")))))) + +;;; Formating + +(defun proced-format-time (time) + "Format time intervall 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-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)))) + (insert (make-string (length process-alist) ?\n)) + (let ((whitespace " ") header-list grammar) + ;; Loop over all attributes + (while (setq grammar (pop format)) + (if (symbolp grammar) + (setq grammar (assq grammar 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 `(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 + (nth 1 grammar) + (mapconcat (lambda (s) + (if s "+" "-")) + (nth 7 grammar) "")))) + value) + + ;; highlight the header of the sort column + (if (eq key proced-sort) + (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) + (make-string (abs (nth 3 grammar)) ?\s)) + 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)))) + (if value (insert (apply 'propertize (funcall fun value) fprops))) + (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 "" field-list))) + (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 () + "Return alist of attributes for each system process. +This alist can be customized via `proced-custom-attributes'." + (mapcar (lambda (pid) + (let* ((attributes (system-process-attributes pid)) + (utime (cdr (assq 'utime attributes))) + (stime (cdr (assq 'stime attributes))) + (cutime (cdr (assq 'cutime attributes))) + (cstime (cdr (assq 'cstime attributes))) + attr) + (setq attributes + (append (list (cons 'pid pid)) + (if (and utime stime) + (list (cons 'time (time-add utime stime)))) + (if (and cutime cstime) + (list (cons 'ctime (time-add cutime cstime)))) + attributes)) + (dolist (fun proced-custom-attributes) + (if (setq attr (funcall fun attributes)) + (push attr attributes))) + (cons pid attributes))) + (list-system-processes))) + +(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." + ;; 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)) + + ;; 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) - (match-string-no-properties 1)) plist)) - ;; generate new listing + (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 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))) - (set-buffer-modified-p nil) - ;; set `proced-procname-column' + (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)) - (and proced-procname-column-regexp - (re-search-forward proced-procname-column-regexp nil t) - (setq proced-procname-column (1- (match-beginning 0)))) - ;; restore process marks - (if plist - (save-excursion - (goto-line 2) - (let (mark) - (while (re-search-forward (concat "^" regexp) nil t) - (if (setq mark (assoc (match-string-no-properties 1) plist)) - (save-excursion - (beginning-of-line) - (insert (cdr mark)) - (delete-char 1))))))) - ;; restore buffer position (if possible) - (goto-line 2) - (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-procname)) + (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 - (setq mode-name (if proced-sorting-scheme - (concat "Proced by " proced-sorting-scheme) - "Proced")) + ;; Does the long `mode-name' clutter the modeline? It would be nice + ;; to have some other location for displaying the values of the various + ;; flags that affect the behavior of proced (flags one might want + ;; to change on the fly). Where?? + (setq mode-name + (concat "Proced" + (if proced-filter + (concat ": " (symbol-name proced-filter)) + "") + (if proced-sort + (let* ((key (if (listp proced-sort) (car proced-sort) + proced-sort)) + (grammar (assq key proced-grammar-alist))) + (concat " by " (if (nth 5 grammar) "-" "+") + (nth 1 grammar))) + ""))) (force-mode-line-update) ;; done (or quiet (input-pending-p) - (message "Updating process information...done.")))) + (message (if revert "Updating process information...done." + "Updating process display...done."))))) (defun proced-revert (&rest args) "Analog of `revert-buffer'." - (proced-update)) + (proced-update t)) ;; I do not want to reinvent the wheel. Should we rename `dired-pop-to-buffer' -;; and move it to simple.el so that proced and ibuffer can easily use it, too? +;; 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." (interactive) - (let ((regexp (concat (proced-marker-regexp) - (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$")) - plist) + (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? + (push (cons (proced-pid-at-point) + ;; How much info should we collect here? (substring (match-string-no-properties 0) 2)) - plist))) - (setq plist (nreverse plist)) - (if (not plist) - (message "No processes marked") - (unless signal - ;; Display marked processes (code taken from `dired-mark-pop-up'). - (let ((bufname " *Marked Processes*") - (header (save-excursion - (goto-char (+ 2 (point-min))) + process-alist))) + (setq process-alist + (if process-alist + (nreverse process-alist) + ;; take current process + (list (cons (proced-pid-at-point) (buffer-substring-no-properties - (point) (line-end-position))))) - (with-current-buffer (get-buffer-create bufname) - (setq truncate-lines t) - (erase-buffer) - (insert header "\n") - (dolist (proc plist) - (insert (cdr proc) "\n")) - (save-window-excursion - (dired-pop-to-buffer bufname) ; all we need - (let* ((completion-ignore-case t) - (pnum (if (= 1 (length plist)) - "1 process" - (format "%d processes" (length plist)))) - ;; 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 plist) - (if (zerop (funcall - proced-signal-function - (string-to-number (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 plist) - (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))))) + (+ 2 (line-beginning-position)) + (line-end-position)))))) + (unless signal + ;; Display marked processes (code taken from `dired-mark-pop-up'). + (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")) + (save-window-excursion + (dired-pop-to-buffer bufname) ; all we need + (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)))) + (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 () + "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." (interactive) + (proced-why) (if (eq last-command 'proced-help) (describe-mode) (message proced-help-string))) @@ -610,56 +1557,10 @@ buffer. You can use it to recover marks." (interactive) (let (buffer-read-only) (undo)) - (message "Change in proced buffer undone. + (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) - (scheme (completing-read "Sorting type: " - proced-sorting-schemes-alist 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 undefined" 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) - (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