From 9cb0138ef3e56533538c2d402d8ad7b2e282ce6c Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Fri, 23 Jun 2023 06:17:55 -0700 Subject: [PATCH 0/1] *** NOT A PATCH *** *** BLURB HERE *** David Leatherman (1): [5.6] Add module for colorizing nicknames to ERC doc/misc/erc.texi | 4 + etc/ERC-NEWS | 8 + lisp/erc/erc-nicks.el | 612 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 416 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1042 insertions(+), 1 deletion(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el Interdiff: diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index cd78ac15e22..2977235b3a8 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -25,14 +25,15 @@ ;; This file provides the `nicks' module for automatic nickname ;; highlighting. Add `nicks' to `erc-modules' to get started. ;; -;; To change the color of a nickname in a target buffer, click on it -;; and choose "Edit face" from the completion interface, and then -;; perform your adjustments in the resulting Customize menu. -;; Non-Customize users can persist their changes permanently by -;; clicking on the face's "location" hyperlink and copying the -;; generated code snippet (`defface' or `use-package') to their -;; init.el. Customize users need only click "Apply and Save", as -;; usual. +;; Use the command `erc-nicks-refresh' to review changes after +;; adjusting an option, like `erc-nicks-contrast-range'. To change +;; the color of a nickname in a target buffer, click on it and choose +;; "Edit face" from the completion interface, and then perform your +;; adjustments in the resulting Customize menu. Non-Customize users +;; can persist changes permanently by clicking on the face's +;; "location" hyperlink and copying the generated code snippet +;; (`defface' or `use-package') to their init.el. Customize users +;; need only click "Apply and Save", as usual. ;;; History: @@ -91,7 +92,7 @@ erc-nicks-skip-faces "Faces to avoid highlighting atop." :type '(repeat symbol)) -(defcustom erc-nicks-nickname-face erc-button-nickname-face +(defcustom erc-nicks-backing-face erc-button-nickname-face "Face to mix with generated one for emphasizing non-speakers." :type '(choice face (const nil))) @@ -103,7 +104,7 @@ erc-nicks-bg-color :type 'string) (defcustom erc-nicks-color-adjustments - '(erc-nicks-invert erc-nicks-cap-contrast erc-nicks-ensaturate) + '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate) "Treatments applied to improve aesthetics or visibility. For example, the function `erc-nicks-invert' inverts a nick when it's too close to the background, and `erc-nicks-add-contrast' @@ -293,7 +294,9 @@ erc-nicks--custom-keywords ;; This doesn't add an entry to the face table because "@" faces are ;; interned in the global `obarray' and thus easily accessible. (defun erc-nicks--revive (new-face old-face nick net) - (put new-face 'erc-nicks--custom-nick (cons nick net)) + (put new-face 'erc-nicks--custom-face t) + (put new-face 'erc-nicks--nick nick) + (put new-face 'erc-nicks--netid erc-networks--id) (put old-face 'erc-nicks--key nil) (apply #'custom-declare-face new-face (face-user-default-spec old-face) (format "Persistent `erc-nicks' color for %s on %s." nick net) @@ -319,7 +322,7 @@ erc-nicks--redirect-face-widget-link (pcase args (`(,widget face-link . ,plist) (when-let* ((face (widget-value widget)) - ((get face 'erc-nicks--custom-nick))) + ((get face 'erc-nicks--custom-face))) (unless (symbol-file face) (setf (plist-get plist :action) (lambda (&rest _) (erc-nicks--create-defface-template face)))) @@ -371,8 +374,10 @@ erc-nicks--create-pool (defun erc-nicks--init-pool (&optional debug) (if (or (eq erc-nicks-colors 'all) (null erc-nicks-color-adjustments)) - (setq erc-nicks--colors-pool nil - erc-nicks--colors-len nil) + (progn (setq erc-nicks--colors-pool nil + erc-nicks--colors-len nil) + (when debug + (erc-nicks-list-faces))) (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors) (defined-colors))) (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors @@ -399,6 +404,8 @@ erc-nicks--get-face (erc-nicks--revive face face nick (erc-network)))))) (let ((color (erc-nicks--determine-color key)) (new-face (make-symbol (concat "erc-nicks-" nick "-face")))) + (put new-face 'erc-nicks--nick nick) + (put new-face 'erc-nicks--netid erc-networks--id) (put new-face 'erc-nicks--key key) (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec) (set-face-documentation @@ -459,10 +466,10 @@ erc-nicks--highlight erc-nicks--max-skip-search)))) (key (funcall erc-nicks--key-function trimmed)) (out (erc-nicks--get-face trimmed key))) - (if (or (null erc-nicks-nickname-face) - (eq base-face erc-nicks-nickname-face)) + (if (or (null erc-nicks-backing-face) + (eq base-face erc-nicks-backing-face)) out - (cons out (erc-list erc-nicks-nickname-face))))) + (cons out (erc-list erc-nicks-backing-face))))) (defun erc-nicks--highlight-button (nick-object) "Possibly add face to `erc-button--nick-user' NICK-OBJECT." @@ -535,16 +542,67 @@ erc-nicks-customize-face (set-face-attribute old-face nil :inherit new-face)) (customize-face new-face))) -(defun erc-nicks-refresh (debug-pool) +(defun erc-nicks--list-faces-help-button-action (face) + (when-let (((or (get face 'erc-nicks--custom-face) + (y-or-n-p (format "Create new persistent face for %s?" + (get face 'erc-nicks--key))))) + (nid (get face 'erc-nicks--netid)) + (foundp (lambda () + (erc-networks--id-equal-p nid erc-networks--id))) + (server-buffer (car (erc-buffer-filter foundp)))) + (with-current-buffer server-buffer + (erc-nicks-customize-face (get face 'erc-nicks--nick))))) + +(defvar help-xref-stack) +(defvar help-xref-stack-item) + +(defun erc-nicks-list-faces () + "Show faces owned by ERC-nicks in a help buffer." + (interactive) + (save-excursion + (list-faces-display (rx bot "erc-nicks-")) + (with-current-buffer "*Faces*" + (setq help-xref-stack nil + help-xref-stack-item '(erc-nicks-list-faces)) + (with-silent-modifications + (goto-char (point-min)) + (while (zerop (forward-line)) + (when (and (get-text-property (point) 'button) + (facep (car (button-get (point) 'help-args)))) + (button-put (point) 'help-function + #'erc-nicks--list-faces-help-button-action) + (if-let* ((face (car (button-get (point) 'help-args))) + ((not (get face 'erc-nicks--custom-face))) + ((not (get face 'erc-nicks--key)))) + (progn (delete-region (pos-bol) (1+ (pos-eol))) + (forward-line -1)) + (when-let* ((nid (get face 'erc-nicks--netid)) + (net (symbol-name (erc-networks--id-symbol nid)))) + (goto-char (button-end (point))) + (skip-syntax-forward "-") + (put-text-property (point) (1+ (point)) 'rear-nonsticky nil) + (forward-char) + (when (stringp (face-foreground face)) + (setq net (format "%-13.13s %s" (substring-no-properties + (face-foreground face)) + net))) + (insert-and-inherit net) + (delete-region (button-start (point)) + (1+ (button-start (point)))) + (delete-region (point) (pos-eol)))))))))) + +(defun erc-nicks-refresh (debug) "Recompute faces for all nicks on current network. -With DEBUG-POOL, list available colors and, in another buffer, -those culled (only applies when `erc-nicks-colors' is set to -something other than `all')." +With DEBUG, review affected faces or colors. Which one depends +on the value of `erc-nicks-colors'." (interactive "P") + (unless (derived-mode-p 'erc-mode) + (user-error "Not an ERC buffer")) (erc-with-server-buffer (unless erc-nicks-mode (user-error "Module `nicks' disabled")) - (erc-nicks--init-pool debug-pool) + (erc-nicks--init-pool debug) (dolist (nick (hash-table-keys erc-nicks--face-table)) + ;; User-tuned faces do not have an `erc-nicks--key' property. (when-let* ((face (gethash nick erc-nicks--face-table)) (key (get face 'erc-nicks--key))) (set-face-foreground face (erc-nicks--determine-color key)))))) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index d8ddaef72e5..052a4c6df70 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -311,5 +311,106 @@ erc-nicks--trim (should (equal (erc-nicks--trim "Bob~") "bob^")) (should (equal (erc-nicks--trim "Bob^") "bob")))) +(defun erc-nicks-tests--create-session (test) + (should-not (memq 'nicks erc-modules)) + (let ((erc-modules (cons 'nicks erc-modules)) + (inhibit-message noninteractive) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer + (cl-letf + (((symbol-function 'erc-server-connect) + (lambda (&rest _) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil)))) + + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester")) + + (let ((inhibit-message noninteractive)) + (dolist (line (split-string "\ +:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456 +:irc.foonet.org 005 tester NETWORK=foonet :are supported +:irc.foonet.org 376 tester :End of /MOTD command." + "\n")) + (erc-parse-server-response erc-server-process line))) + + (with-current-buffer (erc--open-target "#chan") + (erc-update-channel-member + "#chan" "Alice" "Alice" t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-update-channel-member + "#chan" "Bob" "Bob" t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-display-message + nil 'notice (current-buffer) + (concat "This server is in debug mode and is logging all user I/O. " + "Blah Alice (1) Bob (2) blah.")) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "Bob" "Hi Alice" nil t)) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "Alice" "Hi Bob" nil t))) + + (funcall test) + + (when noninteractive + (kill-buffer "#chan") + (kill-buffer))))) + +(ert-deftest erc-nicks-list-faces () + (erc-nicks-tests--create-session + (lambda () + (erc-nicks-list-faces) + (let ((table (buffer-local-value 'erc-nicks--face-table + (get-buffer "foonet"))) + calls) + (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action) + (lambda (&rest r) (push r calls)))) + (with-current-buffer "*Faces*" + (set-window-buffer (selected-window) (current-buffer)) + (goto-char (point-min)) + + (ert-info ("Clicking on face link runs action function") + (forward-button 1) + (should (looking-at "erc-nicks-alice-face")) + (push-button) + (should (eq (car (car calls)) (gethash "alice" table)))) + + (ert-info ("Clicking on sample text describes face") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (push-button) + (should (search-forward-regexp + (rx "Foreground: #" (group (+ xdigit)) eol))) + (forward-button 1) + (push-button)) + + (ert-info ("First entry's sample is rendered correctly") + (let ((hex (match-string 1))) + (should (looking-at (concat "#" hex))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls))) + + (ert-info ("Clicking on another entry's face link runs action") + (forward-button 1) + (should (looking-at "erc-nicks-bob-face")) + (push-button) + (should (eq (car (car calls)) (gethash "bob" table)))) + + (ert-info ("Second entry's sample is rendered correctly") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls)) + + (when noninteractive + (kill-buffer)))))))) ;;; erc-nicks-tests.el ends here -- 2.40.1