;;; proced.el --- operate on system processes like dired
-;; Copyright (C) 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Roland Winkler <Roland.Winkler@physik.uni-erlangen.de>
;; Keywords: Processes, Unix
;; - interactive temporary customizability of flags in `proced-grammar-alist'
;; - allow "sudo kill PID", "renice PID"
;;
-;; Wishlist
-;; - tree view like pstree(1)
-;;
;; 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))
"Alist of rules for handling Proced attributes.
Each element has the form
the corresponding attribute values of two processes. PREDICATE should
return 'equal if P1 has same rank like P2. Any other non-nil value says
that P1 is \"less than\" P2, or nil if not.
+If PREDICATE is nil the attribute cannot be sorted.
PREDICATE defines an ascending sort order. REVERSE is non-nil if the sort
order is descending.
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.
(const :tag "left" left)
(const :tag "right" right)
(integer :tag "width"))
- (function :tag "Predicate")
+ (choice :tag "Predicate"
+ (const :tag "None" nil)
+ (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"))
- (cons (function :tag "Refinement Function")
- (string :tag "Help echo"))
- (const :tag "None" nil)))))
+ (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
;; Sorting can also be based on attributes that are invisible in the listing.
(defcustom proced-format-alist
- '((short user pid pcpu pmem start time (args comm))
- (medium user pid pcpu pmem vsize rss ttname state start time (args comm))
- (long user euid group pid pri nice pcpu pmem vsize rss ttname state
+ '((short user pid tree pcpu pmem start time (args comm))
+ (medium user pid tree pcpu pmem vsize rss ttname state start time (args comm))
+ (long user euid group pid tree pri nice pcpu pmem vsize rss ttname state
start time (args comm))
- (verbose user euid group egid pid ppid pgrp sess pri nice pcpu pmem
+ (verbose user euid group egid pid ppid tree pgrp sess pri nice pcpu pmem
state thcount vsize rss ttname tpgid minflt majflt cminflt cmajflt
start time utime stime ctime cutime cstime etime (args comm)))
"Alist of formats of listing.
;; 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-auto-update-flag)
+(defcustom proced-tree-flag nil
+ "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)
+
+(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)))
"Headers in Proced buffer as a string.")
(make-variable-buffer-local 'proced-header-line)
+(defvar proced-temp-alist nil
+ "Temporary alist (internal variable).")
+
(defvar proced-process-tree nil
- "Process tree of listing (internal variable).")
+ "Proced process tree (internal variable).")
+
+(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.")
(defvar proced-mode-map
(let ((km (make-sparse-keymap)))
;; moving
- (define-key km " " 'proced-next-line)
+ (define-key km " " 'next-line)
(define-key km "n" 'next-line)
(define-key km "p" 'previous-line)
(define-key km "\C-n" 'next-line)
;; 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)
;; similar to `Buffer-menu-sort-by-column'
(define-key km [header-line mouse-1] 'proced-sort-header)
(define-key km [header-line mouse-2] 'proced-sort-header)
+ (define-key km "T" 'proced-toggle-tree)
;; formatting
(define-key km "F" 'proced-format-interactive)
;; operate
(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.")
:style radio
:selected (eq proced-format ',format)]))
proced-format-alist))
+ ["Tree Display" proced-toggle-tree
+ :style toggle
+ :selected (eval proced-tree-flag)
+ :help "Display Proced Buffer as Process Tree"]
"--"
["Omit Marked Processes" proced-omit-processes
:help "Omit Marked Processes in Process Listing."]
(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.
to change the sort scheme. The current sort scheme is indicated in the
mode line, using \"+\" or \"-\" for ascending or descending sort order.
+Type \\[proced-toggle-tree] to toggle whether the listing is
+displayed as process tree.
+
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)
(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.
(proced-filter-parents proced-process-alist cpid omit-cpid)))
(defun proced-mark-process-alist (process-alist &optional quiet)
+ "Mark processes in PROCESS-ALIST.
+If QUIET is non-nil suppress status message."
(let ((count 0))
(if process-alist
(let (buffer-read-only)
(setq proced-filter scheme)
(proced-update t)))
-(defun proced-process-tree (process-alist)
- "Return process tree for PROCESS-ALIST.
-The process tree is an alist with elements (PPID PID1 PID2 ...).
-PPID is a parent PID. PID1, PID2, ... are the child processes of PPID.
-The list of children does not include grandchildren."
- (let (children-list ppid cpids)
- (dolist (process process-alist children-list)
- (setq ppid (cdr (assq 'ppid (cdr process))))
- (if ppid
- (setq children-list
- (if (setq cpids (assq ppid children-list))
- (cons (cons ppid (cons (car process) (cdr cpids)))
- (assq-delete-all ppid children-list))
- (cons (list ppid (car process))
- children-list)))))))
+(defun proced-filter-parents (process-alist pid &optional omit-pid)
+ "For PROCESS-ALIST return list of parent processes of PID.
+This list includes PID unless OMIT-PID is non-nil."
+ (let ((parent-list (unless omit-pid (list (assq pid process-alist))))
+ (process (assq pid process-alist))
+ ppid)
+ (while (and (setq ppid (cdr (assq 'ppid (cdr process))))
+ ;; Ignore a PPID that equals PID.
+ (/= ppid pid)
+ ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
+ (setq process (assq ppid process-alist)))
+ (setq pid ppid)
+ (push process parent-list))
+ parent-list))
(defun proced-filter-children (process-alist ppid &optional omit-ppid)
"For PROCESS-ALIST return list of child processes of PPID.
This list includes PPID unless OMIT-PPID is non-nil."
- (let ((proced-process-tree (proced-process-tree process-alist))
+ (let ((proced-temp-alist (proced-children-alist process-alist))
new-alist)
(dolist (pid (proced-children-pids ppid))
(push (assq pid process-alist) new-alist))
(assq-delete-all ppid new-alist)
new-alist)))
-;; helper function
+;;; Process tree
+
+(defun proced-children-alist (process-alist)
+ "Return children alist for PROCESS-ALIST.
+The children alist has elements (PPID PID1 PID2 ...).
+PPID is a parent PID. PID1, PID2, ... are the child processes of PPID.
+The children alist inherits the sorting order of PROCESS-ALIST.
+The list of children does not include grandchildren."
+ ;; The PPIDs inherit the sorting order of PROCESS-ALIST.
+ (let ((process-tree (mapcar (lambda (a) (list (car a))) process-alist))
+ ppid)
+ (dolist (process process-alist)
+ (setq ppid (cdr (assq 'ppid (cdr process))))
+ (if (and ppid
+ ;; Ignore a PPID that equals PID.
+ (/= ppid (car process))
+ ;; Accept only PPIDs that correspond to members in PROCESS-ALIST.
+ (assq ppid process-alist))
+ (let ((temp-alist process-tree) elt)
+ (while (setq elt (pop temp-alist))
+ (when (eq ppid (car elt))
+ (setq temp-alist nil)
+ (setcdr elt (cons (car process) (cdr elt))))))))
+ ;; The child processes inherit the sorting order of PROCESS-ALIST.
+ (setq process-tree
+ (mapcar (lambda (a) (cons (car a) (nreverse (cdr a))))
+ process-tree))))
+
(defun proced-children-pids (ppid)
"Return list of children PIDs of PPID (including PPID)."
- (let ((cpids (cdr (assq ppid proced-process-tree))))
+ (let ((cpids (cdr (assq ppid proced-temp-alist))))
(if cpids
(cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
(list ppid))))
-(defun proced-filter-parents (process-alist pid &optional omit-pid)
- "For PROCESS-ALIST return list of parent processes of PID.
-This list includes PID unless OMIT-PID is non-nil."
- (let ((parent-list (unless omit-pid (list (assq pid process-alist)))))
- (while (setq pid (cdr (assq 'ppid (cdr (assq pid process-alist)))))
- (push (assq pid process-alist) parent-list))
- parent-list))
+(defun proced-process-tree (process-alist)
+ "Return process tree for PROCESS-ALIST.
+It is an alist of alists where the car of each alist is a parent process
+and the cdr is a list of child processes according to the ppid attribute
+of these processes.
+The process tree inherits the sorting order of PROCESS-ALIST."
+ (let ((proced-temp-alist (proced-children-alist process-alist))
+ pid-alist proced-process-tree)
+ (while (setq pid-alist (pop proced-temp-alist))
+ (push (proced-process-tree-internal pid-alist) proced-process-tree))
+ (nreverse proced-process-tree)))
+
+(defun proced-process-tree-internal (pid-alist)
+ "Helper function for `proced-process-tree'."
+ (let ((cpid-list (cdr pid-alist)) cpid-alist cpid)
+ (while (setq cpid (car cpid-list))
+ (if (setq cpid-alist (assq cpid proced-temp-alist))
+ ;; Unprocessed part of process tree that needs to be
+ ;; analyzed recursively.
+ (progn
+ (setq proced-temp-alist
+ (assq-delete-all cpid proced-temp-alist))
+ (setcar cpid-list (proced-process-tree-internal cpid-alist)))
+ ;; We already processed this subtree and take it "as is".
+ (setcar cpid-list (assq cpid proced-process-tree))
+ (setq proced-process-tree
+ (assq-delete-all cpid proced-process-tree)))
+ (pop cpid-list)))
+ pid-alist)
+
+(defun proced-toggle-tree (arg)
+ "Toggle the display of the process listing as process tree.
+With prefix ARG, display as process tree if ARG is positive, otherwise
+do not display as process tree. Sets the variable `proced-tree-flag'.
+
+The process tree is generated from the selected processes in the
+Proced buffer (that is, the processes in `proced-process-alist').
+All processes that do not have a parent process in this list
+according to their ppid attribute become the root of a process tree.
+Each parent process is followed by its child processes.
+The process tree inherits the chosen sorting order of the process listing,
+that is, child processes of the same parent process are sorted using
+the selected sorting order."
+ (interactive (list (or current-prefix-arg 'toggle)))
+ (setq proced-tree-flag
+ (cond ((eq arg 'toggle) (not proced-tree-flag))
+ (arg (> (prefix-numeric-value arg) 0))
+ (t (not proced-tree-flag))))
+ (proced-update)
+ (message "Proced process tree display %s"
+ (if proced-tree-flag "enabled" "disabled")))
+
+(defun proced-tree (process-alist)
+ "Rearrange PROCESS-ALIST as process tree.
+If `proced-tree-flag' is non-nil, rearrange PROCESS-ALIST such that
+every processes is followed by its child processes. Each process
+gets a tree attribute that specifies the depth of the process in the tree.
+A root process is a process with no parent within PROCESS-ALIST according
+to its value of the ppid attribute. It has depth 0.
+
+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-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))
+ ;; remove tree attribute
+ (let ((process-alist process-alist))
+ (while process-alist
+ (setcar process-alist
+ (assq-delete-all 'tree (car process-alist)))
+ (pop process-alist)))
+ process-alist))
+
+(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-depth))
+ (cdr pprocess))
+ proced-process-tree)
+ (if (cdr process-tree)
+ (let ((proced-tree-depth (1+ proced-tree-depth)))
+ (mapc 'proced-tree-insert (cdr process-tree))))))
;; Refining
(setq proced-sort-internal
(mapcar (lambda (arg)
(let ((grammar (assq arg proced-grammar-alist)))
+ (unless (nth 4 grammar)
+ (error "Attribute %s not sortable" (car grammar)))
(list arg (nth 4 grammar) (nth 5 grammar))))
(cond ((listp sorter) sorter)
((and (symbolp sorter)
Set variable `proced-sort' to SCHEME. The current sort scheme is displayed
in the mode line, using \"+\" or \"-\" for ascending or descending order."
(interactive
- (let ((scheme (completing-read "Sort attribute: "
- proced-grammar-alist nil t)))
+ (let* (choices
+ (scheme (completing-read "Sort attribute: "
+ (dolist (grammar proced-grammar-alist choices)
+ (if (nth 4 grammar)
+ (push (list (car grammar)) choices)))
+ nil t)))
(list (if (string= "" scheme) nil (intern scheme))
;; like 'toggle in `define-derived-mode'
(or current-prefix-arg 'no-arg))))
(substring ttname (if (string-match "\\`/dev/" ttname)
(match-end 0) 0)))
+(defun proced-format-tree (tree)
+ "Format attribute TREE."
+ (concat (make-string tree ?\s) (number-to-string tree)))
+
;; Proced assumes that every process occupies only one line in the listing.
(defun proced-format-args (args)
"Format attribute ARGS.
(let ((standard-attributes
(car (proced-process-attributes (list (emacs-pid)))))
new-format fmi)
+ (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)
;; field the corresponding key.
;; Of course, the sort predicate appearing in help-echo
;; is only part of the story. But it gives the main idea.
- (hprops (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
- `(proced-key ,key mouse-face highlight
- help-echo ,(format proced-header-help-echo
- (if descend "-" "+")
- (nth 1 grammar)
- (if descend "descending" "ascending")))))
+ (hprops
+ (if (nth 4 grammar)
+ (let ((descend (if (eq key sort-key) proced-descend (nth 5 grammar))))
+ `(proced-key ,key mouse-face highlight
+ help-echo ,(format proced-header-help-echo
+ (if descend "-" "+")
+ (nth 1 grammar)
+ (if descend "descending" "ascending"))))))
(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"
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)))
(proced-sort (proced-filter proced-process-alist proced-filter)
proced-sort proced-descend))
+ ;; display as process tree?
+ (setq proced-process-alist
+ (proced-tree proced-process-alist))
+
;; It is useless to keep undo information if we revert, filter, or
;; refine the listing so that `proced-process-alist' has changed.
;; We could keep the undo information if we only re-sort the buffer.
(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."
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")))
(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-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)
- (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 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)))
;; similar to `dired-why'
(defun proced-why ()
(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)
;; arch-tag: a6e312ad-9032-45aa-972d-31a8cfc545af
HCoop / bpt / emacs.git / blobdiff