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   (forward-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   (forward-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 (propertize " " 'display '(space :align-to 0))
 488         (replace-regexp-in-string
 489          "%" "%%" (substring proced-header-line (window-hscroll)))))
 490
 491 (defun proced-update (&optional quiet)
 492   "Update the `proced' process information.  Preserves point and marks."
 493   ;; This is the main function that generates and updates the process listing.
 494   (interactive)
 495   (or quiet (message "Updating process information..."))
 496   (let* ((command (cadr (assoc proced-command proced-command-alist)))
 497          (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)"))
 498          (old-pos (if (save-excursion
 499                         (beginning-of-line)
 500                         (looking-at (concat "^[* ]" regexp)))
 501                       (cons (match-string-no-properties 1)
 502                             (current-column))))
 503          buffer-read-only mp-list)
 504     (goto-char (point-min))
 505     ;; remember marked processes (whatever the mark was)
 506     (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t)
 507       (push (cons (match-string-no-properties 2)
 508                   (match-string-no-properties 1)) mp-list))
 509     ;; generate new listing
 510     (erase-buffer)
 511     (apply 'call-process (car command) nil t nil
 512            (append (cdr command) (cdr (assoc proced-sorting-scheme
 513                                              proced-sorting-schemes-alist))))
 514     (goto-char (point-min))
 515     (while (not (eobp))
 516       (insert "  ")
 517       (forward-line))
 518     ;; (delete-trailing-whitespace)
 519     (goto-char (point-min))
 520     (while (re-search-forward "[ \t\r]+$" nil t)
 521       (delete-region (match-beginning 0) (match-end 0)))
 522     (goto-char (point-min))
 523     (let ((lep (line-end-position)))
 524       (setq proced-header-line (buffer-substring-no-properties (point) lep))
 525       (setq proced-header-alist nil)
 526       ;; FIXME: handle left/right justification properly
 527       (while (re-search-forward "\\([^ \t\n]+\\)[ \t]*\\($\\)?" lep t)
 528         (push (list (match-string-no-properties 1)
 529                     ;; take the column number starting from zero
 530                     (- (match-beginning 0) (point-min))
 531                     (or (not (not (match-beginning 2)))
 532                         (- (match-end 0) (point-min)))
 533                     'left)
 534               proced-header-alist)))
 535     (let ((temp (regexp-opt (mapcar 'car proced-header-alist) t)))
 536       (setq proced-sorting-schemes-re
 537             (concat "\\`" temp "\\(," temp "\\)*\\'")))
 538     ;; remove header line from ps(1) output
 539     (goto-char (point-min))
 540     (delete-region (point)
 541                    (save-excursion (forward-line) (point)))
 542     (set-buffer-modified-p nil)
 543     ;; set `proced-goal-column'
 544     (if proced-goal-header-re
 545         (let ((hlist proced-header-alist) header)
 546           (while (setq header (pop hlist))
 547             (if (string-match proced-goal-header-re (car header))
 548                 (setq proced-goal-column
 549                       (if (eq 'left (nth 3 header))
 550                           (nth 1 header) (nth 2 header))
 551                       hlist nil)))))
 552     ;; restore process marks
 553     (if mp-list
 554         (save-excursion
 555           (goto-char (point-min))
 556           (let (mark)
 557             (while (re-search-forward (concat "^" regexp) nil t)
 558               (if (setq mark (assoc (match-string-no-properties 1) mp-list))
 559                   (save-excursion
 560                     (beginning-of-line)
 561                     (insert (cdr mark))
 562                     (delete-char 1)))))))
 563     ;; restore buffer position (if possible)
 564     (goto-char (point-min))
 565     (if (and old-pos
 566              (re-search-forward
 567               (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>")
 568               nil t))
 569         (progn
 570           (beginning-of-line)
 571           (forward-char (cdr old-pos)))
 572       (proced-move-to-goal-column))
 573     ;; update modeline
 574     ;; Does the long mode-name clutter the modeline?
 575     (setq mode-name (concat "Proced: " proced-command
 576                             (if proced-sorting-scheme
 577                                 (concat " by " proced-sorting-scheme)
 578                               "")))
 579     (force-mode-line-update)
 580     ;; done
 581     (or quiet (input-pending-p)
 582         (message "Updating process information...done."))))
 583
 584 (defun proced-revert (&rest args)
 585   "Analog of `revert-buffer'."
 586   (proced-update))
 587
 588 ;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
 589 ;; and move it to window.el so that proced and ibuffer can easily use it, too?
 590 ;; What about functions like `appt-disp-window' that use
 591 ;; `shrink-window-if-larger-than-buffer'?
 592 (autoload 'dired-pop-to-buffer "dired")
 593
 594 (defun proced-send-signal (&optional signal)
 595   "Send a SIGNAL to the marked processes.
 596 SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
 597 If SIGNAL is nil display marked processes and query interactively for SIGNAL."
 598   (interactive)
 599   (let ((regexp (concat (proced-marker-regexp)
 600                         (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$"))
 601         process-list)
 602     ;; collect marked processes
 603     (save-excursion
 604       (goto-char (point-min))
 605       (while (re-search-forward regexp nil t)
 606         (push (cons (match-string-no-properties 1)
 607                     ;; How much info should we collect here?  Would it be
 608                     ;; better to collect only the PID (to avoid ambiguities)
 609                     ;; and the command name?
 610                     (substring (match-string-no-properties 0) 2))
 611               process-list)))
 612     (setq process-list (nreverse process-list))
 613     (if (not process-list)
 614         (message "No processes marked")
 615       (unless signal
 616         ;; Display marked processes (code taken from `dired-mark-pop-up').
 617         (let ((bufname  " *Marked Processes*")
 618               (header proced-header-line)) ; inherit header line
 619           (with-current-buffer (get-buffer-create bufname)
 620             (setq truncate-lines t
 621                   proced-header-line header
 622                   header-line-format '(:eval (proced-header-line)))
 623             (add-hook 'post-command-hook 'force-mode-line-update nil t)
 624             (erase-buffer)
 625             (dolist (process process-list)
 626               (insert "  " (cdr process) "\n"))
 627             (save-window-excursion
 628               (dired-pop-to-buffer bufname) ; all we need
 629               (let* ((completion-ignore-case t)
 630                      (pnum (if (= 1 (length process-list))
 631                                "1 process"
 632                              (format "%d processes" (length process-list))))
 633                      ;; The following is an ugly hack. Is there a better way
 634                      ;; to help people like me to remember the signals and
 635                      ;; their meanings?
 636                      (tmp (completing-read (concat "Send signal [" pnum
 637                                                    "] (default TERM): ")
 638                                            proced-signal-list
 639                                            nil nil nil nil "TERM")))
 640                 (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
 641                                  (match-string 1 tmp) tmp))))))
 642         ;; send signal
 643         (let ((count 0)
 644               err-list)
 645           (if (functionp proced-signal-function)
 646               ;; use built-in `signal-process'
 647               (let ((signal (if (stringp signal)
 648                                 (if (string-match "\\`[0-9]+\\'" signal)
 649                                     (string-to-number signal)
 650                                   (make-symbol signal))
 651                               signal))) ; number
 652                 (dolist (process process-list)
 653                   (if (zerop (funcall
 654                               proced-signal-function
 655                               (string-to-number (car process)) signal))
 656                       (setq count (1+ count))
 657                     (push (cdr process) err-list))))
 658             ;; use external system call
 659             (let ((signal (concat "-" (if (numberp signal)
 660                                           (number-to-string signal) signal))))
 661               (dolist (process process-list)
 662                 (if (zerop (call-process
 663                             proced-signal-function nil 0 nil
 664                             signal (car process)))
 665                     (setq count (1+ count))
 666                   (push (cdr process) err-list)))))
 667           (if err-list
 668               ;; FIXME: that's not enough to display the errors.
 669               (message "%s: %s" signal err-list)
 670             (proced-success-message "Sent signal to" count)))
 671         ;; final clean-up
 672         (run-hooks 'proced-after-send-signal-hook)))))
 673
 674 (defun proced-help ()
 675   "Provide help for the `proced' user."
 676   (interactive)
 677   (if (eq last-command 'proced-help)
 678       (describe-mode)
 679     (message proced-help-string)))
 680
 681 (defun proced-undo ()
 682   "Undo in a proced buffer.
 683 This doesn't recover killed processes, it just undoes changes in the proced
 684 buffer.  You can use it to recover marks."
 685   (interactive)
 686   (let (buffer-read-only)
 687     (undo))
 688   (message "Change in Proced buffer undone.
 689 Killed processes cannot be recovered by Emacs."))
 690
 691 ;;; Sorting
 692 (defun proced-sort (scheme)
 693   "Sort Proced buffer using SCHEME.
 694 When called interactively, an empty string means nil, i.e., no sorting."
 695   (interactive
 696    (list (let* ((completion-ignore-case t)
 697                 ;; restrict completion list to applicable sorting schemes
 698                 (completion-list
 699                  (apply 'append
 700                         (mapcar (lambda (x)
 701                                   (if (string-match proced-sorting-schemes-re
 702                                                     (car x))
 703                                       (list (car x))))
 704                                 proced-sorting-schemes-alist)))
 705                 (scheme (completing-read "Sorting type: "
 706                                          completion-list nil t)))
 707            (if (string= "" scheme) nil scheme))))
 708   (if (proced-sorting-scheme-p scheme)
 709       (progn
 710         (setq proced-sorting-scheme scheme)
 711         (proced-update))
 712     (error "Proced sorting scheme %s not applicable" scheme)))
 713
 714 (defun proced-sorting-scheme-p (scheme)
 715   "Return non-nil if SCHEME is an applicable sorting scheme.
 716 SCHEME must be a string or nil."
 717   (or (not scheme)
 718       (and (string-match proced-sorting-schemes-re scheme)
 719            (assoc scheme proced-sorting-schemes-alist))))
 720
 721 (defun proced-sort-pcpu ()
 722   "Sort Proced buffer by percentage CPU time (%CPU)."
 723   (interactive)
 724   (proced-sort "%CPU"))
 725
 726 (defun proced-sort-pmem ()
 727   "Sort Proced buffer by percentage memory usage (%MEM)."
 728   (interactive)
 729   (proced-sort "%MEM"))
 730
 731 (defun proced-sort-pid ()
 732   "Sort Proced buffer by PID."
 733   (interactive)
 734   (proced-sort "PID"))
 735
 736 (defun proced-sort-start ()
 737   "Sort Proced buffer by time the command started (START)."
 738   (interactive)
 739   (proced-sort "START"))
 740
 741 (defun proced-sort-time ()
 742   "Sort Proced buffer by cumulative CPU time (TIME)."
 743   (interactive)
 744   (proced-sort "TIME"))
 745
 746 (provide 'proced)
 747
 748 ;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
 749 ;;; proced.el ends here.