# HG changeset patch # User Roland Winkler # Date 1211278635 0 # Node ID 33ea0b47d33647d072caf6c7497a584e60939cc9 # Parent 72e820e4f87dee38ea89b3a91f174bbb71a1af5d (proced-goal-header-re): Renamed from proced-procname-column-regexp. (proced-goal-column): Renamed from proced-procname-column. (proced-move-to-goal-column): Renamed from proced-move-to-procname. (proced-header-face, proced-header-regexp): Removed. (proced-font-lock-keywords): Remove proced-header-face. (proced-header-alist, proced-sorting-schemes-re): New variables. (proced): Rename Proced buffer to *Proced*. (proced-next-line, proced-previous-line): New commands. (proced-do-mark, proced-do-mark-all, proced-toggle-marks) (proced-hide-processes): Do not treat first line as special. (proced-header-space): New function. (proced-update): Use header-line-format. Initialize proced-header-alist and proced-sorting-schemes-re. Set proced-goal-column. Include proced-command in mode-name. (proced-send-signal): Use header-line-format for *Marked Processes* buffer. (proced-sort): Restrict minibuffer completion to applicable sorting schemes. (proced-sorting-scheme-p): Use proced-sorting-schemes-re. diff -r 72e820e4f87d -r 33ea0b47d336 lisp/proced.el --- a/lisp/proced.el Tue May 20 10:14:38 2008 +0000 +++ b/lisp/proced.el Tue May 20 10:17:15 2008 +0000 @@ -28,6 +28,10 @@ ;; on the processes listed. ;; ;; To do: +;; - decompose ps(1) output into columns (for `proced-header-alist') +;; How can we identify columns that may contain whitespace +;; and that can be either right or left justified? +;; Use a "grammar table"? ;; - sort the "cooked" values used in the output format fields ;; if ps(1) doesn't support the requested sorting scheme ;; - filter by user name or other criteria @@ -41,12 +45,8 @@ :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"))) - +;; FIXME: a better approach instead of PID-COLUMN would be based +;; on `proced-header-alist' once we have a reliable scheme to set this variable (defcustom proced-command-alist (cond ((memq system-type '(berkeley-unix)) '(("user" ("ps" "-uxgww") 2) @@ -81,7 +81,18 @@ (repeat (string :tag "option"))) (integer :tag "PID column")))) -;; Should we incorporate in NAME if sorting is done in descending order? +(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) + +;; Should we incorporate in NAME that sorting can be done in ascending +;; or descending order? Then we couldn't associate NAME anymore with one +;; of the headers in the output of ps(1). +;; FIXME: A sorting scheme without options or with an option being a symbol +;; should be implemented in elisp (defcustom proced-sorting-schemes-alist (cond ((memq system-type '(gnu gnu/linux)) ; GNU long options '(("%CPU" "--sort" "-pcpu") ; descending order @@ -100,8 +111,9 @@ ("VSZ,PID" "--sort" "vsz,pid")))) "Alist of sorting schemes. Each element is a list (NAME OPTION1 OPTION2 ...). -NAME denotes the sorting scheme and OPTION1, OPTION2, ... are options -defining the sorting scheme." +NAME denotes the sorting scheme. It is the name of a header or a +comma-separated sequence of headers in the output of ps(1). +OPTION1, OPTION2, ... are options defining the sorting scheme." :group 'proced :type '(repeat (cons (string :tag "name") (repeat (string :tag "option"))))) @@ -116,12 +128,11 @@ proced-sorting-schemes-alist)))) (make-variable-buffer-local 'proced-sorting-scheme) -(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'." +(defcustom proced-goal-header-re "\\b\\(CMD\\|COMMAND\\)\\b" + "If non-nil, regexp that defines the `proced-goal-column'." :group 'proced - :type '(string :tag "name")) -(make-variable-buffer-local 'proced-command) + :type '(choice (const :tag "none" nil) + (regexp :tag "regexp"))) (defcustom proced-signal-function 'signal-process "Name of signal function. @@ -143,6 +154,7 @@ :group 'proced :type '(repeat (string :tag "signal"))) +;; Internal variables (defvar proced-marker-char ?* ; the answer is 42 "In proced, the current mark character.") @@ -152,13 +164,6 @@ :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." @@ -177,54 +182,56 @@ "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-goal-column nil + "Proced goal column. Initialized based on `proced-goal-header-re'.") +(make-variable-buffer-local 'proced-goal-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))))) + '(".+" (proced-move-to-goal-column) 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) + ;; moving + (define-key km " " 'proced-next-line) + (define-key km "n" 'proced-next-line) + (define-key km "p" 'proced-previous-line) + (define-key km "\C-n" 'proced-next-line) + (define-key km "\C-p" 'proced-previous-line) + (define-key km "\C-?" 'proced-previous-line) + (define-key km [down] 'proced-next-line) + (define-key km [up] 'proced-previous-line) + ;; marking (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 "M" 'proced-mark-all) (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) + ;; sorting (define-key km "sc" 'proced-sort-pcpu) (define-key km "sm" 'proced-sort-pmem) (define-key km "sp" 'proced-sort-pid) (define-key km "ss" 'proced-sort-start) (define-key km "sS" 'proced-sort) (define-key km "st" 'proced-sort-time) + ;; operate + (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 + ;; misc + (define-key km "l" 'proced-listing-type) + (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) km) @@ -256,24 +263,40 @@ "(n)ext, (p)revious, (m)ark, (u)nmark, (k)ill, (q)uit (type ? for more help)" "Help string for proced.") +(defvar proced-header-alist nil + "Alist of headers in Proced buffer. +Each element is of the form (NAME START END JUSTIFY). +NAME is name of header in the output of ps(1). +START and END are column numbers starting from 0. +END is t if there is no end column for that field. +JUSTIFY is 'left or 'right for left or right-justified output of ps(1).") +(make-variable-buffer-local 'proced-header-alist) + +(defvar proced-sorting-schemes-re nil + "Regexp to match valid sorting schemes.") +(make-variable-buffer-local 'proced-sorting-schemes-re) + +;; helper functions (defun proced-marker-regexp () "Return regexp matching `proced-marker-char'." + ;; `proced-marker-char' must appear in column zero (concat "^" (regexp-quote (char-to-string proced-marker-char)))) (defun proced-success-message (action count) "Display success message for ACTION performed for COUNT processes." (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." +(defun proced-move-to-goal-column () + "Move to `proced-goal-column' if non-nil." (beginning-of-line) - (if proced-procname-column - (forward-char proced-procname-column) + (if proced-goal-column + (forward-char proced-goal-column) (forward-char 2))) +;; FIXME: a better approach would be based on `proced-header-alist' +;; once we have a reliable scheme to set this variable (defsubst proced-skip-regexp () - "Regexp to skip in process listing." + "Regexp to skip in process listing to find PID column." (apply 'concat (make-list (1- (nth 2 (assoc proced-command proced-command-alist))) "\\s-+\\S-+"))) @@ -306,7 +329,7 @@ \\{proced-mode-map}" (interactive "P") - (let ((buffer (get-buffer-create "*Process Info*")) new) + (let ((buffer (get-buffer-create "*Proced*")) new) (set-buffer buffer) (setq new (zerop (buffer-size))) (if new (proced-mode)) @@ -320,6 +343,20 @@ (message (substitute-command-keys "type \\[quit-window] to quit, \\[proced-help] for help"))))) +(defun proced-next-line (arg) + "Move down lines then position at `proced-goal-column'. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (next-line arg) + (proced-move-to-goal-column)) + +(defun proced-previous-line (arg) + "Move up lines then position at `proced-goal-column'. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (previous-line arg) + (proced-move-to-goal-column)) + (defun proced-mark (&optional count) "Mark the current (or next COUNT) processes." (interactive "p") @@ -341,16 +378,13 @@ "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)))) + (setq count (1+ (if (<= 0 count) count + (min (1- (line-number-at-pos)) (abs count))))) + (beginning-of-line) + (while (not (or (zerop (setq count (1- count))) (eobp))) + (proced-insert-mark mark backward)) + (proced-move-to-goal-column))) (defun proced-mark-all () "Mark all processes." @@ -366,7 +400,7 @@ "Mark all processes using MARK." (let (buffer-read-only) (save-excursion - (goto-line 2) + (goto-char (point-min)) (while (not (eobp)) (proced-insert-mark mark))))) @@ -376,7 +410,7 @@ (let ((mark-re (proced-marker-regexp)) buffer-read-only) (save-excursion - (goto-line 2) + (goto-char (point-min)) (while (not (eobp)) (cond ((looking-at mark-re) (proced-insert-mark nil)) @@ -411,26 +445,22 @@ (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))))) + (delete-region (line-beginning-position) + (save-excursion + (if (<= 0 arg) + (setq count (- arg (forward-line arg))) + (setq count (min (1- (line-number-at-pos)) + (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)) + (unless (zerop count) (proced-move-to-goal-column)) + (unless quiet (proced-success-message "Hid" count)) count)) (defun proced-listing-type (command) @@ -440,6 +470,11 @@ (setq proced-command command) (proced-update)) +;; adopted from `ruler-mode-space' +(defsubst proced-header-space (width) + "Return a single space string of WIDTH times the normal character width." + (propertize " " 'display (list 'space :width width))) + (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. @@ -452,12 +487,12 @@ (looking-at (concat "^[* ]" regexp))) (cons (match-string-no-properties 1) (current-column)))) - buffer-read-only plist) + buffer-read-only mp-list) (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)) + (match-string-no-properties 1)) mp-list)) ;; generate new listing (erase-buffer) (apply 'call-process (car command) nil t nil @@ -471,25 +506,55 @@ (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)))) + (let ((lep (line-end-position))) + ;; header line: code inspired by `ruler-mode-ruler' + (setq header-line-format + (list "" (if (eq 'left (car (window-current-scroll-bars))) + (proced-header-space 'scroll-bar)) + (proced-header-space 'left-fringe) + (proced-header-space 'left-margin) + (replace-regexp-in-string + "%" "%%" (buffer-substring-no-properties (point) lep)))) + (setq proced-header-alist nil) + ;; FIXME: handle left/right justification properly + (while (re-search-forward "\\([^ \t\n]+\\)[ \t]*\\($\\)?" lep t) + (push (list (match-string-no-properties 1) + ;; take the column number starting from zero + (1- (match-beginning 0)) (or (not (not (match-beginning 2))) + (1- (match-end 0))) + 'left) + proced-header-alist))) + (let ((temp (regexp-opt (mapcar 'car proced-header-alist) t))) + (setq proced-sorting-schemes-re + (concat "\\`" temp "\\(," temp "\\)*\\'"))) + ;; remove header line from ps(1) output + (goto-char (point-min)) + (delete-region (point) + (save-excursion (forward-line) (point))) + (set-buffer-modified-p nil) + ;; set `proced-goal-column' + (if proced-goal-header-re + (let ((hlist proced-header-alist) header) + (while (setq header (pop hlist)) + (if (string-match proced-goal-header-re (car header)) + (setq proced-goal-column + (if (eq 'left (nth 3 header)) + (nth 1 header) (nth 2 header)) + hlist nil))))) ;; restore process marks - (if plist + (if mp-list (save-excursion - (goto-line 2) + (goto-char (point-min)) (let (mark) (while (re-search-forward (concat "^" regexp) nil t) - (if (setq mark (assoc (match-string-no-properties 1) plist)) + (if (setq mark (assoc (match-string-no-properties 1) mp-list)) (save-excursion (beginning-of-line) (insert (cdr mark)) (delete-char 1))))))) ;; restore buffer position (if possible) - (goto-line 2) + (goto-char (point-min)) (if (and old-pos (re-search-forward (concat "^[* ]" (proced-skip-regexp) "\\s-+" (car old-pos) "\\>") @@ -497,11 +562,13 @@ (progn (beginning-of-line) (forward-char (cdr old-pos))) - (proced-move-to-procname)) + (proced-move-to-goal-column)) ;; update modeline - (setq mode-name (if proced-sorting-scheme - (concat "Proced by " proced-sorting-scheme) - "Proced")) + ;; Does the long mode-name clutter the modeline? + (setq mode-name (concat "Proced: " proced-command + (if proced-sorting-scheme + (concat " by " proced-sorting-scheme) + ""))) (force-mode-line-update) ;; done (or quiet (input-pending-p) @@ -512,7 +579,9 @@ (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? +;; 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) @@ -522,7 +591,7 @@ (interactive) (let ((regexp (concat (proced-marker-regexp) (proced-skip-regexp) "\\s-+\\([0-9]+\\>\\).*$")) - plist) + process-list) ;; collect marked processes (save-excursion (goto-char (point-min)) @@ -532,29 +601,26 @@ ;; better to collect only the PID (to avoid ambiguities) ;; and the command name? (substring (match-string-no-properties 0) 2)) - plist))) - (setq plist (nreverse plist)) - (if (not plist) + process-list))) + (setq process-list (nreverse process-list)) + (if (not process-list) (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))))) + (header header-line-format)) ; reuse (with-current-buffer (get-buffer-create bufname) - (setq truncate-lines t) + (setq truncate-lines t + header-line-format header) (erase-buffer) - (insert header "\n") - (dolist (proc plist) - (insert (cdr proc) "\n")) + (dolist (process process-list) + (insert " " (cdr process) "\n")) (save-window-excursion (dired-pop-to-buffer bufname) ; all we need (let* ((completion-ignore-case t) - (pnum (if (= 1 (length plist)) + (pnum (if (= 1 (length process-list)) "1 process" - (format "%d processes" (length plist)))) + (format "%d processes" (length process-list)))) ;; The following is an ugly hack. Is there a better way ;; to help people like me to remember the signals and ;; their meanings? @@ -574,7 +640,7 @@ (string-to-number signal) (make-symbol signal)) signal))) ; number - (dolist (process plist) + (dolist (process process-list) (if (zerop (funcall proced-signal-function (string-to-number (car process)) signal)) @@ -583,7 +649,7 @@ ;; use external system call (let ((signal (concat "-" (if (numberp signal) (number-to-string signal) signal)))) - (dolist (process plist) + (dolist (process process-list) (if (zerop (call-process proced-signal-function nil 0 nil signal (car process))) @@ -610,7 +676,7 @@ (interactive) (let (buffer-read-only) (undo)) - (message "Change in proced buffer undone. + (message "Change in Proced buffer undone. Killed processes cannot be recovered by Emacs.")) ;;; Sorting @@ -619,20 +685,29 @@ When called interactively, an empty string means nil, i.e., no sorting." (interactive (list (let* ((completion-ignore-case t) + ;; restrict completion list to applicable sorting schemes + (completion-list + (apply 'append + (mapcar (lambda (x) + (if (string-match proced-sorting-schemes-re + (car x)) + (list (car x)))) + proced-sorting-schemes-alist))) (scheme (completing-read "Sorting type: " - proced-sorting-schemes-alist nil t))) + completion-list nil t))) (if (string= "" scheme) nil scheme)))) (if (proced-sorting-scheme-p scheme) (progn (setq proced-sorting-scheme scheme) (proced-update)) - (error "Proced sorting scheme %s undefined" scheme))) + (error "Proced sorting scheme %s not applicable" scheme))) (defun proced-sorting-scheme-p (scheme) "Return non-nil if SCHEME is an applicable sorting scheme. SCHEME must be a string or nil." (or (not scheme) - (assoc scheme proced-sorting-schemes-alist))) + (and (string-match proced-sorting-schemes-re scheme) + (assoc scheme proced-sorting-schemes-alist)))) (defun proced-sort-pcpu () "Sort Proced buffer by percentage CPU time (%CPU)."