+(defun proced-omit-process ()
+ "Omit process from listing point is on.
+Update `proced-process-alist' accordingly."
+ (setq proced-process-alist
+ (assq-delete-all (proced-pid-at-point) proced-process-alist))
+ (delete-region (line-beginning-position)
+ (save-excursion (forward-line) (point))))
+
+;;; Filtering
+
+(defun proced-filter (process-alist filter-list)
+ "Apply FILTER-LIST to PROCESS-ALIST.
+Return the filtered process list."
+ (if (symbolp filter-list)
+ (setq filter-list (cdr (assq filter-list proced-filter-alist))))
+ (dolist (filter filter-list)
+ (let (new-alist)
+ (cond ( ;; apply function to entire process list
+ (eq (car filter) 'fun-all)
+ (setq new-alist (funcall (cdr filter) process-alist)))
+ ( ;; apply predicate to each list of attributes
+ (eq (car filter) 'function)
+ (dolist (process process-alist)
+ (if (funcall (car filter) (cdr process))
+ (push process new-alist))))
+ (t ;; apply predicate to specified attribute
+ (let ((fun (if (stringp (cdr filter))
+ `(lambda (val)
+ (string-match ,(cdr filter) val))
+ (cdr filter)))
+ value)
+ (dolist (process process-alist)
+ (setq value (cdr (assq (car filter) (cdr process))))
+ (if (and value (funcall fun value))
+ (push process new-alist))))))
+ (setq process-alist new-alist)))
+ process-alist)
+
+(defun proced-filter-interactive (scheme)
+ "Filter Proced buffer using SCHEME.
+When called interactively, an empty string means nil, i.e., no filtering.
+Set variable `proced-filter' to SCHEME. Revert listing."
+ (interactive
+ (let ((scheme (completing-read "Filter: "
+ proced-filter-alist nil t)))
+ (list (if (string= "" scheme) nil (intern scheme)))))
+ ;; only update if necessary
+ (unless (eq proced-filter scheme)
+ (setq proced-filter scheme)
+ (proced-update t)))
+
+(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-temp-alist (proced-children-alist process-alist))
+ new-alist)
+ (dolist (pid (proced-children-pids ppid))
+ (push (assq pid process-alist) new-alist))
+ (if omit-ppid
+ (assq-delete-all ppid new-alist)
+ new-alist)))
+
+;;; 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-temp-alist))))
+ (if cpids
+ (cons ppid (apply 'append (mapcar 'proced-children-pids cpids)))
+ (list ppid))))
+
+(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
+
+;; Filters are used to select the processes in a new listing.
+;; Refiners are used to narrow down further (interactively) the processes
+;; in an existing listing.
+
+(defun proced-refine (&optional event)
+ "Refine Proced listing by comparing with the attribute value at point.
+Optional EVENT is the location of the Proced field.
+
+Refinement is controlled by the REFINER defined for each attribute ATTR
+in `proced-grammar-alist'.
+
+If REFINER is a list of flags and point is on a process's value of ATTR,
+this command compares the value of ATTR of every process with the value
+of ATTR of the process at the position of point.
+
+The predicate for the comparison of two ATTR values is defined
+in `proced-grammar-alist'. For each return value of the predicate
+a refine flag is defined in `proced-grammar-alist'. One can select
+processes for which the value of ATTR is \"less than\", \"equal\",
+and / or \"larger\" than ATTR of the process point is on. A process
+is included in the new listing if the refine flag for the corresponding
+return value of the predicate is non-nil.
+The help-echo string for `proced-refine' uses \"+\" or \"-\" to indicate
+the current values of these refine flags.
+
+If REFINER is a cons pair (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.
+
+This command refines an already existing process listing generated initially
+based on the value of the variable `proced-filter'. It does not change
+this variable. It does not revert the listing. If you frequently need
+a certain refinement, consider defining a new filter in `proced-filter-alist'."
+ (interactive (list last-input-event))
+ (if event (posn-set-point (event-end event)))
+ (let ((key (get-text-property (point) 'proced-key))
+ (pid (get-text-property (point) 'proced-pid)))
+ (if (and key pid)
+ (let* ((grammar (assq key proced-grammar-alist))
+ (refiner (nth 7 grammar)))
+ (when refiner
+ (cond ((functionp (car refiner))
+ (setq proced-process-alist (funcall (car refiner) pid)))
+ ((consp refiner)
+ (let ((predicate (nth 4 grammar))
+ (ref (cdr (assq key (cdr (assq pid proced-process-alist)))))
+ val new-alist)
+ (dolist (process proced-process-alist)
+ (setq val (funcall predicate (cdr (assq key (cdr process))) ref))
+ (if (cond ((not val) (nth 2 refiner))
+ ((eq val 'equal) (nth 1 refiner))
+ (val (car refiner)))
+ (push process new-alist)))
+ (setq proced-process-alist new-alist))))
+ ;; Do not revert listing.
+ (proced-update)))
+ (message "No refiner defined here."))))
+
+;; Proced predicates for sorting and filtering are based on a three-valued
+;; logic:
+;; Predicates take two arguments P1 and P2, the corresponding attribute
+;; values of two processes. Predicates 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.
+
+(defun proced-< (num1 num2)
+ "Return t if NUM1 less than NUM2.
+Return `equal' if NUM1 equals NUM2. Return nil if NUM1 greater than NUM2."
+ (if (= num1 num2)
+ 'equal
+ (< num1 num2)))
+
+(defun proced-string-lessp (s1 s2)
+ "Return t if string S1 is less than S2 in lexicographic order.
+Return `equal' if S1 and S2 have identical contents.
+Return nil otherwise."
+ (if (string= s1 s2)
+ 'equal
+ (string-lessp s1 s2)))
+
+(defun proced-time-lessp (t1 t2)
+ "Return t if time value T1 is less than time value T2.
+Return `equal' if T1 equals T2. Return nil otherwise."
+ (with-decoded-time-value ((high1 low1 micro1 t1)
+ (high2 low2 micro2 t2))
+ (cond ((< high1 high2))
+ ((< high2 high1) nil)
+ ((< low1 low2))
+ ((< low2 low1) nil)
+ ((< micro1 micro2))
+ ((< micro2 micro1) nil)
+ (t 'equal))))
+
+;;; Sorting
+
+(defsubst proced-xor (b1 b2)
+ "Return the logical exclusive or of args B1 and B2."
+ (and (or b1 b2)
+ (not (and b1 b2))))
+
+(defun proced-sort-p (p1 p2)
+ "Predicate for sorting processes P1 and P2."
+ (if (not (cdr proced-sort-internal))
+ ;; only one predicate: fast scheme
+ (let* ((sorter (car proced-sort-internal))
+ (k1 (cdr (assq (car sorter) (cdr p1))))
+ (k2 (cdr (assq (car sorter) (cdr p2)))))
+ ;; if the attributes are undefined, we should really abort sorting
+ (if (and k1 k2)
+ (proced-xor (funcall (nth 1 sorter) k1 k2)
+ (nth 2 sorter))))
+ (let ((sort-list proced-sort-internal) sorter predicate k1 k2)
+ (catch 'done
+ (while (setq sorter (pop sort-list))
+ (setq k1 (cdr (assq (car sorter) (cdr p1)))
+ k2 (cdr (assq (car sorter) (cdr p2)))
+ predicate
+ (if (and k1 k2)
+ (funcall (nth 1 sorter) k1 k2)))
+ (if (not (eq predicate 'equal))
+ (throw 'done (proced-xor predicate (nth 2 sorter)))))
+ (eq t predicate)))))
+
+(defun proced-sort (process-alist sorter descend)
+ "Sort PROCESS-ALIST using scheme SORTER.
+SORTER is a scheme like `proced-sort'.
+DESCEND is non-nil if the first element of SORTER is sorted
+in descending order.
+Return the sorted process list."
+ ;; translate SORTER into a list of lists (KEY PREDICATE REVERSE)
+ (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)
+ (nth 6 (assq sorter proced-grammar-alist))))
+ ((symbolp sorter) (list sorter))
+ (t (error "Sorter undefined %s" sorter)))))
+ (if proced-sort-internal
+ (progn
+ ;; splice DESCEND into the list
+ (setcar proced-sort-internal
+ (list (caar proced-sort-internal)
+ (nth 1 (car proced-sort-internal)) descend))
+ (sort process-alist 'proced-sort-p))
+ process-alist))
+
+(defun proced-sort-interactive (scheme &optional arg)
+ "Sort Proced buffer using SCHEME.
+When called interactively, an empty string means nil, i.e., no sorting.
+
+Prefix ARG controls sort order:
+- If prefix ARG is positive (negative), sort in ascending (descending) order.
+- If ARG is nil or 'no-arg and SCHEME is equal to the previous sorting scheme,
+ reverse the sorting order.
+- If ARG is nil or 'no-arg and SCHEME differs from the previous sorting scheme,
+ adopt the sorting order defined for SCHEME in `proced-grammar-alist'.
+
+Set variable `proced-sort' to SCHEME. The current sort scheme is displayed
+in the mode line, using \"+\" or \"-\" for ascending or descending order."