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, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Proced makes an Emacs buffer containing a listing of the current system
  28 ;; processes (using ps(1)).  You can use the normal Emacs commands
  29 ;; to move around in this buffer, and special Proced commands to operate
  30 ;; on the processes listed.
  31 ;;
  32 ;; To do:
  33 ;; - sort by CPU time or other criteria
  34 ;; - filter by user name or other criteria
  35 ;; - automatic update of process list
  36
  37 ;;; Code:
  38
  39 (defgroup proced nil
  40   "Proced mode."
  41   :group 'processes
  42   :group 'unix
  43   :prefix "proced-")
  44
  45 (defcustom proced-procname-column-regexp "\\b\\(CMD\\|COMMAND\\)\\b"
  46   "If non-nil, regexp that defines the `proced-procname-column'."
  47   :group 'proced
  48   :type '(choice (const :tag "none" nil)
  49                  (regexp :tag "regexp")))
  50
  51 (defcustom proced-command-alist
  52   (cond ((memq system-type '(berkeley-unix netbsd))
  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 '(linux lignux gnu/linux))
  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 syntax doesn't allow us 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                         (option (integer :tag "sort column")))))
  85
  86 (defcustom proced-command (if (zerop (user-real-uid)) "all" "user")
  87   "Name of process listing.
  88 Must be the car of an element of `proced-command-alist'."
  89   :group 'proced
  90   :type '(string :tag "name"))
  91 (make-variable-buffer-local 'proced-command)
  92
  93 (defcustom proced-signal-function 'signal-process
  94   "Name of signal function.
  95 It can be an elisp function (usually `signal-process') or a string specifying
  96 the external command (usually \"kill\")."
  97   :group 'proced
  98   :type '(choice (function :tag "function")
  99                  (string :tag "command")))
 100
 101 (defcustom proced-signal-list
 102   '(("HUP   (1.  Hangup)")
 103     ("INT   (2.  Terminal interrupt)")
 104     ("QUIT  (3.  Terminal quit)")
 105     ("ABRT  (6.  Process abort)")
 106     ("KILL  (9.  Kill -- cannot be caught or ignored)")
 107     ("ALRM  (14. Alarm Clock)")
 108     ("TERM  (15. Termination)"))
 109   "List of signals, used for minibuffer completion."
 110   :group 'proced
 111   :type '(repeat (string :tag "signal")))
 112
 113 (defvar proced-marker-char ?*           ; the answer is 42
 114   "In proced, the current mark character.")
 115
 116 ;; face and font-lock code taken from dired
 117 (defgroup proced-faces nil
 118   "Faces used by Proced."
 119   :group 'proced
 120   :group 'faces)
 121
 122 (defface proced-header
 123   '((t (:inherit font-lock-type-face)))
 124   "Face used for proced headers."
 125   :group 'proced-faces)
 126 (defvar proced-header-face 'proced-header
 127   "Face name used for proced headers.")
 128
 129 (defface proced-mark
 130   '((t (:inherit font-lock-constant-face)))
 131   "Face used for proced marks."
 132   :group 'proced-faces)
 133 (defvar proced-mark-face 'proced-mark
 134   "Face name used for proced marks.")
 135
 136 (defface proced-marked
 137   '((t (:inherit font-lock-warning-face)))
 138   "Face used for marked processes."
 139   :group 'proced-faces)
 140 (defvar proced-marked-face 'proced-marked
 141   "Face name used for marked processes.")
 142
 143 (defvar proced-re-mark "^[^ \n]"
 144   "Regexp matching a marked line.
 145 Important: the match ends just after the marker.")
 146
 147 (defvar proced-header-regexp "\\`.*$"
 148   "Regexp matching a header line.")
 149
 150 (defvar proced-procname-column nil
 151   "Proced command column.
 152 Initialized based on `proced-procname-column-regexp'.")
 153 (make-variable-buffer-local 'proced-procname-column)
 154
 155 (defvar proced-font-lock-keywords
 156   (list
 157    ;;
 158    ;; Process listing headers.
 159    (list proced-header-regexp '(0 proced-header-face))
 160    ;;
 161    ;; Proced marks.
 162    (list proced-re-mark '(0 proced-mark-face))
 163    ;;
 164    ;; Marked files.
 165    (list (concat "^[" (char-to-string proced-marker-char) "]")
 166          '(".+" (proced-move-to-procname) nil (0 proced-marked-face)))))
 167
 168 (defvar proced-mode-map
 169   (let ((km (make-sparse-keymap)))
 170     (define-key km " " 'next-line)
 171     (define-key km "n" 'next-line)
 172     (define-key km "p" 'previous-line)
 173     (define-key km "\C-?" 'previous-line)
 174     (define-key km "h" 'describe-mode)
 175     (define-key km "?" 'proced-help)
 176     (define-key km "d" 'proced-mark) ; Dired compatibility
 177     (define-key km "m" 'proced-mark)
 178     (define-key km "M" 'proced-mark-all)
 179     (define-key km "u" 'proced-unmark)
 180     (define-key km "\177" 'proced-unmark-backward)
 181     (define-key km "U" 'proced-unmark-all)
 182     (define-key km "t" 'proced-toggle-marks)
 183     (define-key km "h" 'proced-hide-processes)
 184     (define-key km "x" 'proced-send-signal) ; Dired compatibility
 185     (define-key km "k" 'proced-send-signal) ; kill processes
 186     (define-key km "l" 'proced-listing-type)
 187     (define-key km "g" 'revert-buffer) ; Dired compatibility
 188     (define-key km "q" 'quit-window)
 189     (define-key km [remap undo] 'proced-undo)
 190     (define-key km [remap advertised-undo] 'proced-undo)
 191     km)
 192   "Keymap for proced commands")
 193
 194 (easy-menu-define
 195   proced-menu proced-mode-map "Proced Menu"
 196   '("Proced"
 197     ["Mark" proced-mark t]
 198     ["Unmark" proced-unmark t]
 199     ["Mark All" proced-mark-all t]
 200     ["Unmark All" proced-unmark-all t]
 201     ["Toggle Marks" proced-unmark-all t]
 202     "--"
 203     ["Hide Marked Processes" proced-hide-processes t]
 204     "--"
 205     ["Revert" revert-buffer t]
 206     ["Send signal" proced-send-signal t]
 207     ["Change listing" proced-listing-type t]))
 208
 209 (defconst proced-help-string
 210   "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit  (type ? for more help)"
 211   "Help string for proced.")
 212
 213 (defun proced-marker-regexp ()
 214   (concat "^" (regexp-quote (char-to-string proced-marker-char))))
 215
 216 (defun proced-success-message (action count)
 217   (message "%s %s process%s" action count (if (= 1 count) "" "es")))
 218
 219 (defun proced-move-to-procname ()
 220   "Move to the beginning of the process name on the current line.
 221 Return the position of the beginning of the process name, or nil if none found."
 222   (beginning-of-line)
 223   (if proced-procname-column
 224       (forward-char proced-procname-column)
 225     (forward-char 2)))
 226
 227 (defsubst proced-skip-regexp ()
 228   "Regexp to skip in process listing."
 229   (apply 'concat (make-list (1- (nth 2 (assoc proced-command
 230                                               proced-command-alist)))
 231                             "\\s-+\\S-+")))
 232
 233 (define-derived-mode proced-mode nil "Proced"
 234   "Mode for displaying UNIX system processes and sending signals to them.
 235 Type \\[proced-mark-process] to mark a process for later commands.
 236 Type \\[proced-send-signal] to send signals to marked processes.
 237
 238 \\{proced-mode-map}"
 239   (abbrev-mode 0)
 240   (auto-fill-mode 0)
 241   (setq buffer-read-only t
 242         truncate-lines t)
 243   (set (make-local-variable 'revert-buffer-function) 'proced-revert)
 244   (set (make-local-variable 'font-lock-defaults)
 245        '(proced-font-lock-keywords t nil nil beginning-of-line)))
 246
 247 ;; Proced mode is suitable only for specially formatted data.
 248 (put 'proced-mode 'mode-class 'special)
 249
 250 ;;;###autoload
 251 (defun proced (&optional arg)
 252   "Mode for displaying UNIX system processes and sending signals to them.
 253 Type \\[proced-mark-process] to mark a process for later commands.
 254 Type \\[proced-send-signal] to send signals to marked processes.
 255
 256 If invoked with optional ARG the window displaying the process
 257 information will be displayed but not selected.
 258
 259 \\{proced-mode-map}"
 260   (interactive "P")
 261   (let ((proced-buffer (get-buffer-create "*Process Info*")) new)
 262     (set-buffer proced-buffer)
 263     (setq new (zerop (buffer-size)))
 264     (when new (proced-mode))
 265
 266     (if (or new arg)
 267         (proced-update))
 268
 269     (if arg
 270         (display-buffer proced-buffer)
 271       (pop-to-buffer proced-buffer)
 272       (message (substitute-command-keys
 273                 "type \\[quit-window] to quit, \\[proced-help] for help")))))
 274
 275
 276 (defun proced-mark (&optional count)
 277   "Mark the current (or next COUNT) processes."
 278   (interactive "p")
 279   (proced-do-mark t count))
 280
 281 (defun proced-unmark (&optional count)
 282   "Unmark the current (or next COUNT) processes."
 283   (interactive "p")
 284   (proced-do-mark nil count))
 285
 286 (defun proced-unmark-backward (&optional count)
 287   "Unmark the previous (or COUNT previous) processes."
 288   (interactive "p")
 289   (proced-do-mark nil (- (or count 1))))
 290
 291 (defun proced-do-mark (mark &optional count)
 292   "Mark the current (or next ARG) processes using MARK."
 293   (or count (setq count 1))
 294   (let ((backward (< count 0))
 295         (line (line-number-at-pos))
 296         buffer-read-only)
 297     ;; do nothing in the first line
 298     (unless (= line 1)
 299       (setq count (1+ (if (<= 0 count) count
 300                         (min (- line 2) (abs count)))))
 301       (beginning-of-line)
 302       (while (not (or (zerop (setq count (1- count))) (eobp)))
 303         (proced-insert-mark mark backward))
 304       (proced-move-to-procname))))
 305
 306 (defun proced-mark-all ()
 307   "Mark all processes."
 308   (interactive)
 309   (proced-do-mark-all t))
 310
 311 (defun proced-unmark-all ()
 312   "Unmark all processes."
 313   (interactive)
 314   (proced-do-mark-all nil))
 315
 316 (defun proced-do-mark-all (mark)
 317   "Mark all processes using MARK."
 318   (let (buffer-read-only)
 319     (save-excursion
 320       (goto-line 2)
 321       (while (not (eobp))
 322         (proced-insert-mark mark)))))
 323
 324 (defun proced-toggle-marks ()
 325   "Toggle marks: marked processes become unmarked, and vice versa."
 326   (interactive)
 327   (let ((mark-re (proced-marker-regexp))
 328         buffer-read-only)
 329     (save-excursion
 330       (goto-line 2)
 331       (while (not (eobp))
 332         (cond ((looking-at mark-re)
 333                (proced-insert-mark nil))
 334               ((looking-at " ")
 335                (proced-insert-mark t))
 336               (t
 337                (forward-line 1)))))))
 338
 339 (defun proced-insert-mark (mark &optional backward)
 340   "If MARK is non-nil, insert `proced-marker-char'.
 341 If BACKWARD is non-nil, move one line backwards before inserting the mark.
 342 Otherwise move one line forward after inserting the mark."
 343   (if backward (forward-line -1))
 344   (insert (if mark proced-marker-char ?\s))
 345   (delete-char 1)
 346   (unless backward (forward-line)))
 347
 348 ;; Mostly analog of `dired-do-kill-lines'.
 349 ;; However, for negative args the target lines of `dired-do-kill-lines'
 350 ;; include the current line, whereas `dired-mark' for negative args operates
 351 ;; on the preceding lines. Here we are consistent with `dired-mark'.
 352 (defun proced-hide-processes (&optional arg quiet)
 353   "Hide marked processes.
 354 With prefix ARG, hide that many lines starting with the current line.
 355 \(A negative argument hides backward.)
 356 If QUIET is non-nil suppress status message.
 357 Returns count of hidden lines."
 358   (interactive "P")
 359   (let ((mark-re (proced-marker-regexp))
 360         (count 0)
 361         buffer-read-only)
 362     (save-excursion
 363       (if arg
 364           ;; Hide ARG lines starting with the current line.
 365           (let ((line (line-number-at-pos)))
 366             ;; do nothing in the first line
 367             (unless (= line 1)
 368               (delete-region (line-beginning-position)
 369                              (save-excursion
 370                                (if (<= 0 arg)
 371                                    (setq count (- arg (forward-line arg)))
 372                                  (setq count (min (- line 2) (abs arg)))
 373                                  (forward-line (- count)))
 374                                (point)))))
 375         ;; Hide marked lines
 376         (goto-line 2)
 377         (while (and (not (eobp))
 378                     (re-search-forward mark-re nil t))
 379           (delete-region (match-beginning 0)
 380                          (save-excursion (forward-line) (point)))
 381           (setq count (1+ count)))))
 382     (unless (zerop count) (proced-move-to-procname))
 383     (unless quiet
 384       (proced-success-message "Hid" count))
 385     count))
 386
 387 (defun proced-listing-type (command)
 388   "Select `proced' listing type COMMAND from `proced-command-alist'."
 389   (interactive
 390    (list (completing-read "Listing type: " proced-command-alist nil t)))
 391   (setq proced-command command)
 392   (proced-update))
 393
 394 (defun proced-update (&optional quiet)
 395   "Update the `proced' process information.  Preserves point and marks."
 396   ;; This is the main function that generates and updates the process listing.
 397   (interactive)
 398   (or quiet (message "Updating process information..."))
 399   (let* ((command (cdr (assoc proced-command proced-command-alist)))
 400          (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)"))
 401          (old-pos (if (save-excursion
 402                         (beginning-of-line)
 403                         (looking-at (concat "^[* ]" regexp)))
 404                       (cons (match-string-no-properties 1)
 405                             (current-column))))
 406          buffer-read-only plist)
 407     (goto-char (point-min))
 408     ;; remember marked processes (whatever the mark was)
 409     (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t)
 410       (push (cons (match-string-no-properties 2)
 411                   (match-string-no-properties 1)) plist))
 412     ;; generate new listing
 413     (erase-buffer)
 414     (apply 'call-process (caar command) nil t nil (cdar command))
 415     (goto-char (point-min))
 416     (while (not (eobp))
 417       (insert "  ")
 418       (forward-line))
 419     ;; (delete-trailing-whitespace)
 420     (goto-char (point-min))
 421     (while (re-search-forward "[ \t\r]+$" nil t)
 422       (delete-region (match-beginning 0) (match-end 0)))
 423     (set-buffer-modified-p nil)
 424     ;; set `proced-procname-column'
 425     (goto-char (point-min))
 426     (and proced-procname-column-regexp
 427          (re-search-forward proced-procname-column-regexp nil t)
 428          (setq proced-procname-column (1- (match-beginning 0))))
 429     ;; restore process marks
 430     (if plist
 431         (save-excursion
 432           (goto-line 2)
 433           (let (mark)
 434             (while (re-search-forward (concat "^" regexp) nil t)
 435               (if (setq mark (assoc (match-string-no-properties 1) plist))
 436                   (save-excursion
 437                     (beginning-of-line)
 438                     (insert (cdr mark))
 439                     (delete-char 1)))))))
 440     ;; restore buffer position (if possible)
 441     (goto-line 2)
 442     (if (and old-pos
 443              (re-search-forward
 444               (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>")
 445               nil t))
 446         (progn
 447           (beginning-of-line)
 448           (forward-char (cdr old-pos)))
 449       (proced-move-to-procname))
 450     (or quiet (input-pending-p)
 451         (message "Updating process information...done."))))
 452
 453 (defun proced-revert (&rest args)
 454   "Analog of `revert-buffer'."
 455   (proced-update))
 456
 457 ;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
 458 ;; and move it to simple.el so that proced and ibuffer can easily use it, too?
 459 (autoload 'dired-pop-to-buffer "dired")
 460
 461 (defun proced-send-signal (&optional signal)
 462   "Send a SIGNAL to the marked processes.
 463 SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
 464 If SIGNAL is nil display marked processes and query interactively for SIGNAL."
 465   (interactive)
 466   (let ((regexp (concat (proced-marker-regexp)
 467                         (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$"))
 468         plist)
 469     ;; collect marked processes
 470     (save-excursion
 471       (goto-char (point-min))
 472       (while (re-search-forward regexp nil t)
 473         (push (cons (match-string-no-properties 1)
 474                     ;; How much info should we collect here?  Would it be
 475                     ;; better to collect only the PID (to avoid ambiguities)
 476                     ;; and the command name?
 477                     (substring (match-string-no-properties 0) 2))
 478               plist)))
 479     (if (not plist)
 480         (message "No processes marked")
 481       (unless signal
 482         ;; Display marked processes (code taken from `dired-mark-pop-up').
 483         (let ((bufname  " *Marked Processes*")
 484               (header (save-excursion
 485                         (goto-char (+ 2 (point-min)))
 486                         (buffer-substring-no-properties
 487                          (point) (line-end-position)))))
 488           (with-current-buffer (get-buffer-create bufname)
 489             (setq truncate-lines t)
 490             (erase-buffer)
 491             (insert header "\n")
 492             (dolist (proc plist)
 493               (insert (cdr proc) "\n"))
 494             (save-window-excursion
 495               (dired-pop-to-buffer bufname) ; all we need
 496               (let* ((completion-ignore-case t)
 497                      (pnum (if (= 1 (length plist))
 498                                "1 process"
 499                              (format "%d processes" (length plist))))
 500                      ;; The following is an ugly hack. Is there a better way
 501                      ;; to help people like me to remember the signals and
 502                      ;; their meanings?
 503                      (tmp (completing-read (concat "Send signal [" pnum
 504                                                    "] (default TERM): ")
 505                                            proced-signal-list
 506                                            nil nil nil nil "TERM")))
 507                 (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
 508                                  (match-string 1 tmp) tmp))))))
 509         ;; send signal
 510         (let ((count 0)
 511               err-list)
 512           (if (functionp proced-signal-function)
 513               ;; use built-in `signal-process'
 514               (let ((signal (if (stringp signal)
 515                                 (if (string-match "\\`[0-9]+\\'" signal)
 516                                     (string-to-number signal)
 517                                   (make-symbol signal))
 518                               signal))) ; number
 519                 (dolist (process plist)
 520                   (if (zerop (funcall
 521                               proced-signal-function
 522                               (string-to-number (car process)) signal))
 523                       (setq count (1+ count))
 524                     (push (cdr process) err-list))))
 525             ;; use external system call
 526             (let ((signal (concat "-" (if (numberp signal)
 527                                           (number-to-string signal) signal))))
 528               (dolist (process plist)
 529                 (if (zerop (call-process
 530                             proced-signal-function nil 0 nil
 531                             signal (car process)))
 532                     (setq count (1+ count))
 533                   (push (cdr process) err-list)))))
 534           (if err-list
 535               ;; FIXME: that's not enough to display the errors.
 536               (message "%s: %s" signal err-list)
 537             (proced-success-message "Sent signal to" count)))
 538         ;; final clean-up
 539         (run-hooks 'proced-after-send-signal-hook)))))
 540
 541 (defun proced-help ()
 542   "Provide help for the `proced' user."
 543   (interactive)
 544   (if (eq last-command 'proced-help)
 545       (describe-mode)
 546     (message proced-help-string)))
 547
 548 (defun proced-undo ()
 549   "Undo in a proced buffer.
 550 This doesn't recover killed processes, it just undoes changes in the proced
 551 buffer.  You can use it to recover marks."
 552   (interactive)
 553   (let (buffer-read-only)
 554     (undo))
 555   (message "Change in proced buffer undone.
 556 Killed processes cannot be recovered by Emacs."))
 557
 558 (provide 'proced)
 559
 560 ;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
 561 ;;; proced.el ends here.