Add colors to Proced (bug#59407)

Add a new custom variable proced-enable-color-flag which when set to a
non-nil value (defaults to nil), will prompt some format functions to
furnish their respective process attributes with colors and effects in
order to make them easier to distinguish and highlight possible issues
(e.g. high memory usage), in a manner similar to htop.

In particular, the current Emacs process id is highlighted purple in
both the process id and parent process id columns, session leaders
have their process ids underlined, larger memory sizes for rss
are highlighted in darker shades of orange, and the first word in the
args property (the executable) is highlighted in blue.

* lisp/proced.el (proced-grammar-alist): Update to use the new format
functions.
(proced-low-memory-usage-threshold): New custom variable to determine
whether a value represents 'low' memory usage, used only in
proced-format-memory for coloring.
(proced-medium-memory-usage-threshold): New custom variable to
determine whether a value represents 'medium' memory usage, used only
in proced-format-memory for coloring.
(proced-enable-color-flag): New custom variable to toggle coloring.
(proced-run-status-code, proced-interruptible-sleep-status-code)
(proced-uninterruptible-sleep-status-code, proced-executable)
(proced-executable, proced-memory-gb, proced-memory-mb)
(proced-memory-default, proced-pid, proced-ppid, proced-pgrp)
(proced-sess, proced-cpu, proced-mem, proced-user, proced-time-colon):
New faces.
(proced-format-time): Edit function to color colons using
proced-time-colon.
(proced-format-args): Edit function to color executables using
proced-executable.
(proced-format-state): New function to color states.
(proced-format-pid): New function to color process ids.
(proced-format-ppid): New function to color parent process ids.
(proced-format-pgrp): New function to color process group ids.
(proced-format-sess): New function to color process session leader
ids.
(proced-format-cpu): New function to color cpu utilization.
(proced-format-mem): New function to color memory utilization.
(proced-format-user): New function to color the user a process
belongs to.

diff --git a/etc/NEWS b/etc/NEWS
index a9d279fee5b2a6443e45a1972ac53f78eb18f609..bfd9b5f26e7e2bd2f4c52a1e315d0c46d73a5a42 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -504,6 +504,14 @@ option) and can be set to nil to disable Just-in-time Lock mode.
 \f
 * Changes in Emacs 29.1
 
+---
+** New user option `proced-enable-color-flag` to enable coloring of proced buffers
+This option prompts some format functions to furnish their respective
+process attributes with colors in a manner similar to htop.
+
+This option is disabled by default and needs setting to a non-nil
+value to take effect.
+
 +++
 ** New user option 'major-mode-remap-alist' to specify favorite major modes.
 This user option lets you remap the default modes (e.g. 'perl-mode' or

diff --git a/lisp/proced.el b/lisp/proced.el
index ac44ae1513d84afd18df7cd2ed4aa7bd3ef2e58f..f91d3d2f223075890bb2e75d74b9f6d919df4354 100644 (file)
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -114,16 +114,16 @@ the external command (usually \"kill\")."
 (defcustom proced-grammar-alist
   '( ;; 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"    proced-format-user 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))
-    (ppid    "PPID"    "%d" right proced-< nil (ppid pid)
+    (state   "Stat"    proced-format-state left proced-string-lessp nil (state pid) (nil t nil))
+    (ppid    "PPID"    proced-format-ppid right proced-< nil (ppid pid)
              ((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"    proced-format-pgrp right proced-< nil (pgrp euid pid) (nil t nil))
+    (sess    "Sess"    proced-format-sess 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))
@@ -141,14 +141,14 @@ the external command (usually \"kill\")."
     (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"   proced-format-memory right proced-< t (vsize pid) (nil t t))
-    (rss     "RSS"     proced-format-memory right proced-< t (rss pid) (nil t t))
+    (rss     "RSS"     proced-format-rss right proced-< t (rss 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))
+    (pcpu    "%CPU"    proced-format-cpu right proced-< t (pcpu pid) (nil t t))
+    (pmem    "%Mem"    proced-format-mem 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)
+    (pid     "PID"     proced-format-pid right proced-< nil (pid)
              ((lambda (ppid) (proced-filter-children proced-process-alist ppid))
               "refine to process children"))
     ;; process tree
@@ -367,6 +367,32 @@ May be used to revert the process listing."
   :type 'hook
   :options '(proced-revert))
 
+(defcustom proced-enable-color-flag nil
+  "Non-nil means Proced should display some process attributes with color."
+  :type 'boolean
+  :version "29.1")
+
+(defcustom proced-low-memory-usage-threshold 0.1
+  "The upper bound for low memory usage, relative to total memory.
+
+When `proced-enable-color-flag' is non-nil, RSS values denoting a proportion
+of memory lower than this value will be displayed using the
+`proced-memory-low-usage' face."
+  :type 'float
+  :version "29.1")
+
+(defcustom proced-medium-memory-usage-threshold 0.5
+  "The upper bound for medium memory usage, relative to total memory.
+
+When `proced-enable-color-flag' is non-nil, RSS values denoting a proportion
+of memory less than this value, but greater than
+`proced-low-memory-usage-threshold', will be displayed using the
+`proced-memory-medium-usage' face.  RSS values denoting a greater proportion
+than this value will be displayed using the `proced-memory-high-usage'
+face."
+  :type 'float
+  :version "29.1")
+
 ;; Internal variables
 
 (defvar proced-available t;(not (null (list-system-processes)))
@@ -403,6 +429,112 @@ It is a list of lists (KEY PREDICATE REVERSE).")
   '((t (:inherit font-lock-keyword-face)))
   "Face used for header of attribute used for sorting.")
 
+(defface proced-run-status-code
+  '((t (:foreground "green")))
+  "Face used in Proced buffers for the running or runnable status code character \"R\"."
+  :version "29.1")
+
+(defface proced-interruptible-sleep-status-code
+  '((((class color) (min-colors 88)) (:foreground "DimGrey"))
+    (t (:italic t)))
+  "Face used in Proced buffers for the interruptible sleep status code character \"S\"."
+  :version "29.1")
+
+(defface proced-uninterruptible-sleep-status-code
+  '((((class color)) (:foreground "red"))
+    (t (:bold t)))
+  "Face used in Proced buffers for the uninterruptible sleep status code character \"D\"."
+  :version "29.1")
+
+(defface proced-executable
+  '((((class color) (min-colors 88) (background dark)) (:foreground "DeepSkyBlue"))
+    (((class color) (background dark)) (:foreground "cyan"))
+    (((class color) (background light)) (:foreground "blue"))
+    (t (:bold t)))
+  "Face used in Proced buffers for executables (first word in the args process attribute)."
+  :version "29.1")
+
+(defface proced-memory-high-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "orange"))
+    (((class color) (min-colors 88) (background light)) (:foreground "OrangeRed"))
+    (((class color)) (:foreground "red"))
+    (t (:underline t)))
+  "Face used in Proced buffers for high memory usage."
+  :version "29.1")
+
+(defface proced-memory-medium-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "yellow3"))
+    (((class color) (min-colors 88) (background light)) (:foreground "orange"))
+    (((class color)) (:foreground "yellow")))
+  "Face used in Proced buffers for medium memory usage."
+  :version "29.1")
+
+(defface proced-memory-low-usage
+  '((((class color) (min-colors 88) (background dark)) (:foreground "#8bcd50"))
+    (((class color)) (:foreground "green")))
+  "Face used in Proced buffers for low memory usage."
+  :version "29.1")
+
+(defface proced-emacs-pid
+  '((((class color) (min-colors 88)) (:foreground "purple"))
+    (((class color)) (:foreground "magenta")))
+  "Face used in Proced buffers for the process ID of the current Emacs process."
+  :version "29.1")
+
+(defface proced-pid
+  '((((class color) (min-colors 88)) (:foreground "#5085ef"))
+    (((class color)) (:foreground "blue")))
+  "Face used in Proced buffers for process IDs."
+  :version "29.1")
+
+(defface proced-session-leader-pid
+  '((((class color) (min-colors 88)) (:foreground "#5085ef" :underline t))
+    (((class color)) (:foreground "blue" :underline t))
+    (t (:underline t)))
+  "Face used in Proced buffers for process IDs which are session leaders."
+  :version "29.1")
+
+(defface proced-ppid
+  '((((class color) (min-colors 88)) (:foreground "#5085bf"))
+    (((class color)) (:foreground "blue")))
+  "Face used in Proced buffers for parent process IDs."
+  :version "29.1")
+
+(defface proced-pgrp
+  '((((class color) (min-colors 88)) (:foreground "#4785bf"))
+    (((class color)) (:foreground "blue")))
+  "Face used in Proced buffers for process group IDs."
+  :version "29.1")
+
+(defface proced-sess
+  '((((class color) (min-colors 88)) (:foreground "#41729f"))
+    (((class color)) (:foreground "MidnightBlue")))
+  "Face used in Proced buffers for process session IDs."
+  :version "29.1")
+
+(defface proced-cpu
+  '((((class color) (min-colors 88)) (:foreground "#6d5cc3" :bold t))
+    (t (:bold t)))
+  "Face used in Proced buffers for process CPU utilization."
+  :version "29.1")
+
+(defface proced-mem
+  '((((class color) (min-colors 88))
+     (:foreground "#6d5cc3")))
+  "Face used in Proced buffers for process memory utilization."
+  :version "29.1")
+
+(defface proced-user
+  '((t (:bold t)))
+  "Face used in Proced buffers for the user owning the process."
+  :version "29.1")
+
+(defface proced-time-colon
+  '((((class color) (min-colors 88)) (:foreground "DarkMagenta"))
+    (t (:bold t)))
+  "Face used in Proced buffers for the colon in time strings."
+  :version "29.1")
+
 (defvar proced-re-mark "^[^ \n]"
   "Regexp matching a marked line.
 Important: the match ends just after the marker.")
@@ -1392,26 +1524,32 @@ Prefix ARG controls sort order, see `proced-sort-interactive'."
          (hours (truncate ftime 3600))
          (ftime (mod ftime 3600))
          (minutes (truncate ftime 60))
-         (seconds (mod ftime 60)))
+         (seconds (mod ftime 60))
+         (colon (if proced-enable-color-flag
+                    (propertize ":" 'font-lock-face 'proced-time-colon)
+                  ":")))
     (cond ((< 0 days)
-           (format "%d-%02d:%02d:%02d" days hours minutes seconds))
+           (format "%d-%02d%3$s%02d%3$s%02d" days hours colon minutes seconds))
           ((< 0 hours)
-           (format "%02d:%02d:%02d" hours minutes seconds))
+           (format "%02d%2$s%02d%2$s%02d" hours colon minutes seconds))
           (t
-           (format "%02d:%02d" minutes seconds)))))
+           (format "%02d%s%02d" minutes colon seconds)))))
 
 (defun proced-format-start (start)
   "Format time START.
 The return string is always 6 characters wide."
   (let ((d-start (decode-time start))
-        (d-current (decode-time)))
+        (d-current (decode-time))
+        (colon (if proced-enable-color-flag
+                   (propertize ":" 'font-lock-face 'proced-time-colon)
+                 ":")))
     (cond (;; process started in previous years
            (< (decoded-time-year d-start) (decoded-time-year d-current))
            (format-time-string "  %Y" start))
           ;; process started today
           ((and (= (decoded-time-day d-start) (decoded-time-day d-current))
                 (= (decoded-time-month d-start) (decoded-time-month d-current)))
-           (format-time-string " %H:%M" start))
+           (string-replace ":" colon (format-time-string " %H:%M" start)))
           (t ;; process started this year
            (format-time-string "%b %e" start)))))
 
@@ -1429,12 +1567,97 @@ The return string is always 6 characters wide."
 (defun proced-format-args (args)
   "Format attribute ARGS.
 Replace newline characters by \"^J\" (two characters)."
-  (string-replace "\n" "^J" args))
+  (string-replace "\n" "^J"
+                  (pcase-let* ((`(,exe . ,rest) (split-string args))
+                               (exe-prop (if proced-enable-color-flag
+                                             (propertize exe 'font-lock-face 'proced-executable)
+                                           exe)))
+                    (mapconcat #'identity (cons exe-prop rest) " "))))
 
 (defun proced-format-memory (kilobytes)
   "Format KILOBYTES in a human readable format."
   (funcall byte-count-to-string-function (* 1024 kilobytes)))
 
+(defun proced-format-rss (kilobytes)
+  "Format RSS KILOBYTES in a human readable format."
+  (let ((formatted (proced-format-memory kilobytes)))
+    (if-let* ((proced-enable-color-flag)
+              (total (car (memory-info)))
+              (proportion (/ (float kilobytes) total)))
+        (cond ((< proportion proced-low-memory-usage-threshold)
+               (propertize formatted 'font-lock-face 'proced-memory-low-usage))
+              ((< proportion proced-medium-memory-usage-threshold)
+               (propertize formatted 'font-lock-face 'proced-memory-medium-usage))
+              (t (propertize formatted 'font-lock-face 'proced-memory-high-usage)))
+      formatted)))
+
+(defun proced-format-state (state)
+  "Format STATE."
+  (cond ((and proced-enable-color-flag (string= state "R"))
+         (propertize state 'font-lock-face 'proced-run-status-code))
+        ((and proced-enable-color-flag (string= state "S"))
+         (propertize state 'font-lock-face 'proced-interruptible-sleep-status-code))
+        ((and proced-enable-color-flag (string= state "D"))
+         (propertize state 'font-lock-face 'proced-uninterruptible-sleep-status-code))
+        (t state)))
+
+(defun proced-format-pid (pid)
+  "Format PID."
+  (let ((proc-info (process-attributes pid))
+        (pid-s (number-to-string pid)))
+    (cond ((and proced-enable-color-flag
+                (not (file-remote-p default-directory))
+                (equal pid (emacs-pid)))
+           (propertize pid-s 'font-lock-face 'proced-emacs-pid))
+          ((and proced-enable-color-flag (equal pid (alist-get 'sess proc-info)))
+           (propertize pid-s 'font-lock-face 'proced-session-leader-pid))
+          (proced-enable-color-flag
+           (propertize pid-s 'font-lock-face 'proced-pid))
+          (t pid-s))))
+
+(defun proced-format-ppid (ppid)
+  "Format PPID."
+  (let ((ppid-s (number-to-string ppid)))
+    (cond ((and proced-enable-color-flag
+                (not (file-remote-p default-directory))
+                (= ppid (emacs-pid)))
+           (propertize ppid-s 'font-lock-face 'proced-emacs-pid))
+          (proced-enable-color-flag
+           (propertize ppid-s 'font-lock-face 'proced-ppid))
+          (t ppid-s))))
+
+(defun proced-format-pgrp (pgrp)
+  "Format PGRP."
+  (if proced-enable-color-flag
+      (propertize (number-to-string pgrp) 'font-lock-face 'proced-pgrp)
+    (number-to-string pgrp)))
+
+(defun proced-format-sess (sess)
+  "Format SESS."
+  (if proced-enable-color-flag
+      (propertize (number-to-string sess) 'font-lock-face 'proced-sess)
+    (number-to-string sess)))
+
+(defun proced-format-cpu (cpu)
+  "Format CPU."
+  (let ((formatted (format "%.1f" cpu)))
+    (if proced-enable-color-flag
+        (propertize formatted 'font-lock-face 'proced-cpu)
+      formatted)))
+
+(defun proced-format-mem (mem)
+  "Format MEM."
+  (let ((formatted (format "%.1f" mem)))
+    (if proced-enable-color-flag
+        (propertize formatted 'font-lock-face 'proced-mem)
+      formatted)))
+
+(defun proced-format-user (user)
+  "Format USER."
+  (if proced-enable-color-flag
+      (propertize user 'font-lock-face 'proced-user)
+    user))
+
 (defun proced-format (process-alist format)
   "Display PROCESS-ALIST using FORMAT."
   (if (symbolp format)