Subject: bug#59407: closed (Re: bug#59407: [PATCH] Add Colors to proced)

From: [email-masked] (GNU bug Tracking System)
Date: Thu, 01 Dec 2022 18:19:02 +0000

Your bug report

#59407: [PATCH] Add Colors to proced

which was filed against the emacs package, has been closed.

The explanation is attached below, along with your original report.
If you require more details, please reply to [email-masked].

-- 
59407: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=59407
GNU Bug Tracking System
Contact [email-masked] with problems

Subject: Re: bug#59407: [PATCH] Add Colors to proced
From: Eli Zaretskii <[email-masked]>
To: Laurence Warne <[email-masked]>
Cc: [email-masked], [email-masked], [email-masked]
Date: Thu, 01 Dec 2022 20:17:29 +0200
List-Id: <debbugs-submit.debbugs.gnu.org>

> From: Laurence Warne <[email-masked]>
> Date: Tue, 29 Nov 2022 14:02:52 +0000
> Cc: Eli Zaretskii <[email-masked]>, [email-masked], [email-masked]
> 
> Nice, the new patch should take this into consideration.

Thanks, installed on the release branch, and closing the bug.

Subject: [PATCH] Add Colors to proced
From: Laurence Warne <[email-masked]>
To: [email-masked]
Date: Sun, 20 Nov 2022 10:26:35 +0000
List-Id: <debbugs-submit.debbugs.gnu.org>

Hi, attached is a patch I've recently been working to do with colorizing
proced buffers, similar to htop.

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

The way I'd recommend to try it out would be:

(require 'proced)
(setq-default proced-auto-update-flag t)
(setq-default proced-auto-update-interval 1)
(setq proced-enable-color-flag t)

And then M-x proced.

Thanks, Laurence
From 362bf56ec5e3fcef3278f633adbe03c6af5893f2 Mon Sep 17 00:00:00 2001
From: Laurence Warne <[email-masked]>
Date: Wed, 16 Nov 2022 14:32:44 +0000
Subject: [PATCH] Add colors to proced

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 and
vsize 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 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): new face
(proced-interruptible-sleep-status-code): new face
(proced-uninterruptible-sleep-status-code): new face
(proced-executable): new face
(proced-memory-gb): new face
(proced-memory-mb): new face
(proced-memory-default): new face
(proced-pid): new face
(proced-ppid): new face
(proced-pgrp): new face
(proced-sess): new face
(proced-cpu): new face
(proced-mem): new face
(proced-user): new face
(proced-time-colon): new face
(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
---
 lisp/proced.el | 223 +++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 207 insertions(+), 16 deletions(-)

diff --git a/lisp/proced.el b/lisp/proced.el
index a6f1a71778..caee4de5e6 100644
--- a/lisp/proced.el
+++ b/lisp/proced.el
@@ -114,16 +114,16 @@ proced-signal-list
 (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))
@@ -143,12 +143,12 @@ proced-grammar-alist
     (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))
     (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,30 @@ proced-after-send-signal-hook
   :type 'hook
   :options '(proced-revert))
 
+(defcustom proced-enable-color-flag nil
+  "Non-nil means some process attributes will be rendered with color."
+  :type 'boolean
+  :version "29.1")
+
+(defcustom proced-low-memory-usage-threshold (* 1024 1024 100)
+  "The low memory usage (in bytes) upper bound.
+
+When `proced-enable-color-flag' is non-nil, vsize and rss values less than
+this value will be rendered using the `proced-memory-low-usage' face."
+  :type 'integer
+  :version "29.1")
+
+(defcustom proced-medium-memory-usage-threshold (* 1024 1024 1024)
+  "The medium memory usage (in bytes) upper bound.
+
+When `proced-enable-color-flag' is non-nil, vsize and rss values less than
+this value, but greater than `proced-low-memory-usage-threshold' will be
+rendered using the `proced-memory-medium-usage' face.  vsize and rss values
+greater than this value will be rendered using the `proced-memory-high-usage'
+face."
+  :type 'integer
+  :version "29.1")
+
 ;; Internal variables
 
 (defvar proced-available t;(not (null (list-system-processes)))
@@ -403,6 +427,91 @@ proced-sort-header
   '((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 for the running or runnable status code character \"R\"."
+  :version "29.1")
+
+(defface proced-interruptible-sleep-status-code
+  '((t (:foreground "DimGrey")))
+  "Face used for the interruptible sleep status code character \"S\"."
+  :version "29.1")
+
+(defface proced-uninterruptible-sleep-status-code
+  '((t (:foreground "red")))
+  "Face used for the uninterruptible sleep status code character \"D\"."
+  :version "29.1")
+
+(defface proced-executable
+  '((t (:foreground "DeepSkyBlue")))
+  "Face for executables (first word in the args process attribute)."
+  :version "29.1")
+
+(defface proced-memory-high-usage
+  '((t (:foreground "orange")))
+  "Face for high memory usage."
+  :version "29.1")
+
+(defface proced-memory-medium-usage
+  '((t (:foreground "#ded93e")))
+  "Face for medium memory usage."
+  :version "29.1")
+
+(defface proced-memory-low-usage
+  '((t (:foreground "#8bcd50")))
+  "Face for low memory usage."
+  :version "29.1")
+
+(defface proced-emacs-pid
+  '((t (:foreground "purple")))
+  "Face for the pid of the current Emacs process."
+  :version "29.1")
+
+(defface proced-pid
+  '((t (:foreground "#5085ef")))
+  "Face for process ids."
+  :version "29.1")
+
+(defface proced-session-leader-pid
+  '((t (:foreground "#5085ef" :underline t)))
+  "Face for process ids which are session leaders."
+  :version "29.1")
+
+(defface proced-ppid
+  '((t (:foreground "#5085bf")))
+  "Face for parent process ids."
+  :version "29.1")
+
+(defface proced-pgrp
+  '((t (:foreground "#4785bf")))
+  "Face for process group ids."
+  :version "29.1")
+
+(defface proced-sess
+  '((t (:foreground "#41729f")))
+  "Face for process session ids."
+  :version "29.1")
+
+(defface proced-cpu
+  '((t (:foreground "#6d5cc3" :bold t)))
+  "Face for process cpu utilization."
+  :version "29.1")
+
+(defface proced-mem
+  '((t (:foreground "#6d5cc3")))
+  "Face for process memory utilization."
+  :version "29.1")
+
+(defface proced-user
+  '((t (:bold t)))
+  "Face for the user."
+  :version "29.1")
+
+(defface proced-time-colon
+  '((t (:foreground "DarkMagenta")))
+  "Face 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.")
@@ -1386,26 +1495,32 @@ proced-format-time
          (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)))))
 
@@ -1423,11 +1538,87 @@ proced-format-tree
 (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)))
+  (let* ((bytes (* 1024 kilobytes))
+         (formatted (funcall byte-count-to-string-function bytes)))
+    (cond ((and proced-enable-color-flag (< bytes proced-low-memory-usage-threshold))
+           (propertize formatted 'font-lock-face 'proced-memory-low-usage))
+          ((and proced-enable-color-flag (< bytes proced-medium-memory-usage-threshold))
+           (propertize formatted 'font-lock-face 'proced-memory-medium-usage))
+          (proced-enable-color-flag
+           (propertize formatted 'font-lock-face 'proced-memory-high-usage))
+          (t 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 (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 (= 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."
-- 
2.30.2