Re: bug#63569: 30.0.50; ERC 5.6: Add automatic nickname highlighting to ERC
"J.P." <[email protected]>
| Newsgroups | gmane.emacs.erc.general |
|---|---|
| Message-ID | <[email protected]> |
v8. Use foreground and background colors when adjusting contrast. Fix memory leak affecting continued sessions.
0000-v7-v8.diff
(text/x-patch, 8.8 KB)
From 7318662ad47e9f7b0da1a72f158690bbd4504724 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" <[email protected]> Date: Fri, 30 Jun 2023 19:38:15 -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 | 635 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 439 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1088 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 dd936af3835..42bbdc1c59d 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -40,9 +40,11 @@ ;; This module has enjoyed a number of contributors across several ;; variants over the years, including: ;; -;; Thibault Polge <[email protected]>, -;; Jay Kamat <[email protected]>, +;; Thibault Polge <[email protected]> +;; Jay Kamat <[email protected]> ;; Alex Kost <[email protected]> +;; Antoine Levitt <antoine dot levitt at gmail> +;; Adam Porter <[email protected]> ;; ;; To those not mentioned, your efforts are no less appreciated. @@ -164,9 +166,32 @@ erc-nicks-key-suffix-format like \"@%-012n\"." :type 'string) +(defvar erc-nicks--max-skip-search 3 ; make this an option? + "Max number of faces to visit when testing `erc-nicks-skip-faces'.") + +(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec + "Function for generating a key to determine nick color. +Called with a trimmed and case-mapped nickname.") + +(defvar erc-nicks--colors-rejects nil) +(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) +(defvar erc-nicks--grad-steps 9) + (defvar-local erc-nicks--face-table nil "Hash table mapping nicks to unique, named faces. -Keys need not be valid nicks.") +Keys are nonempty strings but need not be valid nicks.") + +(defvar-local erc-nicks--downcased-skip-nicks nil + "Case-mapped copy of `erc-nicks-skip-nicks'.") + +(defvar-local erc-nicks--bg-luminance nil) +(defvar-local erc-nicks--bg-mode-value nil) +(defvar-local erc-nicks--colors-len nil) +(defvar-local erc-nicks--colors-pool nil) +(defvar-local erc-nicks--fg-rgb nil) + +(defvar help-xref-stack) +(defvar help-xref-stack-item) ;; https://stackoverflow.com/questions/596216#answer-56678483 (defun erc-nicks--get-luminance (color) @@ -182,8 +207,6 @@ erc-nicks--get-luminance (/ ch 12.92) (expt (/ (+ ch 0.055) 1.055) 2.4))))))) -(defvar-local erc-nicks--bg-luminance nil) - (defun erc-nicks--get-contrast (fg &optional bg) "Return a float between 1 and 21 for colors FG and BG. If FG or BG are floats, interpret them as luminance values." @@ -196,8 +219,6 @@ erc-nicks--get-contrast (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg)) (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg)))) -(defvar-local erc-nicks--bg-mode-value nil) - (defmacro erc-nicks--bg-mode () `(or erc-nicks--bg-mode-value (setq erc-nicks--bg-mode-value @@ -208,20 +229,14 @@ erc-nicks--bg-mode (t '(frame-parameter (selected-frame) 'background-mode)))))) -(defvar erc-nicks--grad-steps 9) - ;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html -;; -;; TODO see implementation in https://elpa.gnu.org/packages/ement and -;; maybe copy that instead. (defun erc-nicks--adjust-contrast (color target &optional decrease) (let* ((lum-bg (or erc-nicks--bg-luminance (setq erc-nicks--bg-luminance (erc-nicks--get-luminance erc-nicks-bg-color)))) - ;; Shouldn't this use the actual bg color instead of b+w? - (stop (if (eq (if decrease 'light 'dark) (erc-nicks--bg-mode)) - '(1.0 1.0 1.0) - '(0.0 0.0 0.0))) + (stop (if decrease + (color-name-to-rgb erc-nicks-bg-color) + erc-nicks--fg-rgb)) ;; From `color-gradient' in color.el (r (nth 0 color)) (g (nth 1 color)) @@ -298,8 +313,6 @@ erc-nicks--gen-color (/ (float (ash (logand color-num #xffff0000) -16)) #xffff) (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff)))) -(defvar-local erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) - ;; 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) @@ -347,10 +360,6 @@ erc-nicks--reduce erc-nicks-color-adjustments (if (stringp color) (color-name-to-rgb color) color)))) -(defvar-local erc-nicks--colors-len nil) -(defvar-local erc-nicks--colors-pool nil) -(defvar erc-nicks--colors-rejects nil) - (defun erc-nicks--create-pool (adjustments colors) "Return COLORS that fall within parameters indicated by ADJUSTMENTS." (let (addp capp satp pool) @@ -415,9 +424,6 @@ erc-nicks--anon-face-p ('foreground-color t) ('background-color t))))) -(defvar erc-nicks--max-skip-search 3 ; make this an option? - "Max number of faces to visit when testing `erc-nicks-skip-faces'.") - (defun erc-nicks--skip-p (prop option limit) "Return non-nil if a face in PROP appears in OPTION. Abandon search after examining LIMIT faces." @@ -434,9 +440,6 @@ erc-nicks--skip-p (when (if (symbolp elem) (memq elem option) (member elem option)) (throw 'found elem)))))) -(defvar-local erc-nicks--downcased-skip-nicks nil - "Case-mapped copy of `erc-nicks-skip-nicks'.") - (defun erc-nicks--trim (nickname) "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'." (erc-downcase @@ -446,10 +449,6 @@ erc-nicks--trim `(: (+ (any ,erc-nicks-ignore-chars)) eot))) nickname))) -(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec - "Function for generating a key to determine nick color. -Called with a trimmed and case-mapped nickname.") - (defun erc-nicks--gen-key-from-format-spec (nickname) "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'." (concat nickname (format-spec erc-nicks-key-suffix-format @@ -505,7 +504,13 @@ nicks temp "\" globally. Please see `erc-nicks-bg-color'.") (custom-set-variables (list 'erc-nicks-bg-color temp)))) (erc-nicks--init-pool) - (setq erc-nicks--face-table (make-hash-table :test #'equal))) + (erc--restore-initialize-priors erc-nicks-mode + erc-nicks--face-table (make-hash-table :test #'equal))) + (setq erc-nicks--fg-rgb + (or (color-name-to-rgb + (face-foreground 'erc-default-face nil 'default)) + (color-name-to-rgb + (readable-foreground-color erc-nicks-bg-color)))) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) #'erc-nicks-customize-face) (advice-add 'widget-create-child-and-convert :filter-args @@ -513,6 +518,7 @@ nicks ((kill-local-variable 'erc-nicks--face-table) (kill-local-variable 'erc-nicks--bg-mode-value) (kill-local-variable 'erc-nicks--bg-luminance) + (kill-local-variable 'erc-nicks--fg-rgb) (kill-local-variable 'erc-nicks--colors-len) (kill-local-variable 'erc-nicks--colors-pool) (kill-local-variable 'erc-nicks--downcased-skip-nicks) @@ -552,9 +558,6 @@ erc-nicks--list-faces-help-button-action (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) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index ec6b351a2e7..08e423bf6b3 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -208,6 +208,8 @@ erc-nicks-invert--dark (ert-deftest erc-nicks-add-contrast () (let ((erc-nicks--bg-luminance 1.0) (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") (erc-nicks-contrast-range '(3.5)) (show (lambda (c) (erc-nicks-tests--print-contrast #'erc-nicks-add-contrast c)))) @@ -240,6 +242,8 @@ erc-nicks-cap-contrast (should (= 12.5 (cdr erc-nicks-contrast-range))) (let ((erc-nicks--bg-luminance 1.0) (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") (show (lambda (c) (erc-nicks-tests--print-contrast #'erc-nicks-cap-contrast c)))) -- 2.41.0
0001-5.6-Add-module-for-colorizing-nicknames-to-ERC.patch
(text/x-patch, 51.8 KB)
From 7318662ad47e9f7b0da1a72f158690bbd4504724 Mon Sep 17 00:00:00 2001 From: David Leatherman <[email protected]> Date: Sun, 18 Dec 2022 19:01:40 -0800 Subject: [PATCH 1/1] [5.6] Add module for colorizing nicknames to ERC * doc/misc/erc.texi: Add `nicks' to module lineup. * etc/ERC-NEWS: Mention new module `nicks'. * lisp/erc/erc-nicks.el: New file. * lisp/erc/erc.el: (erc-modules): Add `nicks'. * test/lisp/erc/erc-nicks-tests.el: New file. * test/lisp/erc/erc-tests (erc-tests--modules): Add `nicks'. (Bug#63569) Co-authored-by: Andy Stewart <[email protected]> --- doc/misc/erc.texi | 4 + etc/ERC-NEWS | 8 + lisp/erc/erc-nicks.el | 635 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 439 +++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1088 insertions(+), 1 deletion(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index ddfdb2e2b64..a67dcb3da7c 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -459,6 +459,10 @@ Modules @item netsplit Detect netsplits +@cindex modules, nicks +@item nicks +Automatically colorize nicks + @cindex modules, noncommands @item noncommands Don't display non-IRC commands after evaluation diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 68cf0e2d6ca..658665f9d86 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get started. +** A new module for nickname highlighting has joined ERC. +Automatic nickname coloring has come to ERC core. Users familiar with +'erc-hl-nicks', from which this module directly descends, will already +be familiar with its suite of handy options. By default, each +nickname in an ERC session receives a unique face with a unique (or +evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get +started. + ** A unified interactive entry point. New users are often dismayed to discover that M-x ERC doesn't connect to its default network, Libera.Chat, over TLS. Though perhaps a diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el new file mode 100644 index 00000000000..42bbdc1c59d --- /dev/null +++ b/lisp/erc/erc-nicks.el @@ -0,0 +1,635 @@ +;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: David Leatherman <[email protected]> +;; Andy Stewart <[email protected]> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file provides the `nicks' module for automatic nickname +;; highlighting. Add `nicks' to `erc-modules' to get started. +;; +;; 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: + +;; This module has enjoyed a number of contributors across several +;; variants over the years, including: +;; +;; Thibault Polge <[email protected]> +;; Jay Kamat <[email protected]> +;; Alex Kost <[email protected]> +;; Antoine Levitt <antoine dot levitt at gmail> +;; Adam Porter <[email protected]> +;; +;; To those not mentioned, your efforts are no less appreciated. + +;; 2023/05 - erc-nicks +;; Rewrite using internal API, and rebrand for ERC 5.6 +;; 2020/03 - erc-hl-nicks 1.3.4 +;; Final release, see [1] for intervening history +;; 2014/05 - erc-highlight-nicknames.el +;; Final release, see [2] for intervening history +;; 2011/08 - erc-hl-nicks 1.0 +;; Initial release forked from erc-highlight-nicknames.el +;; 2008/12 - erc-highlight-nicknames.el +;; First release from Andy Stewart +;; 2007/09 - erc-highlight-nicknames.el +;; Initial release by by André Riemann + +;; [1] <http://www.github.com/leathekd/erc-hl-nicks> +;; [2] <https://www.emacswiki.org/emacs/ErcHighlightNicknames> + +;;; Code: + +(require 'erc-button) +(require 'color) + +(defgroup erc-nicks nil + "Colorize nicknames in ERC buffers." + :package-version '(ERC . "5.6") ; FIXME sync on release + :group 'erc) + +(defcustom erc-nicks-ignore-chars ",`'_-" + "Trailing characters in a nick to ignore while highlighting. +Value should be a string containing characters typically appended +by IRC clients to secure a nickname after a rejection (see option +`erc-nick-uniquifier'). A value of nil means don't trim +anything." + :type '(choice (string :tag "Chars to trim") + (const :tag "Don't trim" nil))) + +(defcustom erc-nicks-skip-nicks nil + "Nicks to avoid highlighting. +ERC only considers this option during module activation, so users +should adjust it before connecting." + :type '(repeat string)) + +(defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face + erc-my-nick-face erc-pal-face erc-fool-face) + "Faces to avoid highlighting atop." + :type '(repeat symbol)) + +(defcustom erc-nicks-backing-face erc-button-nickname-face + "Face to mix with generated one for emphasizing non-speakers." + :type '(choice face (const nil))) + +(defcustom erc-nicks-bg-color + (frame-parameter (selected-frame) 'background-color) + "Background color for calculating contrast. +Set this explicitly when the background color isn't discoverable, +which may be the case in terminal Emacs." + :type 'string) + +(defcustom erc-nicks-color-adjustments + '(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' +attempts to find a decent contrast ratio by brightening or +darkening. When `erc-nicks-colors' is set to the symbol +`defined' or a user-provided list of colors, ERC uses this option +as a guide for culling any colors that don't fall within +`erc-nicks-contrast-range' or `erc-nicks-saturation-range', as +appropriate. For example, if `erc-nicks-cap-contrast' is present +in this option's value, and a color's contrast exceeds the CDR of +`erc-nicks-contrast-range', ERC will purge that color from its +rolls when initializing this module. Specify a value of nil to +inhibit this process." + :type '(repeat + (choice (function-item :tag "Invert" erc-nicks-invert) + (function-item :tag "Add contrast" erc-nicks-add-contrast) + (function-item :tag "Cap contrast" erc-nicks-cap-contrast) + (function-item :tag "Bound saturation" erc-nicks-ensaturate) + function))) + +(defcustom erc-nicks-contrast-range '(4.3 . 12.5) + "Desired range of contrast as a cons of (MIN . MAX). +When `erc-nicks-add-contrast' and/or `erc-nicks-invert' appear in +`erc-nicks-color-adjustments', MIN specifies the minimum amount +of contrast allowed between a buffer's background and its +foreground colors. Depending on the background, nicks may appear +tinted in pastels or shaded with muted grays. MAX works +similarly for reducing contrast, but only when +`erc-nicks-cap-contrast' is active. Users with lighter +backgrounds may want to lower MAX significantly. Either value +can range from 1.0 to 21.0(:1) but may produce unsatisfactory +results toward either extreme." + :type '(cons float float)) + +(defcustom erc-nicks-saturation-range '(0.2 . 0.8) + "Desired range for constraining saturation. +Expressed as a cons of decimal proportions. Only matters when +`erc-nicks-ensaturate' appears in `erc-nicks-color-adjustments'." + :type '(cons float float)) + +(defcustom erc-nicks-colors 'all + "Pool of colors. +List colors as strings (hex or named) or, alternatively, a single +symbol representing a set of colors, like that produced by the +function `defined-colors', which ERC associates with the symbol +`defined'. Similarly, `all' tells ERC to use any 24-bit color. +When specifying a list, users may want to set the option +`erc-nicks-color-adjustments' to nil to prevent unwanted culling." + :type '(choice (const all) (const defined) (list string))) + +(defcustom erc-nicks-key-suffix-format "@%n" + "Template for latter portion of keys to generate colors from. +ERC passes this to `format-spec' with the following specifiers: +%n for the current network and %m for your nickname (not the one +being colorized). If you don't like the generated palette, try +adding extra characters or padding, for example, with something +like \"@%-012n\"." + :type 'string) + +(defvar erc-nicks--max-skip-search 3 ; make this an option? + "Max number of faces to visit when testing `erc-nicks-skip-faces'.") + +(defvar erc-nicks--key-function #'erc-nicks--gen-key-from-format-spec + "Function for generating a key to determine nick color. +Called with a trimmed and case-mapped nickname.") + +(defvar erc-nicks--colors-rejects nil) +(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) +(defvar erc-nicks--grad-steps 9) + +(defvar-local erc-nicks--face-table nil + "Hash table mapping nicks to unique, named faces. +Keys are nonempty strings but need not be valid nicks.") + +(defvar-local erc-nicks--downcased-skip-nicks nil + "Case-mapped copy of `erc-nicks-skip-nicks'.") + +(defvar-local erc-nicks--bg-luminance nil) +(defvar-local erc-nicks--bg-mode-value nil) +(defvar-local erc-nicks--colors-len nil) +(defvar-local erc-nicks--colors-pool nil) +(defvar-local erc-nicks--fg-rgb nil) + +(defvar help-xref-stack) +(defvar help-xref-stack-item) + +;; https://stackoverflow.com/questions/596216#answer-56678483 +(defun erc-nicks--get-luminance (color) + "Return relative luminance of COLOR. +COLOR can be a list of normalized values or a name. This is the +same as the Y component returned by `color-srgb-to-xyz'." + (let ((out 0) + (coefficients '(0.2126 0.7152 0.0722)) + (chnls (if (stringp color) (color-name-to-rgb color) color))) + (dolist (ch chnls out) + (cl-incf out (* (pop coefficients) + (if (<= ch 0.04045) + (/ ch 12.92) + (expt (/ (+ ch 0.055) 1.055) 2.4))))))) + +(defun erc-nicks--get-contrast (fg &optional bg) + "Return a float between 1 and 21 for colors FG and BG. +If FG or BG are floats, interpret them as luminance values." + (let* ((lum-fg (if (numberp fg) fg (erc-nicks--get-luminance fg))) + (lum-bg (if bg + (if (numberp bg) bg (erc-nicks--get-luminance bg)) + (or erc-nicks--bg-luminance + (setq erc-nicks--bg-luminance + (erc-nicks--get-luminance erc-nicks-bg-color)))))) + (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg)) + (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg)))) + +(defmacro erc-nicks--bg-mode () + `(or erc-nicks--bg-mode-value + (setq erc-nicks--bg-mode-value + ,(cond ((fboundp 'frame--current-background-mode) + '(frame--current-background-mode (selected-frame))) + ((fboundp 'frame--current-backround-mode) + '(frame--current-backround-mode (selected-frame))) + (t + '(frame-parameter (selected-frame) 'background-mode)))))) + +;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html +(defun erc-nicks--adjust-contrast (color target &optional decrease) + (let* ((lum-bg (or erc-nicks--bg-luminance + (setq erc-nicks--bg-luminance + (erc-nicks--get-luminance erc-nicks-bg-color)))) + (stop (if decrease + (color-name-to-rgb erc-nicks-bg-color) + erc-nicks--fg-rgb)) + ;; From `color-gradient' in color.el + (r (nth 0 color)) + (g (nth 1 color)) + (b (nth 2 color)) + (interval (float (1+ (expt 2 erc-nicks--grad-steps)))) + (r-step (/ (- (nth 0 stop) r) interval)) + (g-step (/ (- (nth 1 stop) g) interval)) + (b-step (/ (- (nth 2 stop) b) interval)) + (maxtries erc-nicks--grad-steps) + started) + ;; FIXME stop when sufficiently close instead of exhausting. + (while (let* ((lum-fg (erc-nicks--get-luminance (list r g b))) + (darker (if (< lum-bg lum-fg) lum-bg lum-fg)) + (lighter (if (= darker lum-bg) lum-fg lum-bg)) + (cur (/ (+ 0.05 lighter) (+ 0.05 darker))) + (scale (expt 2 maxtries))) + (cond ((if decrease (> cur target) (< cur target)) + (setq r (+ r (* r-step scale)) + g (+ g (* g-step scale)) + b (+ b (* b-step scale)))) + (started + (setq r (- r (* r-step scale)) + g (- g (* g-step scale)) + b (- b (* b-step scale)))) + (t (setq maxtries 1))) + (unless started + (setq started t)) + (setq r (min 1.0 (max 0 r)) + g (min 1.0 (max 0 g)) + b (min 1.0 (max 0 b))) + (not (zerop (cl-decf maxtries))))) + (list r g b))) + +(defun erc-nicks-add-contrast (color) + "Increase COLOR's contrast by blending it with white or black. +Unless sufficient contrast exists between COLOR and the +background, raise it to somewhere around the lower bound of +`erc-nicks-contrast-range'." + (erc-nicks--adjust-contrast color (car erc-nicks-contrast-range))) + +(defun erc-nicks-cap-contrast (color) + "Reduce COLOR's contrast by blending it with white or black. +If excessive contrast exists between COLOR and the background, +lower it to the upper bound of `erc-nicks-contrast-range'." + (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-range) 'remove)) + +(defun erc-nicks-invert (color) + "Invert COLOR based on the CAR of `erc-nicks-contrast-range'. +Don't bother if the inverted color has less contrast than the +input." + (if-let ((con-input (erc-nicks--get-contrast color)) + ((< con-input (car erc-nicks-contrast-range))) + (flipped (mapcar (lambda (c) (- 1.0 c)) color)) + ((> (erc-nicks--get-contrast flipped) con-input))) + flipped + color)) + +(defun erc-nicks-ensaturate (color) + "Ensure COLOR falls within `erc-nicks-saturation-range'." + (pcase-let ((`(,min . ,max) erc-nicks-saturation-range) + (`(,h ,s ,l) (apply #'color-rgb-to-hsl color))) + (cond ((> s max) (setq color (color-hsl-to-rgb h max l))) + ((< s min) (setq color (color-hsl-to-rgb h min l))))) + color) + +;; From https://elpa.gnu.org/packages/ement. The bit depth has been +;; scaled up to try and avoid components being exactly 0.0, which our +;; contrast function doesn't seem to like. +(defun erc-nicks--gen-color (string) + "Generate normalized RGB color from STRING." + (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum))) + (color-num (round (* #xffffffffffff ratio)))) + (list (/ (float (logand color-num #xffff)) #xffff) + (/ (float (ash (logand color-num #xffff0000) -16)) #xffff) + (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff)))) + +;; 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-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) + erc-nicks--custom-keywords)) + +(defun erc-nicks--create-defface-template (face) + (pop-to-buffer (get-buffer-create (format "*New face %s*" face))) + (erase-buffer) + (lisp-interaction-mode) + (insert ";; If you *don't* use Customize, put something like this in your\n" + (substitute-command-keys + ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n") + (format "(defface %s\n '%S\n %S" + face (face-user-default-spec face) (face-documentation face)) + (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr + concat (format "\n %s %S" k (list 'quote v))) + ")\n\n;; Or, if you use use-package\n(use-package erc-nicks\n" + " :custom-face\n" + (format " (%s %S)" face (face-user-default-spec face)) + ")\n")) + +(defun erc-nicks--redirect-face-widget-link (args) + (pcase args + (`(,widget face-link . ,plist) + (when-let* ((face (widget-value widget)) + ((get face 'erc-nicks--custom-face))) + (unless (symbol-file face) + (setf (plist-get plist :action) + (lambda (&rest _) (erc-nicks--create-defface-template face)))) + (setf (plist-get plist :help-echo) "Create or edit `defface'." + (cddr args) plist)))) + args) + +(defun erc-nicks--reduce (color) + "Fold contrast strategies over COLOR, a string or normalized triple. +Return a hex string." + (apply #'color-rgb-to-hex + (seq-reduce (lambda (color strategy) (funcall strategy color)) + erc-nicks-color-adjustments + (if (stringp color) (color-name-to-rgb color) color)))) + +(defun erc-nicks--create-pool (adjustments colors) + "Return COLORS that fall within parameters indicated by ADJUSTMENTS." + (let (addp capp satp pool) + (dolist (adjustment adjustments) + (pcase adjustment + ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t)) + ('erc-nicks-cap-contrast (setq capp t)) + ('erc-nicks-ensaturate (setq satp t)))) + (dolist (color colors) + (let* ((rgb (color-name-to-rgb color)) + (contrast (and (or addp capp) (erc-nicks--get-contrast rgb)))) + (if (or (and addp (< contrast (car erc-nicks-contrast-range))) + (and capp (> contrast (cdr erc-nicks-contrast-range))) + (and-let* ((satp) + (s (cadr (apply #'color-rgb-to-hsl rgb)))) + (or (< s (car erc-nicks-saturation-range)) + (> s (cdr erc-nicks-saturation-range))))) + (when erc-nicks--colors-rejects + (push color erc-nicks--colors-rejects)) + (push color pool)))) + (nreverse pool))) + +(defun erc-nicks--init-pool () + "Initialize colors and optionally display faces or color palette." + (unless (eq erc-nicks-colors 'all) + (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors) + (defined-colors))) + (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors))) + (setq erc-nicks--colors-pool pool + erc-nicks--colors-len (length pool))))) + +(defun erc-nicks--determine-color (key) + (if (eq erc-nicks-colors 'all) + (erc-nicks--reduce (erc-nicks--gen-color key)) + (let ((pool (erc-with-server-buffer erc-nicks--colors-pool)) + (len (erc-with-server-buffer erc-nicks--colors-len))) + (nth (% (abs (random key)) len) pool)))) + +(defun erc-nicks--get-face (nick key) + "Retrieve a face for trimmed and downcased NICK. +If NICK is new, use KEY to derive color, and store under NICK. +Favor a custom erc-nicks-NICK@NETWORK-face when defined." + (let ((table (erc-with-server-buffer erc-nicks--face-table))) + (or (gethash nick table) + (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@" + (erc-network-name) "-face"))) + ((or (and (facep face) 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 + new-face (format "Internal face for %s on %s." nick (erc-network))) + (puthash nick new-face table))))) + +(define-inline erc-nicks--anon-face-p (face) + (inline-quote (and (consp ,face) (pcase (car ,face) + ((pred keywordp) t) + ('foreground-color t) + ('background-color t))))) + +(defun erc-nicks--skip-p (prop option limit) + "Return non-nil if a face in PROP appears in OPTION. +Abandon search after examining LIMIT faces." + (setq prop (if (erc-nicks--anon-face-p prop) (list prop) (ensure-list prop))) + (catch 'found + (while-let (((> limit 0)) + (elem (pop prop))) + (while (and (consp elem) (not (erc-nicks--anon-face-p elem))) + (when (cdr elem) + (push (cdr elem) prop)) + (setq elem (car elem))) + (when elem + (cl-decf limit) + (when (if (symbolp elem) (memq elem option) (member elem option)) + (throw 'found elem)))))) + +(defun erc-nicks--trim (nickname) + "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'." + (erc-downcase + (if erc-nicks-ignore-chars + (string-trim-right nickname + (rx-to-string + `(: (+ (any ,erc-nicks-ignore-chars)) eot))) + nickname))) + +(defun erc-nicks--gen-key-from-format-spec (nickname) + "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'." + (concat nickname (format-spec erc-nicks-key-suffix-format + `((?n . ,(erc-network)) + (?m . ,(erc-current-nick)))))) + +(defun erc-nicks--highlight (nickname &optional base-face) + "Return face for NICKNAME unless it or BASE-FACE is blacklisted." + (when-let* ((trimmed (erc-nicks--trim nickname)) + ((not (member trimmed erc-nicks--downcased-skip-nicks))) + ((not (and base-face + (erc-nicks--skip-p base-face erc-nicks-skip-faces + erc-nicks--max-skip-search)))) + (key (funcall erc-nicks--key-function trimmed)) + (out (erc-nicks--get-face trimmed key))) + (if (or (null erc-nicks-backing-face) + (eq base-face erc-nicks-backing-face)) + out + (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." + (when-let* + ((nick-object) + (face (get-text-property (car (erc-button--nick-bounds nick-object)) + 'font-lock-face)) + (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) + (out (erc-nicks--highlight nick face))) + (setf (erc-button--nick-nickname-face nick-object) out)) + nick-object) + +(define-erc-module nicks nil + "Uniquely colorize nicknames in target buffers." + ((if erc--target + (progn + (setq erc-nicks--downcased-skip-nicks + (mapcar #'erc-downcase erc-nicks-skip-nicks)) + (add-function :filter-return (local 'erc-button--modify-nick-function) + #'erc-nicks--highlight-button '((depth . 80))) + (erc-button--phantom-users-mode +1)) + (unless erc-button-mode + (unless (memq 'button erc-modules) + (erc--warn-once-before-connect 'erc-nicks-mode + "Enabling default global module `button' needed by local" + " module `nicks'. This will impact \C-]all\C-] ERC" + " sessions. Add `nicks' to `erc-modules' to avoid this" + " warning. See Info:\"(erc) Modules\" for more.")) + (erc-button-mode +1)) + (when (equal erc-nicks-bg-color "unspecified-bg") + (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black"))) + (erc-button--display-error-notice-with-keys + "Module `nicks' unable to determine background color. Setting to \"" + temp "\" globally. Please see `erc-nicks-bg-color'.") + (custom-set-variables (list 'erc-nicks-bg-color temp)))) + (erc-nicks--init-pool) + (erc--restore-initialize-priors erc-nicks-mode + erc-nicks--face-table (make-hash-table :test #'equal))) + (setq erc-nicks--fg-rgb + (or (color-name-to-rgb + (face-foreground 'erc-default-face nil 'default)) + (color-name-to-rgb + (readable-foreground-color erc-nicks-bg-color)))) + (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) + #'erc-nicks-customize-face) + (advice-add 'widget-create-child-and-convert :filter-args + #'erc-nicks--redirect-face-widget-link)) + ((kill-local-variable 'erc-nicks--face-table) + (kill-local-variable 'erc-nicks--bg-mode-value) + (kill-local-variable 'erc-nicks--bg-luminance) + (kill-local-variable 'erc-nicks--fg-rgb) + (kill-local-variable 'erc-nicks--colors-len) + (kill-local-variable 'erc-nicks--colors-pool) + (kill-local-variable 'erc-nicks--downcased-skip-nicks) + (when (fboundp 'erc-button--phantom-users-mode) + (erc-button--phantom-users-mode -1)) + (remove-function (local 'erc-button--modify-nick-function) + #'erc-nicks--highlight-button) + (setf (alist-get "Edit face" + erc-button--nick-popup-alist nil 'remove #'equal) + nil)) + 'local) + +(defun erc-nicks-customize-face (nick) + "Customize or create persistent face for NICK." + (interactive (list (or (car (get-text-property (point) 'erc-data)) + (completing-read "nick: " (or erc-channel-users + erc-server-users))))) + (setq nick (erc-nicks--trim (substring-no-properties nick))) + (let* ((net (erc-network)) + (key (funcall erc-nicks--key-function nick)) + (old-face (erc-nicks--get-face nick key)) + (new-face (intern (format "erc-nicks-%s@%s-face" nick net)))) + (unless (eq new-face old-face) + (erc-nicks--revive new-face old-face nick net) + (set-face-attribute old-face nil :foreground 'unspecified) + (set-face-attribute old-face nil :inherit new-face)) + (customize-face new-face))) + +(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))))) + +(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, 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")) + (let ((erc-nicks--colors-rejects (and debug (list t)))) + (erc-nicks--init-pool) + (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))) + (setq key (funcall erc-nicks--key-function nick)) + (put face 'erc-nicks--key key) + (set-face-foreground face (erc-nicks--determine-color key)))) + (when debug + (if (eq erc-nicks-colors 'all) + (erc-nicks-list-faces) + (pcase-dolist (`(,name ,pool) + `(("*erc-nicks-pool*" ,erc-nicks--colors-pool) + ("*erc-nicks-rejects*" + ,(cdr (nreverse erc-nicks--colors-rejects))))) + (when (buffer-live-p (get-buffer name)) + (kill-buffer name)) + (when pool + (save-excursion + (list-colors-display + pool name + (lambda (c) + (message "contrast: %.3f :saturation: %.3f" + (erc-nicks--get-contrast c) + (cadr (apply #'color-rgb-to-hsl + (color-name-to-rgb c)))))))))))))) + +(provide 'erc-nicks) + +;;; erc-nicks.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 70adbb15b5f..a269d10dc51 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2008,6 +2008,7 @@ erc-modules move-to-prompt) (const :tag "netsplit: Detect netsplits" netsplit) (const :tag "networks: Provide data about IRC networks" networks) + (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks) (const :tag "noncommands: Don't display non-IRC commands after evaluation" noncommands) (const :tag "notifications: Desktop alerts on PRIVMSG or mentions" diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el new file mode 100644 index 00000000000..08e423bf6b3 --- /dev/null +++ b/test/lisp/erc/erc-nicks-tests.el @@ -0,0 +1,439 @@ +;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unlike most of ERC's tests, the ones in this file can be run +;; interactively in the same session. + +;; TODO: +;; +;; * Add mock session (or scenario) with buffer snapshots, like those +;; in erc-fill-tests.el. (Should probably move helpers to a common +;; library under ./resources.) + +;;; Code: + +(require 'ert) +(require 'erc-nicks) + +;; This function replicates the behavior of older "invert" strategy +;; implementations from EmacsWiki, etc. The values for the lower and +;; upper bounds (0.33 and 0.66) are likewise inherited. See +;; `erc-nicks--invert-classic--dark' below for one reason its results +;; may not be plainly obvious. +(defun erc-nicks-tests--invert-classic (color) + (if (pcase (erc-nicks--bg-mode) + ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0))) + ('light (> (erc-nicks--get-luminance color) (/ 2 3.0)))) + (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color))) + color)) + + +(ert-deftest erc-nicks--get-luminance () + (should (eql 0.0 (erc-nicks--get-luminance "black"))) + (should (eql 1.0 (erc-nicks--get-luminance "white"))) + (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0)))) + + ;; RGB floats from a `display-graphic-p' session. + (let ((a (erc-nicks--get-luminance ; #9439ad + '(0.5803921568627451 0.2235294117647059 0.6784313725490196))) + (b (erc-nicks--get-luminance ; #ae54c7 + '(0.6823529411764706 0.32941176470588235 0.7803921568627451))) + (c (erc-nicks--get-luminance ; #d19ddf + '(0.8196078431372549 0.615686274509804 0.8745098039215686))) + (d (erc-nicks--get-luminance ; #f5e8f8 + '(0.9607843137254902 0.9098039215686274 0.9725490196078431)))) + ;; Low, med, high contrast comparisons against known values from + ;; an external source. + (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0))) + (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0))) + (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0))))) + +(ert-deftest erc-nicks-invert--classic () + (let ((convert (lambda (n) (apply #'color-rgb-to-hex + (erc-nicks-tests--invert-classic + (color-name-to-rgb n)))))) + (let ((erc-nicks--bg-mode-value 'dark)) + (should (equal (funcall convert "white") "#ffffffffffff")) + (should (equal (funcall convert "black") "#ffffffffffff")) + (should (equal (funcall convert "green") "#0000ffff0000"))) + (let ((erc-nicks--bg-mode-value 'light)) + (should (equal (funcall convert "white") "#000000000000")) + (should (equal (funcall convert "black") "#000000000000")) + (should (equal (funcall convert "green") "#ffff0000ffff"))))) + +(ert-deftest erc-nicks--get-contrast () + (should (= 21.0 (erc-nicks--get-contrast "white" "black"))) + (should (= 21.0 (erc-nicks--get-contrast "black" "white"))) + (should (= 1.0 (erc-nicks--get-contrast "black" "black"))) + (should (= 1.0 (erc-nicks--get-contrast "white" "white")))) + +(defun erc-nicks-tests--print-contrast (fn color) + (let* ((erc-nicks-color-adjustments (list fn)) + (result (erc-nicks--reduce color)) + (start (point))) + (insert (format "%16s%-16s%16s%-16s\n" + (concat color "-") + (concat ">" result) + (concat color " ") + (concat " " result))) + (put-text-property (+ start 32) (+ start 48) 'face + (list :background color :foreground result)) + (put-text-property (+ start 48) (+ start 64) 'face + (list :background result :foreground color)) + result)) + +(ert-deftest erc-nicks--invert-classic--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +;; This shows that the output can be darker (have less contrast) than +;; the input. +(ert-deftest erc-nicks--invert-classic--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#777777777777" (funcall show "#888888888888"))) + (should (equal "#666666666666" (funcall show "#999999999999"))) + (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa")))) + + (when noninteractive + (kill-buffer))))) + +;; These are the same as the legacy version but work in terms of +;; contrast ratios. Converting the original bounds to contrast ratios +;; (assuming pure white and black backgrounds) gives: +;; +;; min-lum of 0.33 ~~> 1.465 +;; max-lum of 0.66 ~~> 7.666 +;; +(ert-deftest erc-nicks-invert--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks-contrast-range '(1.465)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-invert--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (erc-nicks-contrast-range '(7.666)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#888888888888" (funcall show "#888888888888"))) + (should (equal "#999999999999" (funcall show "#999999999999")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-add-contrast () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (erc-nicks-contrast-range '(3.5)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-add-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*") + (should (equal "#893a893a893a" (funcall show "white"))) + (should (equal "#893a893a893a" (funcall show "#893a893a893a"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#0000a12e0000" (funcall show "green"))) + (should (equal "#00000000ffff" (funcall show "blue"))) + + ;; When the input is already near the desired ratio, the result + ;; may not be in bounds, only close. But the difference is + ;; usually imperceptible. + (unless noninteractive + ;; Well inside (light slate gray) + (should (equal "#777788889999" (funcall show "#777788889999"))) + ;; Slightly outside -> just outside + (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa"))) + ;; Just outside -> just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c"))) + ;; Just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-cap-contrast () + (should (= 12.5 (cdr erc-nicks-contrast-range))) + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-cap-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*") + (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14 + (should ; 12.32 -> 12.32 (same) + (equal (funcall show "#34e534e534e5") "#34e534e534e5")) + (should (equal (funcall show "white") "#ffffffffffff")) + + (unless noninteractive + (should (equal (funcall show "DarkRed") "#8b8b00000000")) + (should (equal (funcall show "DarkGreen") "#000064640000")) + ;; 15.29 -> 12.38 + (should (equal (funcall show "DarkBlue") "#1cf11cf198b5")) + + ;; 12.50 -> 12.22 + (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab")) + ;; 12.57 -> 12.28 + (should (equal (funcall show "#338033803380") "#344c344c344c")) + ;; 12.67 -> 12.37 + (should (equal (funcall show "#330033003300") "#33cc33cc33cc"))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks--skip-p () + ;; Baseline + (should-not (erc-nicks--skip-p 'bold nil 10000000)) + (should-not (erc-nicks--skip-p '(bold) nil 10000000)) + (should-not (erc-nicks--skip-p nil '(bold) 10000000)) + (should-not (erc-nicks--skip-p 'bold '(bold) 0)) + (should-not (erc-nicks--skip-p '(bold) '(bold) 0)) + (should-not (erc-nicks--skip-p 'bold '(foo bold) 0)) + (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(fake bold) 1)) + (should (erc-nicks--skip-p 'bold '(foo bar bold) 1)) + (should (erc-nicks--skip-p '(bold) '(bold) 1)) + (should (erc-nicks--skip-p '((bold)) '(bold) 1)) + (should (erc-nicks--skip-p '((((bold)))) '(bold) 1)) + (should (erc-nicks--skip-p '(bold) '(foo bold) 1)) + (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1)) + + ;; Composed + (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1)) + (should (erc-nicks--skip-p '(italic bold) '(bold) 2)) + (should (erc-nicks--skip-p '((italic) bold) '(bold) 2)) + (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2)) + + (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2)) + (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3)) + (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3))) + +(ert-deftest erc-nicks--trim () + (should (equal (erc-nicks--trim "Bob`") "bob")) + (should (equal (erc-nicks--trim "Bob``") "bob")) + + ;; `erc--casemapping-rfc1459' + (let ((erc-nicks-ignore-chars "^")) + (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)))))))) + +(ert-deftest erc-nicks--gen-key-from-format-spec () + (let ((erc-network 'OFTC) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@OFTC00000000"))) + + (let ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "[email protected]"))) + + (let* ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%n/%m") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "[email protected]/tester")))) + +;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b751ef50520..a154b81db30 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1754,7 +1754,7 @@ erc-handle-irc-url (defconst erc-tests--modules '( autoaway autojoin button capab-identify completion dcc fill identd imenu irccontrols keep-place list log match menu move-to-prompt netsplit - networks noncommands notifications notify page readonly + networks nicks noncommands notifications notify page readonly replace ring sasl scrolltobottom services smiley sound spelling stamp track truncate unmorse xdcc)) -- 2.41.0