unofficial mirror of bug-gnu-emacs@gnu.org 
 help / color / mirror / code / Atom feed
* bug#59407: [PATCH] Add Colors to proced
@ 2022-11-20 10:26 Laurence Warne
  2022-11-20 10:48 ` Eli Zaretskii
                   ` (2 more replies)
  0 siblings, 3 replies; 18+ messages in thread
From: Laurence Warne @ 2022-11-20 10:26 UTC (permalink / raw)
  To: 59407


[-- Attachment #1.1: Type: text/plain, Size: 713 bytes --]

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

[-- Attachment #1.2: Type: text/html, Size: 906 bytes --]

[-- Attachment #2: 0001-Add-colors-to-proced.patch --]
[-- Type: text/x-patch, Size: 14569 bytes --]

From 362bf56ec5e3fcef3278f633adbe03c6af5893f2 Mon Sep 17 00:00:00 2001
From: Laurence Warne <laurencewarne@gmail.com>
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


[-- Attachment #3: proced-colours-1.png --]
[-- Type: image/png, Size: 471177 bytes --]

[-- Attachment #4: proced-colours-2.png --]
[-- Type: image/png, Size: 349374 bytes --]

^ permalink raw reply related	[flat|nested] 18+ messages in thread

end of thread, other threads:[~2022-12-01 21:14 UTC | newest]

Thread overview: 18+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-11-20 10:26 bug#59407: [PATCH] Add Colors to proced Laurence Warne
2022-11-20 10:48 ` Eli Zaretskii
2022-11-20 12:33 ` Po Lu via Bug reports for GNU Emacs, the Swiss army knife of text editors
2022-11-20 14:40   ` Eli Zaretskii
2022-11-21  9:07     ` Laurence Warne
2022-11-21 10:32       ` Michael Albinus
2022-11-21 14:28       ` Eli Zaretskii
2022-11-25  9:34         ` Laurence Warne
2022-11-25 11:30           ` Michael Albinus
2022-11-25 15:07             ` Eli Zaretskii
2022-11-25 15:19               ` Michael Albinus
2022-11-26  9:41                 ` Laurence Warne
2022-11-27 16:04                   ` Michael Albinus
2022-11-29 14:02                     ` Laurence Warne
2022-12-01 18:17                       ` Eli Zaretskii
2022-12-01 21:14                         ` Laurence Warne
2022-11-26 12:47           ` Eli Zaretskii
2022-11-20 14:14 ` Michael Albinus

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).