lisp/proced.el

   1 ;;; proced.el --- operate on system processes like dired
   2
   3 ;; Copyright (C) 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
   6 ;; Keywords: Processes, Unix
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  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.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Proced makes an Emacs buffer containing a listing of the current system
  26 ;; processes (using ps(1)).  You can use the normal Emacs commands
  27 ;; to move around in this buffer, and special Proced commands to operate
  28 ;; on the processes listed.
  29 ;;
  30 ;; To do:
  31 ;; - decompose ps(1) output into columns (for `proced-header-alist')
  32 ;;   How can we identify columns that may contain whitespace
  33 ;;   and that can be either right or left justified?
  34 ;;   Use a "grammar table"?
  35 ;; - sort the "cooked" values used in the output format fields
  36 ;;   if ps(1) doesn't support the requested sorting scheme
  37 ;; - filter by user name or other criteria
  38 ;; - automatic update of process list
  39
  40 ;;; Code:
  41
  42 (defgroup proced nil
  43   "Proced mode."
  44   :group 'processes
  45   :group 'unix
  46   :prefix "proced-")
  47
  48 ;; FIXME: a better approach instead of PID-COLUMN would be based
  49 ;; on `proced-header-alist' once we have a reliable scheme to set this variable
  50 (defcustom proced-command-alist
  51   (cond ((memq system-type '(berkeley-unix))
  52          '(("user" ("ps" "-uxgww") 2)
  53            ("user-running" ("ps" "-uxrgww") 2)
  54            ("all" ("ps" "-auxgww") 2)
  55            ("all-running" ("ps" "-auxrgww") 2)))
  56         ((memq system-type '(gnu gnu/linux)) ; BSD syntax
  57          `(("user" ("ps" "uxwww") 2)
  58            ("user-running" ("ps" "uxrwww") 2)
  59            ("all" ("ps" "auxwww") 2)
  60            ("all-running" ("ps" "auxrwww") 2)
  61            ("emacs" ("ps" "--pid" ,(number-to-string (emacs-pid))
  62                      "--ppid" ,(number-to-string (emacs-pid))
  63                       "uwww") 2)))
  64         ((memq system-type '(darwin))
  65          `(("user" ("ps" "-u" ,(number-to-string (user-uid))) 2)
  66            ("all" ("ps" "-Au") 2)))
  67         (t ; standard UNIX syntax; doesn't allow to list running processes only
  68          `(("user" ("ps" "-fu" ,(number-to-string (user-uid))) 2)
  69            ("all" ("ps" "-ef") 2))))
  70   "Alist of commands to get list of processes.
  71 Each element has the form (NAME COMMAND PID-COLUMN).
  72 NAME is a shorthand name to select the type of listing.
  73 COMMAND is a list (COMMAND-NAME ARG1 ARG2 ...),
  74 where COMMAND-NAME is the command to generate the listing (usually \"ps\").
  75 ARG1, ARG2, ... are arguments passed to COMMAND-NAME to generate
  76 a particular listing.  These arguments differ under various operating systems.
  77 PID-COLUMN is the column number (starting from 1) of the process ID."
  78   :group 'proced
  79   :type '(repeat (group (string :tag "name")
  80                         (cons (string :tag "command")
  81                               (repeat (string :tag "option")))
  82                         (integer :tag "PID column"))))
  83
  84 (defcustom proced-command (if (zerop (user-real-uid)) "all" "user")
  85   "Name of process listing.
  86 Must be the car of an element of `proced-command-alist'."
  87   :group 'proced
  88   :type '(string :tag "name"))
  89 (make-variable-buffer-local 'proced-command)
  90
  91 ;; Should we incorporate in NAME that sorting can be done in ascending
  92 ;; or descending order?  Then we couldn't associate NAME anymore with one
  93 ;; of the headers in the output of ps(1).
  94 ;; FIXME: A sorting scheme without options or with an option being a symbol
  95 ;; should be implemented in elisp
  96 (defcustom proced-sorting-schemes-alist
  97   (cond ((memq system-type '(gnu gnu/linux)) ; GNU long options
  98          '(("%CPU" "--sort" "-pcpu") ; descending order
  99            ("%MEM" "--sort" "-pmem") ; descending order
 100            ("COMMAND" "--sort" "args")
 101            ("PID" "--sort" "pid")
 102            ("PGID,PID" "--sort" "pgid,pid")
 103            ("PPID,PID" "--sort" "ppid,pid")
 104            ("RSS" "--sort" "rss,pid") ; equal RSS's are rare
 105            ("STAT,PID" "--sort" "stat,pid")
 106            ("START" "--sort" "start_time")
 107            ("TIME" "--sort" "cputime")
 108            ("TTY,PID" "--sort" "tty,pid")
 109            ("UID,PID" "--sort" "uid,pid")
 110            ("USER,PID" "--sort" "user,pid")
 111            ("VSZ,PID" "--sort" "vsz,pid"))))
 112   "Alist of sorting schemes.
 113 Each element is a list (NAME OPTION1 OPTION2 ...).
 114 NAME denotes the sorting scheme.  It is the name of a header or a
 115 comma-separated sequence of headers in the output of ps(1).
 116 OPTION1, OPTION2, ... are options defining the sorting scheme."
 117   :group 'proced
 118   :type '(repeat (cons (string :tag "name")
 119                        (repeat (string :tag "option")))))
 120
 121 (defcustom proced-sorting-scheme nil
 122   "Proced sorting type.
 123 Must be the car of an element of `proced-sorting-schemes-alist' or nil."
 124   :group 'proced
 125   :type `(choice ,@(append '((const nil)) ; sorting type may be nil
 126                            (mapcar (lambda (item)
 127                                      (list 'const (car item)))
 128                                    proced-sorting-schemes-alist))))
 129 (make-variable-buffer-local 'proced-sorting-scheme)
 130
 131 (defcustom proced-goal-header-re "\\b\\(CMD\\|COMMAND\\)\\b"
 132   "If non-nil, regexp that defines the `proced-goal-column'."
 133   :group 'proced
 134   :type '(choice (const :tag "none" nil)
 135                  (regexp :tag "regexp")))
 136
 137 (defcustom proced-signal-function 'signal-process
 138   "Name of signal function.
 139 It can be an elisp function (usually `signal-process') or a string specifying
 140 the external command (usually \"kill\")."
 141   :group 'proced
 142   :type '(choice (function :tag "function")
 143                  (string :tag "command")))
 144
 145 (defcustom proced-signal-list
 146   '(("HUP   (1.  Hangup)")
 147     ("INT   (2.  Terminal interrupt)")
 148     ("QUIT  (3.  Terminal quit)")
 149     ("ABRT  (6.  Process abort)")
 150     ("KILL  (9.  Kill -- cannot be caught or ignored)")
 151     ("ALRM  (14. Alarm Clock)")
 152     ("TERM  (15. Termination)"))
 153   "List of signals, used for minibuffer completion."
 154   :group 'proced
 155   :type '(repeat (string :tag "signal")))
 156
 157 ;; Internal variables
 158 (defvar proced-marker-char ?*           ; the answer is 42
 159   "In proced, the current mark character.")
 160
 161 ;; face and font-lock code taken from dired
 162 (defgroup proced-faces nil
 163   "Faces used by Proced."
 164   :group 'proced
 165   :group 'faces)
 166
 167 (defface proced-mark
 168   '((t (:inherit font-lock-constant-face)))
 169   "Face used for proced marks."
 170   :group 'proced-faces)
 171 (defvar proced-mark-face 'proced-mark
 172   "Face name used for proced marks.")
 173
 174 (defface proced-marked
 175   '((t (:inherit font-lock-warning-face)))
 176   "Face used for marked processes."
 177   :group 'proced-faces)
 178 (defvar proced-marked-face 'proced-marked
 179   "Face name used for marked processes.")
 180
 181 (defvar proced-re-mark "^[^ \n]"
 182   "Regexp matching a marked line.
 183 Important: the match ends just after the marker.")
 184
 185 (defvar proced-goal-column nil
 186   "Proced goal column.  Initialized based on `proced-goal-header-re'.")
 187 (make-variable-buffer-local 'proced-goal-column)
 188
 189 (defvar proced-font-lock-keywords
 190   (list
 191    ;;
 192    ;; Proced marks.
 193    (list proced-re-mark '(0 proced-mark-face))
 194    ;;
 195    ;; Marked files.
 196    (list (concat "^[" (char-to-string proced-marker-char) "]")
 197          '(".+" (proced-move-to-goal-column) nil (0 proced-marked-face)))))
 198
 199 (defvar proced-mode-map
 200   (let ((km (make-sparse-keymap)))
 201     ;; moving
 202     (define-key km " " 'proced-next-line)
 203     (define-key km "n" 'proced-next-line)
 204     (define-key km "p" 'proced-previous-line)
 205     (define-key km "\C-n" 'proced-next-line)
 206     (define-key km "\C-p" 'proced-previous-line)
 207     (define-key km "\C-?" 'proced-previous-line)
 208     (define-key km [down] 'proced-next-line)
 209     (define-key km [up] 'proced-previous-line)
 210     ;; marking
 211     (define-key km "d" 'proced-mark) ; Dired compatibility
 212     (define-key km "m" 'proced-mark)
 213     (define-key km "u" 'proced-unmark)
 214     (define-key km "\177" 'proced-unmark-backward)
 215     (define-key km "M" 'proced-mark-all)
 216     (define-key km "U" 'proced-unmark-all)
 217     (define-key km "t" 'proced-toggle-marks)
 218     ;; sorting
 219     (define-key km "sc" 'proced-sort-pcpu)
 220     (define-key km "sm" 'proced-sort-pmem)
 221     (define-key km "sp" 'proced-sort-pid)
 222     (define-key km "ss" 'proced-sort-start)
 223     (define-key km "sS" 'proced-sort)
 224     (define-key km "st" 'proced-sort-time)
 225     ;; operate
 226     (define-key km "h" 'proced-hide-processes)
 227     (define-key km "x" 'proced-send-signal) ; Dired compatibility
 228     (define-key km "k" 'proced-send-signal) ; kill processes
 229     ;; misc
 230     (define-key km "l" 'proced-listing-type)
 231     (define-key km "g" 'revert-buffer) ; Dired compatibility
 232     (define-key km "h" 'describe-mode)
 233     (define-key km "?" 'proced-help)
 234     (define-key km "q" 'quit-window)
 235     (define-key km [remap undo] 'proced-undo)
 236     (define-key km [remap advertised-undo] 'proced-undo)
 237     km)
 238   "Keymap for proced commands")
 239
 240 (easy-menu-define
 241   proced-menu proced-mode-map "Proced Menu"
 242   '("Proced"
 243     ["Mark" proced-mark t]
 244     ["Unmark" proced-unmark t]
 245     ["Mark All" proced-mark-all t]
 246     ["Unmark All" proced-unmark-all t]
 247     ["Toggle Marks" proced-unmark-all t]
 248     "--"
 249     ["Sort" proced-sort t]
 250     ["Sort by %CPU" proced-sort-pcpu (proced-sorting-scheme-p "%CPU")]
 251     ["Sort by %MEM" proced-sort-pmem (proced-sorting-scheme-p "%MEM")]
 252     ["Sort by PID" proced-sort-pid (proced-sorting-scheme-p "PID")]
 253     ["Sort by START" proced-sort-start (proced-sorting-scheme-p "START")]
 254     ["Sort by TIME" proced-sort-time (proced-sorting-scheme-p "TIME")]
 255     "--"
 256     ["Hide Marked Processes" proced-hide-processes t]
 257     "--"
 258     ["Revert" revert-buffer t]
 259     ["Send signal" proced-send-signal t]
 260     ["Change listing" proced-listing-type t]))
 261
 262 (defconst proced-help-string
 263   "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit  (type ? for more help)"
 264   "Help string for proced.")
 265
 266 (defvar proced-header-line nil
 267   "Headers in Proced buffer as a string.")
 268 (make-variable-buffer-local 'proced-header-line)
 269
 270 (defvar proced-header-alist nil
 271   "Alist of headers in Proced buffer.
 272 Each element is of the form (NAME START END JUSTIFY).
 273 NAME is name of header in the output of ps(1).
 274 START and END are column numbers starting from 0.
 275 END is t if there is no end column for that field.
 276 JUSTIFY is 'left or 'right for left or right-justified output of ps(1).")
 277 (make-variable-buffer-local 'proced-header-alist)
 278
 279 (defvar proced-sorting-schemes-re nil
 280   "Regexp to match valid sorting schemes.")
 281 (make-variable-buffer-local 'proced-sorting-schemes-re)
 282
 283 ;; helper functions
 284 (defun proced-marker-regexp ()
 285   "Return regexp matching `proced-marker-char'."
 286   ;; `proced-marker-char' must appear in column zero
 287   (concat "^" (regexp-quote (char-to-string proced-marker-char))))
 288
 289 (defun proced-success-message (action count)
 290   "Display success message for ACTION performed for COUNT processes."
 291   (message "%s %s process%s" action count (if (= 1 count) "" "es")))
 292
 293 (defun proced-move-to-goal-column ()
 294   "Move to `proced-goal-column' if non-nil."
 295   (beginning-of-line)
 296   (if proced-goal-column
 297       (forward-char proced-goal-column)
 298     (forward-char 2)))
 299
 300 ;; FIXME: a better approach would be based on `proced-header-alist'
 301 ;; once we have a reliable scheme to set this variable
 302 (defsubst proced-skip-regexp ()
 303   "Regexp to skip in process listing to find PID column."
 304   (apply 'concat (make-list (1- (nth 2 (assoc proced-command
 305                                               proced-command-alist)))
 306                             "\\s-+\\S-+")))
 307
 308 (define-derived-mode proced-mode nil "Proced"
 309   "Mode for displaying UNIX system processes and sending signals to them.
 310 Type \\[proced-mark-process] to mark a process for later commands.
 311 Type \\[proced-send-signal] to send signals to marked processes.
 312
 313 \\{proced-mode-map}"
 314   (abbrev-mode 0)
 315   (auto-fill-mode 0)
 316   (setq buffer-read-only t
 317         truncate-lines t
 318         header-line-format '(:eval (proced-header-line)))
 319   (add-hook 'post-command-hook 'force-mode-line-update nil t)
 320   (set (make-local-variable 'revert-buffer-function) 'proced-revert)
 321   (set (make-local-variable 'font-lock-defaults)
 322        '(proced-font-lock-keywords t nil nil beginning-of-line)))
 323
 324 ;; Proced mode is suitable only for specially formatted data.
 325 (put 'proced-mode 'mode-class 'special)
 326
 327 ;;;###autoload
 328 (defun proced (&optional arg)
 329   "Mode for displaying UNIX system processes and sending signals to them.
 330 Type \\[proced-mark-process] to mark a process for later commands.
 331 Type \\[proced-send-signal] to send signals to marked processes.
 332
 333 If invoked with optional ARG the window displaying the process
 334 information will be displayed but not selected.
 335
 336 \\{proced-mode-map}"
 337   (interactive "P")
 338   (let ((buffer (get-buffer-create "*Proced*")) new)
 339     (set-buffer buffer)
 340     (setq new (zerop (buffer-size)))
 341     (if new (proced-mode))
 342
 343     (if (or new arg)
 344         (proced-update))
 345
 346     (if arg
 347         (display-buffer buffer)
 348       (pop-to-buffer buffer)
 349       (message (substitute-command-keys
 350                 "type \\[quit-window] to quit, \\[proced-help] for help")))))
 351
 352 (defun proced-next-line (arg)
 353   "Move down lines then position at `proced-goal-column'.
 354 Optional prefix ARG says how many lines to move; default is one line."
 355   (interactive "p")
 356   (next-line arg)
 357   (proced-move-to-goal-column))
 358
 359 (defun proced-previous-line (arg)
 360   "Move up lines then position at `proced-goal-column'.
 361 Optional prefix ARG says how many lines to move; default is one line."
 362   (interactive "p")
 363   (previous-line arg)
 364   (proced-move-to-goal-column))
 365
 366 (defun proced-mark (&optional count)
 367   "Mark the current (or next COUNT) processes."
 368   (interactive "p")
 369   (proced-do-mark t count))
 370
 371 (defun proced-unmark (&optional count)
 372   "Unmark the current (or next COUNT) processes."
 373   (interactive "p")
 374   (proced-do-mark nil count))
 375
 376 (defun proced-unmark-backward (&optional count)
 377   "Unmark the previous (or COUNT previous) processes."
 378   ;; Analogous to `dired-unmark-backward',
 379   ;; but `ibuffer-unmark-backward' behaves different.
 380   (interactive "p")
 381   (proced-do-mark nil (- (or count 1))))
 382
 383 (defun proced-do-mark (mark &optional count)
 384   "Mark the current (or next ARG) processes using MARK."
 385   (or count (setq count 1))
 386   (let ((backward (< count 0))
 387         buffer-read-only)
 388     (setq count (1+ (if (<= 0 count) count
 389                       (min (1- (line-number-at-pos)) (abs count)))))
 390     (beginning-of-line)
 391     (while (not (or (zerop (setq count (1- count))) (eobp)))
 392       (proced-insert-mark mark backward))
 393     (proced-move-to-goal-column)))
 394
 395 (defun proced-mark-all ()
 396   "Mark all processes."
 397   (interactive)
 398   (proced-do-mark-all t))
 399
 400 (defun proced-unmark-all ()
 401   "Unmark all processes."
 402   (interactive)
 403   (proced-do-mark-all nil))
 404
 405 (defun proced-do-mark-all (mark)
 406   "Mark all processes using MARK."
 407   (let (buffer-read-only)
 408     (save-excursion
 409       (goto-char (point-min))
 410       (while (not (eobp))
 411         (proced-insert-mark mark)))))
 412
 413 (defun proced-toggle-marks ()
 414   "Toggle marks: marked processes become unmarked, and vice versa."
 415   (interactive)
 416   (let ((mark-re (proced-marker-regexp))
 417         buffer-read-only)
 418     (save-excursion
 419       (goto-char (point-min))
 420       (while (not (eobp))
 421         (cond ((looking-at mark-re)
 422                (proced-insert-mark nil))
 423               ((looking-at " ")
 424                (proced-insert-mark t))
 425               (t
 426                (forward-line 1)))))))
 427
 428 (defun proced-insert-mark (mark &optional backward)
 429   "If MARK is non-nil, insert `proced-marker-char'.
 430 If BACKWARD is non-nil, move one line backwards before inserting the mark.
 431 Otherwise move one line forward after inserting the mark."
 432   (if backward (forward-line -1))
 433   (insert (if mark proced-marker-char ?\s))
 434   (delete-char 1)
 435   (unless backward (forward-line)))
 436
 437 ;; Mostly analog of `dired-do-kill-lines'.
 438 ;; However, for negative args the target lines of `dired-do-kill-lines'
 439 ;; include the current line, whereas `dired-mark' for negative args operates
 440 ;; on the preceding lines. Here we are consistent with `dired-mark'.
 441 (defun proced-hide-processes (&optional arg quiet)
 442   "Hide marked processes.
 443 With prefix ARG, hide that many lines starting with the current line.
 444 \(A negative argument hides backward.)
 445 If QUIET is non-nil suppress status message.
 446 Returns count of hidden lines."
 447   (interactive "P")
 448   (let ((mark-re (proced-marker-regexp))
 449         (count 0)
 450         buffer-read-only)
 451     (save-excursion
 452       (if arg
 453           ;; Hide ARG lines starting with the current line.
 454           (delete-region (line-beginning-position)
 455                          (save-excursion
 456                            (if (<= 0 arg)
 457                                (setq count (- arg (forward-line arg)))
 458                              (setq count (min (1- (line-number-at-pos))
 459                                               (abs arg)))
 460                              (forward-line (- count)))
 461                            (point)))
 462         ;; Hide marked lines
 463         (while (and (not (eobp))
 464                     (re-search-forward mark-re nil t))
 465           (delete-region (match-beginning 0)
 466                          (save-excursion (forward-line) (point)))
 467           (setq count (1+ count)))))
 468     (unless (zerop count) (proced-move-to-goal-column))
 469     (unless quiet (proced-success-message "Hid" count))
 470     count))
 471
 472 (defun proced-listing-type (command)
 473   "Select `proced' listing type COMMAND from `proced-command-alist'."
 474   (interactive
 475    (list (completing-read "Listing type: " proced-command-alist nil t)))
 476   (setq proced-command command)
 477   (proced-update))
 478
 479 ;; adopted from `ruler-mode-space'
 480 (defsubst proced-header-space (width)
 481   "Return a single space string of WIDTH times the normal character width."
 482   (propertize " " 'display (list 'space :width width)))
 483
 484 ;; header line: code inspired by `ruler-mode-ruler'
 485 (defun proced-header-line ()
 486   "Return header line for Proced buffer."
 487   (list "" (if (eq 'left (car (window-current-scroll-bars)))
 488                (proced-header-space 'scroll-bar))
 489         (proced-header-space 'left-fringe)
 490         (proced-header-space 'left-margin)
 491         (replace-regexp-in-string
 492          "%" "%%" (substring proced-header-line (window-hscroll)))))
 493
 494 (defun proced-update (&optional quiet)
 495   "Update the `proced' process information.  Preserves point and marks."
 496   ;; This is the main function that generates and updates the process listing.
 497   (interactive)
 498   (or quiet (message "Updating process information..."))
 499   (let* ((command (cadr (assoc proced-command proced-command-alist)))
 500          (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)"))
 501          (old-pos (if (save-excursion
 502                         (beginning-of-line)
 503                         (looking-at (concat "^[* ]" regexp)))
 504                       (cons (match-string-no-properties 1)
 505                             (current-column))))
 506          buffer-read-only mp-list)
 507     (goto-char (point-min))
 508     ;; remember marked processes (whatever the mark was)
 509     (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t)
 510       (push (cons (match-string-no-properties 2)
 511                   (match-string-no-properties 1)) mp-list))
 512     ;; generate new listing
 513     (erase-buffer)
 514     (apply 'call-process (car command) nil t nil
 515            (append (cdr command) (cdr (assoc proced-sorting-scheme
 516                                              proced-sorting-schemes-alist))))
 517     (goto-char (point-min))
 518     (while (not (eobp))
 519       (insert "  ")
 520       (forward-line))
 521     ;; (delete-trailing-whitespace)
 522     (goto-char (point-min))
 523     (while (re-search-forward "[ \t\r]+$" nil t)
 524       (delete-region (match-beginning 0) (match-end 0)))
 525     (goto-char (point-min))
 526     (let ((lep (line-end-position)))
 527       (setq proced-header-line (buffer-substring-no-properties (point) lep))
 528       (setq proced-header-alist nil)
 529       ;; FIXME: handle left/right justification properly
 530       (while (re-search-forward "\\([^ \t\n]+\\)[ \t]*\\($\\)?" lep t)
 531         (push (list (match-string-no-properties 1)
 532                     ;; take the column number starting from zero
 533                     (1- (match-beginning 0)) (or (not (not (match-beginning 2)))
 534                                                  (1- (match-end 0)))
 535                     'left)
 536               proced-header-alist)))
 537     (let ((temp (regexp-opt (mapcar 'car proced-header-alist) t)))
 538       (setq proced-sorting-schemes-re
 539             (concat "\\`" temp "\\(," temp "\\)*\\'")))
 540     ;; remove header line from ps(1) output
 541     (goto-char (point-min))
 542     (delete-region (point)
 543                    (save-excursion (forward-line) (point)))
 544     (set-buffer-modified-p nil)
 545     ;; set `proced-goal-column'
 546     (if proced-goal-header-re
 547         (let ((hlist proced-header-alist) header)
 548           (while (setq header (pop hlist))
 549             (if (string-match proced-goal-header-re (car header))
 550                 (setq proced-goal-column
 551                       (if (eq 'left (nth 3 header))
 552                           (nth 1 header) (nth 2 header))
 553                       hlist nil)))))
 554     ;; restore process marks
 555     (if mp-list
 556         (save-excursion
 557           (goto-char (point-min))
 558           (let (mark)
 559             (while (re-search-forward (concat "^" regexp) nil t)
 560               (if (setq mark (assoc (match-string-no-properties 1) mp-list))
 561                   (save-excursion
 562                     (beginning-of-line)
 563                     (insert (cdr mark))
 564                     (delete-char 1)))))))
 565     ;; restore buffer position (if possible)
 566     (goto-char (point-min))
 567     (if (and old-pos
 568              (re-search-forward
 569               (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>")
 570               nil t))
 571         (progn
 572           (beginning-of-line)
 573           (forward-char (cdr old-pos)))
 574       (proced-move-to-goal-column))
 575     ;; update modeline
 576     ;; Does the long mode-name clutter the modeline?
 577     (setq mode-name (concat "Proced: " proced-command
 578                             (if proced-sorting-scheme
 579                                 (concat " by " proced-sorting-scheme)
 580                               "")))
 581     (force-mode-line-update)
 582     ;; done
 583     (or quiet (input-pending-p)
 584         (message "Updating process information...done."))))
 585
 586 (defun proced-revert (&rest args)
 587   "Analog of `revert-buffer'."
 588   (proced-update))
 589
 590 ;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
 591 ;; and move it to window.el so that proced and ibuffer can easily use it, too?
 592 ;; What about functions like `appt-disp-window' that use
 593 ;; `shrink-window-if-larger-than-buffer'?
 594 (autoload 'dired-pop-to-buffer "dired")
 595
 596 (defun proced-send-signal (&optional signal)
 597   "Send a SIGNAL to the marked processes.
 598 SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
 599 If SIGNAL is nil display marked processes and query interactively for SIGNAL."
 600   (interactive)
 601   (let ((regexp (concat (proced-marker-regexp)
 602                         (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$"))
 603         process-list)
 604     ;; collect marked processes
 605     (save-excursion
 606       (goto-char (point-min))
 607       (while (re-search-forward regexp nil t)
 608         (push (cons (match-string-no-properties 1)
 609                     ;; How much info should we collect here?  Would it be
 610                     ;; better to collect only the PID (to avoid ambiguities)
 611                     ;; and the command name?
 612                     (substring (match-string-no-properties 0) 2))
 613               process-list)))
 614     (setq process-list (nreverse process-list))
 615     (if (not process-list)
 616         (message "No processes marked")
 617       (unless signal
 618         ;; Display marked processes (code taken from `dired-mark-pop-up').
 619         (let ((bufname  " *Marked Processes*")
 620               (header proced-header-line)) ; inherit header line
 621           (with-current-buffer (get-buffer-create bufname)
 622             (setq truncate-lines t
 623                   proced-header-line header
 624                   header-line-format '(:eval (proced-header-line)))
 625             (add-hook 'post-command-hook 'force-mode-line-update nil t)
 626             (erase-buffer)
 627             (dolist (process process-list)
 628               (insert "  " (cdr process) "\n"))
 629             (save-window-excursion
 630               (dired-pop-to-buffer bufname) ; all we need
 631               (let* ((completion-ignore-case t)
 632                      (pnum (if (= 1 (length process-list))
 633                                "1 process"
 634                              (format "%d processes" (length process-list))))
 635                      ;; The following is an ugly hack. Is there a better way
 636                      ;; to help people like me to remember the signals and
 637                      ;; their meanings?
 638                      (tmp (completing-read (concat "Send signal [" pnum
 639                                                    "] (default TERM): ")
 640                                            proced-signal-list
 641                                            nil nil nil nil "TERM")))
 642                 (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
 643                                  (match-string 1 tmp) tmp))))))
 644         ;; send signal
 645         (let ((count 0)
 646               err-list)
 647           (if (functionp proced-signal-function)
 648               ;; use built-in `signal-process'
 649               (let ((signal (if (stringp signal)
 650                                 (if (string-match "\\`[0-9]+\\'" signal)
 651                                     (string-to-number signal)
 652                                   (make-symbol signal))
 653                               signal))) ; number
 654                 (dolist (process process-list)
 655                   (if (zerop (funcall
 656                               proced-signal-function
 657                               (string-to-number (car process)) signal))
 658                       (setq count (1+ count))
 659                     (push (cdr process) err-list))))
 660             ;; use external system call
 661             (let ((signal (concat "-" (if (numberp signal)
 662                                           (number-to-string signal) signal))))
 663               (dolist (process process-list)
 664                 (if (zerop (call-process
 665                             proced-signal-function nil 0 nil
 666                             signal (car process)))
 667                     (setq count (1+ count))
 668                   (push (cdr process) err-list)))))
 669           (if err-list
 670               ;; FIXME: that's not enough to display the errors.
 671               (message "%s: %s" signal err-list)
 672             (proced-success-message "Sent signal to" count)))
 673         ;; final clean-up
 674         (run-hooks 'proced-after-send-signal-hook)))))
 675
 676 (defun proced-help ()
 677   "Provide help for the `proced' user."
 678   (interactive)
 679   (if (eq last-command 'proced-help)
 680       (describe-mode)
 681     (message proced-help-string)))
 682
 683 (defun proced-undo ()
 684   "Undo in a proced buffer.
 685 This doesn't recover killed processes, it just undoes changes in the proced
 686 buffer.  You can use it to recover marks."
 687   (interactive)
 688   (let (buffer-read-only)
 689     (undo))
 690   (message "Change in Proced buffer undone.
 691 Killed processes cannot be recovered by Emacs."))
 692
 693 ;;; Sorting
 694 (defun proced-sort (scheme)
 695   "Sort Proced buffer using SCHEME.
 696 When called interactively, an empty string means nil, i.e., no sorting."
 697   (interactive
 698    (list (let* ((completion-ignore-case t)
 699                 ;; restrict completion list to applicable sorting schemes
 700                 (completion-list
 701                  (apply 'append
 702                         (mapcar (lambda (x)
 703                                   (if (string-match proced-sorting-schemes-re
 704                                                     (car x))
 705                                       (list (car x))))
 706                                 proced-sorting-schemes-alist)))
 707                 (scheme (completing-read "Sorting type: "
 708                                          completion-list nil t)))
 709            (if (string= "" scheme) nil scheme))))
 710   (if (proced-sorting-scheme-p scheme)
 711       (progn
 712         (setq proced-sorting-scheme scheme)
 713         (proced-update))
 714     (error "Proced sorting scheme %s not applicable" scheme)))
 715
 716 (defun proced-sorting-scheme-p (scheme)
 717   "Return non-nil if SCHEME is an applicable sorting scheme.
 718 SCHEME must be a string or nil."
 719   (or (not scheme)
 720       (and (string-match proced-sorting-schemes-re scheme)
 721            (assoc scheme proced-sorting-schemes-alist))))
 722
 723 (defun proced-sort-pcpu ()
 724   "Sort Proced buffer by percentage CPU time (%CPU)."
 725   (interactive)
 726   (proced-sort "%CPU"))
 727
 728 (defun proced-sort-pmem ()
 729   "Sort Proced buffer by percentage memory usage (%MEM)."
 730   (interactive)
 731   (proced-sort "%MEM"))
 732
 733 (defun proced-sort-pid ()
 734   "Sort Proced buffer by PID."
 735   (interactive)
 736   (proced-sort "PID"))
 737
 738 (defun proced-sort-start ()
 739   "Sort Proced buffer by time the command started (START)."
 740   (interactive)
 741   (proced-sort "START"))
 742
 743 (defun proced-sort-time ()
 744   "Sort Proced buffer by cumulative CPU time (TIME)."
 745   (interactive)
 746   (proced-sort "TIME"))
 747
 748 (provide 'proced)
 749
 750 ;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
 751 ;;; proced.el ends here.