X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/0d9f702fd085bc8ad560a3e1f08d5e93054a5d33..7e09ef09a479731d01b1ca46e94ddadd73ac98e3:/lisp/proced.el diff --git a/lisp/proced.el b/lisp/proced.el index c6c7dfd89e..69355ab044 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -1,6 +1,6 @@ ;;; proced.el --- operate on system processes like dired -;; Copyright (C) 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ;; Author: Roland Winkler ;; Keywords: Processes, Unix @@ -28,8 +28,11 @@ ;; listed. See `proced-mode' for getting started. ;; ;; To do: -;; - interactive temporary customizability of flags in `proced-grammar-alist' -;; - allow "sudo kill PID", "renice PID" +;; - Interactive temporary customizability of flags in `proced-grammar-alist' +;; - Allow "sudo kill PID", "sudo renice PID" +;; `proced-send-signal' operates on multiple processes one by one. +;; With "sudo" we want to execute one "kill" or "renice" command +;; for all marked processes. Is there a `sudo-call-process'? ;; ;; Thoughts and Ideas ;; - Currently, `process-attributes' returns the list of @@ -46,8 +49,6 @@ ;;; Code: -(require 'time-date) ; for `with-decoded-time-value' - (defgroup proced nil "Proced mode." :group 'processes @@ -62,6 +63,12 @@ the external command (usually \"kill\")." :type '(choice (function :tag "function") (string :tag "command"))) +(defcustom proced-renice-command "renice" + "Name of renice command." + :group 'proced + :version "24.3" + :type '(string :tag "command")) + (defcustom proced-signal-list '( ;; signals supported on all POSIX compliant systems ("HUP" . " (1. Hangup)") @@ -395,7 +402,7 @@ It is a list of lists (KEY PREDICATE REVERSE).") :group 'proced-faces) (defface proced-marked - '((t (:inherit font-lock-warning-face))) + '((t (:inherit error))) "Face used for marked processes." :group 'proced-faces) @@ -491,6 +498,7 @@ Important: the match ends just after the marker.") (define-key km "o" 'proced-omit-processes) (define-key km "x" 'proced-send-signal) ; Dired compatibility (define-key km "k" 'proced-send-signal) ; kill processes + (define-key km "r" 'proced-renice) ; renice processes ;; misc (define-key km "h" 'describe-mode) (define-key km "?" 'proced-help) @@ -561,8 +569,11 @@ Important: the match ends just after the marker.") :style toggle :selected (eval proced-auto-update-flag) :help "Auto Update of Proced Buffer"] + "--" ["Send signal" proced-send-signal - :help "Send Signal to Marked Processes"])) + :help "Send Signal to Marked Processes"] + ["Renice" proced-renice + :help "Renice Marked Processes"])) ;; helper functions (defun proced-marker-regexp () @@ -659,11 +670,14 @@ After displaying or updating a Proced buffer, Proced runs the normal hook ;;;###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'. +\\ +If invoked with optional ARG, do not select the window displaying +the process information. -See `proced-mode' for a description of features available in Proced buffers." +This function runs the normal hook `proced-post-display-hook'. + +See `proced-mode' for a description of features available in +Proced buffers." (interactive "P") (unless proced-available (error "Proced is not available on this system")) @@ -1170,15 +1184,8 @@ Return nil otherwise." (defun proced-time-lessp (t1 t2) "Return t if time value T1 is less than time value T2. Return `equal' if T1 equals T2. Return nil otherwise." - (with-decoded-time-value ((high1 low1 micro1 t1) - (high2 low2 micro2 t2)) - (cond ((< high1 high2)) - ((< high2 high1) nil) - ((< low1 low2)) - ((< low2 low1) nil) - ((< micro1 micro2)) - ((< micro2 micro1) nil) - (t 'equal)))) + (or (time-less-p t1 t2) + (if (not (time-less-p t2 t1)) 'equal))) ;;; Sorting @@ -1332,7 +1339,7 @@ Prefix ARG controls sort order, see `proced-sort-interactive'." (proced-sort-interactive key arg) (message "No sorter defined here.")))))) -;;; Formating +;;; Formatting (defun proced-format-time (time) "Format time interval TIME." @@ -1651,8 +1658,8 @@ After updating a displayed Proced buffer run the normal hook (goto-char new-pos) (goto-char (point-min)) (proced-move-to-goal-column))) - ;; update modeline - ;; Does the long `mode-name' clutter the modeline? It would be nice + ;; update mode line + ;; Does the long `mode-name' clutter the mode line? It would be nice ;; to have some other location for displaying the values of the various ;; flags that affect the behavior of proced (flags one might want ;; to change on the fly). Where?? @@ -1676,19 +1683,16 @@ After updating a displayed Proced buffer run the normal hook (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)) -(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. -After sending the signal, this command runs the normal hook -`proced-after-send-signal-hook'." - (interactive) +(defun proced-marked-processes () + "Return marked processes as alist of PIDs. +If no process is marked return alist with the PID of the process point is on. +The cdrs of the alist are the text strings displayed by Proced for these +processes. They are used for error messages." (let ((regexp (proced-marker-regexp)) process-alist) ;; collect marked processes @@ -1701,99 +1705,183 @@ After sending the signal, this command runs the normal hook (+ 2 (line-beginning-position)) (line-end-position))) process-alist))) - (setq process-alist - (if process-alist - (nreverse process-alist) - ;; take current process - (list (cons (proced-pid-at-point) + (if process-alist + (nreverse process-alist) + ;; take current process + (let ((pid (proced-pid-at-point))) + (if pid + (list (cons pid (buffer-substring-no-properties (+ 2 (line-beginning-position)) - (line-end-position)))))) + (line-end-position))))))))) + +(defmacro proced-with-processes-buffer (process-alist &rest body) + "Execute the forms in BODY in a temporary buffer displaying PROCESS-ALIST. +PROCESS-ALIST is an alist of process PIDs as in `proced-process-alist'. +The value returned is the value of the last form in BODY." + (declare (indent 1) (debug t)) + ;; Use leading space in buffer name to make this buffer ephemeral + `(let ((bufname " *Marked Processes*") + (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) + (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 + ;; 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) + ,@body)))) + +(defun proced-send-signal (&optional signal process-alist) + "Send a SIGNAL to processes in PROCESS-ALIST. +PROCESS-ALIST is an alist as returned by `proced-marked-processes'. +Interactively, PROCESS-ALIST contains the marked processes. +If no process is marked, it contains the process point is on, +SIGNAL may be a string (HUP, INT, TERM, etc.) or a number. +After sending SIGNAL to all processes in PROCESS-ALIST, this command +runs the normal hook `proced-after-send-signal-hook'. + +For backward compatibility SIGNAL and PROCESS-ALIST may be nil. +Then PROCESS-ALIST contains the marked processes or the process point is on +and SIGNAL is queried interactively. This noninteractive usage is still +supported but discouraged. It will be removed in a future version of Emacs." + (interactive + (let* ((process-alist (proced-marked-processes)) + (pnum (if (= 1 (length process-alist)) + "1 process" + (format "%d processes" (length process-alist)))) + (completion-ignore-case t) + (completion-extra-properties + '(:annotation-function + (lambda (s) (cdr (assoc s proced-signal-list)))))) + (proced-with-processes-buffer process-alist + (list (completing-read (concat "Send signal [" pnum + "] (default TERM): ") + proced-signal-list + nil nil nil nil "TERM") + process-alist)))) + + (unless (and signal process-alist) + ;; Discouraged usage (supported for backward compatibility): + ;; The new calling sequence separates more cleanly between the parts + ;; of the code required for interactive and noninteractive calls so that + ;; the command can be used more flexibly in noninteractive ways, too. + (unless (get 'proced-send-signal 'proced-outdated) + (put 'proced-send-signal 'proced-outdated t) + (message "Outdated usage of `proced-send-signal'") + (sit-for 2)) + (setq process-alist (proced-marked-processes)) (unless signal - ;; Display marked processes (code taken from `dired-mark-pop-up'). - (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) - (let ((inhibit-read-only t)) - (erase-buffer) - (buffer-disable-undo) - (setq buffer-read-only t) - (dolist (process process-alist) - (insert " " (cdr process) "\n"))) - (save-window-excursion - ;; 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)))) - (completion-annotate-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) - (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)))) + (let ((pnum (if (= 1 (length process-alist)) + "1 process" + (format "%d processes" (length process-alist)))) + (completion-ignore-case t) + (completion-extra-properties + '(:annotation-function + (lambda (s) (cdr (assoc s proced-signal-list)))))) + (proced-with-processes-buffer process-alist + (setq signal (completing-read (concat "Send signal [" pnum + "] (default TERM): ") + proced-signal-list + nil nil nil nil "TERM")))))) + + (let (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 + (unless (zerop (funcall + proced-signal-function (car process) signal)) + (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 (format "-%s" signal))) + (dolist (process process-alist) + (with-temp-buffer + (condition-case nil + (unless (zerop (call-process + proced-signal-function nil t nil + signal (number-to-string (car process)))) + (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 + (format "Signal %s" 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" (length process-alist)))) + ;; final clean-up + (run-hooks 'proced-after-send-signal-hook)) + +(defun proced-renice (priority process-alist) + "Renice the processes in PROCESS-ALIST to PRIORITY. +PROCESS-ALIST is an alist as returned by `proced-marked-processes'. +Interactively, PROCESS-ALIST contains the marked processes. +If no process is marked, it contains the process point is on, +After renicing all processes in PROCESS-ALIST, this command runs +the normal hook `proced-after-send-signal-hook'." + (interactive + (let ((process-alist (proced-marked-processes))) + (proced-with-processes-buffer process-alist + (list (read-number "New priority: ") + process-alist)))) + (if (numberp priority) + (setq priority (number-to-string priority))) + (let (failures) + (dolist (process process-alist) + (with-temp-buffer + (condition-case nil + (unless (zerop (call-process + proced-renice-command nil t nil + priority (number-to-string (car process)))) + (proced-log (current-buffer)) + (proced-log "%s\n" (cdr process)) + (push (cdr process) failures)) + (error ; catch errors from failed renice + (proced-log (current-buffer)) + (proced-log "%s\n" (cdr process)) + (push (cdr process) failures))))) + (if failures + (proced-log-summary + (format "Renice %s" priority) + (format "%d of %d renice%s failed" + (length failures) (length process-alist) + (if (= 1 (length process-alist)) "" "s"))) + (proced-success-message "Reniced" (length process-alist)))) + ;; final clean-up + (run-hooks 'proced-after-send-signal-hook)) ;; similar to `dired-why' (defun proced-why () @@ -1868,16 +1956,6 @@ buffer. You can use it to recover marks." (message "Change in Proced buffer undone. Killed processes cannot be recovered by Emacs.")) -(defun proced-unload-function () - "Unload the Proced library." - (save-current-buffer - (dolist (buf (buffer-list)) - (set-buffer buf) - (when (eq major-mode 'proced-mode) - (funcall (or (default-value 'major-mode) 'fundamental-mode))))) - ;; continue standard unloading - nil) - (provide 'proced) ;;; proced.el ends here