From d74d0c4266e503337d52b5f2abeb45757af54c3a Mon Sep 17 00:00:00 2001 From: Roland Winkler Date: Sat, 6 Sep 2008 23:05:49 +0000 Subject: [PATCH] Require time-date. (proced-command-alist, proced-command, proced-goal-header-re) (proced-sorting-schemes-alist, proced-sorting-scheme) (proced-header-alist, proced-sorting-schemes-re) (proced-skip-regexp, proced-next-line, proced-previous-line) (proced-listing-type, proced-sorting-scheme-p): Removed. (proced-grammar-alist, proced-custom-attributes) (proced-format-alist, proced-format, proced-filter-alist) (proced-filter, proced-sort, proced-goal-attribute) (proced-timer-interval, proced-timer-flag, proced-timer) (proced-process-alist, proced-sort-internal, proced-process-tree) (proced-header-help-echo, proced-field-help-echo): New variables. (proced-pid-at-point, proced-timer, proced-mark-process-alist) (proced-omit-process, proced-filter, proced-process-tree) (proced-filter-children, proced-children-pids) (proced-filter-parents, proced-<, proced-string-lessp) (proced-time-lessp, proced-xor, proced-sort-p) (proced-format-time, proced-format-start, proced-format-ttname) (proced-format, proced-process-attributes): New functions. (proced-toggle-timer-flag, proced-mark-children) (proced-mark-parents, proced-filter-interactive) (proced-filter-attribute, proced-sort-interactive) (proced-sort-header, proced-format-interactive): New commands. (proced-move-to-goal-column): Use goal-column. (proced-mode): Use proced-timer. (proced-do-mark-all): Display process count. Use use-region-p. Simplify. (proced-omit-processes): Use use-region-p. (proced-sort-pcpu, proced-sort-pmem, proced-sort-pid) (proced-sort-start, proced-sort-time, proced-sort-user): Use proced-sort-interactive. (proced-sort): Make it a function that performs the actual sort. (proced-update): New arg revert. Use proced-process-alist, proced-filter, proced-sort, proced-format, and proced-grammar-alist. Preserve position of point based on fields. Make header line and fields clickable. (proced-send-signal): Use proced-pid-at-point and proced-process-alist. (proced-why): Use save-selected-window. (proced-log): Use buffer-read-only. --- lisp/ChangeLog | 43 ++ lisp/proced.el | 1355 +++++++++++++++++++++++++++++++++++++++----------------- 2 files changed, 999 insertions(+), 399 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 75ed212df39..e99988e0b7a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,46 @@ +2008-09-06 Roland Winkler + + * proced.el: Require time-date. + (proced-command-alist, proced-command, proced-goal-header-re) + (proced-sorting-schemes-alist, proced-sorting-scheme) + (proced-header-alist, proced-sorting-schemes-re) + (proced-skip-regexp, proced-next-line, proced-previous-line) + (proced-listing-type, proced-sorting-scheme-p): Removed. + (proced-grammar-alist, proced-custom-attributes) + (proced-format-alist, proced-format, proced-filter-alist) + (proced-filter, proced-sort, proced-goal-attribute) + (proced-timer-interval, proced-timer-flag, proced-timer) + (proced-process-alist, proced-sort-internal, proced-process-tree) + (proced-header-help-echo, proced-field-help-echo): New variables. + (proced-pid-at-point, proced-timer, proced-mark-process-alist) + (proced-omit-process, proced-filter, proced-process-tree) + (proced-filter-children, proced-children-pids) + (proced-filter-parents, proced-<, proced-string-lessp) + (proced-time-lessp, proced-xor, proced-sort-p) + (proced-format-time, proced-format-start, proced-format-ttname) + (proced-format, proced-process-attributes): New functions. + (proced-toggle-timer-flag, proced-mark-children) + (proced-mark-parents, proced-filter-interactive) + (proced-filter-attribute, proced-sort-interactive) + (proced-sort-header, proced-format-interactive): New commands. + (proced-move-to-goal-column): Use goal-column. + (proced-mode): Use proced-timer. + (proced-do-mark-all): Display process count. Use use-region-p. + Simplify. + (proced-omit-processes): Use use-region-p. + (proced-sort-pcpu, proced-sort-pmem, proced-sort-pid) + (proced-sort-start, proced-sort-time, proced-sort-user): Use + proced-sort-interactive. + (proced-sort): Make it a function that performs the actual sort. + (proced-update): New arg revert. Use proced-process-alist, + proced-filter, proced-sort, proced-format, and + proced-grammar-alist. Preserve position of point based on fields. + Make header line and fields clickable. + (proced-send-signal): Use proced-pid-at-point and + proced-process-alist. + (proced-why): Use save-selected-window. + (proced-log): Use buffer-read-only. + 2008-09-06 Chong Yidong * tooltip.el (tooltip-mode): Initialize unconditionally to t. diff --git a/lisp/proced.el b/lisp/proced.el index afc11e4c88b..007fe20b517 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -22,119 +22,26 @@ ;;; 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. ;; ;; To do: -;; - use list-system-processes and system-process-attributes -;; - sort and filter by user name or other criteria -;; - make fields clickable for marking / filtering / sorting: -;; clicking on a USER field marks all processes of this user etc -;; clicking on a %MEM field marks all processes with at least this %MEM. -;; clicking on a header field sorts according to this header -;; - mark parent and children PIDs (or both) -;; - automatic update of process list +;; - use defcustom where appropriate +;; - interactive temporary customizability of `proced-grammar-alist' ;; - allow "sudo kill PID", "renice 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 @@ -144,7 +51,7 @@ the external command (usually \"kill\")." (string :tag "command"))) (defcustom proced-signal-list - '(;; signals supported on all POSIX compliant systems + '( ;; signals supported on all POSIX compliant systems ("HUP (1. Hangup)") ("INT (2. Terminal interrupt)") ("QUIT (3. Terminal quit)") @@ -162,7 +69,199 @@ the external command (usually \"kill\")." :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. +(defvar proced-grammar-alist + '( ;; attributes defined in `system-process-attributes' + (euid "EUID" "%d" right proced-< nil (euid pid) (nil t nil)) + (user "USER" "%s" left proced-string-lessp nil (user pid) (nil t nil)) + (egid "EGID" "%d" right proced-< nil (egid euid pid) (nil t nil)) + (group "GROUP" "%s" left proced-string-lessp nil (group user pid) (nil t nil)) + (comm "COMMAND" "%s" left proced-string-lessp nil (comm pid) (nil t nil)) + (state "STAT" "%s" left proced-string-lessp nil (state pid) (nil t nil)) + (ppid "PPID" "%d" right proced-< nil (ppid pid) (nil t nil)) + (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" "%s" 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 FILTER-SCHEME). + +KEY is the car of a process attribute. + +NAME appears in the header line. + +FORMAT specifies the format for displaying the attribute values. +It is either a string passed to `format' or a function called with one +argument, the value of the attribute. + +If JUSTIFY is an integer, its modulus gives the width of the attribute +vales 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 ...) defing a hierarchy of rules +for sorting the process listing. KEY1, KEY2, ... are KEYs appearing as cars +of `proced-grammar-alist'. First the PREDICATE of KEY1 is evaluated. +If it yields non-equal, it defines the sorting order for the corresponding +processes. If it evaluates to 'equal the PREDICATE of KEY2 is evaluated, etc. + +FILTER-SCHEME is a list (LESS-B EQUAL-B LARGER-B) used by the command +`proced-filter-attribute' for filtering KEY (see there). This command +compares the value of attribute KEY of every process with the value +of attribute KEY of the process at the position of point using PREDICATE. +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.") + +(defvar 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'.") + +;; 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. + +(defvar proced-format-alist + '((short user pid pcpu pmem start time args) + (medium user pid pcpu pmem vsize rss ttname state start time args) + (long user euid group pid pri nice pcpu pmem vsize rss ttname state + start time args) + (verbose user euid group egid pid ppid pgrp sess comm pri nice pcpu pmem + 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'.") + +(defvar 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'.") +(make-variable-buffer-local 'proced-format) + +;; FIXME: is there a better name for filter `user' that does not coincide +;; with an attribute key? +(defvar proced-filter-alist + `((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.") + +(defvar 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'.") +(make-variable-buffer-local 'proced-filter) + +(defvar proced-sort 'pcpu + "Current sorting scheme for proced listing. +It must be the KEY of an element of `proced-grammar-alist'. +It can also be a list of KEYs as in the SORT-SCHEMEs of the elements +of `proced-grammar-alist'.") +(make-variable-buffer-local 'proced-format) + +(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 updating Proced buffers." + :group 'proced + :type 'integer) + +(defcustom proced-timer-flag nil + "Non-nil for regular update of a Proced buffer. +Can be changed interactively via `proced-toggle-timer-flag'." + :group 'proced + :type 'boolean) +(make-variable-buffer-local 'proced-timer-flag) + ;; Internal variables + +(defvar proced-process-alist nil + "Alist of PIDs displayed by Proced.") +(make-variable-buffer-local 'proced-process-alist) + +(defvar proced-sort-internal nil + "Sorting scheme for listing (internal format).") + (defvar proced-marker-char ?* ; the answer is 42 "In proced, the current mark character.") @@ -190,9 +289,30 @@ the external command (usually \"kill\")." "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-log-buffer "*Proced log*" + "Name of Proced Log buffer.") + +(defvar proced-process-tree nil + "Process tree of listing (internal variable).") + +(defvar proced-timer nil + "Stores if Proced timer is already installed.") + +(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-2: sort by attribute %s%s" + "Help string shown when mouse is over a sortable header.") + +(defconst proced-field-help-echo + "mouse-2, RET: filter by attribute %s %s" + "Help string shown when mouse is over a filterable field.") (defvar proced-font-lock-keywords (list @@ -208,35 +328,44 @@ Important: the match ends just after the marker.") (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 "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) (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-filter-attribute) + (define-key km "\C-m" 'proced-filter-attribute) ;; 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) + (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 "l" 'proced-listing-type) - (define-key km "g" 'revert-buffer) ; Dired compatibility + (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) @@ -258,54 +387,52 @@ Important: the match ends just after the marker.") :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 - :help "Sort Process List"] - ["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 Sorting 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)) "--" ["Omit Marked Processes" proced-omit-processes :help "Omit Marked Processes in Process Listing."] "--" ["Revert" revert-buffer :help "Revert Process Listing"] + ["Regular Update" proced-toggle-timer-flag + :style radio + :selected (eval proced-timer-flag) + :help "Regular Update of Proced buffer"] ["Send signal" proced-send-signal - :help "Send Signal to Marked Processes"] - ("Listing Type" - :help "Select Type of Process Listing" - ,@(mapcar (lambda (el) - (let ((command (car el))) - `[,command (proced-listing-type ,command) - :style radio - :selected (string= proced-command ,command)])) - proced-command-alist)))) - -(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) - -(defvar proced-log-buffer "*Proced log*" - "Name of Proced Log buffer.") + :help "Send Signal to Marked Processes"])) ;; helper functions (defun proced-marker-regexp () @@ -317,20 +444,37 @@ 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." (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-+"))) + (unless (eobp) + (if goal-column + (forward-char goal-column) + (forward-char 2)))) + +(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. @@ -346,7 +490,10 @@ 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-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) @@ -367,7 +514,7 @@ information will be displayed but not selected. (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) @@ -375,19 +522,25 @@ information will be displayed but not selected. (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)) +(defun proced-timer () + "Update Proced buffers regularly 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 regularly. +With prefix ARG, update this buffer regularly if ARG is positive, +otherwise do not update. Sets the variable `proced-timer-flag'. +The time interval for updates is specified via `proced-timer-interval'." + (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." @@ -436,23 +589,24 @@ unmark the region." "Mark all processes using MARK. If `transient-mark-mode' is turned on and the region is active, mark the region." - (let (buffer-read-only) + (let ((count 0) end buffer-read-only) (save-excursion - (if (and transient-mark-mode mark-active) + (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'. - (let ((end (save-excursion - (goto-char (region-end)) - (unless (looking-at "^") (forward-line)) - (point)))) - (goto-char (region-beginning)) - (unless (looking-at "^") (beginning-of-line)) - (while (< (point) end) - (proced-insert-mark mark))) + (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)) - (while (not (eobp)) - (proced-insert-mark mark)))))) + (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." @@ -478,152 +632,613 @@ 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'. +;; 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 omitted lines." (interactive "P") (let ((mark-re (proced-marker-regexp)) (count 0) buffer-read-only) - (if arg - ;; Omit 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))) - ;; Omit marked lines - (save-excursion - (goto-char (point-min)) - (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 "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." + (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 &optional revert) + "Filter Proced buffer using SCHEME. +When called interactively, an empty string means nil, i.e., no filtering. +With prefix REVERT non-nil 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)) + current-prefix-arg))) + (setq proced-filter scheme) + (proced-update revert)) + +(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)) + +(defun proced-filter-attribute (&optional event) + "Filter Proced listing based on the attribute at point. +Optional EVENT is the location of the Proced field." + (interactive (list last-input-event)) + (if event (posn-set-point (event-end event))) + (let ((key (get-text-property (point) 'proced-key)) + (pid (get-text-property (point) 'proced-pid))) + (if (and key pid) + (let* ((grammar (assq key proced-grammar-alist)) + (predicate (nth 4 grammar)) + (filter (nth 7 grammar)) + (ref (cdr (assq key (cdr (assq pid proced-process-alist))))) + val new-alist) + (when ref + (dolist (process proced-process-alist) + (setq val (funcall predicate (cdr (assq key (cdr process))) ref)) + (if (cond ((not val) (nth 2 filter)) + ((eq val 'equal) (nth 1 filter)) + (val (car filter))) + (push process new-alist))) + (setq proced-process-alist new-alist) + (proced-update))) + (message "No filter defined here.")))) + +;; Proced predicates for sorting and filtering are based on a three-valued +;; logic: +;; Predicates takes two arguments P1 and P2, the corresponding attribute +;; values of two processes. Predicate should return 'equal if P1 has +;; 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-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))))) +;;; 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 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." + (interactive + (let ((scheme (completing-read "Sorting type: " + proced-grammar-alist nil t))) + (list (if (string= "" scheme) nil (intern scheme)) + current-prefix-arg))) + (setq proced-sort scheme) + (proced-update revert)) + +(defun proced-sort-pcpu (&optional revert) + "Sort Proced buffer by percentage CPU time (%CPU)." + (interactive "P") + (proced-sort-interactive 'pcpu revert)) + +(defun proced-sort-pmem (&optional revert) + "Sort Proced buffer by percentage memory usage (%MEM)." + (interactive "P") + (proced-sort-interactive 'pmem)) + +(defun proced-sort-pid (&optional revert) + "Sort Proced buffer by PID." + (interactive "P") + (proced-sort-interactive 'pid revert)) + +(defun proced-sort-start (&optional revert) + "Sort Proced buffer by time the command started (START)." + (interactive "P") + (proced-sort-interactive 'start revert)) + +(defun proced-sort-time (&optional revert) + "Sort Proced buffer by CPU time (TIME)." + (interactive "P") + (proced-sort-interactive 'time revert)) + +(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." + (interactive "e\nP") + (let ((start (event-start event)) + col key) + (save-selected-window + (select-window (posn-window start)) + (setq col (+ (1- (car (posn-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 prefix \"/dev/\"." + ;; Does this work for all systems? + (format "%s" (substring ttname + (if (string-match "\\`/dev/" ttname) + (match-end 0) 0)))) + +(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 (if (stringp (nth 2 grammar)) + `(lambda (arg) (format ,(nth 2 grammar) arg)) + (nth 2 grammar))) + (whitespace (if format whitespace "")) + ;; Text properties: + ;; We use the text property `proced-key' to store in each + ;; field the corresponding key. + ;; Of course, the sort predicate appearing in help-echo + ;; is only part of the story. But it gives the main idea. + (hprops `(proced-key ,key mouse-face highlight + help-echo ,(format proced-header-help-echo + (if (nth 5 grammar) "-" "+") + (nth 1 grammar)))) + (fprops `(proced-key ,key mouse-face highlight + help-echo ,(format proced-field-help-echo + (nth 1 grammar) + (mapconcat (lambda (s) + (if s "+" "-")) + (nth 7 grammar) "")))) + value) + + (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-update (&optional quiet) +(defun proced-format-interactive (scheme &optional revert) + "Format Proced buffer using SCHEME. +When called interactively, an empty string means nil, i.e., no formatting. +With prefix REVERT non-nil revert listing." + (interactive + (let ((scheme (completing-read "Format: " + proced-format-alist nil t))) + (list (if (string= "" scheme) nil (intern scheme)) + current-prefix-arg))) + (setq proced-format scheme) + (proced-update revert)) + +;; 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)))) + (setq attributes + (append (list (cons 'pid pid)) + (if (and utime stime) + (list (cons 'time (time-add utime stime)))) + (if (and cutime cstime) + (list (cons 'ctime (time-add cutime cstime)))) + attributes)) + (dolist (fun proced-custom-attributes) + (push (funcall fun attributes) attributes)) + (cons pid attributes))) + (list-system-processes))) + +(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) - (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) - (goto-char (point-min)) + (interactive "P") + (setq revert (or revert (not proced-process-alist))) + (or quiet (message (if revert "Updating process information..." + "Updating process display..."))) + ;; If point is on a field, we try to return point to that field. + ;; Otherwise we try to return to the same column + (let ((old-pos (let ((key (get-text-property (point) 'proced-key))) + (list (proced-pid-at-point) key + (if 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 + (when revert + ;; all attributes of all processes + (setq proced-process-alist (proced-process-attributes)) + ;; do not keep undo information + (if (consp buffer-undo-list) + (setq buffer-undo-list nil))) + ;; filtering and sorting + (setq proced-process-alist + (proced-sort (proced-filter proced-process-alist + proced-filter) proced-sort)) + ;; generate listing (erase-buffer) - (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 + (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) (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) - (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))) + (if (or mp-list old-pos) + (let (pid mark new-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 + (setq new-pos (if goal-column + (+ (line-beginning-position) goal-column) + (line-beginning-position))))) + (setq new-pos (min (+ (line-beginning-position) (nth 2 old-pos)) + (line-end-position))))) + (forward-line)) + (if new-pos + (goto-char new-pos) + (proced-move-to-goal-column))) (proced-move-to-goal-column)) ;; 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) - ""))) + (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 window.el so that proced and ibuffer can easily use it, too? @@ -637,48 +1252,43 @@ 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]+\\>\\).*$")) - 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? + (push (cons (proced-pid-at-point) + ;; How much info should we collect here? (substring (match-string-no-properties 0) 2)) - process-list))) - (setq process-list - (if process-list - (nreverse process-list) + process-alist))) + (setq process-alist + (if process-alist + (nreverse process-alist) ;; take current process - (save-excursion - (beginning-of-line) - (looking-at (concat "^" (proced-skip-regexp) - "\\s-+\\([0-9]+\\>\\).*$")) - (list (cons (match-string-no-properties 1) - (substring (match-string-no-properties 0) 2)))))) + (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*") - (header proced-header-line)) ; inherit header line + (header-line (substring-no-properties proced-header-line))) (with-current-buffer (get-buffer-create bufname) (setq truncate-lines t - proced-header-line header + 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-list) + (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)) + (pnum (if (= 1 (length process-alist)) "1 process" - (format "%d processes" (length process-list)))) - ;; The following is an ugly hack. Is there a better way + (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 @@ -698,12 +1308,11 @@ If SIGNAL is nil display marked processes and query interactively for SIGNAL." (if (string-match "\\`[0-9]+\\'" signal) (string-to-number signal) (make-symbol signal)) - signal))) ; number - (dolist (process process-list) + 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)) (proced-log "%s\n" (cdr process)) (push (cdr process) failures)) @@ -714,12 +1323,12 @@ If SIGNAL is nil display marked processes and query interactively for SIGNAL." ;; use external system call (let ((signal (concat "-" (if (numberp signal) (number-to-string signal) signal)))) - (dolist (process process-list) + (dolist (process process-alist) (with-temp-buffer (condition-case err (if (zerop (call-process proced-signal-function nil t nil - signal (car process))) + signal (number-to-string (car process)))) (setq count (1+ count)) (proced-log (current-buffer)) (proced-log "%s\n" (cdr process)) @@ -729,32 +1338,35 @@ If SIGNAL is nil display marked processes and query interactively for SIGNAL." (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-list) - (if (= 1 (length process-list)) "" "s"))) + (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)))) -;; just like `dired-why' +;; 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) - (let ((owindow (selected-window)) - (window (display-buffer (get-buffer proced-log-buffer)))) - (unwind-protect - (progn - (select-window window) - (goto-char (point-max)) - (forward-line -1) - (backward-page 1) - (recenter 0)) - (select-window owindow))))) + (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) @@ -767,7 +1379,7 @@ and \f (formfeed) at the end." (let ((obuf (current-buffer))) (with-current-buffer (get-buffer-create proced-log-buffer) (goto-char (point-max)) - (let ((inhibit-read-only t)) + (let (buffer-read-only) (cond ((stringp log) (insert (if args (apply 'format log args) @@ -811,61 +1423,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 -- 2.11.4.GIT