(erc-input-message): Replace last-command-char with last-command-event.
[bpt/emacs.git] / lisp / proced.el
CommitLineData
e6854b3f 1;;; proced.el --- operate on system processes like dired
37e4d8ed 2
ae940284 3;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
1ba1a8b9 4
37e4d8ed 5;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
37e4d8ed
RW
6;; Keywords: Processes, Unix
7
1ba1a8b9
RW
8;; This file is part of GNU Emacs.
9
eb3fa2cf 10;; GNU Emacs is free software: you can redistribute it and/or modify
1ba1a8b9 11;; it under the terms of the GNU General Public License as published by
eb3fa2cf
GM
12;; the Free Software Foundation, either version 3 of the License, or
13;; (at your option) any later version.
37e4d8ed 14
1ba1a8b9
RW
15;; GNU Emacs is distributed in the hope that it will be useful,
16;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;; GNU General Public License for more details.
37e4d8ed
RW
19
20;; You should have received a copy of the GNU General Public License
eb3fa2cf 21;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
37e4d8ed
RW
22
23;;; Commentary:
24
d74d0c42
RW
25;; Proced makes an Emacs buffer containing a listing of the current
26;; system processes. You can use the normal Emacs commands to move around
27;; in this buffer, and special Proced commands to operate on the processes
da643190 28;; listed. See `proced-mode' for getting started.
37e4d8ed 29;;
e6854b3f 30;; To do:
da643190 31;; - interactive temporary customizability of flags in `proced-grammar-alist'
9f583d14 32;; - allow "sudo kill PID", "renice PID"
da643190 33;;
413e65fe
RW
34;; Thoughts and Ideas
35;; - Currently, `system-process-attributes' returns the list of
36;; command-line arguments of a process as one concatenated string.
37;; This format is compatible with `shell-command'. Also, under
38;; MS-Windows, the command-line arguments are actually stored as a
39;; single string, so that it is impossible to reverse-engineer it back
40;; into separate arguments. Alternatively, `system-process-attributes'
41;; could (try to) return a list of strings that correspond to individual
42;; command-line arguments. Then one could feed such a list of
43;; command-line arguments into `call-process' or `start-process'.
44;; Are there real-world applications when such a feature would be useful?
45;; What about something like `proced-restart-pid'?
37e4d8ed
RW
46
47;;; Code:
48
d74d0c42
RW
49(require 'time-date) ; for `with-decoded-time-value'
50
37e4d8ed
RW
51(defgroup proced nil
52 "Proced mode."
53 :group 'processes
54 :group 'unix
55 :prefix "proced-")
56
e6854b3f
RW
57(defcustom proced-signal-function 'signal-process
58 "Name of signal function.
59It can be an elisp function (usually `signal-process') or a string specifying
60the external command (usually \"kill\")."
37e4d8ed 61 :group 'proced
e6854b3f
RW
62 :type '(choice (function :tag "function")
63 (string :tag "command")))
37e4d8ed
RW
64
65(defcustom proced-signal-list
d74d0c42 66 '( ;; signals supported on all POSIX compliant systems
9f583d14 67 ("HUP (1. Hangup)")
37e4d8ed
RW
68 ("INT (2. Terminal interrupt)")
69 ("QUIT (3. Terminal quit)")
70 ("ABRT (6. Process abort)")
9f583d14 71 ("KILL (9. Kill - cannot be caught or ignored)")
37e4d8ed 72 ("ALRM (14. Alarm Clock)")
9f583d14
RW
73 ("TERM (15. Termination)")
74 ;; POSIX 1003.1-2001
75 ;; Which systems do not support these signals so that we can
76 ;; exclude them from `proced-signal-list'?
77 ("CONT (Continue executing)")
78 ("STOP (Stop executing / pause - cannot be caught or ignored)")
79 ("TSTP (Terminal stop / pause)"))
37e4d8ed
RW
80 "List of signals, used for minibuffer completion."
81 :group 'proced
82 :type '(repeat (string :tag "signal")))
83
d74d0c42
RW
84;; For which attributes can we use a fixed width of the output field?
85;; A fixed width speeds up formatting, yet it can make
86;; `proced-grammar-alist' system-dependent.
87;; (If proced runs like top(1) we want it to be fast.)
88;;
89;; If it is impossible / unlikely that an attribute has the same value
90;; for two processes, then sorting can be based on one ordinary (fast)
91;; predicate like `<'. Otherwise, a list of proced predicates can be used
92;; to refine the sort.
93;;
94;; It would be neat if one could temporarily override the following
95;; predefined rules.
204ebc5b 96(defcustom proced-grammar-alist
d74d0c42
RW
97 '( ;; attributes defined in `system-process-attributes'
98 (euid "EUID" "%d" right proced-< nil (euid pid) (nil t nil))
da643190 99 (user "USER" nil left proced-string-lessp nil (user pid) (nil t nil))
d74d0c42 100 (egid "EGID" "%d" right proced-< nil (egid euid pid) (nil t nil))
da643190
RW
101 (group "GROUP" nil left proced-string-lessp nil (group user pid) (nil t nil))
102 (comm "COMMAND" nil left proced-string-lessp nil (comm pid) (nil t nil))
103 (state "STAT" nil left proced-string-lessp nil (state pid) (nil t nil))
b4f671ce 104 (ppid "PPID" "%d" right proced-< nil (ppid pid)
3ac09bb4 105 ((lambda (ppid) (proced-filter-parents proced-process-alist ppid))
b4f671ce 106 "refine to process parents"))
d74d0c42
RW
107 (pgrp "PGRP" "%d" right proced-< nil (pgrp euid pid) (nil t nil))
108 (sess "SESS" "%d" right proced-< nil (sess pid) (nil t nil))
109 (ttname "TTY" proced-format-ttname left proced-string-lessp nil (ttname pid) (nil t nil))
110 (tpgid "TPGID" "%d" right proced-< nil (tpgid pid) (nil t nil))
111 (minflt "MINFLT" "%d" right proced-< nil (minflt pid) (nil t t))
112 (majflt "MAJFLT" "%d" right proced-< nil (majflt pid) (nil t t))
113 (cminflt "CMINFLT" "%d" right proced-< nil (cminflt pid) (nil t t))
114 (cmajflt "CMAJFLT" "%d" right proced-< nil (cmajflt pid) (nil t t))
115 (utime "UTIME" proced-format-time right proced-time-lessp t (utime pid) (nil t t))
116 (stime "STIME" proced-format-time right proced-time-lessp t (stime pid) (nil t t))
3ac09bb4 117 (time "TIME" proced-format-time right proced-time-lessp t (time pid) (nil t t))
d74d0c42
RW
118 (cutime "CUTIME" proced-format-time right proced-time-lessp t (cutime pid) (nil t t))
119 (cstime "CSTIME" proced-format-time right proced-time-lessp t (cstime pid) (nil t t))
3ac09bb4 120 (ctime "CTIME" proced-format-time right proced-time-lessp t (ctime pid) (nil t t))
d74d0c42
RW
121 (pri "PR" "%d" right proced-< t (pri pid) (nil t t))
122 (nice "NI" "%3d" 3 proced-< t (nice pid) (t t nil))
123 (thcount "THCOUNT" "%d" right proced-< t (thcount pid) (nil t t))
124 (start "START" proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
125 (vsize "VSIZE" "%d" right proced-< t (vsize pid) (nil t t))
126 (rss "RSS" "%d" right proced-< t (rss pid) (nil t t))
127 (etime "ETIME" proced-format-time right proced-time-lessp t (etime pid) (nil t t))
128 (pcpu "%CPU" "%.1f" right proced-< t (pcpu pid) (nil t t))
129 (pmem "%MEM" "%.1f" right proced-< t (pmem pid) (nil t t))
da643190 130 (args "ARGS" proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
d74d0c42
RW
131 ;;
132 ;; attributes defined by proced (see `proced-process-attributes')
b4f671ce 133 (pid "PID" "%d" right proced-< nil (pid)
3ac09bb4 134 ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
b4f671ce 135 "refine to process children"))
f1d27653
RW
136 ;; process tree
137 (tree "TREE" proced-format-tree left nil nil nil nil))
d74d0c42
RW
138 "Alist of rules for handling Proced attributes.
139
140Each element has the form
141
b4f671ce 142 (KEY NAME FORMAT JUSTIFY PREDICATE REVERSE SORT-SCHEME REFINER).
d74d0c42 143
204ebc5b 144Symbol KEY is the car of a process attribute.
d74d0c42 145
204ebc5b 146String NAME appears in the header line.
d74d0c42 147
d0482e4e
JB
148FORMAT specifies the format for displaying the attribute values. It can
149be a string passed to `format'. It can be a function called with one
150argument, the value of the attribute. The value nil means take as is.
d74d0c42
RW
151
152If JUSTIFY is an integer, its modulus gives the width of the attribute
da643190 153values formatted with FORMAT. If JUSTIFY is positive, NAME appears
d74d0c42
RW
154right-justified, otherwise it appears left-justified. If JUSTIFY is 'left
155or 'right, the field width is calculated from all field values in the listing.
156If JUSTIFY is 'left, the field values are formatted left-justified and
157right-justified otherwise.
158
159PREDICATE is the predicate for sorting and filtering the process listing
160based on attribute KEY. PREDICATE takes two arguments P1 and P2,
161the corresponding attribute values of two processes. PREDICATE should
162return 'equal if P1 has same rank like P2. Any other non-nil value says
163that P1 is \"less than\" P2, or nil if not.
f1d27653 164If PREDICATE is nil the attribute cannot be sorted.
d74d0c42 165
b4f671ce
RW
166PREDICATE defines an ascending sort order. REVERSE is non-nil if the sort
167order is descending.
d74d0c42 168
da643190 169SORT-SCHEME is a list (KEY1 KEY2 ...) defining a hierarchy of rules
d74d0c42
RW
170for sorting the process listing. KEY1, KEY2, ... are KEYs appearing as cars
171of `proced-grammar-alist'. First the PREDICATE of KEY1 is evaluated.
da643190 172If it yields non-equal, it defines the sort order for the corresponding
d74d0c42
RW
173processes. If it evaluates to 'equal the PREDICATE of KEY2 is evaluated, etc.
174
b4f671ce 175REFINER can be a list of flags (LESS-B EQUAL-B LARGER-B) used by the command
da643190
RW
176`proced-refine' (see there) to refine the listing based on attribute KEY.
177This command compares the value of attribute KEY of every process with
178the value of attribute KEY of the process at the position of point
179using PREDICATE.
d74d0c42
RW
180If PREDICATE yields non-nil, the process is accepted if LESS-B is non-nil.
181If PREDICATE yields 'equal, the process is accepted if EQUAL-B is non-nil.
b4f671ce
RW
182If PREDICATE yields nil, the process is accepted if LARGER-B is non-nil.
183
3ac09bb4 184REFINER can also be a list (FUNCTION HELP-ECHO).
b4f671ce
RW
185FUNCTION is called with one argument, the PID of the process at the position
186of point. The function must return a list of PIDs that is used for the refined
187listing. HELP-ECHO is a string that is shown when mouse is over this field.
188
189If REFINER is nil no refinement is done."
204ebc5b
RW
190 :group 'proced
191 :type '(repeat (list :tag "Attribute"
192 (symbol :tag "Key")
193 (string :tag "Header")
194 (choice :tag "Format"
195 (const :tag "None" nil)
196 (string :tag "Format String")
197 (function :tag "Formatting Function"))
198 (choice :tag "Justification"
199 (const :tag "left" left)
200 (const :tag "right" right)
201 (integer :tag "width"))
f1d27653
RW
202 (choice :tag "Predicate"
203 (const :tag "None" nil)
204 (function :tag "Function"))
b4f671ce 205 (boolean :tag "Descending Sort Order")
204ebc5b 206 (repeat :tag "Sort Scheme" (symbol :tag "Key"))
b4f671ce 207 (choice :tag "Refiner"
f1d27653 208 (const :tag "None" nil)
3ac09bb4
RW
209 (list (function :tag "Refinement Function")
210 (string :tag "Help echo"))
b4f671ce
RW
211 (list :tag "Refine Flags"
212 (boolean :tag "Less")
213 (boolean :tag "Equal")
3ac09bb4 214 (boolean :tag "Larger"))))))
204ebc5b
RW
215
216(defcustom proced-custom-attributes nil
d74d0c42
RW
217 "List of functions defining custom attributes.
218This variable extends the functionality of `proced-process-attributes'.
219Each function is called with one argument, the list of attributes
220of a system process. It returns a cons cell of the form (KEY . VALUE)
204ebc5b
RW
221like `system-process-attributes'. This cons cell is appended to the list
222returned by `proced-process-attributes'.
223If the function returns nil, the value is ignored."
224 :group 'proced
225 :type '(repeat (function :tag "Attribute")))
d74d0c42
RW
226
227;; Formatting and sorting rules are defined "per attribute". If formatting
228;; and / or sorting should use more than one attribute, it appears more
229;; transparent to define a new derived attribute, so that formatting and
230;; sorting can use them consistently. (Are there exceptions to this rule?
231;; Would it be advantageous to have yet more general methods available?)
232;; Sorting can also be based on attributes that are invisible in the listing.
233
204ebc5b 234(defcustom proced-format-alist
f1d27653
RW
235 '((short user pid tree pcpu pmem start time (args comm))
236 (medium user pid tree pcpu pmem vsize rss ttname state start time (args comm))
237 (long user euid group pid tree pri nice pcpu pmem vsize rss ttname state
b4f671ce 238 start time (args comm))
f1d27653 239 (verbose user euid group egid pid ppid tree pgrp sess pri nice pcpu pmem
d74d0c42 240 state thcount vsize rss ttname tpgid minflt majflt cminflt cmajflt
b4f671ce 241 start time utime stime ctime cutime cstime etime (args comm)))
d74d0c42
RW
242 "Alist of formats of listing.
243The car of each element is a symbol, the name of the format.
b4f671ce
RW
244The cdr is a list of attribute keys appearing in `proced-grammar-alist'.
245An element of this list may also be a list of attribute keys that specifies
246alternatives. If the first attribute is absent for a process, use the second
247one, etc."
204ebc5b
RW
248 :group 'proced
249 :type '(alist :key-type (symbol :tag "Format Name")
b4f671ce
RW
250 :value-type (repeat :tag "Keys"
251 (choice (symbol :tag "")
252 (repeat :tag "Alternative Keys"
253 (symbol :tag ""))))))
d74d0c42 254
204ebc5b 255(defcustom proced-format 'short
d74d0c42
RW
256 "Current format of Proced listing.
257It can be the car of an element of `proced-format-alist'.
204ebc5b
RW
258It can also be a list of keys appearing in `proced-grammar-alist'."
259 :group 'proced
260 :type '(choice (symbol :tag "Format Name")
261 (repeat :tag "Keys" (symbol :tag ""))))
d74d0c42
RW
262(make-variable-buffer-local 'proced-format)
263
264;; FIXME: is there a better name for filter `user' that does not coincide
265;; with an attribute key?
204ebc5b 266(defcustom proced-filter-alist
d74d0c42
RW
267 `((user (user . ,(concat "\\`" (user-real-login-name) "\\'")))
268 (user-running (user . ,(concat "\\`" (user-real-login-name) "\\'"))
269 (state . "\\`[Rr]\\'"))
270 (all)
271 (all-running (state . "\\`[Rr]\\'"))
272 (emacs (fun-all . (lambda (list)
273 (proced-filter-children list ,(emacs-pid))))))
274 "Alist of process filters.
275The car of each element is a symbol, the name of the filter.
276The cdr is a list of elementary filters that are applied to every process.
277A process is displayed if it passes all elementary filters of a selected
278filter.
279
280An elementary filter can be one of the following:
281\(KEY . REGEXP) If value of attribute KEY matches REGEXP,
282 accept this process.
283\(KEY . FUN) Apply function FUN to attribute KEY. Accept this process,
284 if FUN returns non-nil.
285\(function . FUN) For each process, apply function FUN to list of attributes
286 of each. Accept the process if FUN returns non-nil.
287\(fun-all . FUN) Apply function FUN to entire process list.
204ebc5b
RW
288 FUN must return the filtered list."
289 :group 'proced
290 :type '(repeat (cons :tag "Filter"
291 (symbol :tag "Filter Name")
292 (repeat :tag "Filters"
293 (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp)
294 (cons :tag "Key . Function" (symbol :tag "Key") function)
295 (cons :tag "Function" (const :tag "Key: function" function) function)
296 (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function))))))
297
298(defcustom proced-filter 'user
d74d0c42
RW
299 "Current filter of proced listing.
300It can be the car of an element of `proced-filter-alist'.
301It can also be a list of elementary filters as in the cdrs of the elements
204ebc5b
RW
302of `proced-filter-alist'."
303 :group 'proced
304 :type '(choice (symbol :tag "Filter Name")
305 (repeat :tag "Filters"
306 (choice (cons :tag "Key . Regexp" (symbol :tag "Key") regexp)
307 (cons :tag "Key . Function" (symbol :tag "Key") function)
308 (cons :tag "Function" (const :tag "Key: function" function) function)
309 (cons :tag "Fun-all" (const :tag "Key: fun-all" fun-all) function)))))
d74d0c42
RW
310(make-variable-buffer-local 'proced-filter)
311
204ebc5b 312(defcustom proced-sort 'pcpu
da643190 313 "Current sort scheme for proced listing.
d74d0c42
RW
314It must be the KEY of an element of `proced-grammar-alist'.
315It can also be a list of KEYs as in the SORT-SCHEMEs of the elements
204ebc5b
RW
316of `proced-grammar-alist'."
317 :group 'proced
318 :type '(choice (symbol :tag "Sort Scheme")
319 (repeat :tag "Key List" (symbol :tag "Key"))))
d74d0c42
RW
320(make-variable-buffer-local 'proced-format)
321
b4f671ce
RW
322(defcustom proced-descend t
323 "Non-nil if proced listing is sorted in descending order."
324 :group 'proced
325 :type '(boolean :tag "Descending Sort Order"))
326(make-variable-buffer-local 'proced-descend)
327
d74d0c42
RW
328(defcustom proced-goal-attribute 'args
329 "If non-nil, key of the attribute that defines the `goal-column'."
330 :group 'proced
331 :type '(choice (const :tag "none" nil)
332 (symbol :tag "key")))
333
413e65fe 334(defcustom proced-auto-update-interval 5
204ebc5b 335 "Time interval in seconds for auto updating Proced buffers."
d74d0c42
RW
336 :group 'proced
337 :type 'integer)
338
413e65fe 339(defcustom proced-auto-update-flag nil
da643190 340 "Non-nil for auto update of a Proced buffer.
413e65fe 341Can be changed interactively via `proced-toggle-auto-update'."
d74d0c42
RW
342 :group 'proced
343 :type 'boolean)
413e65fe 344(make-variable-buffer-local 'proced-auto-update-flag)
d74d0c42 345
f1d27653 346(defcustom proced-tree-flag nil
744c85fb 347 "Non-nil for display of Proced buffer as process tree."
f1d27653
RW
348 :group 'proced
349 :type 'boolean)
350(make-variable-buffer-local 'proced-tree-flag)
351
3ac09bb4
RW
352(defcustom proced-post-display-hook nil
353 "Normal hook run after displaying or updating a Proced buffer.
354May be used to adapt the window size via `fit-window-to-buffer'."
355 :type 'hook
356 :options '(fit-window-to-buffer)
357 :group 'proced)
358
92d9ce48 359;; Internal variables
d74d0c42 360
4ed46aef
RW
361(defvar proced-available (not (null (list-system-processes)))
362 "Non-nil means Proced is known to work on this system.")
363
d74d0c42 364(defvar proced-process-alist nil
da643190
RW
365 "Alist of processes displayed by Proced.
366The car of each element is the PID, and the cdr is a list of
367cons pairs, see `proced-process-attributes'.")
d74d0c42
RW
368(make-variable-buffer-local 'proced-process-alist)
369
370(defvar proced-sort-internal nil
b4f671ce
RW
371 "Sort scheme for listing (internal format).
372It is a list of lists (KEY PREDICATE REVERSE).")
d74d0c42 373
37e4d8ed 374(defvar proced-marker-char ?* ; the answer is 42
d0482e4e 375 "In Proced, the current mark character.")
37e4d8ed 376
aa5fecb5
RW
377;; Faces and font-lock code taken from dired,
378;; but face variables are deprecated for new code.
37e4d8ed
RW
379(defgroup proced-faces nil
380 "Faces used by Proced."
381 :group 'proced
382 :group 'faces)
383
37e4d8ed
RW
384(defface proced-mark
385 '((t (:inherit font-lock-constant-face)))
d0482e4e 386 "Face used for Proced marks."
37e4d8ed 387 :group 'proced-faces)
37e4d8ed
RW
388
389(defface proced-marked
390 '((t (:inherit font-lock-warning-face)))
391 "Face used for marked processes."
392 :group 'proced-faces)
37e4d8ed 393
da643190
RW
394(defface proced-sort-header
395 '((t (:inherit font-lock-keyword-face)))
396 "Face used for header of attribute used for sorting."
397 :group 'proced-faces)
da643190 398
37e4d8ed
RW
399(defvar proced-re-mark "^[^ \n]"
400 "Regexp matching a marked line.
401Important: the match ends just after the marker.")
402
d74d0c42
RW
403(defvar proced-header-line nil
404 "Headers in Proced buffer as a string.")
405(make-variable-buffer-local 'proced-header-line)
406
48152a70
RW
407(defvar proced-temp-alist nil
408 "Temporary alist (internal variable).")
f1d27653 409
d74d0c42 410(defvar proced-process-tree nil
f1d27653
RW
411 "Proced process tree (internal variable).")
412
3ac09bb4
RW
413(defvar proced-tree-depth nil
414 "Internal variable for depth of Proced process tree.")
d74d0c42 415
413e65fe
RW
416(defvar proced-auto-update-timer nil
417 "Stores if Proced auto update timer is already installed.")
d74d0c42 418
204ebc5b
RW
419(defvar proced-log-buffer "*Proced log*"
420 "Name of Proced Log buffer.")
421
d74d0c42
RW
422(defconst proced-help-string
423 "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit (type ? for more help)"
d0482e4e 424 "Help string for Proced.")
d74d0c42
RW
425
426(defconst proced-header-help-echo
da643190 427 "mouse-1, mouse-2: sort by attribute %s%s (%s)"
d74d0c42
RW
428 "Help string shown when mouse is over a sortable header.")
429
430(defconst proced-field-help-echo
da643190
RW
431 "mouse-2, RET: refine by attribute %s %s"
432 "Help string shown when mouse is over a refinable field.")
37e4d8ed
RW
433
434(defvar proced-font-lock-keywords
aa5fecb5
RW
435 `(;; (Any) proced marks.
436 (,proced-re-mark . 'proced-mark)
437 ;; Processes marked with `proced-marker-char'
438 ;; Should we make sure that only certain attributes are font-locked?
439 (,(concat "^[" (char-to-string proced-marker-char) "]")
440 ".+" (proced-move-to-goal-column) nil (0 'proced-marked))))
37e4d8ed
RW
441
442(defvar proced-mode-map
443 (let ((km (make-sparse-keymap)))
92d9ce48 444 ;; moving
5adfa483 445 (define-key km " " 'next-line)
d74d0c42
RW
446 (define-key km "n" 'next-line)
447 (define-key km "p" 'previous-line)
448 (define-key km "\C-n" 'next-line)
449 (define-key km "\C-p" 'previous-line)
450 (define-key km "\C-?" 'previous-line)
451 (define-key km [down] 'next-line)
452 (define-key km [up] 'previous-line)
92d9ce48 453 ;; marking
d74d0c42 454 (define-key km "d" 'proced-mark) ; Dired compatibility ("delete")
37e4d8ed 455 (define-key km "m" 'proced-mark)
37e4d8ed 456 (define-key km "u" 'proced-unmark)
e6854b3f 457 (define-key km "\177" 'proced-unmark-backward)
92d9ce48 458 (define-key km "M" 'proced-mark-all)
37e4d8ed 459 (define-key km "U" 'proced-unmark-all)
e6854b3f 460 (define-key km "t" 'proced-toggle-marks)
d74d0c42
RW
461 (define-key km "C" 'proced-mark-children)
462 (define-key km "P" 'proced-mark-parents)
463 ;; filtering
464 (define-key km "f" 'proced-filter-interactive)
da643190
RW
465 (define-key km [mouse-2] 'proced-refine)
466 (define-key km "\C-m" 'proced-refine)
92d9ce48 467 ;; sorting
61548252
RW
468 (define-key km "sc" 'proced-sort-pcpu)
469 (define-key km "sm" 'proced-sort-pmem)
470 (define-key km "sp" 'proced-sort-pid)
471 (define-key km "ss" 'proced-sort-start)
d74d0c42 472 (define-key km "sS" 'proced-sort-interactive)
61548252 473 (define-key km "st" 'proced-sort-time)
d74d0c42 474 (define-key km "su" 'proced-sort-user)
da643190
RW
475 ;; similar to `Buffer-menu-sort-by-column'
476 (define-key km [header-line mouse-1] 'proced-sort-header)
d74d0c42 477 (define-key km [header-line mouse-2] 'proced-sort-header)
f1d27653 478 (define-key km "T" 'proced-toggle-tree)
d74d0c42
RW
479 ;; formatting
480 (define-key km "F" 'proced-format-interactive)
92d9ce48 481 ;; operate
9f583d14 482 (define-key km "o" 'proced-omit-processes)
92d9ce48
RW
483 (define-key km "x" 'proced-send-signal) ; Dired compatibility
484 (define-key km "k" 'proced-send-signal) ; kill processes
485 ;; misc
92d9ce48
RW
486 (define-key km "h" 'describe-mode)
487 (define-key km "?" 'proced-help)
37e4d8ed
RW
488 (define-key km [remap undo] 'proced-undo)
489 (define-key km [remap advertised-undo] 'proced-undo)
3ac09bb4 490 ;; Additional keybindings are inherited from `special-mode-map'
37e4d8ed 491 km)
d0482e4e 492 "Keymap for Proced commands.")
37e4d8ed
RW
493
494(easy-menu-define
495 proced-menu proced-mode-map "Proced Menu"
9f583d14
RW
496 `("Proced"
497 ["Mark" proced-mark
498 :help "Mark Current Process"]
499 ["Unmark" proced-unmark
500 :help "Unmark Current Process"]
501 ["Mark All" proced-mark-all
502 :help "Mark All Processes"]
503 ["Unmark All" proced-unmark-all
504 :help "Unmark All Process"]
505 ["Toggle Marks" proced-toggle-marks
506 :help "Marked Processes Become Unmarked, and Vice Versa"]
d74d0c42
RW
507 ["Mark Children" proced-mark-children
508 :help "Mark Current Process and its Children"]
509 ["Mark Parents" proced-mark-parents
510 :help "Mark Current Process and its Parents"]
e6854b3f 511 "--"
d74d0c42
RW
512 ("Filters"
513 :help "Select Filter for Process Listing"
514 ,@(mapcar (lambda (el)
515 (let ((filter (car el)))
516 `[,(symbol-name filter)
517 (proced-filter-interactive ',filter)
518 :style radio
519 :selected (eq proced-filter ',filter)]))
520 proced-filter-alist))
521 ("Sorting"
da643190 522 :help "Select Sort Scheme"
d74d0c42
RW
523 ["Sort..." proced-sort-interactive
524 :help "Sort Process List"]
525 "--"
526 ["Sort by %CPU" proced-sort-pcpu]
527 ["Sort by %MEM" proced-sort-pmem]
528 ["Sort by PID" proced-sort-pid]
529 ["Sort by START" proced-sort-start]
530 ["Sort by TIME" proced-sort-time]
531 ["Sort by USER" proced-sort-user])
532 ("Formats"
533 :help "Select Format for Process Listing"
534 ,@(mapcar (lambda (el)
535 (let ((format (car el)))
536 `[,(symbol-name format)
537 (proced-format-interactive ',format)
538 :style radio
539 :selected (eq proced-format ',format)]))
540 proced-format-alist))
f1d27653
RW
541 ["Tree Display" proced-toggle-tree
542 :style toggle
543 :selected (eval proced-tree-flag)
544 :help "Display Proced Buffer as Process Tree"]
61548252 545 "--"
9f583d14
RW
546 ["Omit Marked Processes" proced-omit-processes
547 :help "Omit Marked Processes in Process Listing."]
37e4d8ed 548 "--"
9f583d14
RW
549 ["Revert" revert-buffer
550 :help "Revert Process Listing"]
413e65fe 551 ["Auto Update" proced-toggle-auto-update
b4f671ce 552 :style toggle
413e65fe 553 :selected (eval proced-auto-update-flag)
da643190 554 :help "Auto Update of Proced Buffer"]
9f583d14 555 ["Send signal" proced-send-signal
d74d0c42 556 :help "Send Signal to Marked Processes"]))
9f583d14 557
92d9ce48 558;; helper functions
e6854b3f 559(defun proced-marker-regexp ()
61548252 560 "Return regexp matching `proced-marker-char'."
92d9ce48 561 ;; `proced-marker-char' must appear in column zero
e6854b3f
RW
562 (concat "^" (regexp-quote (char-to-string proced-marker-char))))
563
564(defun proced-success-message (action count)
61548252 565 "Display success message for ACTION performed for COUNT processes."
e6854b3f
RW
566 (message "%s %s process%s" action count (if (= 1 count) "" "es")))
567
d74d0c42
RW
568;; Unlike dired, we do not define our own commands for vertical motion.
569;; If `goal-column' is set, `next-line' and `previous-line' are fancy
570;; commands to satisfy our modest needs. If `proced-goal-attribute'
571;; and/or `goal-column' are not set, `next-line' and `previous-line'
572;; are really what we need to preserve the column of point.
573;; We use `proced-move-to-goal-column' for "non-interactive" cases only
574;; to get a well-defined position of point.
575
92d9ce48 576(defun proced-move-to-goal-column ()
da643190 577 "Move to `goal-column' if non-nil. Return position of point."
e6854b3f 578 (beginning-of-line)
d74d0c42
RW
579 (unless (eobp)
580 (if goal-column
581 (forward-char goal-column)
da643190
RW
582 (forward-char 2)))
583 (point))
d74d0c42
RW
584
585(defun proced-header-line ()
586 "Return header line for Proced buffer."
587 (list (propertize " " 'display '(space :align-to 0))
588 (replace-regexp-in-string ;; preserve text properties
589 "\\(%\\)" "\\1\\1" (substring proced-header-line (window-hscroll)))))
590
591(defun proced-pid-at-point ()
592 "Return pid of system process at point.
593Return nil if point is not on a process line."
594 (save-excursion
595 (beginning-of-line)
596 (if (looking-at "^. .")
597 (get-text-property (match-end 0) 'proced-pid))))
598
599;; proced mode
e6854b3f 600
3ac09bb4 601(define-derived-mode proced-mode special-mode "Proced"
079ba9b7 602 "Mode for displaying UNIX system processes and sending signals to them.
204ebc5b
RW
603Type \\[proced] to start a Proced session. In a Proced buffer
604type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
079ba9b7
SM
605Type \\[proced-send-signal] to send signals to marked processes.
606
da643190
RW
607The initial content of a listing is defined by the variable `proced-filter'
608and the variable `proced-format'.
609The variable `proced-filter' specifies which system processes are displayed.
610The variable `proced-format' specifies which attributes are displayed for
611each process. Type \\[proced-filter-interactive] and \\[proced-format-interactive]
612to change the values of `proced-filter' and `proced-format'.
613The current value of the variable `proced-filter' is indicated in the
614mode line.
615
616The sort order of Proced listings is defined by the variable `proced-sort'.
617Type \\[proced-sort-interactive] or click on a header in the header line
618to change the sort scheme. The current sort scheme is indicated in the
619mode line, using \"+\" or \"-\" for ascending or descending sort order.
620
f1d27653
RW
621Type \\[proced-toggle-tree] to toggle whether the listing is
622displayed as process tree.
623
4ed46aef 624An existing Proced listing can be refined by typing \\[proced-refine].
da643190
RW
625Refining an existing listing does not update the variable `proced-filter'.
626
627The attribute-specific rules for formatting, filtering, sorting, and refining
628are defined in `proced-grammar-alist'.
629
3ac09bb4
RW
630After displaying or updating a Proced buffer, Proced runs the normal hook
631`proced-post-display-hook'.
632
079ba9b7
SM
633\\{proced-mode-map}"
634 (abbrev-mode 0)
635 (auto-fill-mode 0)
636 (setq buffer-read-only t
b9df5969
RW
637 truncate-lines t
638 header-line-format '(:eval (proced-header-line)))
639 (add-hook 'post-command-hook 'force-mode-line-update nil t)
079ba9b7
SM
640 (set (make-local-variable 'revert-buffer-function) 'proced-revert)
641 (set (make-local-variable 'font-lock-defaults)
d74d0c42 642 '(proced-font-lock-keywords t nil nil beginning-of-line))
413e65fe
RW
643 (if (and (not proced-auto-update-timer) proced-auto-update-interval)
644 (setq proced-auto-update-timer
645 (run-at-time t proced-auto-update-interval
646 'proced-auto-update-timer))))
216d81a1 647
079ba9b7
SM
648;;;###autoload
649(defun proced (&optional arg)
da643190 650 "Generate a listing of UNIX system processes.
37e4d8ed
RW
651If invoked with optional ARG the window displaying the process
652information will be displayed but not selected.
3ac09bb4 653Runs the normal hook `proced-post-display-hook'.
37e4d8ed 654
667df88c 655See `proced-mode' for a description of features available in Proced buffers."
37e4d8ed 656 (interactive "P")
413e65fe
RW
657 (unless proced-available
658 (error "Proced is not available on this system"))
92d9ce48 659 (let ((buffer (get-buffer-create "*Proced*")) new)
61548252 660 (set-buffer buffer)
37e4d8ed 661 (setq new (zerop (buffer-size)))
3ac09bb4
RW
662 (when new
663 (proced-mode)
664 ;; `proced-update' runs `proced-post-display-hook' only if the
665 ;; Proced buffer has been selected. Yet the following call of
666 ;; `proced-update' is for an empty Proced buffer that has not
667 ;; yet been selected. Therefore we need to call
668 ;; `proced-post-display-hook' below.
669 (proced-update t))
37e4d8ed 670 (if arg
3ac09bb4
RW
671 (progn
672 (display-buffer buffer)
673 (with-current-buffer buffer
674 (run-hooks 'proced-post-display-hook)))
61548252 675 (pop-to-buffer buffer)
3ac09bb4 676 (run-hooks 'proced-post-display-hook)
008c22f2
JL
677 (message
678 (substitute-command-keys
679 "Type \\<proced-mode-map>\\[quit-window] to quit, \\[proced-help] for help")))))
37e4d8ed 680
413e65fe 681(defun proced-auto-update-timer ()
da643190 682 "Auto-update Proced buffers using `run-at-time'."
d74d0c42
RW
683 (dolist (buf (buffer-list))
684 (with-current-buffer buf
685 (if (and (eq major-mode 'proced-mode)
413e65fe 686 proced-auto-update-flag)
d74d0c42
RW
687 (proced-update t t)))))
688
413e65fe 689(defun proced-toggle-auto-update (arg)
da643190
RW
690 "Change whether this Proced buffer is updated automatically.
691With prefix ARG, update this buffer automatically if ARG is positive,
413e65fe
RW
692otherwise do not update. Sets the variable `proced-auto-update-flag'.
693The time interval for updates is specified via `proced-auto-update-interval'."
d74d0c42 694 (interactive (list (or current-prefix-arg 'toggle)))
413e65fe
RW
695 (setq proced-auto-update-flag
696 (cond ((eq arg 'toggle) (not proced-auto-update-flag))
d74d0c42 697 (arg (> (prefix-numeric-value arg) 0))
413e65fe
RW
698 (t (not proced-auto-update-flag))))
699 (message "Proced auto update %s"
700 (if proced-auto-update-flag "enabled" "disabled")))
92d9ce48 701
3ac09bb4
RW
702;;; Mark
703
37e4d8ed
RW
704(defun proced-mark (&optional count)
705 "Mark the current (or next COUNT) processes."
706 (interactive "p")
707 (proced-do-mark t count))
708
709(defun proced-unmark (&optional count)
710 "Unmark the current (or next COUNT) processes."
711 (interactive "p")
712 (proced-do-mark nil count))
713
e6854b3f
RW
714(defun proced-unmark-backward (&optional count)
715 "Unmark the previous (or COUNT previous) processes."
61548252
RW
716 ;; Analogous to `dired-unmark-backward',
717 ;; but `ibuffer-unmark-backward' behaves different.
e6854b3f
RW
718 (interactive "p")
719 (proced-do-mark nil (- (or count 1))))
720
37e4d8ed 721(defun proced-do-mark (mark &optional count)
9f583d14 722 "Mark the current (or next COUNT) processes using MARK."
37e4d8ed 723 (or count (setq count 1))
e6854b3f 724 (let ((backward (< count 0))
37e4d8ed 725 buffer-read-only)
92d9ce48
RW
726 (setq count (1+ (if (<= 0 count) count
727 (min (1- (line-number-at-pos)) (abs count)))))
728 (beginning-of-line)
729 (while (not (or (zerop (setq count (1- count))) (eobp)))
730 (proced-insert-mark mark backward))
731 (proced-move-to-goal-column)))
37e4d8ed 732
3ac09bb4
RW
733(defun proced-toggle-marks ()
734 "Toggle marks: marked processes become unmarked, and vice versa."
735 (interactive)
736 (let ((mark-re (proced-marker-regexp))
737 buffer-read-only)
738 (save-excursion
739 (goto-char (point-min))
740 (while (not (eobp))
741 (cond ((looking-at mark-re)
742 (proced-insert-mark nil))
743 ((looking-at " ")
744 (proced-insert-mark t))
745 (t
746 (forward-line 1)))))))
747
748(defun proced-insert-mark (mark &optional backward)
749 "If MARK is non-nil, insert `proced-marker-char'.
750If BACKWARD is non-nil, move one line backwards before inserting the mark.
751Otherwise move one line forward after inserting the mark."
752 (if backward (forward-line -1))
753 (insert (if mark proced-marker-char ?\s))
754 (delete-char 1)
755 (unless backward (forward-line)))
756
37e4d8ed 757(defun proced-mark-all ()
9f583d14
RW
758 "Mark all processes.
759If `transient-mark-mode' is turned on and the region is active,
760mark the region."
37e4d8ed
RW
761 (interactive)
762 (proced-do-mark-all t))
763
764(defun proced-unmark-all ()
9f583d14
RW
765 "Unmark all processes.
766If `transient-mark-mode' is turned on and the region is active,
767unmark the region."
37e4d8ed
RW
768 (interactive)
769 (proced-do-mark-all nil))
770
771(defun proced-do-mark-all (mark)
9f583d14
RW
772 "Mark all processes using MARK.
773If `transient-mark-mode' is turned on and the region is active,
774mark the region."
3ac09bb4
RW
775 (let* ((count 0)
776 (proced-marker-char (if mark proced-marker-char ?\s))
777 (marker-re (proced-marker-regexp))
778 end buffer-read-only)
e6854b3f 779 (save-excursion
d74d0c42 780 (if (use-region-p)
9f583d14
RW
781 ;; Operate even on those lines that are only partially a part
782 ;; of region. This appears most consistent with
783 ;; `proced-move-to-goal-column'.
d74d0c42
RW
784 (progn (setq end (save-excursion
785 (goto-char (region-end))
786 (unless (looking-at "^") (forward-line))
787 (point)))
788 (goto-char (region-beginning))
789 (unless (looking-at "^") (beginning-of-line)))
9f583d14 790 (goto-char (point-min))
d74d0c42
RW
791 (setq end (point-max)))
792 (while (< (point) end)
3ac09bb4
RW
793 (unless (looking-at marker-re)
794 (setq count (1+ count))
795 (insert proced-marker-char)
796 (delete-char 1))
797 (forward-line))
798 (proced-success-message (if mark "Marked" "Unmarked") count))))
e6854b3f 799
d74d0c42
RW
800(defun proced-mark-children (ppid &optional omit-ppid)
801 "Mark child processes of process PPID.
802Also mark process PPID unless prefix OMIT-PPID is non-nil."
803 (interactive (list (proced-pid-at-point) current-prefix-arg))
804 (proced-mark-process-alist
805 (proced-filter-children proced-process-alist ppid omit-ppid)))
806
807(defun proced-mark-parents (cpid &optional omit-cpid)
808 "Mark parent processes of process CPID.
809Also mark CPID unless prefix OMIT-CPID is non-nil."
810 (interactive (list (proced-pid-at-point) current-prefix-arg))
811 (proced-mark-process-alist
812 (proced-filter-parents proced-process-alist cpid omit-cpid)))
813
814(defun proced-mark-process-alist (process-alist &optional quiet)
f1d27653
RW
815 "Mark processes in PROCESS-ALIST.
816If QUIET is non-nil suppress status message."
d74d0c42
RW
817 (let ((count 0))
818 (if process-alist
819 (let (buffer-read-only)
820 (save-excursion
821 (goto-char (point-min))
822 (while (not (eobp))
823 (when (assq (proced-pid-at-point) process-alist)
824 (insert proced-marker-char)
825 (delete-char 1)
826 (setq count (1+ count)))
827 (forward-line)))))
828 (unless quiet
829 (proced-success-message "Marked" count))))
830
e6854b3f
RW
831;; Mostly analog of `dired-do-kill-lines'.
832;; However, for negative args the target lines of `dired-do-kill-lines'
833;; include the current line, whereas `dired-mark' for negative args operates
d74d0c42 834;; on the preceding lines. Here we are consistent with `dired-mark'.
9f583d14
RW
835(defun proced-omit-processes (&optional arg quiet)
836 "Omit marked processes.
837With prefix ARG, omit that many lines starting with the current line.
838\(A negative argument omits backward.)
d74d0c42
RW
839If `transient-mark-mode' is turned on and the region is active,
840omit the processes in region.
e6854b3f 841If QUIET is non-nil suppress status message.
9f583d14 842Returns count of omitted lines."
e6854b3f
RW
843 (interactive "P")
844 (let ((mark-re (proced-marker-regexp))
845 (count 0)
846 buffer-read-only)
d74d0c42
RW
847 (cond ((use-region-p) ;; Omit active region
848 (let ((lines (count-lines (region-beginning) (region-end))))
849 (save-excursion
850 (goto-char (region-beginning))
851 (while (< count lines)
852 (proced-omit-process)
853 (setq count (1+ count))))))
854 ((not arg) ;; Omit marked lines
855 (save-excursion
856 (goto-char (point-min))
857 (while (and (not (eobp))
858 (re-search-forward mark-re nil t))
859 (proced-omit-process)
860 (setq count (1+ count)))))
861 ((< 0 arg) ;; Omit forward
862 (while (and (not (eobp)) (< count arg))
863 (proced-omit-process)
864 (setq count (1+ count))))
865 ((< arg 0) ;; Omit backward
866 (while (and (not (bobp)) (< count (- arg)))
867 (forward-line -1)
868 (proced-omit-process)
869 (setq count (1+ count)))))
92d9ce48 870 (unless (zerop count) (proced-move-to-goal-column))
9f583d14 871 (unless quiet (proced-success-message "Omitted" count))
e6854b3f 872 count))
37e4d8ed 873
d74d0c42
RW
874(defun proced-omit-process ()
875 "Omit process from listing point is on.
876Update `proced-process-alist' accordingly."
877 (setq proced-process-alist
878 (assq-delete-all (proced-pid-at-point) proced-process-alist))
879 (delete-region (line-beginning-position)
880 (save-excursion (forward-line) (point))))
881
882;;; Filtering
883
884(defun proced-filter (process-alist filter-list)
da643190
RW
885 "Apply FILTER-LIST to PROCESS-ALIST.
886Return the filtered process list."
d74d0c42
RW
887 (if (symbolp filter-list)
888 (setq filter-list (cdr (assq filter-list proced-filter-alist))))
889 (dolist (filter filter-list)
890 (let (new-alist)
891 (cond ( ;; apply function to entire process list
892 (eq (car filter) 'fun-all)
893 (setq new-alist (funcall (cdr filter) process-alist)))
894 ( ;; apply predicate to each list of attributes
895 (eq (car filter) 'function)
896 (dolist (process process-alist)
897 (if (funcall (car filter) (cdr process))
898 (push process new-alist))))
899 (t ;; apply predicate to specified attribute
900 (let ((fun (if (stringp (cdr filter))
901 `(lambda (val)
902 (string-match ,(cdr filter) val))
903 (cdr filter)))
904 value)
905 (dolist (process process-alist)
906 (setq value (cdr (assq (car filter) (cdr process))))
907 (if (and value (funcall fun value))
908 (push process new-alist))))))
909 (setq process-alist new-alist)))
910 process-alist)
911
da643190 912(defun proced-filter-interactive (scheme)
d74d0c42
RW
913 "Filter Proced buffer using SCHEME.
914When called interactively, an empty string means nil, i.e., no filtering.
da643190 915Set variable `proced-filter' to SCHEME. Revert listing."
37e4d8ed 916 (interactive
d74d0c42
RW
917 (let ((scheme (completing-read "Filter: "
918 proced-filter-alist nil t)))
da643190 919 (list (if (string= "" scheme) nil (intern scheme)))))
aa5fecb5
RW
920 ;; only update if necessary
921 (unless (eq proced-filter scheme)
922 (setq proced-filter scheme)
923 (proced-update t)))
d74d0c42 924
48152a70
RW
925(defun proced-filter-parents (process-alist pid &optional omit-pid)
926 "For PROCESS-ALIST return list of parent processes of PID.
927This list includes PID unless OMIT-PID is non-nil."
928 (let ((parent-list (unless omit-pid (list (assq pid process-alist))))
929 (process (assq pid process-alist))
930 ppid)
931 (while (and (setq ppid (cdr (assq 'ppid (cdr process))))
932 ;; Ignore a PPID that equals PID.
933 (/= ppid pid)
934 ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
935 (setq process (assq ppid process-alist)))
936 (setq pid ppid)
937 (push process parent-list))
938 parent-list))
939
940(defun proced-filter-children (process-alist ppid &optional omit-ppid)
941 "For PROCESS-ALIST return list of child processes of PPID.
942This list includes PPID unless OMIT-PPID is non-nil."
943 (let ((proced-temp-alist (proced-children-alist process-alist))
944 new-alist)
945 (dolist (pid (proced-children-pids ppid))
946 (push (assq pid process-alist) new-alist))
947 (if omit-ppid
948 (assq-delete-all ppid new-alist)
949 new-alist)))
950
951;;; Process tree
952
f1d27653
RW
953(defun proced-children-alist (process-alist)
954 "Return children alist for PROCESS-ALIST.
955The children alist has elements (PPID PID1 PID2 ...).
d74d0c42 956PPID is a parent PID. PID1, PID2, ... are the child processes of PPID.
48152a70 957The children alist inherits the sorting order of PROCESS-ALIST.
d74d0c42 958The list of children does not include grandchildren."
f1d27653
RW
959 ;; The PPIDs inherit the sorting order of PROCESS-ALIST.
960 (let ((process-tree (mapcar (lambda (a) (list (car a))) process-alist))
961 ppid)
962 (dolist (process process-alist)
d74d0c42 963 (setq ppid (cdr (assq 'ppid (cdr process))))
f1d27653
RW
964 (if (and ppid
965 ;; Ignore a PPID that equals PID.
966 (/= ppid (car process))
967 ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
968 (assq ppid process-alist))
969 (let ((temp-alist process-tree) elt)
970 (while (setq elt (pop temp-alist))
971 (when (eq ppid (car elt))
972 (setq temp-alist nil)
973 (setcdr elt (cons (car process) (cdr elt))))))))
974 ;; The child processes inherit the sorting order of PROCESS-ALIST.
975 (setq process-tree
976 (mapcar (lambda (a) (cons (car a) (nreverse (cdr a))))
977 process-tree))))
978
48152a70
RW
979(defun proced-children-pids (ppid)
980 "Return list of children PIDs of PPID (including PPID)."
981 (let ((cpids (cdr (assq ppid proced-temp-alist))))
982 (if cpids
983 (cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
984 (list ppid))))
985
f1d27653 986(defun proced-process-tree (process-alist)
48152a70
RW
987 "Return process tree for PROCESS-ALIST.
988It is an alist of alists where the car of each alist is a parent process
989and the cdr is a list of child processes according to the ppid attribute
990of these processes.
991The process tree inherits the sorting order of PROCESS-ALIST."
992 (let ((proced-temp-alist (proced-children-alist process-alist))
f1d27653 993 pid-alist proced-process-tree)
48152a70 994 (while (setq pid-alist (pop proced-temp-alist))
f1d27653
RW
995 (push (proced-process-tree-internal pid-alist) proced-process-tree))
996 (nreverse proced-process-tree)))
997
998(defun proced-process-tree-internal (pid-alist)
999 "Helper function for `proced-process-tree'."
1000 (let ((cpid-list (cdr pid-alist)) cpid-alist cpid)
1001 (while (setq cpid (car cpid-list))
48152a70 1002 (if (setq cpid-alist (assq cpid proced-temp-alist))
f1d27653
RW
1003 ;; Unprocessed part of process tree that needs to be
1004 ;; analyzed recursively.
1005 (progn
48152a70
RW
1006 (setq proced-temp-alist
1007 (assq-delete-all cpid proced-temp-alist))
f1d27653
RW
1008 (setcar cpid-list (proced-process-tree-internal cpid-alist)))
1009 ;; We already processed this subtree and take it "as is".
1010 (setcar cpid-list (assq cpid proced-process-tree))
1011 (setq proced-process-tree
1012 (assq-delete-all cpid proced-process-tree)))
1013 (pop cpid-list)))
1014 pid-alist)
1015
1016(defun proced-toggle-tree (arg)
48152a70 1017 "Toggle the display of the process listing as process tree.
f1d27653 1018With prefix ARG, display as process tree if ARG is positive, otherwise
48152a70
RW
1019do not display as process tree. Sets the variable `proced-tree-flag'.
1020
1021The process tree is generated from the selected processes in the
1022Proced buffer (that is, the processes in `proced-process-alist').
1023All processes that do not have a parent process in this list
1024according to their ppid attribute become the root of a process tree.
1025Each parent process is followed by its child processes.
1026The process tree inherits the chosen sorting order of the process listing,
1027that is, child processes of the same parent process are sorted using
1028the selected sorting order."
f1d27653
RW
1029 (interactive (list (or current-prefix-arg 'toggle)))
1030 (setq proced-tree-flag
1031 (cond ((eq arg 'toggle) (not proced-tree-flag))
1032 (arg (> (prefix-numeric-value arg) 0))
1033 (t (not proced-tree-flag))))
1034 (proced-update)
1035 (message "Proced process tree display %s"
1036 (if proced-tree-flag "enabled" "disabled")))
1037
1038(defun proced-tree (process-alist)
48152a70
RW
1039 "Rearrange PROCESS-ALIST as process tree.
1040If `proced-tree-flag' is non-nil, rearrange PROCESS-ALIST such that
1041every processes is followed by its child processes. Each process
1042gets a tree attribute that specifies the depth of the process in the tree.
1043A root process is a process with no parent within PROCESS-ALIST according
1044to its value of the ppid attribute. It has depth 0.
1045
1046If `proced-tree-flag' is nil, remove the tree attribute.
1047Return the rearranged process list."
f1d27653
RW
1048 (if proced-tree-flag
1049 ;; add tree attribute
1050 (let ((process-tree (proced-process-tree process-alist))
3ac09bb4 1051 (proced-tree-depth 0)
48152a70 1052 (proced-temp-alist process-alist)
f1d27653
RW
1053 proced-process-tree pt)
1054 (while (setq pt (pop process-tree))
1055 (proced-tree-insert pt))
1056 (nreverse proced-process-tree))
48152a70
RW
1057 ;; remove tree attribute
1058 (let ((process-alist process-alist))
1059 (while process-alist
1060 (setcar process-alist
1061 (assq-delete-all 'tree (car process-alist)))
1062 (pop process-alist)))
1063 process-alist))
f1d27653
RW
1064
1065(defun proced-tree-insert (process-tree)
1066 "Helper function for `proced-tree'."
48152a70 1067 (let ((pprocess (assq (car process-tree) proced-temp-alist)))
f1d27653 1068 (push (append (list (car pprocess))
3ac09bb4 1069 (list (cons 'tree proced-tree-depth))
f1d27653
RW
1070 (cdr pprocess))
1071 proced-process-tree)
1072 (if (cdr process-tree)
3ac09bb4 1073 (let ((proced-tree-depth (1+ proced-tree-depth)))
f1d27653 1074 (mapc 'proced-tree-insert (cdr process-tree))))))
d74d0c42 1075
da643190
RW
1076;; Refining
1077
1078;; Filters are used to select the processes in a new listing.
1079;; Refiners are used to narrow down further (interactively) the processes
1080;; in an existing listing.
1081
1082(defun proced-refine (&optional event)
1083 "Refine Proced listing by comparing with the attribute value at point.
1084Optional EVENT is the location of the Proced field.
1085
b4f671ce
RW
1086Refinement is controlled by the REFINER defined for each attribute ATTR
1087in `proced-grammar-alist'.
1088
4ed46aef
RW
1089If REFINER is a list of flags and point is on a process's value of ATTR,
1090this command compares the value of ATTR of every process with the value
1091of ATTR of the process at the position of point.
da643190
RW
1092
1093The predicate for the comparison of two ATTR values is defined
1094in `proced-grammar-alist'. For each return value of the predicate
b4f671ce
RW
1095a refine flag is defined in `proced-grammar-alist'. One can select
1096processes for which the value of ATTR is \"less than\", \"equal\",
1097and / or \"larger\" than ATTR of the process point is on. A process
1098is included in the new listing if the refine flag for the corresponding
1099return value of the predicate is non-nil.
da643190 1100The help-echo string for `proced-refine' uses \"+\" or \"-\" to indicate
b4f671ce
RW
1101the current values of these refine flags.
1102
1103If REFINER is a cons pair (FUNCTION . HELP-ECHO), FUNCTION is called
1104with one argument, the PID of the process at the position of point.
1105The function must return a list of PIDs that is used for the refined
1106listing. HELP-ECHO is a string that is shown when mouse is over this field.
da643190 1107
b4f671ce
RW
1108This command refines an already existing process listing generated initially
1109based on the value of the variable `proced-filter'. It does not change
1110this variable. It does not revert the listing. If you frequently need
1111a certain refinement, consider defining a new filter in `proced-filter-alist'."
d74d0c42
RW
1112 (interactive (list last-input-event))
1113 (if event (posn-set-point (event-end event)))
1114 (let ((key (get-text-property (point) 'proced-key))
1115 (pid (get-text-property (point) 'proced-pid)))
1116 (if (and key pid)
1117 (let* ((grammar (assq key proced-grammar-alist))
b4f671ce
RW
1118 (refiner (nth 7 grammar)))
1119 (when refiner
1120 (cond ((functionp (car refiner))
1121 (setq proced-process-alist (funcall (car refiner) pid)))
1122 ((consp refiner)
1123 (let ((predicate (nth 4 grammar))
1124 (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
1125 val new-alist)
1126 (dolist (process proced-process-alist)
1127 (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
1128 (if (cond ((not val) (nth 2 refiner))
1129 ((eq val 'equal) (nth 1 refiner))
1130 (val (car refiner)))
1131 (push process new-alist)))
1132 (setq proced-process-alist new-alist))))
da643190 1133 ;; Do not revert listing.
d74d0c42 1134 (proced-update)))
da643190 1135 (message "No refiner defined here."))))
d74d0c42
RW
1136
1137;; Proced predicates for sorting and filtering are based on a three-valued
1138;; logic:
da643190
RW
1139;; Predicates take two arguments P1 and P2, the corresponding attribute
1140;; values of two processes. Predicates should return 'equal if P1 has
d74d0c42
RW
1141;; same rank like P2. Any other non-nil value says that P1 is "less than" P2,
1142;; or nil if not.
1143
1144(defun proced-< (num1 num2)
1145 "Return t if NUM1 less than NUM2.
1146Return `equal' if NUM1 equals NUM2. Return nil if NUM1 greater than NUM2."
1147 (if (= num1 num2)
1148 'equal
1149 (< num1 num2)))
1150
1151(defun proced-string-lessp (s1 s2)
1152 "Return t if string S1 is less than S2 in lexicographic order.
1153Return `equal' if S1 and S2 have identical contents.
1154Return nil otherwise."
1155 (if (string= s1 s2)
1156 'equal
1157 (string-lessp s1 s2)))
1158
1159(defun proced-time-lessp (t1 t2)
1160 "Return t if time value T1 is less than time value T2.
1161Return `equal' if T1 equals T2. Return nil otherwise."
1162 (with-decoded-time-value ((high1 low1 micro1 t1)
1163 (high2 low2 micro2 t2))
1164 (cond ((< high1 high2))
1165 ((< high2 high1) nil)
1166 ((< low1 low2))
1167 ((< low2 low1) nil)
1168 ((< micro1 micro2))
1169 ((< micro2 micro1) nil)
1170 (t 'equal))))
37e4d8ed 1171
d74d0c42
RW
1172;;; Sorting
1173
1174(defsubst proced-xor (b1 b2)
1175 "Return the logical exclusive or of args B1 and B2."
1176 (and (or b1 b2)
1177 (not (and b1 b2))))
1178
1179(defun proced-sort-p (p1 p2)
1180 "Predicate for sorting processes P1 and P2."
1181 (if (not (cdr proced-sort-internal))
1182 ;; only one predicate: fast scheme
1183 (let* ((sorter (car proced-sort-internal))
1184 (k1 (cdr (assq (car sorter) (cdr p1))))
1185 (k2 (cdr (assq (car sorter) (cdr p2)))))
1186 ;; if the attributes are undefined, we should really abort sorting
1187 (if (and k1 k2)
1188 (proced-xor (funcall (nth 1 sorter) k1 k2)
1189 (nth 2 sorter))))
1190 (let ((sort-list proced-sort-internal) sorter predicate k1 k2)
1191 (catch 'done
1192 (while (setq sorter (pop sort-list))
1193 (setq k1 (cdr (assq (car sorter) (cdr p1)))
1194 k2 (cdr (assq (car sorter) (cdr p2)))
1195 predicate
1196 (if (and k1 k2)
1197 (funcall (nth 1 sorter) k1 k2)))
1198 (if (not (eq predicate 'equal))
1199 (throw 'done (proced-xor predicate (nth 2 sorter)))))
1200 (eq t predicate)))))
1201
b4f671ce 1202(defun proced-sort (process-alist sorter descend)
d74d0c42 1203 "Sort PROCESS-ALIST using scheme SORTER.
b4f671ce
RW
1204SORTER is a scheme like `proced-sort'.
1205DESCEND is non-nil if the first element of SORTER is sorted
1206in descending order.
da643190 1207Return the sorted process list."
d74d0c42
RW
1208 ;; translate SORTER into a list of lists (KEY PREDICATE REVERSE)
1209 (setq proced-sort-internal
1210 (mapcar (lambda (arg)
1211 (let ((grammar (assq arg proced-grammar-alist)))
f1d27653
RW
1212 (unless (nth 4 grammar)
1213 (error "Attribute %s not sortable" (car grammar)))
d74d0c42
RW
1214 (list arg (nth 4 grammar) (nth 5 grammar))))
1215 (cond ((listp sorter) sorter)
1216 ((and (symbolp sorter)
1217 (nth 6 (assq sorter proced-grammar-alist))))
1218 ((symbolp sorter) (list sorter))
1219 (t (error "Sorter undefined %s" sorter)))))
1220 (if proced-sort-internal
b4f671ce
RW
1221 (progn
1222 ;; splice DESCEND into the list
1223 (setcar proced-sort-internal
1224 (list (caar proced-sort-internal)
1225 (nth 1 (car proced-sort-internal)) descend))
1226 (sort process-alist 'proced-sort-p))
d74d0c42
RW
1227 process-alist))
1228
4ed46aef 1229(defun proced-sort-interactive (scheme &optional arg)
d74d0c42
RW
1230 "Sort Proced buffer using SCHEME.
1231When called interactively, an empty string means nil, i.e., no sorting.
da643190 1232
4ed46aef
RW
1233Prefix ARG controls sort order:
1234- If prefix ARG is positive (negative), sort in ascending (descending) order.
1235- If ARG is nil or 'no-arg and SCHEME is equal to the previous sorting scheme,
1236 reverse the sorting order.
1237- If ARG is nil or 'no-arg and SCHEME differs from the previous sorting scheme,
1238 adopt the sorting order defined for SCHEME in `proced-grammar-alist'.
b4f671ce 1239
da643190
RW
1240Set variable `proced-sort' to SCHEME. The current sort scheme is displayed
1241in the mode line, using \"+\" or \"-\" for ascending or descending order."
d74d0c42 1242 (interactive
f1d27653
RW
1243 (let* (choices
1244 (scheme (completing-read "Sort attribute: "
1245 (dolist (grammar proced-grammar-alist choices)
1246 (if (nth 4 grammar)
1247 (push (list (car grammar)) choices)))
1248 nil t)))
d74d0c42 1249 (list (if (string= "" scheme) nil (intern scheme))
4ed46aef
RW
1250 ;; like 'toggle in `define-derived-mode'
1251 (or current-prefix-arg 'no-arg))))
1252
b4f671ce 1253 (setq proced-descend
4ed46aef
RW
1254 ;; If `proced-sort-interactive' is called repeatedly for the same
1255 ;; sort key, the sort order is reversed.
1256 (cond ((and (eq arg 'no-arg) (equal proced-sort scheme))
1257 (not proced-descend))
1258 ((eq arg 'no-arg)
1259 (nth 5 (assq (if (consp scheme) (car scheme) scheme)
1260 proced-grammar-alist)))
1261 (arg (< (prefix-numeric-value arg) 0))
1262 ((equal proced-sort scheme)
1263 (not proced-descend))
1264 (t (nth 5 (assq (if (consp scheme) (car scheme) scheme)
1265 proced-grammar-alist))))
b4f671ce 1266 proced-sort scheme)
4ed46aef 1267 (proced-update))
d74d0c42 1268
4ed46aef 1269(defun proced-sort-pcpu (&optional arg)
b4f671ce 1270 "Sort Proced buffer by percentage CPU time (%CPU).
4ed46aef
RW
1271Prefix ARG controls sort order, see `proced-sort-interactive'."
1272 (interactive (list (or current-prefix-arg 'no-arg)))
1273 (proced-sort-interactive 'pcpu arg))
d74d0c42 1274
4ed46aef 1275(defun proced-sort-pmem (&optional arg)
b4f671ce 1276 "Sort Proced buffer by percentage memory usage (%MEM).
4ed46aef
RW
1277Prefix ARG controls sort order, see `proced-sort-interactive'."
1278 (interactive (list (or current-prefix-arg 'no-arg)))
1279 (proced-sort-interactive 'pmem arg))
d74d0c42 1280
4ed46aef 1281(defun proced-sort-pid (&optional arg)
b4f671ce 1282 "Sort Proced buffer by PID.
4ed46aef
RW
1283Prefix ARG controls sort order, see `proced-sort-interactive'."
1284 (interactive (list (or current-prefix-arg 'no-arg)))
1285 (proced-sort-interactive 'pid arg))
d74d0c42 1286
4ed46aef 1287(defun proced-sort-start (&optional arg)
b4f671ce 1288 "Sort Proced buffer by time the command started (START).
4ed46aef
RW
1289Prefix ARG controls sort order, see `proced-sort-interactive'."
1290 (interactive (list (or current-prefix-arg 'no-arg)))
1291 (proced-sort-interactive 'start arg))
d74d0c42 1292
4ed46aef 1293(defun proced-sort-time (&optional arg)
b4f671ce 1294 "Sort Proced buffer by CPU time (TIME).
4ed46aef
RW
1295Prefix ARG controls sort order, see `proced-sort-interactive'."
1296 (interactive (list (or current-prefix-arg 'no-arg)))
1297 (proced-sort-interactive 'time arg))
d74d0c42 1298
4ed46aef 1299(defun proced-sort-user (&optional arg)
b4f671ce 1300 "Sort Proced buffer by USER.
4ed46aef
RW
1301Prefix ARG controls sort order, see `proced-sort-interactive'."
1302 (interactive (list (or current-prefix-arg 'no-arg)))
1303 (proced-sort-interactive 'user arg))
d74d0c42 1304
4ed46aef 1305(defun proced-sort-header (event &optional arg)
d74d0c42
RW
1306 "Sort Proced listing based on an attribute.
1307EVENT is a mouse event with starting position in the header line.
d0482e4e 1308It is converted to the corresponding attribute key.
b4f671ce 1309This command updates the variable `proced-sort'.
4ed46aef
RW
1310Prefix ARG controls sort order, see `proced-sort-interactive'."
1311 (interactive (list last-input-event (or last-prefix-arg 'no-arg)))
d74d0c42
RW
1312 (let ((start (event-start event))
1313 col key)
1314 (save-selected-window
1315 (select-window (posn-window start))
aa5fecb5 1316 (setq col (+ (1- (car (posn-actual-col-row start)))
d74d0c42
RW
1317 (window-hscroll)))
1318 (when (and (<= 0 col) (< col (length proced-header-line)))
1319 (setq key (get-text-property col 'proced-key proced-header-line))
1320 (if key
4ed46aef 1321 (proced-sort-interactive key arg)
d74d0c42
RW
1322 (message "No sorter defined here."))))))
1323
1324;;; Formating
1325
1326(defun proced-format-time (time)
667df88c 1327 "Format time interval TIME."
d74d0c42
RW
1328 (let* ((ftime (float-time time))
1329 (days (truncate ftime 86400))
1330 (ftime (mod ftime 86400))
1331 (hours (truncate ftime 3600))
1332 (ftime (mod ftime 3600))
1333 (minutes (truncate ftime 60))
1334 (seconds (mod ftime 60)))
1335 (cond ((< 0 days)
1336 (format "%d-%02d:%02d:%02d" days hours minutes seconds))
1337 ((< 0 hours)
1338 (format "%02d:%02d:%02d" hours minutes seconds))
1339 (t
1340 (format "%02d:%02d" minutes seconds)))))
1341
1342(defun proced-format-start (start)
1343 "Format time START.
1344The return string is always 6 characters wide."
1345 (let ((d-start (decode-time start))
1346 (d-current (decode-time)))
1347 (cond ( ;; process started in previous years
1348 (< (nth 5 d-start) (nth 5 d-current))
1349 (format-time-string " %Y" start))
1350 ;; process started today
1351 ((and (= (nth 3 d-start) (nth 3 d-current))
1352 (= (nth 4 d-start) (nth 4 d-current)))
1353 (format-time-string " %H:%M" start))
1354 (t ;; process started this year
1355 (format-time-string "%b %e" start)))))
1356
1357(defun proced-format-ttname (ttname)
da643190 1358 "Format attribute TTNAME, omitting path \"/dev/\"."
d74d0c42 1359 ;; Does this work for all systems?
da643190
RW
1360 (substring ttname (if (string-match "\\`/dev/" ttname)
1361 (match-end 0) 0)))
1362
f1d27653
RW
1363(defun proced-format-tree (tree)
1364 "Format attribute TREE."
1365 (concat (make-string tree ?\s) (number-to-string tree)))
1366
b4f671ce 1367;; Proced assumes that every process occupies only one line in the listing.
da643190
RW
1368(defun proced-format-args (args)
1369 "Format attribute ARGS.
1370Replace newline characters by \"^J\" (two characters)."
1371 (replace-regexp-in-string "\n" "^J" args))
d74d0c42
RW
1372
1373(defun proced-format (process-alist format)
1374 "Display PROCESS-ALIST using FORMAT."
1375 (if (symbolp format)
1376 (setq format (cdr (assq format proced-format-alist))))
b4f671ce
RW
1377
1378 ;; Not all systems give us all attributes. We take `emacs-pid' as a
1379 ;; representative process PID. If FORMAT contains a list of alternative
1380 ;; attributes, we take the first attribute that is non-nil for `emacs-pid'.
1381 ;; If none of the alternatives is non-nil, the attribute is ignored
1382 ;; in the listing.
1383 (let ((standard-attributes
1384 (car (proced-process-attributes (list (emacs-pid)))))
1385 new-format fmi)
3ac09bb4
RW
1386 (if (and proced-tree-flag
1387 (assq 'ppid standard-attributes))
1388 (push (cons 'tree 0) standard-attributes))
b4f671ce
RW
1389 (dolist (fmt format)
1390 (if (symbolp fmt)
1391 (if (assq fmt standard-attributes)
1392 (push fmt new-format))
1393 (while (setq fmi (pop fmt))
1394 (when (assq fmi standard-attributes)
1395 (push fmi new-format)
1396 (setq fmt nil)))))
1397 (setq format (nreverse new-format)))
1398
d74d0c42 1399 (insert (make-string (length process-alist) ?\n))
b4f671ce
RW
1400 (let ((whitespace " ") (unknown "?")
1401 (sort-key (if (consp proced-sort) (car proced-sort) proced-sort))
1402 header-list grammar)
d74d0c42 1403 ;; Loop over all attributes
b4f671ce 1404 (while (setq grammar (assq (pop format) proced-grammar-alist))
d74d0c42 1405 (let* ((key (car grammar))
da643190
RW
1406 (fun (cond ((stringp (nth 2 grammar))
1407 `(lambda (arg) (format ,(nth 2 grammar) arg)))
1408 ((not (nth 2 grammar)) 'identity)
1409 ( t (nth 2 grammar))))
d74d0c42
RW
1410 (whitespace (if format whitespace ""))
1411 ;; Text properties:
1412 ;; We use the text property `proced-key' to store in each
1413 ;; field the corresponding key.
1414 ;; Of course, the sort predicate appearing in help-echo
1415 ;; is only part of the story. But it gives the main idea.
f1d27653
RW
1416 (hprops
1417 (if (nth 4 grammar)
1418 (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
1419 `(proced-key ,key mouse-face highlight
1420 help-echo ,(format proced-header-help-echo
1421 (if descend "-" "+")
1422 (nth 1 grammar)
1423 (if descend "descending" "ascending"))))))
b4f671ce
RW
1424 (refiner (nth 7 grammar))
1425 (fprops
1426 (cond ((functionp (car refiner))
1427 `(proced-key ,key mouse-face highlight
1428 help-echo ,(format "mouse-2, RET: %s"
3ac09bb4 1429 (nth 1 refiner))))
b4f671ce
RW
1430 ((consp refiner)
1431 `(proced-key ,key mouse-face highlight
1432 help-echo ,(format "mouse-2, RET: refine by attribute %s %s"
d74d0c42
RW
1433 (nth 1 grammar)
1434 (mapconcat (lambda (s)
1435 (if s "+" "-"))
b4f671ce 1436 refiner ""))))))
d74d0c42
RW
1437 value)
1438
da643190 1439 ;; highlight the header of the sort column
b4f671ce 1440 (if (eq key sort-key)
aa5fecb5 1441 (setq hprops (append '(face proced-sort-header) hprops)))
d74d0c42
RW
1442 (goto-char (point-min))
1443 (cond ( ;; fixed width of output field
1444 (numberp (nth 3 grammar))
1445 (dolist (process process-alist)
1446 (end-of-line)
1447 (setq value (cdr (assq key (cdr process))))
1448 (insert (if value
1449 (apply 'propertize (funcall fun value) fprops)
b4f671ce
RW
1450 (format (concat "%" (number-to-string (nth 3 grammar)) "s")
1451 unknown))
d74d0c42
RW
1452 whitespace)
1453 (forward-line))
1454 (push (format (concat "%" (number-to-string (nth 3 grammar)) "s")
1455 (apply 'propertize (nth 1 grammar) hprops))
1456 header-list))
1457
1458 ( ;; last field left-justified
1459 (and (not format) (eq 'left (nth 3 grammar)))
1460 (dolist (process process-alist)
1461 (end-of-line)
1462 (setq value (cdr (assq key (cdr process))))
b4f671ce
RW
1463 (insert (if value (apply 'propertize (funcall fun value) fprops)
1464 unknown))
d74d0c42
RW
1465 (forward-line))
1466 (push (apply 'propertize (nth 1 grammar) hprops) header-list))
1467
1468 (t ;; calculated field width
1469 (let ((width (length (nth 1 grammar)))
1470 field-list value)
1471 (dolist (process process-alist)
1472 (setq value (cdr (assq key (cdr process))))
1473 (if value
1474 (setq value (apply 'propertize (funcall fun value) fprops)
1475 width (max width (length value))
1476 field-list (cons value field-list))
b4f671ce
RW
1477 (push unknown field-list)
1478 (setq width (max width (length unknown)))))
d74d0c42
RW
1479 (let ((afmt (concat "%" (if (eq 'left (nth 3 grammar)) "-" "")
1480 (number-to-string width) "s")))
1481 (push (format afmt (apply 'propertize (nth 1 grammar) hprops))
1482 header-list)
1483 (dolist (value (nreverse field-list))
1484 (end-of-line)
1485 (insert (format afmt value) whitespace)
1486 (forward-line))))))))
1487
1488 ;; final cleanup
1489 (goto-char (point-min))
1490 (dolist (process process-alist)
1491 ;; We use the text property `proced-pid' to store in each line
1492 ;; the corresponding pid
1493 (put-text-property (point) (line-end-position) 'proced-pid (car process))
1494 (forward-line))
1495 ;; Set header line
1496 (setq proced-header-line
1497 (mapconcat 'identity (nreverse header-list) whitespace))
1498 (if (string-match "[ \t]+$" proced-header-line)
1499 (setq proced-header-line (substring proced-header-line 0
1500 (match-beginning 0))))
1501 ;; (delete-trailing-whitespace)
1502 (goto-char (point-min))
1503 (while (re-search-forward "[ \t\r]+$" nil t)
1504 (delete-region (match-beginning 0) (match-end 0)))))
b9df5969 1505
d74d0c42
RW
1506(defun proced-format-interactive (scheme &optional revert)
1507 "Format Proced buffer using SCHEME.
1508When called interactively, an empty string means nil, i.e., no formatting.
da643190 1509Set variable `proced-format' to SCHEME.
d74d0c42
RW
1510With prefix REVERT non-nil revert listing."
1511 (interactive
1512 (let ((scheme (completing-read "Format: "
1513 proced-format-alist nil t)))
1514 (list (if (string= "" scheme) nil (intern scheme))
1515 current-prefix-arg)))
aa5fecb5
RW
1516 ;; only update if necessary
1517 (when (or (not (eq proced-format scheme)) revert)
1518 (setq proced-format scheme)
1519 (proced-update revert)))
d74d0c42
RW
1520
1521;; generate listing
1522
b4f671ce 1523(defun proced-process-attributes (&optional pid-list)
d74d0c42 1524 "Return alist of attributes for each system process.
b4f671ce
RW
1525This alist can be customized via `proced-custom-attributes'.
1526Optional arg PID-LIST is a list of PIDs of system process that are analyzed.
1527If no attributes are known for a process (possibly because it already died)
1528the process is ignored."
1529 ;; Should we make it customizable whether processes with empty attribute
1530 ;; lists are ignored? When would such processes be of interest?
3ac09bb4 1531 (let (process-alist attributes attr)
b4f671ce
RW
1532 (dolist (pid (or pid-list (list-system-processes)) process-alist)
1533 (when (setq attributes (system-process-attributes pid))
3ac09bb4
RW
1534 (setq attributes (cons (cons 'pid pid) attributes))
1535 (dolist (fun proced-custom-attributes)
1536 (if (setq attr (funcall fun attributes))
1537 (push attr attributes)))
1538 (push (cons pid attributes) process-alist)))))
d74d0c42
RW
1539
1540(defun proced-update (&optional revert quiet)
d0482e4e 1541 "Update the Proced process information. Preserves point and marks.
d74d0c42 1542With prefix REVERT non-nil, revert listing.
3ac09bb4
RW
1543Suppress status information if QUIET is nil.
1544After updating a displayed Proced buffer run the normal hook
1545`proced-post-display-hook'."
e6854b3f 1546 ;; This is the main function that generates and updates the process listing.
d74d0c42
RW
1547 (interactive "P")
1548 (setq revert (or revert (not proced-process-alist)))
1549 (or quiet (message (if revert "Updating process information..."
1550 "Updating process display...")))
da643190
RW
1551 (if revert ;; evaluate all processes
1552 (setq proced-process-alist (proced-process-attributes)))
1553 ;; filtering and sorting
1554 (setq proced-process-alist
b4f671ce
RW
1555 (proced-sort (proced-filter proced-process-alist proced-filter)
1556 proced-sort proced-descend))
da643190 1557
f1d27653
RW
1558 ;; display as process tree?
1559 (setq proced-process-alist
1560 (proced-tree proced-process-alist))
1561
da643190
RW
1562 ;; It is useless to keep undo information if we revert, filter, or
1563 ;; refine the listing so that `proced-process-alist' has changed.
1564 ;; We could keep the undo information if we only re-sort the buffer.
1565 ;; Would that be useful? Re-re-sorting is easy, too.
1566 (if (consp buffer-undo-list)
1567 (setq buffer-undo-list nil))
1568 (let ((buffer-undo-list t)
1569 ;; If point is on a field, we try to return point to that field.
1570 ;; Otherwise we try to return to the same column
1571 (old-pos (let ((pid (proced-pid-at-point))
1572 (key (get-text-property (point) 'proced-key)))
1573 (list pid key ; can both be nil
d74d0c42
RW
1574 (if key
1575 (if (get-text-property (1- (point)) 'proced-key)
1576 (- (point) (previous-single-property-change
1577 (point) 'proced-key))
1578 0)
1579 (current-column)))))
1580 buffer-read-only mp-list)
37e4d8ed 1581 ;; remember marked processes (whatever the mark was)
d74d0c42
RW
1582 (goto-char (point-min))
1583 (while (re-search-forward "^\\(\\S-\\)" nil t)
1584 (push (cons (save-match-data (proced-pid-at-point))
92d9ce48 1585 (match-string-no-properties 1)) mp-list))
da643190 1586
d74d0c42 1587 ;; generate listing
37e4d8ed 1588 (erase-buffer)
d74d0c42 1589 (proced-format proced-process-alist proced-format)
37e4d8ed
RW
1590 (goto-char (point-min))
1591 (while (not (eobp))
1592 (insert " ")
1593 (forward-line))
d74d0c42
RW
1594 (setq proced-header-line (concat " " proced-header-line))
1595 (if revert (set-buffer-modified-p nil))
da643190 1596
d74d0c42
RW
1597 ;; set `goal-column'
1598 (let ((grammar (assq proced-goal-attribute proced-grammar-alist)))
1599 (setq goal-column ;; set to nil if no match
1600 (if (and grammar
1601 (not (zerop (buffer-size)))
1602 (string-match (regexp-quote (nth 1 grammar))
1603 proced-header-line))
1604 (if (nth 3 grammar)
1605 (match-beginning 0)
1606 (match-end 0)))))
da643190 1607
204ebc5b
RW
1608 ;; Restore process marks and buffer position (if possible).
1609 ;; Sometimes this puts point in the middle of the proced buffer
da643190 1610 ;; where it is not interesting. Is there a better / more flexible solution?
92d9ce48 1611 (goto-char (point-min))
da643190
RW
1612 (let (pid mark new-pos)
1613 (if (or mp-list (car old-pos))
d74d0c42
RW
1614 (while (not (eobp))
1615 (setq pid (proced-pid-at-point))
1616 (when (setq mark (assq pid mp-list))
1617 (insert (cdr mark))
1618 (delete-char 1)
1619 (beginning-of-line))
1620 (when (eq (car old-pos) pid)
1621 (if (nth 1 old-pos)
1622 (let ((limit (line-end-position)) pos)
1623 (while (and (not new-pos)
1624 (setq pos (next-property-change (point) nil limit)))
1625 (goto-char pos)
1626 (when (eq (nth 1 old-pos)
1627 (get-text-property (point) 'proced-key))
1628 (forward-char (min (nth 2 old-pos)
1629 (- (next-property-change (point))
1630 (point))))
1631 (setq new-pos (point))))
1632 (unless new-pos
da643190
RW
1633 ;; we found the process, but the field of point
1634 ;; is not listed anymore
1635 (setq new-pos (proced-move-to-goal-column))))
d74d0c42
RW
1636 (setq new-pos (min (+ (line-beginning-position) (nth 2 old-pos))
1637 (line-end-position)))))
da643190
RW
1638 (forward-line)))
1639 (if new-pos
1640 (goto-char new-pos)
1641 (goto-char (point-min))
1642 (proced-move-to-goal-column)))
61548252 1643 ;; update modeline
da643190
RW
1644 ;; Does the long `mode-name' clutter the modeline? It would be nice
1645 ;; to have some other location for displaying the values of the various
1646 ;; flags that affect the behavior of proced (flags one might want
1647 ;; to change on the fly). Where??
d74d0c42
RW
1648 (setq mode-name
1649 (concat "Proced"
1650 (if proced-filter
1651 (concat ": " (symbol-name proced-filter))
1652 "")
1653 (if proced-sort
b4f671ce 1654 (let* ((key (if (consp proced-sort) (car proced-sort)
d74d0c42
RW
1655 proced-sort))
1656 (grammar (assq key proced-grammar-alist)))
b4f671ce 1657 (concat " by " (if proced-descend "-" "+")
d74d0c42
RW
1658 (nth 1 grammar)))
1659 "")))
61548252 1660 (force-mode-line-update)
3ac09bb4
RW
1661 ;; run `proced-post-display-hook' only for a displayed buffer.
1662 (if (get-buffer-window) (run-hooks 'proced-post-display-hook))
61548252 1663 ;; done
37e4d8ed 1664 (or quiet (input-pending-p)
d74d0c42
RW
1665 (message (if revert "Updating process information...done."
1666 "Updating process display...done.")))))
37e4d8ed
RW
1667
1668(defun proced-revert (&rest args)
4ed46aef
RW
1669 "Reevaluate the process listing based on the currently running processes.
1670Preserves point and marks."
d74d0c42 1671 (proced-update t))
37e4d8ed 1672
37e4d8ed
RW
1673(defun proced-send-signal (&optional signal)
1674 "Send a SIGNAL to the marked processes.
9f583d14 1675If no process is marked, operate on current process.
37e4d8ed 1676SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
3ac09bb4
RW
1677If SIGNAL is nil display marked processes and query interactively for SIGNAL.
1678After sending the signal, this command runs the normal hook
1679`proced-after-send-signal-hook'."
37e4d8ed 1680 (interactive)
d74d0c42
RW
1681 (let ((regexp (proced-marker-regexp))
1682 process-alist)
37e4d8ed
RW
1683 ;; collect marked processes
1684 (save-excursion
1685 (goto-char (point-min))
1686 (while (re-search-forward regexp nil t)
d74d0c42
RW
1687 (push (cons (proced-pid-at-point)
1688 ;; How much info should we collect here?
3ac09bb4
RW
1689 (buffer-substring-no-properties
1690 (+ 2 (line-beginning-position))
1691 (line-end-position)))
d74d0c42
RW
1692 process-alist)))
1693 (setq process-alist
1694 (if process-alist
1695 (nreverse process-alist)
9f583d14 1696 ;; take current process
d74d0c42
RW
1697 (list (cons (proced-pid-at-point)
1698 (buffer-substring-no-properties
1699 (+ 2 (line-beginning-position))
1700 (line-end-position))))))
9f583d14
RW
1701 (unless signal
1702 ;; Display marked processes (code taken from `dired-mark-pop-up').
1703 (let ((bufname " *Marked Processes*")
d74d0c42 1704 (header-line (substring-no-properties proced-header-line)))
9f583d14
RW
1705 (with-current-buffer (get-buffer-create bufname)
1706 (setq truncate-lines t
d74d0c42 1707 proced-header-line header-line ; inherit header line
9f583d14
RW
1708 header-line-format '(:eval (proced-header-line)))
1709 (add-hook 'post-command-hook 'force-mode-line-update nil t)
1710 (erase-buffer)
d74d0c42 1711 (dolist (process process-alist)
9f583d14
RW
1712 (insert " " (cdr process) "\n"))
1713 (save-window-excursion
3ac09bb4
RW
1714 (pop-to-buffer (current-buffer))
1715 (fit-window-to-buffer (get-buffer-window) nil 1)
9f583d14 1716 (let* ((completion-ignore-case t)
d74d0c42 1717 (pnum (if (= 1 (length process-alist))
9f583d14 1718 "1 process"
d74d0c42
RW
1719 (format "%d processes" (length process-alist))))
1720 ;; The following is an ugly hack. Is there a better way
9f583d14
RW
1721 ;; to help people like me to remember the signals and
1722 ;; their meanings?
1723 (tmp (completing-read (concat "Send signal [" pnum
1724 "] (default TERM): ")
1725 proced-signal-list
1726 nil nil nil nil "TERM")))
1727 (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
1728 (match-string 1 tmp) tmp))))))
1729 ;; send signal
1730 (let ((count 0)
1731 failures)
1732 ;; Why not always use `signal-process'? See
1733 ;; http://lists.gnu.org/archive/html/emacs-devel/2008-03/msg02955.html
1734 (if (functionp proced-signal-function)
1735 ;; use built-in `signal-process'
1736 (let ((signal (if (stringp signal)
1737 (if (string-match "\\`[0-9]+\\'" signal)
1738 (string-to-number signal)
1739 (make-symbol signal))
d74d0c42
RW
1740 signal))) ; number
1741 (dolist (process process-alist)
9f583d14
RW
1742 (condition-case err
1743 (if (zerop (funcall
d74d0c42 1744 proced-signal-function (car process) signal))
9f583d14
RW
1745 (setq count (1+ count))
1746 (proced-log "%s\n" (cdr process))
1747 (push (cdr process) failures))
3ac09bb4 1748 (error ; catch errors from failed signals
9f583d14
RW
1749 (proced-log "%s\n" err)
1750 (proced-log "%s\n" (cdr process))
1751 (push (cdr process) failures)))))
1752 ;; use external system call
1753 (let ((signal (concat "-" (if (numberp signal)
1754 (number-to-string signal) signal))))
d74d0c42 1755 (dolist (process process-alist)
9f583d14
RW
1756 (with-temp-buffer
1757 (condition-case err
1758 (if (zerop (call-process
1759 proced-signal-function nil t nil
d74d0c42 1760 signal (number-to-string (car process))))
9f583d14
RW
1761 (setq count (1+ count))
1762 (proced-log (current-buffer))
1763 (proced-log "%s\n" (cdr process))
1764 (push (cdr process) failures))
3ac09bb4 1765 (error ; catch errors from failed signals
9f583d14
RW
1766 (proced-log (current-buffer))
1767 (proced-log "%s\n" (cdr process))
1768 (push (cdr process) failures)))))))
1769 (if failures
d74d0c42
RW
1770 ;; Proced error message are not always very precise.
1771 ;; Can we issue a useful one-line summary in the
1772 ;; message area (using FAILURES) if only one signal failed?
9f583d14
RW
1773 (proced-log-summary
1774 signal
1775 (format "%d of %d signal%s failed"
d74d0c42
RW
1776 (length failures) (length process-alist)
1777 (if (= 1 (length process-alist)) "" "s")))
9f583d14
RW
1778 (proced-success-message "Sent signal to" count)))
1779 ;; final clean-up
1780 (run-hooks 'proced-after-send-signal-hook))))
1781
d74d0c42 1782;; similar to `dired-why'
9f583d14
RW
1783(defun proced-why ()
1784 "Pop up a buffer with error log output from Proced.
1785A group of errors from a single command ends with a formfeed.
1786Thus, use \\[backward-page] to find the beginning of a group of errors."
1787 (interactive)
1788 (if (get-buffer proced-log-buffer)
d74d0c42
RW
1789 (save-selected-window
1790 ;; move `proced-log-buffer' to the front of the buffer list
1791 (select-window (display-buffer (get-buffer proced-log-buffer)))
1792 (setq truncate-lines t)
1793 (set-buffer-modified-p nil)
1794 (setq buffer-read-only t)
1795 (goto-char (point-max))
1796 (forward-line -1)
1797 (backward-page 1)
1798 (recenter 0))))
9f583d14
RW
1799
1800;; similar to `dired-log'
1801(defun proced-log (log &rest args)
1802 "Log a message or the contents of a buffer.
1803If LOG is a string and there are more args, it is formatted with
1804those ARGS. Usually the LOG string ends with a \\n.
1805End each bunch of errors with (proced-log t signal):
1806this inserts the current time, buffer and signal at the start of the page,
1807and \f (formfeed) at the end."
1808 (let ((obuf (current-buffer)))
1809 (with-current-buffer (get-buffer-create proced-log-buffer)
1810 (goto-char (point-max))
d74d0c42 1811 (let (buffer-read-only)
9f583d14
RW
1812 (cond ((stringp log)
1813 (insert (if args
1814 (apply 'format log args)
1815 log)))
1816 ((bufferp log)
1817 (insert-buffer-substring log))
1818 ((eq t log)
1819 (backward-page 1)
1820 (unless (bolp)
1821 (insert "\n"))
1822 (insert (current-time-string)
1823 "\tBuffer `" (buffer-name obuf) "', "
1824 (format "signal `%s'\n" (car args)))
1825 (goto-char (point-max))
1826 (insert "\f\n")))))))
1827
1828;; similar to `dired-log-summary'
1829(defun proced-log-summary (signal string)
1830 "State a summary of SIGNAL's failures, in echo area and log buffer.
1831STRING is an overall summary of the failures."
1832 (message "Signal %s: %s--type ? for details" signal string)
1833 ;; Log a summary describing a bunch of errors.
1834 (proced-log (concat "\n" string "\n"))
1835 (proced-log t signal))
37e4d8ed
RW
1836
1837(defun proced-help ()
d0482e4e 1838 "Provide help for the Proced user."
37e4d8ed 1839 (interactive)
9f583d14 1840 (proced-why)
37e4d8ed
RW
1841 (if (eq last-command 'proced-help)
1842 (describe-mode)
1843 (message proced-help-string)))
1844
1845(defun proced-undo ()
d0482e4e
JB
1846 "Undo in a Proced buffer.
1847This doesn't recover killed processes, it just undoes changes in the Proced
37e4d8ed
RW
1848buffer. You can use it to recover marks."
1849 (interactive)
1850 (let (buffer-read-only)
1851 (undo))
92d9ce48 1852 (message "Change in Proced buffer undone.
37e4d8ed
RW
1853Killed processes cannot be recovered by Emacs."))
1854
1855(provide 'proced)
1856
dfab9988 1857;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
9f583d14 1858;;; proced.el ends here