view lisp/proced.el @ 94312:eaaf578ce48f

(calendar-scroll-left): Handle case when event-start is nil.

;;; proced.el --- operate on system processes like dired

;; Copyright (C) 2008 Free Software Foundation, Inc.

;; Author: Roland Winkler <[e-mail]>
;; Keywords: Processes, Unix

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Proced makes an Emacs buffer containing a listing of the current system
;; processes (using ps(1)).  You can use the normal Emacs commands
;; to move around in this buffer, and special Proced commands to operate
;; on the processes listed.
;;
;; To do:
;; - sort by CPU time or other criteria
;; - filter by user name or other criteria
;; - automatic update of process list

;;; Code:

(defgroup proced nil
  "Proced mode."
  :group 'processes
  :group 'unix
  :prefix "proced-")

(defcustom proced-procname-column-regexp "\\b\\(CMD\\|COMMAND\\)\\b"
  "If non-nil, regexp that defines the `proced-procname-column'."
  :group 'proced
  :type '(choice (const :tag "none" nil)
                 (regexp :tag "regexp")))

(defcustom proced-command-alist
  (cond ((memq system-type '(berkeley-unix netbsd))
         '(("user" ("ps" "-uxgww") 2)
           ("user-running" ("ps" "-uxrgww") 2)
           ("all" ("ps" "-auxgww") 2)
           ("all-running" ("ps" "-auxrgww") 2)))
        ((memq system-type '(linux lignux gnu/linux))
         `(("user" ("ps" "uxwww") 2)
           ("user-running" ("ps" "uxrwww") 2)
           ("all" ("ps" "auxwww") 2)
           ("all-running" ("ps" "auxrwww") 2)
           ("emacs" ("ps" "--pid" ,(number-to-string (emacs-pid))
                     "--ppid" ,(number-to-string (emacs-pid))
                      "uwww") 2)))
        ((memq system-type '(darwin))
         `(("user" ("ps" "-u" ,(number-to-string (user-uid))) 2)
           ("all" ("ps" "-Au") 2)))
        (t ; standard syntax doesn't allow us to list running processes only
         `(("user" ("ps" "-fu" ,(number-to-string (user-uid))) 2)
           ("all" ("ps" "-ef") 2))))
  "Alist of commands to get list of processes.
Each element has the form (NAME COMMAND PID-COLUMN).
NAME is a shorthand name to select the type of listing.
COMMAND is a list (COMMAND-NAME ARG1 ARG2 ...),
where COMMAND-NAME is the command to generate the listing (usually \"ps\").
ARG1, ARG2, ... are arguments passed to COMMAND-NAME to generate
a particular listing.  These arguments differ under various operating systems.
PID-COLUMN is the column number (starting from 1) of the process ID."
  :group 'proced
  :type '(repeat (group (string :tag "name")
                        (cons (string :tag "command")
                              (repeat (string :tag "option")))
                        (integer :tag "PID column")
                        (option (integer :tag "sort column")))))

(defcustom proced-command (if (zerop (user-real-uid)) "all" "user")
  "Name of process listing.
Must be the car of an element of `proced-command-alist'."
  :group 'proced
  :type '(string :tag "name"))
(make-variable-buffer-local 'proced-command)

(defcustom proced-signal-function 'signal-process
  "Name of signal function.
It can be an elisp function (usually `signal-process') or a string specifying
the external command (usually \"kill\")."
  :group 'proced
  :type '(choice (function :tag "function")
                 (string :tag "command")))

(defcustom proced-signal-list
  '(("HUP   (1.  Hangup)")
    ("INT   (2.  Terminal interrupt)")
    ("QUIT  (3.  Terminal quit)")
    ("ABRT  (6.  Process abort)")
    ("KILL  (9.  Kill -- cannot be caught or ignored)")
    ("ALRM  (14. Alarm Clock)")
    ("TERM  (15. Termination)"))
  "List of signals, used for minibuffer completion."
  :group 'proced
  :type '(repeat (string :tag "signal")))

(defvar proced-marker-char ?*		; the answer is 42
  "In proced, the current mark character.")

;; face and font-lock code taken from dired
(defgroup proced-faces nil
  "Faces used by Proced."
  :group 'proced
  :group 'faces)

(defface proced-header
  '((t (:inherit font-lock-type-face)))
  "Face used for proced headers."
  :group 'proced-faces)
(defvar proced-header-face 'proced-header
  "Face name used for proced headers.")

(defface proced-mark
  '((t (:inherit font-lock-constant-face)))
  "Face used for proced marks."
  :group 'proced-faces)
(defvar proced-mark-face 'proced-mark
  "Face name used for proced marks.")

(defface proced-marked
  '((t (:inherit font-lock-warning-face)))
  "Face used for marked processes."
  :group 'proced-faces)
(defvar proced-marked-face 'proced-marked
  "Face name used for marked processes.")

(defvar proced-re-mark "^[^ \n]"
  "Regexp matching a marked line.
Important: the match ends just after the marker.")

(defvar proced-header-regexp "\\`.*$"
  "Regexp matching a header line.")

(defvar proced-procname-column nil
  "Proced command column.
Initialized based on `proced-procname-column-regexp'.")
(make-variable-buffer-local 'proced-procname-column)

(defvar proced-font-lock-keywords
  (list
   ;;
   ;; Process listing headers.
   (list proced-header-regexp '(0 proced-header-face))
   ;;
   ;; Proced marks.
   (list proced-re-mark '(0 proced-mark-face))
   ;;
   ;; Marked files.
   (list (concat "^[" (char-to-string proced-marker-char) "]")
         '(".+" (proced-move-to-procname) nil (0 proced-marked-face)))))

(defvar proced-mode-map
  (let ((km (make-sparse-keymap)))
    (define-key km " " 'next-line)
    (define-key km "n" 'next-line)
    (define-key km "p" 'previous-line)
    (define-key km "\C-?" 'previous-line)
    (define-key km "h" 'describe-mode)
    (define-key km "?" 'proced-help)
    (define-key km "d" 'proced-mark) ; Dired compatibility
    (define-key km "m" 'proced-mark)
    (define-key km "M" 'proced-mark-all)
    (define-key km "u" 'proced-unmark)
    (define-key km "\177" 'proced-unmark-backward)
    (define-key km "U" 'proced-unmark-all)
    (define-key km "t" 'proced-toggle-marks)
    (define-key km "h" 'proced-hide-processes)
    (define-key km "x" 'proced-send-signal) ; Dired compatibility
    (define-key km "k" 'proced-send-signal) ; kill processes
    (define-key km "l" 'proced-listing-type)
    (define-key km "g" 'revert-buffer) ; Dired compatibility
    (define-key km "q" 'quit-window)
    (define-key km [remap undo] 'proced-undo)
    (define-key km [remap advertised-undo] 'proced-undo)
    km)
  "Keymap for proced commands")

(easy-menu-define
  proced-menu proced-mode-map "Proced Menu"
  '("Proced"
    ["Mark" proced-mark t]
    ["Unmark" proced-unmark t]
    ["Mark All" proced-mark-all t]
    ["Unmark All" proced-unmark-all t]
    ["Toggle Marks" proced-unmark-all t]
    "--"
    ["Hide Marked Processes" proced-hide-processes t]
    "--"
    ["Revert" revert-buffer t]
    ["Send signal" proced-send-signal t]
    ["Change listing" proced-listing-type t]))

(defconst proced-help-string
  "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit  (type ? for more help)"
  "Help string for proced.")

(defun proced-marker-regexp ()
  (concat "^" (regexp-quote (char-to-string proced-marker-char))))

(defun proced-success-message (action count)
  (message "%s %s process%s" action count (if (= 1 count) "" "es")))

(defun proced-move-to-procname ()
  "Move to the beginning of the process name on the current line.
Return the position of the beginning of the process name, or nil if none found."
  (beginning-of-line)
  (if proced-procname-column
      (forward-char proced-procname-column)
    (forward-char 2)))

(defsubst proced-skip-regexp ()
  "Regexp to skip in process listing."
  (apply 'concat (make-list (1- (nth 2 (assoc proced-command
                                              proced-command-alist)))
                            "\\s-+\\S-+")))

(define-derived-mode proced-mode nil "Proced"
  "Mode for displaying UNIX system processes and sending signals to them.
Type \\[proced-mark-process] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.

\\{proced-mode-map}"
  (abbrev-mode 0)
  (auto-fill-mode 0)
  (setq buffer-read-only t
        truncate-lines t)
  (set (make-local-variable 'revert-buffer-function) 'proced-revert)
  (set (make-local-variable 'font-lock-defaults)
       '(proced-font-lock-keywords t nil nil beginning-of-line)))

;; Proced mode is suitable only for specially formatted data.
(put 'proced-mode 'mode-class 'special)

;;;###autoload
(defun proced (&optional arg)
  "Mode for displaying UNIX system processes and sending signals to them.
Type \\[proced-mark-process] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.

If invoked with optional ARG the window displaying the process
information will be displayed but not selected.

\\{proced-mode-map}"
  (interactive "P")
  (let ((proced-buffer (get-buffer-create "*Process Info*")) new)
    (set-buffer proced-buffer)
    (setq new (zerop (buffer-size)))
    (when new (proced-mode))

    (if (or new arg)
        (proced-update))

    (if arg
	(display-buffer proced-buffer)
      (pop-to-buffer proced-buffer)
      (message (substitute-command-keys
                "type \\[quit-window] to quit, \\[proced-help] for help")))))


(defun proced-mark (&optional count)
  "Mark the current (or next COUNT) processes."
  (interactive "p")
  (proced-do-mark t count))

(defun proced-unmark (&optional count)
  "Unmark the current (or next COUNT) processes."
  (interactive "p")
  (proced-do-mark nil count))

(defun proced-unmark-backward (&optional count)
  "Unmark the previous (or COUNT previous) processes."
  (interactive "p")
  (proced-do-mark nil (- (or count 1))))

(defun proced-do-mark (mark &optional count)
  "Mark the current (or next ARG) processes using MARK."
  (or count (setq count 1))
  (let ((backward (< count 0))
        (line (line-number-at-pos))
	buffer-read-only)
    ;; do nothing in the first line
    (unless (= line 1)
      (setq count (1+ (if (<= 0 count) count
                        (min (- line 2) (abs count)))))
      (beginning-of-line)
      (while (not (or (zerop (setq count (1- count))) (eobp)))
        (proced-insert-mark mark backward))
      (proced-move-to-procname))))

(defun proced-mark-all ()
  "Mark all processes."
  (interactive)
  (proced-do-mark-all t))

(defun proced-unmark-all ()
  "Unmark all processes."
  (interactive)
  (proced-do-mark-all nil))

(defun proced-do-mark-all (mark)
  "Mark all processes using MARK."
  (let (buffer-read-only)
    (save-excursion
      (goto-line 2)
      (while (not (eobp))
        (proced-insert-mark mark)))))

(defun proced-toggle-marks ()
  "Toggle marks: marked processes become unmarked, and vice versa."
  (interactive)
  (let ((mark-re (proced-marker-regexp))
        buffer-read-only)
    (save-excursion
      (goto-line 2)
      (while (not (eobp))
        (cond ((looking-at mark-re)
               (proced-insert-mark nil))
              ((looking-at " ")
               (proced-insert-mark t))
              (t
               (forward-line 1)))))))

(defun proced-insert-mark (mark &optional backward)
  "If MARK is non-nil, insert `proced-marker-char'.
If BACKWARD is non-nil, move one line backwards before inserting the mark.
Otherwise move one line forward after inserting the mark."
  (if backward (forward-line -1))
  (insert (if mark proced-marker-char ?\s))
  (delete-char 1)
  (unless backward (forward-line)))

;; Mostly analog of `dired-do-kill-lines'.
;; However, for negative args the target lines of `dired-do-kill-lines'
;; include the current line, whereas `dired-mark' for negative args operates
;; on the preceding lines. Here we are consistent with `dired-mark'.
(defun proced-hide-processes (&optional arg quiet)
  "Hide marked processes.
With prefix ARG, hide that many lines starting with the current line.
\(A negative argument hides backward.)
If QUIET is non-nil suppress status message.
Returns count of hidden lines."
  (interactive "P")
  (let ((mark-re (proced-marker-regexp))
        (count 0)
        buffer-read-only)
    (save-excursion
      (if arg
          ;; Hide ARG lines starting with the current line.
          (let ((line (line-number-at-pos)))
            ;; do nothing in the first line
            (unless (= line 1)
              (delete-region (line-beginning-position)
                             (save-excursion
                               (if (<= 0 arg)
                                   (setq count (- arg (forward-line arg)))
                                 (setq count (min (- line 2) (abs arg)))
                                 (forward-line (- count)))
                               (point)))))
        ;; Hide marked lines
        (goto-line 2)
        (while (and (not (eobp))
                    (re-search-forward mark-re nil t))
          (delete-region (match-beginning 0)
                         (save-excursion (forward-line) (point)))
          (setq count (1+ count)))))
    (unless (zerop count) (proced-move-to-procname))
    (unless quiet
      (proced-success-message "Hid" count))
    count))

(defun proced-listing-type (command)
  "Select `proced' listing type COMMAND from `proced-command-alist'."
  (interactive
   (list (completing-read "Listing type: " proced-command-alist nil t)))
  (setq proced-command command)
  (proced-update))

(defun proced-update (&optional quiet)
  "Update the `proced' process information.  Preserves point and marks."
  ;; This is the main function that generates and updates the process listing.
  (interactive)
  (or quiet (message "Updating process information..."))
  (let* ((command (cdr (assoc proced-command proced-command-alist)))
         (regexp (concat (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\)"))
         (old-pos (if (save-excursion
                        (beginning-of-line)
                        (looking-at (concat "^[* ]" regexp)))
                      (cons (match-string-no-properties 1)
                            (current-column))))
         buffer-read-only plist)
    (goto-char (point-min))
    ;; remember marked processes (whatever the mark was)
    (while (re-search-forward (concat "^\\(\\S-\\)" regexp) nil t)
      (push (cons (match-string-no-properties 2)
                  (match-string-no-properties 1)) plist))
    ;; generate new listing
    (erase-buffer)
    (apply 'call-process (caar command) nil t nil (cdar command))
    (goto-char (point-min))
    (while (not (eobp))
      (insert "  ")
      (forward-line))
    ;; (delete-trailing-whitespace)
    (goto-char (point-min))
    (while (re-search-forward "[ \t\r]+$" nil t)
      (delete-region (match-beginning 0) (match-end 0)))
    (set-buffer-modified-p nil)
    ;; set `proced-procname-column'
    (goto-char (point-min))
    (and proced-procname-column-regexp
         (re-search-forward proced-procname-column-regexp nil t)
         (setq proced-procname-column (1- (match-beginning 0))))
    ;; restore process marks
    (if plist
        (save-excursion
          (goto-line 2)
          (let (mark)
            (while (re-search-forward (concat "^" regexp) nil t)
              (if (setq mark (assoc (match-string-no-properties 1) plist))
                  (save-excursion
                    (beginning-of-line)
                    (insert (cdr mark))
                    (delete-char 1)))))))
    ;; restore buffer position (if possible)
    (goto-line 2)
    (if (and old-pos
             (re-search-forward
              (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>")
              nil t))
        (progn
          (beginning-of-line)
          (forward-char (cdr old-pos)))
      (proced-move-to-procname))
    (or quiet (input-pending-p)
        (message "Updating process information...done."))))

(defun proced-revert (&rest args)
  "Analog of `revert-buffer'."
  (proced-update))

;; I do not want to reinvent the wheel.  Should we rename `dired-pop-to-buffer'
;; and move it to simple.el so that proced and ibuffer can easily use it, too?
(autoload 'dired-pop-to-buffer "dired")

(defun proced-send-signal (&optional signal)
  "Send a SIGNAL to the marked processes.
SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
If SIGNAL is nil display marked processes and query interactively for SIGNAL."
  (interactive)
  (let ((regexp (concat (proced-marker-regexp)
                        (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$"))
        plist)
    ;; collect marked processes
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward regexp nil t)
        (push (cons (match-string-no-properties 1)
                    ;; How much info should we collect here?  Would it be
                    ;; better to collect only the PID (to avoid ambiguities)
                    ;; and the command name?
                    (substring (match-string-no-properties 0) 2))
              plist)))
    (if (not plist)
        (message "No processes marked")
      (unless signal
        ;; Display marked processes (code taken from `dired-mark-pop-up').
        (let ((bufname  " *Marked Processes*")
              (header (save-excursion
                        (goto-char (+ 2 (point-min)))
                        (buffer-substring-no-properties
                         (point) (line-end-position)))))
          (with-current-buffer (get-buffer-create bufname)
            (setq truncate-lines t)
            (erase-buffer)
            (insert header "\n")
            (dolist (proc plist)
              (insert (cdr proc) "\n"))
            (save-window-excursion
              (dired-pop-to-buffer bufname) ; all we need
              (let* ((completion-ignore-case t)
                     (pnum (if (= 1 (length plist))
                               "1 process"
                             (format "%d processes" (length plist))))
                     ;; The following is an ugly hack. Is there a better way
                     ;; to help people like me to remember the signals and
                     ;; their meanings?
                     (tmp (completing-read (concat "Send signal [" pnum
                                                   "] (default TERM): ")
                                           proced-signal-list
                                           nil nil nil nil "TERM")))
                (setq signal (if (string-match "^\\(\\S-+\\)\\s-" tmp)
                                 (match-string 1 tmp) tmp))))))
        ;; send signal
        (let ((count 0)
              err-list)
          (if (functionp proced-signal-function)
              ;; use built-in `signal-process'
              (let ((signal (if (stringp signal)
                                (if (string-match "\\`[0-9]+\\'" signal)
                                    (string-to-number signal)
                                  (make-symbol signal))
                              signal))) ; number
                (dolist (process plist)
                  (if (zerop (funcall
                              proced-signal-function
                              (string-to-number (car process)) signal))
                      (setq count (1+ count))
                    (push (cdr process) err-list))))
            ;; use external system call
            (let ((signal (concat "-" (if (numberp signal)
                                          (number-to-string signal) signal))))
              (dolist (process plist)
                (if (zerop (call-process
                            proced-signal-function nil 0 nil
                            signal (car process)))
                    (setq count (1+ count))
                  (push (cdr process) err-list)))))
          (if err-list
              ;; FIXME: that's not enough to display the errors.
              (message "%s: %s" signal err-list)
            (proced-success-message "Sent signal to" count)))
        ;; final clean-up
        (run-hooks 'proced-after-send-signal-hook)))))

(defun proced-help ()
  "Provide help for the `proced' user."
  (interactive)
  (if (eq last-command 'proced-help)
      (describe-mode)
    (message proced-help-string)))

(defun proced-undo ()
  "Undo in a proced buffer.
This doesn't recover killed processes, it just undoes changes in the proced
buffer.  You can use it to recover marks."
  (interactive)
  (let (buffer-read-only)
    (undo))
  (message "Change in proced buffer undone.
Killed processes cannot be recovered by Emacs."))

(provide 'proced)

;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
;;; proced.el ends here.