diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 8497382a733..e28e7122cce 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -118,11 +118,21 @@ The following values are allowed: nil - do not highlight the message at all `nick' - highlight pal's nickname only - `message' - highlight the entire message from pal + \\+`message' - highlight the full message body from a matching pal `all' - highlight the entire message (including the nick) from pal -Any other value disables pal highlighting altogether." +A value of `nick' only highlights a matching sender's nick in the +bracketed speaker portion of the message. A value of \\+`message' +basically highlights its complement: the message-body alone, after the +speaker tag. All values for this option require a matching sender to be +an actual user on the network \(or a bot/service) as opposed to a host +name, such as that of the server itself \(e.g. \"irc.gnu.org\"). When +patterns from other user-based categories \(namely, \\+`fool' and +\\+`dangerous-host') also match, the behavior is undefined. However, in +ERC 5.6, `erc-dangerous-host-face' is known to clobber `erc-fool-face', +which in turn clobbers `erc-pal-face'. \(Other effects, such as +\\+`fool'-related invisibility may not survive such collisions.)" :type '(choice (const nil) (const nick) (const message) @@ -130,17 +140,18 @@ Any other value disables pal highlighting altogether." (defcustom erc-fool-highlight-type 'nick "Determines how to highlight messages by fools. -See `erc-fools'. +Unlike with the \\+`pal' and \\+`dangerous-host' categories, ERC doesn't +only attempt to match associated patterns (here, from `erc-fools') +against a message's sender, it also checks for matches in traditional +IRC-style \"mentions\" in which a speaker addresses a USER directly: -The following values are allowed: + USER: hi. + USER, hi. - nil - do not highlight the message at all - `nick' - highlight fool's nickname only - `message' - highlight the entire message from fool - `all' - highlight the entire message (including the nick) - from fool - -Any other value disables fool highlighting altogether." +However, at present, this option doesn't offer a means of highlighting +matched mentions alone. See `erc-pal-highlight-type' for a summary of +possible values and additional details common to categories like +\\+`fool' that normally match against a message's sender." :type '(choice (const nil) (const nick) (const message) @@ -165,16 +176,10 @@ Any other value disables keyword highlighting altogether." (defcustom erc-dangerous-host-highlight-type 'nick "Determines how to highlight messages by nicks from dangerous-hosts. -See `erc-dangerous-hosts'. - -The following values are allowed: - - `nick' - highlight nick from dangerous-host only - `message' - highlight the entire message from dangerous-host - `all' - highlight the entire message (including the nick) - from dangerous-host - -Any other value disables dangerous-host highlighting altogether." +Use option `erc-dangerous-hosts' to specify patterns. See +`erc-pal-highlight-type' for a summary of possible values as well as +additional details common to categories like \\+`dangerous-host' that +normally match against a message's sender." :type '(choice (const nil) (const nick) (const message) diff --git a/test/lisp/erc/erc-match-tests.el b/test/lisp/erc/erc-match-tests.el index 34610fc0438..d22a945724b 100644 --- a/test/lisp/erc/erc-match-tests.el +++ b/test/lisp/erc/erc-match-tests.el @@ -22,6 +22,9 @@ (require 'ert-x) (require 'erc-match) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) (ert-deftest erc-add-entry-to-list () @@ -190,4 +193,400 @@ (should (equal (cadr (pop calls)) nil)) (should (equal erc-dangerous-hosts '("example.net"))))))) +(defun erc-match-tests--assert-face-absent (face end) + "Ensure FACE is absent from point until pos or substring END." + (when (stringp end) + (save-excursion + (search-forward end) + (setq end (1- (match-beginning 0))))) + (ert-info ((format "Face %S absent throughout: %S" face + (buffer-substring-no-properties (point) end))) + (while (<= (point) end) + (ert-info ((format "Looking at: (%d %c)" (char-after) (char-after))) + (let ((val (ensure-list (get-text-property (point) 'font-lock-face)))) + (should-not (memq face val)))) + (forward-char)))) + +(defun erc-match-tests--assert-face-present (face end) + "Ensure FACE is present from point until pos or substring END." + (when (stringp end) + (save-excursion + (search-forward end) + (setq end (1- (match-beginning 0))))) + (ert-info ((format "Face %S appears throughout: %S" face + (buffer-substring-no-properties (point) end))) + (while (<= (point) end) + (ert-info ((format "Looking at: (%d %c)" (char-after) (char-after))) + (let ((val (ensure-list (get-text-property (point) 'font-lock-face)))) + (should (eq face (car val))))) + (forward-char)))) + +(defun erc-match-tests--assert-speaker-highlighted (nick face) + (search-forward (concat "<" nick ">")) + (goto-char (pos-bol)) + (should (= (char-after) ?<)) + (should (equal (get-text-property (point) 'font-lock-face) + 'erc-default-face)) + + (ert-info ((format "Nick in <%s> highlighted" nick)) + (forward-char) + (erc-match-tests--assert-face-present face "> ")) + + (should (= (char-after) ?>))) + +(defun erc-match-tests--assert-speaker-only-highlighted (nick face) + (erc-match-tests--assert-speaker-highlighted nick face) + (ert-info ("Remaining text in line not highlighted") + (erc-match-tests--assert-face-absent face (pos-eol)))) + +(defun erc-match-tests--perform (test) + (erc-tests-common-make-server-buf) + (setq erc-server-current-nick "tester") + (with-current-buffer (erc--open-target "#chan") + (funcall test)) + (when noninteractive + (erc-tests-common-kill-buffers))) + +;; The `nick' highlight type only covers a matching sender's speaker +;; tag. It does not do any highlighting for pal/fool/dangerous-host +;; mentions. While `current-nick' and `keyword' categories match +;; against a message's content, the speaker's nick is still highlighted +;; (in the corresponding face) when a match occurs. +(defun erc-match-tests--hl-type-nick (face &optional test) + (should (eq erc-current-nick-highlight-type 'keyword)) + (should (eq erc-keyword-highlight-type 'keyword)) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + ;; Change highlight type for match categories `keyword' and + ;; `current-nick' to `nick'. + (let ((erc-current-nick-highlight-type 'nick) + (erc-keyword-highlight-type 'nick) + (erc-keywords '("thing"))) + (erc-tests-common-simulate-privmsg "bob" "hi alice") + (erc-tests-common-simulate-privmsg "alice" "hi bob") + (erc-tests-common-simulate-privmsg "bob" "hi tester") + (erc-tests-common-simulate-privmsg "bob" "something blue")) + (goto-char (point-min)) + + ;; A sender's nick appears in `erc-{pals,fools,dangerous-hosts}', + ;; so the nick portion of their speaker tag alone is highlighted. + (erc-match-tests--assert-speaker-only-highlighted "bob" face) + + ;; A non-matching sender mentions a would-be match (if message + ;; bodies were considered), and the nick portion of their speaker + ;; tag is *not* highlighted. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face (pos-eol)) + + ;; A matching sender mentions our own nick ("tester"), and their + ;; speaker's nick is highlighted in `erc-current-nick-face' instead + ;; of the normal category face (e.g., `erc-pal-face'). This + ;; happens because the implementation applies highlighting for + ;; non-NUH-based categories (`keyword' and `current-nick') after + ;; sender-based ones. + (should (looking-at (rx ""))) + (erc-match-tests--assert-speaker-only-highlighted + "bob" 'erc-current-nick-face) + + ;; A matching sender mentions keyword "tester", and their speaker's + ;; nick is highlighted in `erc-keyword-face' instead of the normal + ;; category face for the same reason mentioned above. + (should (looking-at (rx ""))) + (erc-match-tests--assert-speaker-only-highlighted + "bob" 'erc-keyword-face) + + (when test + (funcall test))))) + +(defun erc-match-tests--hl-type-nick/mention (face) + (erc-match-tests--hl-type-nick + face + (lambda () + (erc-tests-common-simulate-privmsg "alice" "bob: one") + (erc-tests-common-simulate-privmsg "alice" "bob, two") + (erc-tests-common-simulate-privmsg "alice" "three, bob.") + + (search-forward " bob: one") + (goto-char (pos-bol)) + (erc-match-tests--assert-speaker-only-highlighted "alice" face) + + (search-forward " bob, two") + (goto-char (pos-bol)) + (erc-match-tests--assert-speaker-only-highlighted "alice" face) + + (search-forward " three, bob.") + (goto-char (pos-bol)) + (erc-match-tests--assert-speaker-only-highlighted "alice" face)))) + +(ert-deftest erc-match-message/pal/nick () + (should (eq erc-pal-highlight-type 'nick)) + (let ((erc-pals (list "bob"))) + (erc-match-tests--hl-type-nick 'erc-pal-face))) + +(ert-deftest erc-match-message/fool/nick () + (should (eq erc-fool-highlight-type 'nick)) + (let ((erc-fools (list "bob"))) + (erc-match-tests--hl-type-nick/mention 'erc-fool-face))) + +(ert-deftest erc-match-message/dangerous-host/nick () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (let ((erc-dangerous-hosts (list "bob"))) + (erc-match-tests--hl-type-nick 'erc-dangerous-host-face))) + +(defun erc-match-tests--hl-type-message (face) + (should (eq erc-current-nick-highlight-type 'keyword)) + (should (eq erc-keyword-highlight-type 'keyword)) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + ;; Change highlight type for categories `keyword' and + ;; `current-nick' to `message'. + (let ((erc-current-nick-highlight-type 'message) + (erc-keyword-highlight-type 'message) + (erc-keywords '("thing"))) + (erc-tests-common-simulate-privmsg "bob" "hi alice") + (erc-tests-common-simulate-privmsg "alice" "hi bob") + (erc-tests-common-simulate-privmsg "bob" "hi tester") + (erc-tests-common-simulate-privmsg "bob" "something blue")) + (goto-char (point-min)) + + ;; Message body portion appears in `erc-{pals,fools,dangerous-hosts}'. + ;; But the speaker portion is not highlighted by `match'. + (erc-match-tests--assert-face-absent face "hi alice") + (erc-match-tests--assert-face-present face + (+ (point) (length "hi alice") -1)) + + ;; A non-matching sender mentions a would-be match (if message + ;; bodies were considered), but nothing is highlighted. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face (pos-eol)) + + ;; A matching sender mentions our own nick ("tester"), and the + ;; message body is highlighted in `erc-current-nick-face' instead + ;; of the normal category face (e.g., `erc-pal-face'). + (should (looking-at (rx ""))) + (save-excursion (erc-match-tests--assert-face-absent face "hi tester")) + (erc-match-tests--assert-face-absent 'erc-current-nick-face "hi tester") + (erc-match-tests--assert-face-present 'erc-current-nick-face (pos-eol)) + + ;; A matching sender mentions keyword "thing", and the message body + ;; is highlighted in `erc-keyword-face' instead of the normal + ;; category face. + (should (looking-at (rx ""))) + (save-excursion (erc-match-tests--assert-face-absent face "something")) + (erc-match-tests--assert-face-absent 'erc-keyword-face "something") + (erc-match-tests--assert-face-present 'erc-keyword-face (pos-eol))))) + +(ert-deftest erc-match-message/pal/message () + (should (eq erc-pal-highlight-type 'nick)) + (let ((erc-pals (list "bob")) + (erc-pal-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-pal-face))) + +(ert-deftest erc-match-message/fool/message () + (should (eq erc-fool-highlight-type 'nick)) + (let ((erc-fools (list "bob")) + (erc-fool-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-fool-face))) + +(ert-deftest erc-match-message/dangerous-host/message () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (let ((erc-dangerous-hosts (list "bob")) + (erc-dangerous-host-highlight-type 'message)) + (erc-match-tests--hl-type-message 'erc-dangerous-host-face))) + +(defun erc-match-tests--hl-type-all (face) + (should (eq erc-current-nick-highlight-type 'keyword)) + (should (eq erc-keyword-highlight-type 'keyword)) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + ;; Change highlight type for categories `current-nick' and + ;; `keyword' to `all'. + (let ((erc-current-nick-highlight-type 'all) + (erc-keyword-highlight-type 'all) + (erc-keywords '("thing"))) + (erc-tests-common-simulate-privmsg "bob" "hi alice") + (erc-tests-common-simulate-privmsg "alice" "hi bob") + (erc-tests-common-simulate-privmsg "bob" "hi tester") + (erc-tests-common-simulate-privmsg "bob" "something blue")) + (goto-char (point-min)) + + ;; Entire message, including speaker appears in a speaker-based + ;; face `erc-{pals,fools,dangerous-hosts}'. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-present + face (+ (point) (length " hi alice") -1)) + + ;; A non-matching sender mentions a would-be match (if message + ;; bodies were considered), but nothing is highlighted. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent face (pos-eol)) + + ;; A matching sender mentions our own nick ("tester"), and the + ;; entire message, including the speaker portion, is highlighted in + ;; `erc-current-nick-face' instead of the normal category face + ;; (e.g., `erc-pal-face'). + (should (looking-at (rx ""))) + (save-excursion (erc-match-tests--assert-face-absent face (pos-eol))) + (erc-match-tests--assert-face-present 'erc-current-nick-face (pos-eol)) + + ;; A matching sender mentions keyword "thing", and the entire + ;; message is highlighted in `erc-keyword-face' instead of the + ;; normal category face. + (should (looking-at (rx ""))) + (save-excursion (erc-match-tests--assert-face-absent face (pos-eol))) + (erc-match-tests--assert-face-present 'erc-keyword-face (pos-eol))))) + +(ert-deftest erc-match-message/pal/all () + (should (eq erc-pal-highlight-type 'nick)) + (let ((erc-pals (list "bob")) + (erc-pal-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-pal-face))) + +(ert-deftest erc-match-message/fool/all () + (should (eq erc-fool-highlight-type 'nick)) + (let ((erc-fools (list "bob")) + (erc-fool-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-fool-face))) + +(ert-deftest erc-match-message/dangerous-host/all () + (should (eq erc-dangerous-host-highlight-type 'nick)) + (let ((erc-dangerous-hosts (list "bob")) + (erc-dangerous-host-highlight-type 'all)) + (erc-match-tests--hl-type-all 'erc-dangerous-host-face))) + +(defun erc-match-tests--hl-type-nick-or-keyword () + (should (eq erc-current-nick-highlight-type 'keyword)) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "alice") + ;; Change highlight type for category `current-nick' from the + ;; default to `nick-or-keyword'. + (let ((erc-current-nick-highlight-type 'nick-or-keyword)) + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :bob tester alice") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-privmsg "bob" "hi tester")) + (goto-char (point-min)) + + ;; An initial NAMES burst arrives. Its sender is "irc.foonet.org", + ;; so `match' skips the "nick" half of `nick-or-keyword' and + ;; considers the input non-NUH-based (because a host name alone + ;; can't be a real user). IOW, it pretends the option's value is + ;; `keyword', and highlights all occurrences in the message body. + (search-forward "*** Users on #chan: bob tester") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent 'erc-current-nick-face "tester") + (erc-match-tests--assert-face-present 'erc-current-nick-face + (+ (point) (length "tester") -1)) + (erc-match-tests--assert-face-absent 'erc-current-nick-face (pos-eol)) + + ;; Someone mentions our nick ("tester"), and only their speaker + ;; tag's nick is highlighted in `erc-current-nick-face' because + ;; that speaker is a real server user. + (search-forward "") + (goto-char (pos-bol)) + (should-not (get-text-property (point) 'erc-current-nick-face)) + (forward-char) + (erc-match-tests--assert-face-present 'erc-current-nick-face + "> hi tester") + (erc-match-tests--assert-face-absent 'erc-current-nick-face + (+ (point) (length "hi tester")))))) + +(ert-deftest erc-match-message/current-nick/nick-or-keyword () + (erc-match-tests--hl-type-nick-or-keyword)) + +(defun erc-match-tests--hl-type-keyword () + (should (eq erc-keyword-highlight-type 'keyword)) + + (erc-match-tests--perform + (lambda () + (erc-tests-common-add-cmem "bob") + (erc-tests-common-add-cmem "imamodel") + (erc-tests-common-add-cmem "ModerNerd") + + (let ((erc-keywords '("mode"))) + (erc-tests-common-simulate-line + ":irc.foonet.org 353 tester = #chan :bob imamodel ModerNerd tester") + (erc-tests-common-simulate-line + ":irc.foonet.org 366 tester #chan :End of NAMES list") + (erc-tests-common-simulate-line + ":irc.foonet.org 324 tester #chan +Cnt") + (erc-tests-common-simulate-line + ":irc.foonet.org 329 tester #chan 1703579802") + (erc-tests-common-simulate-privmsg "bob" "imamodel: spam a la mode!") + (erc-tests-common-simulate-privmsg "imamodel" "hi bob")) + + (goto-char (point-min)) + + ;; All occurrences highlighted in a non-user-based message. + (search-forward "*** Users on #chan:") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent 'erc-keyword-face "model ") + (erc-match-tests--assert-face-present 'erc-keyword-face "l ") + (erc-match-tests--assert-face-absent 'erc-keyword-face "Mode") + (erc-match-tests--assert-face-present 'erc-keyword-face "rNerd") + (erc-match-tests--assert-face-absent 'erc-keyword-face (pos-eol)) + + ;; Formatted text matched against rather than original message. + (search-forward "*** #chan modes:") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent 'erc-keyword-face "modes:") + (erc-match-tests--assert-face-present 'erc-keyword-face "s: +Cnt") + (erc-match-tests--assert-face-absent 'erc-keyword-face (pos-eol)) + + ;; All occurrences highlighted in a user-based message. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent 'erc-keyword-face "model") + (erc-match-tests--assert-face-present 'erc-keyword-face "l: spam") + (erc-match-tests--assert-face-absent 'erc-keyword-face "mode!") + (erc-match-tests--assert-face-present 'erc-keyword-face "!") + (erc-match-tests--assert-face-absent 'erc-keyword-face (pos-eol)) + + ;; Matching speaker ignored. + (search-forward "") + (goto-char (pos-bol)) + (erc-match-tests--assert-face-absent 'erc-keyword-face (pos-eol))))) + +(ert-deftest erc-match-message/keyword/keyword () + (erc-match-tests--hl-type-keyword)) + +(defun erc-match-tests--log-matches () + (let ((erc-log-matches-flag t) + (erc-timestamp-format "[@@TS@@]")) + (erc-match-tests--hl-type-keyword) + (with-current-buffer "*scratch*" + (ert-simulate-keys "\t\r" + (erc-go-to-log-matches-buffer)) + (should (equal (buffer-name) "ERC Keywords")) + (goto-char (point-min)) + (should (equal (buffer-string) "\ + == Type \"q\" to dismiss messages == +[@@TS@@] *** Users on #chan: bob imamodel ModerNerd tester +[@@TS@@] *** #chan modes: +Cnt +[@@TS@@] imamodel: spam a la mode! +")) + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-log-matches () + (erc-match-tests--log-matches)) + + ;;; erc-match-tests.el ends here diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el index 91654467dae..db0c5d626c9 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -40,6 +40,10 @@ (require 'ert-x) (require 'erc) (eval-when-compile (require 'erc-stamp)) +(eval-and-compile + (let ((load-path (cons (expand-file-name "../erc-d" (ert-resource-directory)) + load-path))) + (require 'erc-d-i))) (defmacro erc-tests-common-equal-with-props (a b) "Compare strings A and B for equality including text props. @@ -153,6 +157,39 @@ For simplicity, assume string evaluates to itself." (let ((sexp (erc-tests-common-string-to-propertized-parts (pp-last-sexp)))) (if arg (insert (pp-to-string sexp)) (pp-macroexpand-expression sexp)))) + +(cl-defun erc-tests-common-add-cmem + (nick &optional (host "fsf.org") + (user (concat "~" (substring nick 0 (min 10 (length nick))))) + (full-name (upcase-initials nick))) + "Create channel user for NICK with test-oriented defaults." + (erc-update-channel-member (erc-target) nick nick t nil nil nil nil nil + host user full-name)) + +(defun erc-tests-common-parse-line (line) + "Return a single `erc-response' parsed from line." + (let ((parsed (erc-d-i--parse-message line))) + (make-erc-response :unparsed (erc-d-i-message.unparsed parsed) + :sender (erc-d-i-message.sender parsed) + :command (erc-d-i-message.command parsed) + :command-args (erc-d-i-message.command-args parsed) + :contents (erc-d-i-message.contents parsed) + :tags (erc-d-i-message.tags parsed)))) + +(defun erc-tests-common-simulate-line (line) + "Run response handlers for raw IRC protocol LINE." + (let ((parsed (erc-tests-common-parse-line line)) + (erc--msg-prop-overrides (or erc--msg-prop-overrides + '((erc--ts . 0))))) + (erc-call-hooks erc-server-process parsed))) + +(defun erc-tests-common-simulate-privmsg (nick msg) + (erc-tests-common-simulate-line + (format ":%s PRIVMSG %s :%s" + (erc-user-spec (erc-get-server-user nick)) + (erc-target) + msg))) + ;; The following utilities are meant to help prepare tests for ;; `erc--get-inserted-msg-bounds' and friends. (defun erc-tests-common-get-inserted-msg-setup ()