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