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