mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-28 07:45:00 +00:00
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' to inventory of available modules. (Bug#63569) Special thanks to Corwin Brust for doing much of the administrative legwork to bring this addition to ERC. Co-authored-by: Andy Stewart <lazycat.manatee@gmail.com> Co-authored-by: F. Jason Park <jp@neverwas.me>
This commit is contained in:
David Leatherman
F. Jason Park
parent
b354b3a53b
commit
9bdc5c6204
@ -459,6 +459,10 @@ Display a menu in ERC buffers
|
||||
@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
|
||||
|
||||
@ -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
|
||||
|
||||
633
lisp/erc/erc-nicks.el
Normal file
633
lisp/erc/erc-nicks.el
Normal file
@ -0,0 +1,633 @@
|
||||
;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*-
|
||||
|
||||
;; Copyright (C) 2023 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: David Leatherman <leathekd@gmail.com>
|
||||
;; Andy Stewart <lazycat.manatee@gmail.com>
|
||||
|
||||
;; 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
|
||||
;; on Emacs 28+ 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 <thibault@thb.lt>
|
||||
;; Jay Kamat <jaygkamat@gmail.com>
|
||||
;; Alex Kost <alezost@gmail.com>
|
||||
;; Antoine Levitt <antoine dot levitt at gmail>
|
||||
;; Adam Porter <adam@alphapapa.net>
|
||||
;;
|
||||
;; 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 target 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 (erc--with-dependent-type-match (repeat face) erc-match))
|
||||
|
||||
(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 of 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) (repeat 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--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 the foreground.
|
||||
Unless sufficient contrast exists between COLOR and the
|
||||
background, raise it to meet 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 the background.
|
||||
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 adjustment 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 (erc-nicks--gen-key-from-format-spec 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 `button' 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)
|
||||
(unless erc-button--nick-popup-alist
|
||||
(kill-local-variable 'erc-button--nick-popup-alist)))
|
||||
'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 (erc-nicks--gen-key-from-format-spec 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 (erc-nicks--gen-key-from-format-spec 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
|
||||
@ -2066,6 +2066,7 @@ removed from the list will be disabled."
|
||||
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"
|
||||
|
||||
538
test/lisp/erc/erc-nicks-tests.el
Normal file
538
test/lisp/erc/erc-nicks-tests.el
Normal file
@ -0,0 +1,538 @@
|
||||
;;; 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-x)
|
||||
(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"))))
|
||||
|
||||
(defvar erc-nicks-tests--fake-face-list nil)
|
||||
|
||||
;; Since we can't delete faces, mock `face-list' to only return those
|
||||
;; in `erc-nicks--face-table' created by the current test.
|
||||
(defun erc-nicks-tests--face-list ()
|
||||
(let ((table (buffer-local-value 'erc-nicks--face-table
|
||||
(get-buffer "foonet")))
|
||||
out)
|
||||
(maphash (lambda (k v)
|
||||
(when (member k erc-nicks-tests--fake-face-list)
|
||||
(push v out)))
|
||||
table)
|
||||
(nreverse out)))
|
||||
|
||||
(defun erc-nicks-tests--create-session (test alice bob)
|
||||
(should-not (memq 'nicks erc-modules))
|
||||
(advice-add 'face-list :override #'erc-nicks-tests--face-list)
|
||||
(let ((erc-modules (cons 'nicks erc-modules))
|
||||
(inhibit-message noninteractive)
|
||||
(erc-nicks-tests--fake-face-list
|
||||
(list (downcase alice) (downcase bob)))
|
||||
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")
|
||||
(when (get-buffer " *Custom-Work*")
|
||||
(kill-buffer " *Custom-Work*"))
|
||||
(kill-buffer))))
|
||||
(advice-remove 'face-list #'erc-nicks-tests--face-list))
|
||||
|
||||
(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-alice1-face"))
|
||||
(push-button)
|
||||
(should (eq (car (car calls)) (gethash "alice1" 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-bob1-face"))
|
||||
(push-button)
|
||||
(should (eq (car (car calls)) (gethash "bob1" 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))))))
|
||||
"Alice1" "Bob1"))
|
||||
|
||||
(ert-deftest erc-nicks-customize-face ()
|
||||
(unless (>= emacs-major-version 28)
|
||||
(ert-skip "Face link required in customize-face buffers"))
|
||||
(erc-nicks-tests--create-session
|
||||
(lambda ()
|
||||
(erc-nicks-list-faces)
|
||||
(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-alice2"))
|
||||
(ert-simulate-keys "y\r"
|
||||
(call-interactively #'push-button nil)))
|
||||
|
||||
(with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*"
|
||||
(should (search-forward "Erc Nicks Alice2@Foonet Face" nil t))
|
||||
(widget-button-press (1- (point))))
|
||||
|
||||
(with-current-buffer "*New face erc-nicks-alice2@foonet-face*"
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "(use-package erc-nicks" nil t))
|
||||
(should (search-forward ":foreground \"#" nil t))
|
||||
(when noninteractive
|
||||
(kill-buffer)))
|
||||
|
||||
(with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*"
|
||||
(should (search-forward "Foreground: #" nil t))
|
||||
(when noninteractive
|
||||
(kill-buffer)))
|
||||
|
||||
(when noninteractive
|
||||
(kill-buffer))))
|
||||
"Alice2" "Bob2"))
|
||||
|
||||
(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")
|
||||
"bob@Libera.Chat0")))
|
||||
|
||||
(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")
|
||||
"bob@Libera.Chat/tester"))))
|
||||
|
||||
(ert-deftest erc-nicks--create-pool ()
|
||||
(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--colors-rejects '(t)))
|
||||
|
||||
;; Reject
|
||||
(should-not (erc-nicks--create-pool '(erc-nicks-invert) '("white")))
|
||||
(should (equal (pop erc-nicks--colors-rejects) "white")) ; too close
|
||||
(should-not (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("black")))
|
||||
(should (equal (pop erc-nicks--colors-rejects) "black")) ; too far
|
||||
(should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("white")))
|
||||
(should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color
|
||||
(should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("red")))
|
||||
(should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color
|
||||
|
||||
;; Safe
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-invert) '("black"))
|
||||
'("black")))
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-add-contrast) '("black"))
|
||||
'("black")))
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("white"))
|
||||
'("white")))
|
||||
(let ((erc-nicks-saturation-range '(0.5 . 1.0)))
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("green"))
|
||||
'("green"))))
|
||||
(let ((erc-nicks-saturation-range '(0.0 . 0.5)))
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("gray"))
|
||||
'("gray"))))
|
||||
(unless noninteractive
|
||||
(should
|
||||
(equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("firebrick"))
|
||||
'("firebrick"))))
|
||||
(should (equal erc-nicks--colors-rejects '(t)))))
|
||||
|
||||
;;; erc-nicks-tests.el ends here
|
||||
@ -1953,7 +1953,7 @@
|
||||
(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))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user