Leverage inverse-video for erc-inverse-face
* lisp/erc/erc-goodies.el (erc-inverse-face): Specify face attribute `:inverse-video' (née :reverse-video) to swap foreground and background colors over affected intervals, as per https://modern.ircdocs.horse/formatting#reverse-color. (erc-control-default-fg erc-control-default-bg): New faces for 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): Return new, dedicated faces instead of `default', and don't nest them in a list. * test/lisp/erc/erc-goodies-tests.el (erc-controls-highlight--inverse): Redo completely, asserting behavior described in the spec linked to above. (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)
This commit is contained in:
F. Jason Park
parent
18b6289adf
commit
7b4ca9e609
2 changed files with 122 additions and 47 deletions
|
|
@ -661,7 +661,7 @@ The value `erc-interpret-controls-p' must also be t for this to work."
|
|||
:group 'erc-faces)
|
||||
|
||||
(defface erc-inverse-face
|
||||
'((t :foreground "White" :background "Black"))
|
||||
'((t :inverse-video t))
|
||||
"ERC inverse face."
|
||||
:group 'erc-faces)
|
||||
|
||||
|
|
@ -675,6 +675,16 @@ The value `erc-interpret-controls-p' must also be t for this to work."
|
|||
"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 +814,7 @@ The value `erc-interpret-controls-p' must also be t for this to work."
|
|||
(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 +830,7 @@ The value `erc-interpret-controls-p' must also be t for this to work."
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
;; Hovering over the redacted area should reveal its underlying text
|
||||
;; in a high-contrast face.
|
||||
|
||||
(ert-deftest erc-controls-highlight--spoilers ()
|
||||
(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)
|
||||
(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 "<bob> " 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)))
|
||||
|
||||
(ert-deftest erc-controls-highlight--inverse ()
|
||||
(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)
|
||||
|
||||
(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 "<bob> " 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)))))
|
||||
(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 "<bob> " 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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue