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-alist nil
 267   "Alist of headers in Proced buffer.
 268 Each element is of the form (NAME START END JUSTIFY).
 269 NAME is name of header in the output of ps(1).
 270 START and END are column numbers starting from 0.
 271 END is t if there is no end column for that field.
 272 JUSTIFY is 'left or 'right for left or right-justified output of ps(1).")
 273 (make-variable-buffer-local 'proced-header-alist)
 274
 275 (defvar proced-sorting-schemes-re nil
 276   "Regexp to match valid sorting schemes.")
 277 (make-variable-buffer-local 'proced-sorting-schemes-re)
 278
 279 ;; helper functions
 280 (defun proced-marker-regexp ()
 281   "Return regexp matching `proced-marker-char'."
 282   ;; `proced-marker-char' must appear in column zero
 283   (concat "^" (regexp-quote (char-to-string proced-marker-char))))
 284
 285 (defun proced-success-message (action count)
 286   "Display success message for ACTION performed for COUNT processes."
 287   (message "%s %s process%s" action count (if (= 1 count) "" "es")))
 288
 289 (defun proced-move-to-goal-column ()
 290   "Move to `proced-goal-column' if non-nil."
 291   (beginning-of-line)
 292   (if proced-goal-column
 293       (forward-char proced-goal-column)
 294     (forward-char 2)))
 295
 296 ;; FIXME: a better approach would be based on `proced-header-alist'
 297 ;; once we have a reliable scheme to set this variable
 298 (defsubst proced-skip-regexp ()
 299   "Regexp to skip in process listing to find PID column."
 300   (apply 'concat (make-list (1- (nth 2 (assoc proced-command
 301                                               proced-command-alist)))
 302                             "\\s-+\\S-+")))
 303
 304 (define-derived-mode proced-mode nil "Proced"
 305   "Mode for displaying UNIX system processes and sending signals to them.
 306 Type \\[proced-mark-process] to mark a process for later commands.
 307 Type \\[proced-send-signal] to send signals to marked processes.
 308
 309 \\{proced-mode-map}"
 310   (abbrev-mode 0)
 311   (auto-fill-mode 0)
 312   (setq buffer-read-only t
 313         truncate-lines t)
 314   (set (make-local-variable 'revert-buffer-function) 'proced-revert)
 315   (set (make-local-variable 'font-lock-defaults)
 316        '(proced-font-lock-keywords t nil nil beginning-of-line)))
 317
 318 ;; Proced mode is suitable only for specially formatted data.
 319 (put 'proced-mode 'mode-class 'special)
 320
 321 ;;;###autoload
 322 (defun proced (&optional arg)
 323   "Mode for displaying UNIX system processes and sending signals to them.
 324 Type \\[proced-mark-process] to mark a process for later commands.
 325 Type \\[proced-send-signal] to send signals to marked processes.
 326
 327 If invoked with optional ARG the window displaying the process
 328 information will be displayed but not selected.
 329
 330 \\{proced-mode-map}"
 331   (interactive "P")
 332   (let ((buffer (get-buffer-create "*Proced*")) new)
 333     (set-buffer buffer)
 334     (setq new (zerop (buffer-size)))
 335     (if new (proced-mode))
 336
 337     (if (or new arg)
 338         (proced-update))
 339
 340     (if arg
 341         (display-buffer buffer)
 342       (pop-to-buffer buffer)
 343       (message (substitute-command-keys
 344                 "type \\[quit-window] to quit, \\[proced-help] for help")))))
 345
 346 (defun proced-next-line (arg)
 347   "Move down lines then position at `proced-goal-column'.
 348 Optional prefix ARG says how many lines to move; default is one line."
 349   (interactive "p")
 350   (next-line arg)
 351   (proced-move-to-goal-column))
 352
 353 (defun proced-previous-line (arg)
 354   "Move up lines then position at `proced-goal-column'.
 355 Optional prefix ARG says how many lines to move; default is one line."
 356   (interactive "p")
 357   (previous-line arg)
 358   (proced-move-to-goal-column))
 359
 360 (defun proced-mark (&optional count)
 361   "Mark the current (or next COUNT) processes."
 362   (interactive "p")
 363   (proced-do-mark t count))
 364
 365 (defun proced-unmark (&optional count)
 366   "Unmark the current (or next COUNT) processes."
 367   (interactive "p")
 368   (proced-do-mark nil count))
 369
 370 (defun proced-unmark-backward (&optional count)
 371   "Unmark the previous (or COUNT previous) processes."
 372   ;; Analogous to `dired-unmark-backward',
 373   ;; but `ibuffer-unmark-backward' behaves different.
 374   (interactive "p")
 375   (proced-do-mark nil (- (or count 1))))
 376
 377 (defun proced-do-mark (mark &optional count)
 378   "Mark the current (or next ARG) processes using MARK."
 379   (or count (setq count 1))
 380   (let ((backward (< count 0))
 381         buffer-read-only)
 382     (setq count (1+ (if (<= 0 count) count
 383                       (min (1- (line-number-at-pos)) (abs count)))))
 384     (beginning-of-line)
 385     (while (not (or (zerop (setq count (1- count))) (eobp)))
 386       (proced-insert-mark mark backward))
 387     (proced-move-to-goal-column)))
 388
 389 (defun proced-mark-all ()
 390   "Mark all processes."
 391   (interactive)
 392   (proced-do-mark-all t))
 393
 394 (defun proced-unmark-all ()
 395   "Unmark all processes."
 396   (interactive)
 397   (proced-do-mark-all nil))
 398
 399 (defun proced-do-mark-all (mark)
 400   "Mark all processes using MARK."
 401   (let (buffer-read-only)
 402     (save-excursion
 403       (goto-char (point-min))
 404       (while (not (eobp))
 405         (proced-insert-mark mark)))))
 406
 407 (defun proced-toggle-marks ()
 408   "Toggle marks: marked processes become unmarked, and vice versa."
 409   (interactive)
 410   (let ((mark-re (proced-marker-regexp))
 411         buffer-read-only)
 412     (save-excursion
 413       (goto-char (point-min))
 414       (while (not (eobp))
 415         (cond ((looking-at mark-re)
 416                (proced-insert-mark nil))
 417               ((looking-at " ")
 418                (proced-insert-mark t))
 419               (t
 420                (forward-line 1)))))))
 421
 422 (defun proced-insert-mark (mark &optional backward)
 423   "If MARK is non-nil, insert `proced-marker-char'.
 424 If BACKWARD is non-nil, move one line backwards before inserting the mark.
 425 Otherwise move one line forward after inserting the mark."
 426   (if backward (forward-line -1))
 427   (insert (if mark proced-marker-char ?\s))
 428   (delete-char 1)
 429   (unless backward (forward-line)))
 430
 431 ;; Mostly analog of `dired-do-kill-lines'.
 432 ;; However, for negative args the target lines of `dired-do-kill-lines'
 433 ;; include the current line, whereas `dired-mark' for negative args operates
 434 ;; on the preceding lines. Here we are consistent with `dired-mark'.
 435 (defun proced-hide-processes (&optional arg quiet)
 436   "Hide marked processes.
 437 With prefix ARG, hide that many lines starting with the current line.
 438 \(A negative argument hides backward.)
 439 If QUIET is non-nil suppress status message.
 440 Returns count of hidden lines."
 441   (interactive "P")
 442   (let ((mark-re (proced-marker-regexp))
 443         (count 0)
 444         buffer-read-only)
 445     (save-excursion
 446       (if arg
 447           ;; Hide ARG lines starting with the current line.
 448           (delete-region (line-beginning-position)
 449                          (save-excursion
 450                            (if (<= 0 arg)
 451                                (setq count (- arg (forward-line arg)))
 452                              (setq count (min (1- (line-number-at-pos))
 453                                               (abs arg)))
 454                              (forward-line (- count)))
 455                            (point)))
 456         ;; Hide marked lines
 457         (while (and (not (eobp))
 458                     (re-search-forward mark-re nil t))
 459           (delete-region (match-beginning 0)
 460                          (save-excursion (forward-line) (point)))
 461           (setq count (1+ count)))))
 462     (unless (zerop count) (proced-move-to-goal-column))
 463     (unless quiet (proced-success-message "Hid" count))
 464     count))
 465
 466 (defun proced-listing-type (command)
 467   "Select `proced' listing type COMMAND from `proced-command-alist'."
 468   (interactive
 469    (list (completing-read "Listing type: " proced-command-alist nil t)))
 470   (setq proced-command command)
 471   (proced-update))
 472
 473 ;; adopted from `ruler-mode-space'
 474 (defsubst proced-header-space (width)
 475   "Return a single space string of WIDTH times the normal character width."
 476   (propertize " " 'display (list 'space :width width)))
 477
 478 (defun proced-update (&optional quiet)
 479   "Update the `proced' process information.  Preserves point and marks."
 480   ;; This is the main function that generates and updates the process listing.
 481   (interactive)
 482   (or quiet (message "Updating process information..."))
 483   (let* ((command (cadr (assoc proced-command proced-command-alist)))
 484          (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)"))
 485          (old-pos (if (save-excursion
 486                         (beginning-of-line)
 487                         (looking-at (concat "^[* ]" regexp)))
 488                       (cons (match-string-no-properties 1)
 489                             (current-column))))
 490          buffer-read-only mp-list)
 491     (goto-char (point-min))
 492     ;; remember marked processes (whatever the mark was)
 493     (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t)
 494       (push (cons (match-string-no-properties 2)
 495                   (match-string-no-properties 1)) mp-list))
 496     ;; generate new listing
 497     (erase-buffer)
 498     (apply 'call-process (car command) nil t nil
 499            (append (cdr command) (cdr (assoc proced-sorting-scheme
 500                                              proced-sorting-schemes-alist))))
 501     (goto-char (point-min))
 502     (while (not (eobp))
 503       (insert "  ")
 504       (forward-line))
 505     ;; (delete-trailing-whitespace)
 506     (goto-char (point-min))
 507     (while (re-search-forward "[ \t\r]+$" nil t)
 508       (delete-region (match-beginning 0) (match-end 0)))
 509     (goto-char (point-min))
 510     (let ((lep (line-end-position)))
 511       ;; header line: code inspired by `ruler-mode-ruler'
 512       (setq header-line-format
 513             (list "" (if (eq 'left (car (window-current-scroll-bars)))
 514                          (proced-header-space 'scroll-bar))
 515                   (proced-header-space 'left-fringe)
 516                   (proced-header-space 'left-margin)
 517                   (replace-regexp-in-string
 518                    "%" "%%" (buffer-substring-no-properties (point) lep))))
 519       (setq proced-header-alist nil)
 520       ;; FIXME: handle left/right justification properly
 521       (while (re-search-forward "\\([^ \t\n]+\\)[ \t]*\\($\\)?" lep t)
 522         (push (list (match-string-no-properties 1)
 523                     ;; take the column number starting from zero
 524                     (1- (match-beginning 0)) (or (not (not (match-beginning 2)))
 525                                                  (1- (match-end 0)))
 526                     'left)
 527               proced-header-alist)))
 528     (let ((temp (regexp-opt (mapcar 'car proced-header-alist) t)))
 529       (setq proced-sorting-schemes-re
 530             (concat "\\`" temp "\\(," temp "\\)*\\'")))
 531     ;; remove header line from ps(1) output
 532     (goto-char (point-min))
 533     (delete-region (point)
 534                    (save-excursion (forward-line) (point)))
 535     (set-buffer-modified-p nil)
 536     ;; set `proced-goal-column'
 537     (if proced-goal-header-re
 538         (let ((hlist proced-header-alist) header)
 539           (while (setq header (pop hlist))
 540             (if (string-match proced-goal-header-re (car header))
 541                 (setq proced-goal-column
 542                       (if (eq 'left (nth 3 header))
 543                           (nth 1 header) (nth 2 header))
 544                       hlist nil)))))
 545     ;; restore process marks
 546     (if mp-list
 547         (save-excursion
 548           (goto-char (point-min))
 549           (let (mark)
 550             (while (re-search-forward (concat "^" regexp) nil t)
 551               (if (setq mark (assoc (match-string-no-properties 1) mp-list))
 552                   (save-excursion
 553                     (beginning-of-line)
 554                     (insert (cdr mark))
 555                     (delete-char 1)))))))
 556     ;; restore buffer position (if possible)
 557     (goto-char (point-min))
 558     (if (and old-pos
 559              (re-search-forward
 560               (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>")
 561               nil t))
 562         (progn
 563           (beginning-of-line)
 564           (forward-char (cdr old-pos)))
 565       (proced-move-to-goal-column))
 566     ;; update modeline
 567     ;; Does the long mode-name clutter the modeline?
 568     (setq mode-name (concat "Proced: " proced-command
 569                             (if proced-sorting-scheme
 570                                 (concat " by " proced-sorting-scheme)
 571                               "")))
 572     (force-mode-line-update)
 573     ;; done
 574     (or quiet (input-pending-p)
 575         (message "Updating process information...done."))))
 576
 577 (defun proced-revert (&rest args)
 578   "Analog of `revert-buffer'."
 579   (proced-update))
 580
 581 ;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
 582 ;; and move it to window.el so that proced and ibuffer can easily use it, too?
 583 ;; What about functions like `appt-disp-window' that use
 584 ;; `shrink-window-if-larger-than-buffer'?
 585 (autoload 'dired-pop-to-buffer "dired")
 586
 587 (defun proced-send-signal (&optional signal)
 588   "Send a SIGNAL to the marked processes.
 589 SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
 590 If SIGNAL is nil display marked processes and query interactively for SIGNAL."
 591   (interactive)
 592   (let ((regexp (concat (proced-marker-regexp)
 593                         (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$"))
 594         process-list)
 595     ;; collect marked processes
 596     (save-excursion
 597       (goto-char (point-min))
 598       (while (re-search-forward regexp nil t)
 599         (push (cons (match-string-no-properties 1)
 600                     ;; How much info should we collect here?  Would it be
 601                     ;; better to collect only the PID (to avoid ambiguities)
 602                     ;; and the command name?
 603                     (substring (match-string-no-properties 0) 2))
 604               process-list)))
 605     (setq process-list (nreverse process-list))
 606     (if (not process-list)
 607         (message "No processes marked")
 608       (unless signal
 609         ;; Display marked processes (code taken from `dired-mark-pop-up').
 610         (let ((bufname  " *Marked Processes*")
 611               (header header-line-format)) ; reuse
 612           (with-current-buffer (get-buffer-create bufname)
 613             (setq truncate-lines t
 614                   header-line-format header)
 615             (erase-buffer)
 616             (dolist (process process-list)
 617               (insert "  " (cdr process) "\n"))
 618             (save-window-excursion
 619               (dired-pop-to-buffer bufname) ; all we need
 620               (let* ((completion-ignore-case t)
 621                      (pnum (if (= 1 (length process-list))
 622                                "1 process"
 623                              (format "%d processes" (length process-list))))
 624                      ;; The following is an ugly hack. Is there a better way
 625                      ;; to help people like me to remember the signals and
 626                      ;; their meanings?
 627                      (tmp (completing-read (concat "Send signal [" pnum
 628                                                    "] (default TERM): ")
 629                                            proced-signal-list
 630                                            nil nil nil nil "TERM")))
 631                 (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
 632                                  (match-string 1 tmp) tmp))))))
 633         ;; send signal
 634         (let ((count 0)
 635               err-list)
 636           (if (functionp proced-signal-function)
 637               ;; use built-in `signal-process'
 638               (let ((signal (if (stringp signal)
 639                                 (if (string-match "\\`[0-9]+\\'" signal)
 640                                     (string-to-number signal)
 641                                   (make-symbol signal))
 642                               signal))) ; number
 643                 (dolist (process process-list)
 644                   (if (zerop (funcall
 645                               proced-signal-function
 646                               (string-to-number (car process)) signal))
 647                       (setq count (1+ count))
 648                     (push (cdr process) err-list))))
 649             ;; use external system call
 650             (let ((signal (concat "-" (if (numberp signal)
 651                                           (number-to-string signal) signal))))
 652               (dolist (process process-list)
 653                 (if (zerop (call-process
 654                             proced-signal-function nil 0 nil
 655                             signal (car process)))
 656                     (setq count (1+ count))
 657                   (push (cdr process) err-list)))))
 658           (if err-list
 659               ;; FIXME: that's not enough to display the errors.
 660               (message "%s: %s" signal err-list)
 661             (proced-success-message "Sent signal to" count)))
 662         ;; final clean-up
 663         (run-hooks 'proced-after-send-signal-hook)))))
 664
 665 (defun proced-help ()
 666   "Provide help for the `proced' user."
 667   (interactive)
 668   (if (eq last-command 'proced-help)
 669       (describe-mode)
 670     (message proced-help-string)))
 671
 672 (defun proced-undo ()
 673   "Undo in a proced buffer.
 674 This doesn't recover killed processes, it just undoes changes in the proced
 675 buffer.  You can use it to recover marks."
 676   (interactive)
 677   (let (buffer-read-only)
 678     (undo))
 679   (message "Change in Proced buffer undone.
 680 Killed processes cannot be recovered by Emacs."))
 681
 682 ;;; Sorting
 683 (defun proced-sort (scheme)
 684   "Sort Proced buffer using SCHEME.
 685 When called interactively, an empty string means nil, i.e., no sorting."
 686   (interactive
 687    (list (let* ((completion-ignore-case t)
 688                 ;; restrict completion list to applicable sorting schemes
 689                 (completion-list
 690                  (apply 'append
 691                         (mapcar (lambda (x)
 692                                   (if (string-match proced-sorting-schemes-re
 693                                                     (car x))
 694                                       (list (car x))))
 695                                 proced-sorting-schemes-alist)))
 696                 (scheme (completing-read "Sorting type: "
 697                                          completion-list nil t)))
 698            (if (string= "" scheme) nil scheme))))
 699   (if (proced-sorting-scheme-p scheme)
 700       (progn
 701         (setq proced-sorting-scheme scheme)
 702         (proced-update))
 703     (error "Proced sorting scheme %s not applicable" scheme)))
 704
 705 (defun proced-sorting-scheme-p (scheme)
 706   "Return non-nil if SCHEME is an applicable sorting scheme.
 707 SCHEME must be a string or nil."
 708   (or (not scheme)
 709       (and (string-match proced-sorting-schemes-re scheme)
 710            (assoc scheme proced-sorting-schemes-alist))))
 711
 712 (defun proced-sort-pcpu ()
 713   "Sort Proced buffer by percentage CPU time (%CPU)."
 714   (interactive)
 715   (proced-sort "%CPU"))
 716
 717 (defun proced-sort-pmem ()
 718   "Sort Proced buffer by percentage memory usage (%MEM)."
 719   (interactive)
 720   (proced-sort "%MEM"))
 721
 722 (defun proced-sort-pid ()
 723   "Sort Proced buffer by PID."
 724   (interactive)
 725   (proced-sort "PID"))
 726
 727 (defun proced-sort-start ()
 728   "Sort Proced buffer by time the command started (START)."
 729   (interactive)
 730   (proced-sort "START"))
 731
 732 (defun proced-sort-time ()
 733   "Sort Proced buffer by cumulative CPU time (TIME)."
 734   (interactive)
 735   (proced-sort "TIME"))
 736
 737 (provide 'proced)
 738
 739 ;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
 740 ;;; proced.el ends here.