emacs: lisp/proced.el comparison

comparison lisp/proced.el @ 100847:883cbe72dc04

(proced-grammar-alist): Refiner can be a list (function help-echo) instead of a cons pair. (proced-post-display-hook): New variable. (proced-tree-depth): Renamed from proced-tree-indent. (proced-mode): Derive mode from special-mode. (proced-mode-map): Changed accordingly. (proced, proced-update): Run proced-post-display-hook. (proced-do-mark-all): Count processes for which mark has been updated. (proced-format): Check for ppid attribute. (proced-process-attributes): Take time and ctime attribute from system-process-attributes. (proced-send-signal): Doc fix. Collect properly the info on marked processes. Use fit-window-to-buffer instead of dired-pop-to-buffer.

author	Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
date	Sat, 03 Jan 2009 12:18:53 +0000
parents	6a68c7a91e31
children	a9dc0e7c3f2b

comparison

equal deleted inserted replaced

-:d74b83c02d95
+:883cbe72dc04
 (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))
 (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))
 (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))
 (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))
 (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))
 "Alist of rules for handling Proced attributes.
 Each element has the form
 using PREDICATE.
 If PREDICATE yields non-nil, the process is accepted if LESS-B is non-nil.
 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.
 If REFINER is nil no refinement is done."
 (function :tag "Function"))
 (boolean :tag "Descending Sort Order")
 (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"))
+(boolean :tag "Larger"))))))
-(cons (function :tag "Refinement Function")
-(string :tag "Help echo"))))))
 (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
 "Non-nil for display of Proced buffer as process tree."
 :group 'proced
 :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)
 ;; Internal variables
 (defvar proced-available (not (null (list-system-processes)))
 "Non-nil means Proced is known to work on this system.")
 "Temporary alist (internal variable).")
 (defvar proced-process-tree nil
 "Proced process tree (internal variable).")
-(defvar proced-tree-indent nil
+(defvar proced-tree-depth nil
-"Internal variable for indentation of Proced process tree.")
+"Internal variable for depth of Proced process tree.")
 (defvar proced-auto-update-timer nil
 "Stores if Proced auto update timer is already installed.")
 (defvar proced-log-buffer "*Proced log*"
 ;; operate
 (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
 ;; 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.")
 (easy-menu-define
 proced-menu proced-mode-map "Proced Menu"
 (if (looking-at "^. .")
 (get-text-property (match-end 0) 'proced-pid))))
 ;; proced mode
-(define-derived-mode proced-mode nil "Proced"
+(define-derived-mode proced-mode special-mode "Proced"
 "Mode for displaying UNIX 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.
 An existing Proced listing can be refined by typing \\[proced-refine].
 Refining an existing listing does not update the variable `proced-filter'.
 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)
 (setq buffer-read-only t
 (if (and (not proced-auto-update-timer) proced-auto-update-interval)
 (setq proced-auto-update-timer
 (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")
 (unless proced-available
 (error "Proced is not available on this system"))
 (let ((buffer (get-buffer-create "*Proced*")) new)
 (set-buffer buffer)
 (setq new (zerop (buffer-size)))
-(if new (proced-mode))
+(when new
-(if (or new arg)
+(proced-mode)
-(proced-update t))
+;; `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
+(run-hooks 'proced-post-display-hook)))
 (pop-to-buffer buffer)
+(run-hooks 'proced-post-display-hook)
 (message
 (substitute-command-keys
 "Type \\<proced-mode-map>\\[quit-window] to quit, \\[proced-help] for help")))))
 (defun proced-auto-update-timer ()
 (arg (> (prefix-numeric-value arg) 0))
 (t (not proced-auto-update-flag))))
 (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-do-mark t 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-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 the region."
 (interactive)
 (defun proced-do-mark-all (mark)
 "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
 ;; of region.  This appears most consistent with
 ;; `proced-move-to-goal-column'.
 (goto-char (region-beginning))
 (unless (looking-at "^") (beginning-of-line)))
 (goto-char (point-min))
 (setq end (point-max)))
 (while (< (point) end)
-(setq count (1+ count))
+(unless (looking-at marker-re)
-(proced-insert-mark mark))
+(setq count (1+ count))
-(proced-success-message "Marked" count))))
+(insert proced-marker-char)
+(delete-char 1))
-(defun proced-toggle-marks ()
+(forward-line))
-"Toggle marks: marked processes become unmarked, and vice versa."
+(proced-success-message (if mark "Marked" "Unmarked") count))))
-(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-children (ppid &optional omit-ppid)
 "Mark child processes of process PPID.
 Also mark process PPID unless prefix OMIT-PPID is non-nil."
 (interactive (list (proced-pid-at-point) current-prefix-arg))
 If `proced-tree-flag' is nil, remove the tree attribute.
 Return the rearranged process list."
 (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))
 (proced-tree-insert pt))
 (nreverse proced-process-tree))
 (defun proced-tree-insert (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
 ;; Filters are used to select the processes in a new listing.
 ;; If none of the alternatives is non-nil, the attribute is ignored
 ;; in the listing.
 (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)
 (push fmt new-format))
 (while (setq fmi (pop fmt))
 (refiner (nth 7 grammar))
 (fprops
 (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"
 (nth 1 grammar)
 (mapconcat (lambda (s)
 Optional arg PID-LIST is a list of PIDs of system process that are analyzed.
 If no attributes are known for a process (possibly because it already died)
 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)))
+(setq attributes (cons (cons 'pid pid) attributes))
-(stime (cdr (assq 'stime attributes)))
+(dolist (fun proced-custom-attributes)
-(cutime (cdr (assq 'cutime attributes)))
+(if (setq attr (funcall fun attributes))
-(cstime (cdr (assq 'cstime attributes)))
+(push attr attributes)))
-attr)
+(push (cons pid attributes) process-alist)))))
-(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))))))
 (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)))
 (or quiet (message (if revert "Updating process information..."
 "Updating process display...")))
 (grammar (assq key proced-grammar-alist)))
 (concat " by " (if proced-descend "-" "+")
 (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)
 "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)
 ;; collect marked processes
 (save-excursion
 (goto-char (point-min))
 (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
 (nreverse process-alist)
 ;; take current process
 (add-hook 'post-command-hook 'force-mode-line-update nil t)
 (erase-buffer)
 (dolist (process process-alist)
 (insert "  " (cdr process) "\n"))
 (save-window-excursion
-(dired-pop-to-buffer bufname) ; all we need
+(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
 (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
+(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)
 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
+(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.

Mercurial > emacs

comparison lisp/proced.el @ 100847:883cbe72dc04