From 2c0b39529cfc9edd6178f4243145688b915d37c6 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 7 Mar 2024 21:53:11 -0800 Subject: [PATCH 1/3] [5.6] Leverage inverse-video for erc-inverse-face * lisp/erc/erc-goodies.el (erc-inverse-face): Prefer the "reversing" effect of swapping foreground and background colors over affected intervals. See https://modern.ircdocs.horse/formatting#reverse-color. (erc-control-default-fg erc-control-default-bg): New faces to allow for customizing the look of IRC color-code number 99. Ignore the ERC convention of prefixing control-code-derived faces with "fg:" and "bg:" because it doesn't comport with modern sensibilities, which demand identifiers normally be namespaced. (erc-get-bg-color-face, erc-get-fg-color-face): Don't wrap face in a list, and use new, dedicated faces. * test/lisp/erc/erc-goodies-tests.el (erc-controls-highlight--inverse): Redo, asserting behavior described in https://modern.ircdocs.horse/formatting#reverse-color. (erc-controls-highlight--spoilers): New test based on the body of the old `erc-controls-highlight--inverse', except without shadowing `erc-insert-modify-hook' with an unrealistic, idealized value. Adjust expected buffer state to reflect the new role of `erc-spoiler-face'. (Bug#69597) --- lisp/erc/erc-goodies.el | 18 +++- test/lisp/erc/erc-goodies-tests.el | 153 ++++++++++++++++++++--------- 2 files changed, 124 insertions(+), 47 deletions(-) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 7e30b1060fd..dbf869dafe6 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -661,7 +661,9 @@ erc-italic-face :group 'erc-faces) (defface erc-inverse-face - '((t :foreground "White" :background "Black")) + '((((supports :inverse-video t)) + :inverse-video t) + (t :foreground "White" :background "Black")) "ERC inverse face." :group 'erc-faces) @@ -675,6 +677,16 @@ erc-underline-face "ERC underline face." :group 'erc-faces) +(defface erc-control-default-fg '((t :inherit default)) + "ERC foreground face for the \"default\" color code." + :group 'erc-faces) + +(defface erc-control-default-bg '((t :inherit default)) + "ERC background face for the \"default\" color code." + :group 'erc-faces) + +;; FIXME rename these to something like `erc-control-color-N-fg', +;; and deprecate the old names via `define-obsolete-face-alias'. (defface fg:erc-color-face0 '((t :foreground "White")) "ERC face." :group 'erc-faces) @@ -804,7 +816,7 @@ erc-get-bg-color-face (intern (concat "bg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :background (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) '(default))))) + (t (erc-log (format " Wrong color: %s" n)) 'erc-control-default-fg)))) (defun erc-get-fg-color-face (n) "Fetches the right face for foreground color N (0-15)." @@ -820,7 +832,7 @@ erc-get-fg-color-face (intern (concat "fg:erc-color-face" (number-to-string n)))) ((< 15 n 99) (list :foreground (aref erc--controls-additional-colors (- n 16)))) - (t (erc-log (format " Wrong color: %s" n)) '(default))))) + (t (erc-log (format " Wrong color: %s" n)) 'erc-control-default-bg)))) ;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el index 7013ce0c8fc..c8fb0544a72 100644 --- a/test/lisp/erc/erc-goodies-tests.el +++ b/test/lisp/erc/erc-goodies-tests.el @@ -29,19 +29,23 @@ (defun erc-goodies-tests--assert-face (beg end-str present &optional absent) (setq beg (+ beg (point-min))) (let ((end (+ beg (1- (length end-str))))) - (while (and beg (< beg end)) - (let* ((val (get-text-property beg 'font-lock-face)) - (ft (flatten-tree (ensure-list val)))) - (dolist (p (ensure-list present)) - (if (consp p) - (should (member p val)) - (should (memq p ft)))) - (dolist (a (ensure-list absent)) - (if (consp a) - (should-not (member a val)) - (should-not (memq a ft)))) - (setq beg (text-property-not-all beg (point-max) - 'font-lock-face val)))))) + (ert-info ((format "beg: %S, end-str: %S" beg end-str)) + (while (and beg (< beg end)) + (let* ((val (get-text-property beg 'font-lock-face)) + (ft (flatten-tree (ensure-list val)))) + (ert-info ((format "looking-at: %S, val: %S" + (buffer-substring-no-properties beg end) + val)) + (dolist (p (ensure-list present)) + (if (consp p) + (should (member p val)) + (should (memq p ft)))) + (dolist (a (ensure-list absent)) + (if (consp a) + (should-not (member a val)) + (should-not (memq a ft))))) + (setq beg (text-property-not-all beg (point-max) + 'font-lock-face val))))))) ;; These are from the "Examples" section of ;; https://modern.ircdocs.horse/formatting.html @@ -129,39 +133,100 @@ erc-controls-highlight--examples ;; Hovering over the redacted area should reveal its underlying text ;; in a high-contrast face. -(ert-deftest erc-controls-highlight--inverse () +(ert-deftest erc-controls-highlight--spoilers () (should (eq t erc-interpret-controls-p)) - (let ((erc-insert-modify-hook '(erc-controls-highlight)) - erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) - (with-current-buffer (get-buffer-create "#chan") - (erc-mode) - (setq-local erc-interpret-mirc-color t) - (erc--initialize-markers (point) nil) + (erc-tests-common-make-server-buf) + (with-current-buffer (erc--open-target "#chan") + (setq-local erc-interpret-mirc-color t) + (let* ((raw (concat "BEGIN " + "\C-c0,0 WhiteOnWhite " + "\C-c1,1 BlackOnBlack " + "\C-c99,99 Default " + "\C-o END")) + (msg (erc-format-privmessage "bob" raw nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward " " nil t)) + (save-restriction + ;; Narrow to EOL or start of right-side stamp. + (narrow-to-region (point) (line-end-position)) + (save-excursion + (search-forward "WhiteOn") + (should (eq (get-text-property (point) 'mouse-face) + 'erc-spoiler-face)) + (search-forward "BlackOn") + (should (eq (get-text-property (point) 'mouse-face) + 'erc-spoiler-face))) + ;; Start wtih ERC default face. + (erc-goodies-tests--assert-face + 0 "BEGIN " 'erc-default-face + '(fg:erc-color-face0 bg:erc-color-face0)) + ;; Masked in all white. + (erc-goodies-tests--assert-face + 6 "WhiteOnWhite" '(fg:erc-color-face0 bg:erc-color-face0) + '(fg:erc-color-face1 bg:erc-color-face1)) + ;; Masked in all black. + (erc-goodies-tests--assert-face + 20 "BlackOnBlack" '(fg:erc-color-face1 bg:erc-color-face1) + '(erc-control-default-fg erc-control-default-bg)) + ;; Explicit "default" code ignoerd. + (erc-goodies-tests--assert-face + 34 "Default" '(erc-control-default-fg erc-control-default-bg) + '(fg:erc-color-face1 bg:erc-color-face1)) + (erc-goodies-tests--assert-face + 43 "END" 'erc-default-face + '(erc-control-default-bg erc-control-default-fg)))) + (when noninteractive + (erc-tests-common-kill-buffers))) - (let* ((m "Spoiler: \C-c0,0Hello\C-c1,1World!") - (msg (erc-format-privmessage "bob" m nil t))) - (erc-display-message nil nil (current-buffer) msg)) - (forward-line -1) - (should (search-forward " " nil t)) - (save-restriction - (narrow-to-region (point) (pos-eol)) - (should (eq (get-text-property (+ 9 (point)) 'mouse-face) - 'erc-inverse-face)) - (should (eq (get-text-property (1- (pos-eol)) 'mouse-face) - 'erc-inverse-face)) - (erc-goodies-tests--assert-face - 0 "Spoiler: " 'erc-default-face - '(fg:erc-color-face0 bg:erc-color-face0)) - (erc-goodies-tests--assert-face - 9 "Hello" '(erc-spoiler-face) - '( fg:erc-color-face0 bg:erc-color-face0 - fg:erc-color-face1 bg:erc-color-face1)) - (erc-goodies-tests--assert-face - 18 " World" '(erc-spoiler-face) - '( fg:erc-color-face0 bg:erc-color-face0 - fg:erc-color-face1 bg:erc-color-face1 ))) - (when noninteractive - (kill-buffer))))) +(ert-deftest erc-controls-highlight--inverse () + (should (eq t erc-interpret-controls-p)) + (erc-tests-common-make-server-buf) + (with-current-buffer (erc--open-target "#chan") + (setq-local erc-interpret-mirc-color t) + (defvar erc-fill-column) + (let* ((erc-fill-column 90) + (raw (concat "BEGIN " + "\C-c3,13 GreenOnPink " + "\C-v PinkOnGreen " + "\C-c99,99 ReversedDefault " + "\C-v NormalDefault " + "\C-o END")) + (msg (erc-format-privmessage "bob" raw nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward " " nil t)) + (save-restriction + ;; Narrow to EOL or start of right-side stamp. + (narrow-to-region (point) (line-end-position)) + ;; Baseline. + (erc-goodies-tests--assert-face + 0 "BEGIN " 'erc-default-face + '(fg:erc-color-face0 bg:erc-color-face0)) + ;; Normal fg/bg combo. + (erc-goodies-tests--assert-face + 6 "GreenOnPink" '(fg:erc-color-face3 bg:erc-color-face13) + '(erc-inverse-face)) + ;; Reverse of previous, so former-bg on former-fg. + (erc-goodies-tests--assert-face + 19 "PinkOnGreen" + '(erc-inverse-face fg:erc-color-face3 bg:erc-color-face13) + nil) + ;; The inverse of `default' because reverse still in effect. + (erc-goodies-tests--assert-face + 32 "ReversedDefault" '(erc-inverse-face erc-control-default-fg + erc-control-default-bg) + '(fg:erc-color-face3 bg:erc-color-face13)) + (erc-goodies-tests--assert-face + 49 "NormalDefault" '(erc-control-default-fg + erc-control-default-bg) + '(erc-inverse-face fg:erc-color-face1 bg:erc-color-face1)) + (erc-goodies-tests--assert-face + 64 "END" 'erc-default-face + '( erc-control-default-fg erc-control-default-bg + fg:erc-color-face0 bg:erc-color-face0)))) + (when noninteractive + (erc-tests-common-kill-buffers))) (defvar erc-goodies-tests--motd ;; This is from ergo's MOTD -- 2.44.0