From bc7be45dbd90145b9bc76dbff349bf51a8315211 Mon Sep 17 00:00:00 2001 From: Roland Winkler Date: Sun, 23 Sep 2012 07:34:23 -0500 Subject: [PATCH] lisp/proced.el: new command proced-renice --- etc/NEWS | 2 + lisp/proced.el | 296 ++++++++++++++++++++++++++++++++----------------- 2 files changed, 195 insertions(+), 103 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index dc60aaa138..5595fafd37 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -411,6 +411,8 @@ server properties. ** In Perl mode, new option `perl-indent-parens-as-block' causes non-block closing brackets to be aligned with the line of the opening bracket. +** In Proced mode, new command `proced-renice' renices selected processes. + ** Python mode A new version of python.el, which provides several new features, including: diff --git a/lisp/proced.el b/lisp/proced.el index d98bf7d2c5..be6cae2ef0 100644 --- a/lisp/proced.el +++ b/lisp/proced.el @@ -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 @@ -62,6 +65,11 @@ the external command (usually \"kill\")." :type '(choice (function :tag "function") (string :tag "command"))) +(defcustom proced-renice-command "renice" + "Name of renice command." + :group 'proced + :type '(string :tag "command")) + (defcustom proced-signal-list '( ;; signals supported on all POSIX compliant systems ("HUP" . " (1. Hangup)") @@ -491,6 +499,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 +570,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 () @@ -1686,14 +1698,11 @@ After updating a displayed Proced buffer run the normal hook 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 @@ -1706,102 +1715,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 usge (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")) - (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) - (let* ((completion-ignore-case t) - (pnum (if (= 1 (length process-alist)) - "1 process" - (format "%d processes" (length process-alist)))) - (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) - (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 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))) + (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 () -- 2.20.1