;;; proced.el --- operate on system processes like dired
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2012 Free Software Foundation, Inc.
-;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
+;; Author: Roland Winkler <winkler@gnu.org>
;; Keywords: Processes, Unix
;; This file is part of GNU Emacs.
;; - allow "sudo kill PID", "renice PID"
;;
;; Thoughts and Ideas
-;; - Currently, `system-process-attributes' returns the list of
+;; - Currently, `process-attributes' returns the list of
;; command-line arguments of a process as one concatenated string.
;; This format is compatible with `shell-command'. Also, under
;; MS-Windows, the command-line arguments are actually stored as a
;; single string, so that it is impossible to reverse-engineer it back
-;; into separate arguments. Alternatively, `system-process-attributes'
+;; into separate arguments. Alternatively, `process-attributes'
;; could (try to) return a list of strings that correspond to individual
;; command-line arguments. Then one could feed such a list of
;; command-line arguments into `call-process' or `start-process'.
(defcustom proced-signal-list
'( ;; signals supported on all POSIX compliant systems
- ("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)")
+ ("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)")
;; POSIX 1003.1-2001
;; Which systems do not support these signals so that we can
;; exclude them from `proced-signal-list'?
- ("CONT (Continue executing)")
- ("STOP (Stop executing / pause - cannot be caught or ignored)")
- ("TSTP (Terminal stop / pause)"))
+ ("CONT" . " (Continue executing)")
+ ("STOP" . " (Stop executing / pause - cannot be caught or ignored)")
+ ("TSTP" . " (Terminal stop / pause)"))
"List of signals, used for minibuffer completion."
:group 'proced
- :type '(repeat (string :tag "signal")))
+ :type '(repeat (cons (string :tag "signal name")
+ (string :tag "description"))))
;; For which attributes can we use a fixed width of the output field?
;; A fixed width speeds up formatting, yet it can make
;; It would be neat if one could temporarily override the following
;; predefined rules.
(defcustom proced-grammar-alist
- '( ;; attributes defined in `system-process-attributes'
+ '( ;; attributes defined in `process-attributes'
(euid "EUID" "%d" right proced-< nil (euid pid) (nil t nil))
- (user "USER" nil left proced-string-lessp nil (user pid) (nil t nil))
+ (user "User" nil left proced-string-lessp nil (user pid) (nil t nil))
(egid "EGID" "%d" right proced-< nil (egid euid pid) (nil t nil))
- (group "GROUP" nil left proced-string-lessp nil (group user pid) (nil t nil))
- (comm "COMMAND" nil left proced-string-lessp nil (comm pid) (nil t nil))
- (state "STAT" nil left proced-string-lessp nil (state pid) (nil t nil))
+ (group "Group" nil left proced-string-lessp nil (group user pid) (nil t nil))
+ (comm "Command" nil left proced-string-lessp nil (comm pid) (nil t nil))
+ (state "Stat" nil left proced-string-lessp nil (state pid) (nil t nil))
(ppid "PPID" "%d" right proced-< nil (ppid pid)
- ((lambda (ppid) (proced-filter-parents proced-process-alist ppid)) .
+ ((lambda (ppid) (proced-filter-parents proced-process-alist ppid))
"refine to process parents"))
- (pgrp "PGRP" "%d" right proced-< nil (pgrp euid pid) (nil t nil))
- (sess "SESS" "%d" right proced-< nil (sess pid) (nil t nil))
+ (pgrp "PGrp" "%d" right proced-< nil (pgrp euid pid) (nil t nil))
+ (sess "Sess" "%d" right proced-< nil (sess pid) (nil t nil))
(ttname "TTY" proced-format-ttname left proced-string-lessp nil (ttname pid) (nil t nil))
(tpgid "TPGID" "%d" right proced-< nil (tpgid pid) (nil t nil))
- (minflt "MINFLT" "%d" right proced-< nil (minflt pid) (nil t t))
- (majflt "MAJFLT" "%d" right proced-< nil (majflt pid) (nil t t))
- (cminflt "CMINFLT" "%d" right proced-< nil (cminflt pid) (nil t t))
- (cmajflt "CMAJFLT" "%d" right proced-< nil (cmajflt pid) (nil t t))
- (utime "UTIME" proced-format-time right proced-time-lessp t (utime pid) (nil t t))
- (stime "STIME" proced-format-time right proced-time-lessp t (stime pid) (nil t t))
- (cutime "CUTIME" proced-format-time right proced-time-lessp t (cutime pid) (nil t t))
- (cstime "CSTIME" proced-format-time right proced-time-lessp t (cstime pid) (nil t t))
- (pri "PR" "%d" right proced-< t (pri pid) (nil t t))
- (nice "NI" "%3d" 3 proced-< t (nice pid) (t t nil))
- (thcount "THCOUNT" "%d" right proced-< t (thcount pid) (nil t t))
- (start "START" proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
- (vsize "VSIZE" "%d" right proced-< t (vsize pid) (nil t t))
+ (minflt "MinFlt" "%d" right proced-< nil (minflt pid) (nil t t))
+ (majflt "MajFlt" "%d" right proced-< nil (majflt pid) (nil t t))
+ (cminflt "CMinFlt" "%d" right proced-< nil (cminflt pid) (nil t t))
+ (cmajflt "CMajFlt" "%d" right proced-< nil (cmajflt pid) (nil t t))
+ (utime "UTime" proced-format-time right proced-time-lessp t (utime pid) (nil t t))
+ (stime "STime" proced-format-time right proced-time-lessp t (stime pid) (nil t t))
+ (time "Time" proced-format-time right proced-time-lessp t (time pid) (nil t t))
+ (cutime "CUTime" proced-format-time right proced-time-lessp t (cutime pid) (nil t t))
+ (cstime "CSTime" proced-format-time right proced-time-lessp t (cstime pid) (nil t t))
+ (ctime "CTime" proced-format-time right proced-time-lessp t (ctime pid) (nil t t))
+ (pri "Pr" "%d" right proced-< t (pri pid) (nil t t))
+ (nice "Ni" "%3d" 3 proced-< t (nice pid) (t t nil))
+ (thcount "THCount" "%d" right proced-< t (thcount pid) (nil t t))
+ (start "Start" proced-format-start 6 proced-time-lessp nil (start pid) (t t nil))
+ (vsize "VSize" "%d" right proced-< t (vsize pid) (nil t t))
(rss "RSS" "%d" right proced-< t (rss pid) (nil t t))
- (etime "ETIME" proced-format-time right proced-time-lessp t (etime pid) (nil t t))
+ (etime "ETime" proced-format-time right proced-time-lessp t (etime pid) (nil t t))
(pcpu "%CPU" "%.1f" right proced-< t (pcpu pid) (nil t t))
- (pmem "%MEM" "%.1f" right proced-< t (pmem pid) (nil t t))
- (args "ARGS" proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
+ (pmem "%Mem" "%.1f" right proced-< t (pmem pid) (nil t t))
+ (args "Args" proced-format-args left proced-string-lessp nil (args pid) (nil t nil))
;;
;; attributes defined by proced (see `proced-process-attributes')
(pid "PID" "%d" right proced-< nil (pid)
- ((lambda (ppid) (proced-filter-children proced-process-alist ppid)) .
+ ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
"refine to process children"))
- ;; time: sum of utime and stime
- (time "TIME" proced-format-time right proced-time-lessp t (time pid) (nil t t))
- ;; ctime: sum of cutime and cstime
- (ctime "CTIME" proced-format-time right proced-time-lessp t (ctime pid) (nil t t))
;; process tree
- (tree "TREE" proced-format-tree left nil nil nil nil))
+ (tree "Tree" proced-format-tree left nil nil nil nil))
"Alist of rules for handling Proced attributes.
Each element has the form
If PREDICATE yields 'equal, the process is accepted if EQUAL-B is non-nil.
If PREDICATE yields nil, the process is accepted if LARGER-B is non-nil.
-REFINER can also be a cons pair (FUNCTION . HELP-ECHO).
+REFINER can also be a list (FUNCTION HELP-ECHO).
FUNCTION is called with one argument, the PID of the process at the position
of point. The function must return a list of PIDs that is used for the refined
listing. HELP-ECHO is a string that is shown when mouse is over this field.
(repeat :tag "Sort Scheme" (symbol :tag "Key"))
(choice :tag "Refiner"
(const :tag "None" nil)
+ (list (function :tag "Refinement Function")
+ (string :tag "Help echo"))
(list :tag "Refine Flags"
(boolean :tag "Less")
(boolean :tag "Equal")
- (boolean :tag "Larger"))
- (cons (function :tag "Refinement Function")
- (string :tag "Help echo"))))))
+ (boolean :tag "Larger"))))))
(defcustom proced-custom-attributes nil
"List of functions defining custom attributes.
This variable extends the functionality of `proced-process-attributes'.
Each function is called with one argument, the list of attributes
of a system process. It returns a cons cell of the form (KEY . VALUE)
-like `system-process-attributes'. This cons cell is appended to the list
+like `process-attributes'. This cons cell is appended to the list
returned by `proced-process-attributes'.
If the function returns nil, the value is ignored."
:group 'proced
;; FIXME: is there a better name for filter `user' that does not coincide
;; with an attribute key?
(defcustom proced-filter-alist
- `((user (user . ,(concat "\\`" (user-real-login-name) "\\'")))
- (user-running (user . ,(concat "\\`" (user-real-login-name) "\\'"))
+ `((user (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'")))
+ (user-running (user . ,(concat "\\`" (regexp-quote (user-real-login-name)) "\\'"))
(state . "\\`[Rr]\\'"))
(all)
(all-running (state . "\\`[Rr]\\'"))
:group 'proced
:type '(choice (symbol :tag "Sort Scheme")
(repeat :tag "Key List" (symbol :tag "Key"))))
-(make-variable-buffer-local 'proced-format)
+(make-variable-buffer-local 'proced-sort)
(defcustom proced-descend t
"Non-nil if proced listing is sorted in descending order."
:type 'boolean)
(make-variable-buffer-local 'proced-tree-flag)
+(defcustom proced-post-display-hook nil
+ "Normal hook run after displaying or updating a Proced buffer.
+May be used to adapt the window size via `fit-window-to-buffer'."
+ :type 'hook
+ :options '(fit-window-to-buffer)
+ :group 'proced)
+
+(defcustom proced-after-send-signal-hook nil
+ "Normal hook run after sending a signal to processes by `proced-send-signal'.
+May be used to revert the process listing."
+ :type 'hook
+ :options '(proced-revert)
+ :group 'proced)
+
;; Internal variables
(defvar proced-available (not (null (list-system-processes)))
:group 'proced-faces)
(defface proced-marked
- '((t (:inherit font-lock-warning-face)))
+ '((t (:inherit error)))
"Face used for marked processes."
:group 'proced-faces)
(defvar proced-process-tree nil
"Proced process tree (internal variable).")
-(defvar proced-tree-indent nil
- "Internal variable for indentation of Proced process tree.")
+(defvar proced-tree-depth nil
+ "Internal variable for depth of Proced process tree.")
(defvar proced-auto-update-timer nil
"Stores if Proced auto update timer is already installed.")
;; marking
(define-key km "d" 'proced-mark) ; Dired compatibility ("delete")
(define-key km "m" 'proced-mark)
+ (put 'proced-mark :advertised-binding "m")
(define-key km "u" 'proced-unmark)
(define-key km "\177" 'proced-unmark-backward)
(define-key km "M" 'proced-mark-all)
(define-key km "x" 'proced-send-signal) ; Dired compatibility
(define-key km "k" 'proced-send-signal) ; kill processes
;; misc
- (define-key km "g" 'revert-buffer) ; Dired compatibility
(define-key km "h" 'describe-mode)
(define-key km "?" 'proced-help)
- (define-key km "q" 'quit-window)
(define-key km [remap undo] 'proced-undo)
(define-key km [remap advertised-undo] 'proced-undo)
+ ;; Additional keybindings are inherited from `special-mode-map'
km)
"Keymap for Proced commands.")
(defun proced-header-line ()
"Return header line for Proced buffer."
(list (propertize " " 'display '(space :align-to 0))
- (replace-regexp-in-string ;; preserve text properties
- "\\(%\\)" "\\1\\1" (substring proced-header-line (window-hscroll)))))
+ (if (<= (window-hscroll) (length proced-header-line))
+ (replace-regexp-in-string ;; preserve text properties
+ "\\(%\\)" "\\1\\1"
+ (substring proced-header-line (window-hscroll))))))
(defun proced-pid-at-point ()
"Return pid of system process at point.
;; proced mode
-(define-derived-mode proced-mode nil "Proced"
- "Mode for displaying UNIX system processes and sending signals to them.
+(define-derived-mode proced-mode special-mode "Proced"
+ "Mode for displaying system processes and sending signals to them.
Type \\[proced] to start a Proced session. In a Proced buffer
type \\<proced-mode-map>\\[proced-mark] to mark a process for later commands.
Type \\[proced-send-signal] to send signals to marked processes.
The attribute-specific rules for formatting, filtering, sorting, and refining
are defined in `proced-grammar-alist'.
+After displaying or updating a Proced buffer, Proced runs the normal hook
+`proced-post-display-hook'.
+
\\{proced-mode-map}"
(abbrev-mode 0)
(auto-fill-mode 0)
(run-at-time t proced-auto-update-interval
'proced-auto-update-timer))))
-;; Proced mode is suitable only for specially formatted data.
-(put 'proced-mode 'mode-class 'special)
-
;;;###autoload
(defun proced (&optional arg)
"Generate a listing of UNIX system processes.
If invoked with optional ARG the window displaying the process
information will be displayed but not selected.
+Runs the normal hook `proced-post-display-hook'.
See `proced-mode' for a description of features available in Proced buffers."
(interactive "P")
(let ((buffer (get-buffer-create "*Proced*")) new)
(set-buffer buffer)
(setq new (zerop (buffer-size)))
- (if new (proced-mode))
- (if (or new arg)
- (proced-update t))
+ (when new
+ (proced-mode)
+ ;; `proced-update' runs `proced-post-display-hook' only if the
+ ;; Proced buffer has been selected. Yet the following call of
+ ;; `proced-update' is for an empty Proced buffer that has not
+ ;; yet been selected. Therefore we need to call
+ ;; `proced-post-display-hook' below.
+ (proced-update t))
(if arg
- (display-buffer buffer)
+ (progn
+ (display-buffer buffer)
+ (with-current-buffer buffer
+ (proced-update t)))
(pop-to-buffer buffer)
+ (proced-update t)
(message
(substitute-command-keys
"Type \\<proced-mode-map>\\[quit-window] to quit, \\[proced-help] for help")))))
(message "Proced auto update %s"
(if proced-auto-update-flag "enabled" "disabled")))
+;;; Mark
+
(defun proced-mark (&optional count)
"Mark the current (or next COUNT) processes."
(interactive "p")
(proced-insert-mark mark backward))
(proced-move-to-goal-column)))
+(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-char (point-min))
+ (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)))
+
(defun proced-mark-all ()
"Mark all processes.
If `transient-mark-mode' is turned on and the region is active,
"Mark all processes using MARK.
If `transient-mark-mode' is turned on and the region is active,
mark the region."
- (let ((count 0) end buffer-read-only)
+ (let* ((count 0)
+ (proced-marker-char (if mark proced-marker-char ?\s))
+ (marker-re (proced-marker-regexp))
+ end buffer-read-only)
(save-excursion
(if (use-region-p)
;; Operate even on those lines that are only partially a part
(goto-char (point-min))
(setq end (point-max)))
(while (< (point) end)
- (setq count (1+ count))
- (proced-insert-mark mark))
- (proced-success-message "Marked" count))))
-
-(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-char (point-min))
- (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)))
+ (unless (looking-at marker-re)
+ (setq count (1+ count))
+ (insert proced-marker-char)
+ (delete-char 1))
+ (forward-line))
+ (proced-success-message (if mark "Marked" "Unmarked") count))))
(defun proced-mark-children (ppid &optional omit-ppid)
"Mark child processes of process PPID.
(if proced-tree-flag
;; add tree attribute
(let ((process-tree (proced-process-tree process-alist))
- (proced-tree-indent 0)
+ (proced-tree-depth 0)
(proced-temp-alist process-alist)
proced-process-tree pt)
(while (setq pt (pop process-tree))
"Helper function for `proced-tree'."
(let ((pprocess (assq (car process-tree) proced-temp-alist)))
(push (append (list (car pprocess))
- (list (cons 'tree proced-tree-indent))
+ (list (cons 'tree proced-tree-depth))
(cdr pprocess))
proced-process-tree)
(if (cdr process-tree)
- (let ((proced-tree-indent (1+ proced-tree-indent)))
+ (let ((proced-tree-depth (1+ proced-tree-depth)))
(mapc 'proced-tree-insert (cdr process-tree))))))
;; Refining
(proced-sort-interactive key arg)
(message "No sorter defined here."))))))
-;;; Formating
+;;; Formatting
(defun proced-format-time (time)
"Format time interval TIME."
(let ((standard-attributes
(car (proced-process-attributes (list (emacs-pid)))))
new-format fmi)
- (if proced-tree-flag (push (cons 'tree 0) standard-attributes))
+ (if (and proced-tree-flag
+ (assq 'ppid standard-attributes))
+ (push (cons 'tree 0) standard-attributes))
(dolist (fmt format)
(if (symbolp fmt)
(if (assq fmt standard-attributes)
(cond ((functionp (car refiner))
`(proced-key ,key mouse-face highlight
help-echo ,(format "mouse-2, RET: %s"
- (cdr refiner))))
+ (nth 1 refiner))))
((consp refiner)
`(proced-key ,key mouse-face highlight
help-echo ,(format "mouse-2, RET: refine by attribute %s %s"
the process is ignored."
;; Should we make it customizable whether processes with empty attribute
;; lists are ignored? When would such processes be of interest?
- (let (process-alist attributes)
+ (let (process-alist attributes attr)
(dolist (pid (or pid-list (list-system-processes)) process-alist)
- (when (setq attributes (system-process-attributes pid))
- (let ((utime (cdr (assq 'utime attributes)))
- (stime (cdr (assq 'stime attributes)))
- (cutime (cdr (assq 'cutime attributes)))
- (cstime (cdr (assq 'cstime attributes)))
- attr)
- (setq attributes
- (append (list (cons 'pid pid))
- (if (and utime stime)
- (list (cons 'time (time-add utime stime))))
- (if (and cutime cstime)
- (list (cons 'ctime (time-add cutime cstime))))
- attributes))
- (dolist (fun proced-custom-attributes)
- (if (setq attr (funcall fun attributes))
- (push attr attributes)))
- (push (cons pid attributes) process-alist))))))
+ (when (setq attributes (process-attributes pid))
+ (setq attributes (cons (cons 'pid pid) attributes))
+ (dolist (fun proced-custom-attributes)
+ (if (setq attr (funcall fun attributes))
+ (push attr attributes)))
+ (push (cons pid attributes) process-alist)))))
(defun proced-update (&optional revert quiet)
"Update the Proced process information. Preserves point and marks.
With prefix REVERT non-nil, revert listing.
-Suppress status information if QUIET is nil."
+Suppress status information if QUIET is nil.
+After updating a displayed Proced buffer run the normal hook
+`proced-post-display-hook'."
;; This is the main function that generates and updates the process listing.
(interactive "P")
(setq revert (or revert (not proced-process-alist)))
(nth 1 grammar)))
"")))
(force-mode-line-update)
+ ;; run `proced-post-display-hook' only for a displayed buffer.
+ (if (get-buffer-window) (run-hooks 'proced-post-display-hook))
;; done
(or quiet (input-pending-p)
(message (if revert "Updating process information...done."
"Updating process display...done.")))))
-(defun proced-revert (&rest args)
+(defun proced-revert (&rest _args)
"Reevaluate the process listing based on the currently running processes.
Preserves point and marks."
(proced-update t))
-;; I do not want to reinvent the wheel. Should we rename `dired-pop-to-buffer'
-;; and move it to window.el so that proced and ibuffer can easily use it, too?
-;; What about functions like `appt-disp-window' that use
-;; `shrink-window-if-larger-than-buffer'?
-(autoload 'dired-pop-to-buffer "dired")
-
(defun proced-send-signal (&optional signal)
"Send a SIGNAL to the marked processes.
If no process is marked, operate on current process.
SIGNAL may be a string (HUP, INT, TERM, etc.) or a number.
-If SIGNAL is nil display marked processes and query interactively for SIGNAL."
+If SIGNAL is nil display marked processes and query interactively for SIGNAL.
+After sending the signal, this command runs the normal hook
+`proced-after-send-signal-hook'."
(interactive)
(let ((regexp (proced-marker-regexp))
process-alist)
(while (re-search-forward regexp nil t)
(push (cons (proced-pid-at-point)
;; How much info should we collect here?
- (substring (match-string-no-properties 0) 2))
+ (buffer-substring-no-properties
+ (+ 2 (line-beginning-position))
+ (line-end-position)))
process-alist)))
(setq process-alist
(if process-alist
(line-end-position))))))
(unless signal
;; Display marked processes (code taken from `dired-mark-pop-up').
- (let ((bufname " *Marked Processes*")
+ (let ((bufname " *Marked Processes*") ; use leading space in buffer name
+ ; to make this buffer ephemeral
(header-line (substring-no-properties proced-header-line)))
(with-current-buffer (get-buffer-create bufname)
(setq truncate-lines t
proced-header-line header-line ; inherit header line
header-line-format '(:eval (proced-header-line)))
(add-hook 'post-command-hook 'force-mode-line-update nil t)
- (erase-buffer)
- (dolist (process process-alist)
- (insert " " (cdr process) "\n"))
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (buffer-disable-undo)
+ (setq buffer-read-only t)
+ (dolist (process process-alist)
+ (insert " " (cdr process) "\n"))
+ (delete-char -1)
+ (goto-char (point-min)))
(save-window-excursion
- (dired-pop-to-buffer bufname) ; all we need
+ ;; Analogous to `dired-pop-to-buffer'
+ ;; Don't split window horizontally. (Bug#1806)
+ (let (split-width-threshold)
+ (pop-to-buffer (current-buffer)))
+ (fit-window-to-buffer (get-buffer-window) nil 1)
(let* ((completion-ignore-case t)
(pnum (if (= 1 (length process-alist))
"1 process"
(format "%d processes" (length process-alist))))
- ;; 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)
- failures)
- ;; Why not always use `signal-process'? See
- ;; http://lists.gnu.org/archive/html/emacs-devel/2008-03/msg02955.html
- (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 process-alist)
- (condition-case err
- (if (zerop (funcall
- proced-signal-function (car process) signal))
- (setq count (1+ count))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures))
- (error ;; catch errors from failed signals
- (proced-log "%s\n" err)
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures)))))
- ;; use external system call
- (let ((signal (concat "-" (if (numberp signal)
- (number-to-string signal) signal))))
+ (completion-extra-properties
+ '(:annotation-function
+ (lambda (s) (cdr (assoc s proced-signal-list))))))
+ (setq signal
+ (completing-read (concat "Send signal [" pnum
+ "] (default TERM): ")
+ proced-signal-list
+ nil nil nil nil "TERM")))))))
+ ;; send signal
+ (let ((count 0)
+ failures)
+ ;; Why not always use `signal-process'? See
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2008-03/msg02955.html
+ (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 process-alist)
- (with-temp-buffer
- (condition-case err
- (if (zerop (call-process
- proced-signal-function nil t nil
- signal (number-to-string (car process))))
- (setq count (1+ count))
- (proced-log (current-buffer))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures))
- (error ;; catch errors from failed signals
- (proced-log (current-buffer))
- (proced-log "%s\n" (cdr process))
- (push (cdr process) failures)))))))
- (if failures
- ;; Proced error message are not always very precise.
- ;; Can we issue a useful one-line summary in the
- ;; message area (using FAILURES) if only one signal failed?
- (proced-log-summary
- signal
- (format "%d of %d signal%s failed"
- (length failures) (length process-alist)
- (if (= 1 (length process-alist)) "" "s")))
- (proced-success-message "Sent signal to" count)))
- ;; final clean-up
- (run-hooks 'proced-after-send-signal-hook))))
+ (condition-case err
+ (if (zerop (funcall
+ proced-signal-function (car process) signal))
+ (setq count (1+ count))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures))
+ (error ; catch errors from failed signals
+ (proced-log "%s\n" err)
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures)))))
+ ;; use external system call
+ (let ((signal (concat "-" (if (numberp signal)
+ (number-to-string signal) signal))))
+ (dolist (process process-alist)
+ (with-temp-buffer
+ (condition-case nil
+ (if (zerop (call-process
+ proced-signal-function nil t nil
+ signal (number-to-string (car process))))
+ (setq count (1+ count))
+ (proced-log (current-buffer))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures))
+ (error ; catch errors from failed signals
+ (proced-log (current-buffer))
+ (proced-log "%s\n" (cdr process))
+ (push (cdr process) failures)))))))
+ (if failures
+ ;; Proced error message are not always very precise.
+ ;; Can we issue a useful one-line summary in the
+ ;; message area (using FAILURES) if only one signal failed?
+ (proced-log-summary
+ signal
+ (format "%d of %d signal%s failed"
+ (length failures) (length process-alist)
+ (if (= 1 (length process-alist)) "" "s")))
+ (proced-success-message "Sent signal to" count)))
+ ;; final clean-up
+ (run-hooks 'proced-after-send-signal-hook)))
;; similar to `dired-why'
(defun proced-why ()
(provide 'proced)
-;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
;;; proced.el ends here
HCoop / bpt / emacs.git / blobdiff