commit 6e80509099e27e237787186f4e8731bfdfb9b00d (HEAD, refs/remotes/origin/master) Author: F. Jason Park Date: Fri Oct 11 14:25:43 2024 -0700 Use erc-compat analog for window-no-other-p * lisp/erc/erc-compat.el (erc-compat--window-no-other-p): New function. * lisp/erc/erc-speedbar.el (erc-speedbar-toggle-nicknames-window-lock): Use compat adapter for `window-no-other-p'. diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index b5b8fbaf8ab..cb401782125 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -440,6 +440,18 @@ fallback." `(or ,v ""))))) spec))))) + +;;;; Misc 31.1 + +(defun erc-compat--window-no-other-p (window) + ;; See bug#73706. + (if (fboundp 'window-no-other-p) + (window-no-other-p window) + (setq window (window-normalize-window window t)) + (and (not ignore-window-parameters) + (window-parameter window 'no-other-window)))) + + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index a281e13734c..e8c41a1f239 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -652,7 +652,7 @@ unlock the window." (when-let ((window (get-buffer-window speedbar-buffer))) (let ((val (cond ((natnump arg) t) ((integerp arg) nil) - (t (not (window-no-other-p window)))))) + (t (not (erc-compat--window-no-other-p window)))))) (with-current-buffer speedbar-buffer (setq cursor-type (not val))) (set-window-parameter window 'no-other-window val) commit 9bddb264ba851f39068773b9538de4170928e159 Author: F. Jason Park Date: Thu Oct 10 16:17:03 2024 -0700 Add baseline test coverage for erc-match * lisp/erc/erc-match.el (erc-pal-highlight-type) (erc-fool-highlight-type, erc-dangerous-host-highlight-type): Clarify some areas in doc strings. * test/lisp/erc/erc-match-tests.el: Require `erc-test-common' library. (erc-match-tests--assert-face-absent) (erc-match-tests--assert-face-present) (erc-match-tests--assert-speaker-highlighted) (erc-match-tests--assert-speaker-only-highlighted) (erc-match-tests--perform) (erc-match-tests--hl-type-nick): New functions. (erc-match-message/pal/nick, erc-match-message/fool/nick) (erc-match-message/dangerous-host/nick): New tests. (erc-match-tests--hl-type-message): New function. (erc-match-message/pal/message) (erc-match-message/fool/message) (erc-match-message/dangerous-host/message): New tests. (erc-match-tests--hl-type-all): New function. (erc-match-message/pal/all, erc-match-message/fool/all) (erc-match-message/dangerous-host/all): New tests. (erc-match-tests--hl-type-nick-or-keyword): New function. (erc-match-message/current-nick/nick-or-keyword): New test. (erc-match-tests--hl-type-keyword): New function. (erc-match-message/keyword/keyword): New test. (erc-match-tests--log-matches): New function. (erc-log-matches): New test. * test/lisp/erc/resources/erc-tests-common.el: Require `erc-d-i'. (erc-tests-common-add-cmem, erc-tests-common-parse-line) (erc-tests-common-simulate-line) (erc-tests-common-simulate-privmsg): New functions. 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'. - -The following values are allowed: - - 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." +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: + + USER: hi. + USER, hi. + +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 () commit 9906e34f973f15c0f96ebcfcc6ea4d1144bc6e8f Author: F. Jason Park Date: Thu Sep 26 21:34:25 2024 -0700 Crystallize erc-nicks-track-faces behavior * etc/ERC-NEWS: Mention changes to `erc-track-faces-normal-list' and `erc-track-faces-priority-list'. Also mention new choice variant for option `erc-nicks-track-faces', although that's arguably just a bug fix because it makes good on previously unrealized behavior implied by the doc strings. * lisp/erc/erc-nicks.el (erc-nicks-skip-faces): Remove faces applied by the `match' module, namely, `erc-current-nick-face', `erc-pal-face', and `erc-fool-face'. That module runs its hooks after `button' on `erc-insert-modify-hook', and because `nicks' piggybacks on `button', it can never encounter those faces while assaying. (erc-nicks-track-faces): Update doc, and introduce new `t' value choice. (erc-nicks-mode, erc-nicks-disable): Update removals from `erc-track--alt-normals-function' to reflect recent renamings. (erc-nicks--reject-uninterned-faces): Use helper. (erc-nicks--oursp, erc-nicks--ours-p): Rename former to latter to respect project style guidelines regarding predicates. (erc-nicks-track-normal-max-rank): New variable. (erc-nicks--check-normals, erc-nicks--assess-track-faces): Rename former to latter, and change purpose to checking for "normals" membership, ranks position, and incumbent face ownership. Remove unused CONTENDERS parameter. Additionally, change behavior to consider replacing the current mode-line face when it's not `nicks' owned if it's explicitly ranked lower than `erc-default-face'. (erc-nicks--track-prioritize, erc-nicks--track-always): New complementary functions implementing the t and `prioritize' variants of `erc-nicks-track-faces'. Both make use of the factored-out `erc-nicks--check-normals' logic. (erc-nicks--setup-track-integration): Add `erc-nicks--track-always' to `erc-track--alt-normals-function' when `erc-track-normal-faces' is t. * lisp/erc/erc-track.el (erc-track--massage-nick-button-faces): Change type of symbol property `erc-track--obsolete-faces' for options `erc-track-faces-priority-list' and friends from a boolean to an alist. (erc-track-faces-priority-list): Add new face for buttonized speakers. (erc-track-faces-normal-list): Add new face for buttonized speakers. Also add `erc-notice-face'. (erc-track--priority-faces): New local variable to cache ranked faces and complement `erc-track--normal-faces'. (erc-track--setup): Initialize new `erc-track--priority-faces' variable, and refactor. (erc-track--alt-normals-function): Doc. (erc-track--select-mode-line-face): Update expected type of `ranks' parameter. (erc-track-modified-channels): Fix wrong-type bug occurring when `erc-track-ignore-normal-contenders-p' and `erc-track-priority-faces-only' are both non-nil. Also fix subtle compatibility oversight regarding an empty face list returned by `erc-track--collect-faces-in'. * test/lisp/erc/erc-nicks-tests.el: Load helpers and fixtures library. (erc-nicks-tests--track-faces): New function. (erc-nicks-track-faces/prioritize, erc-nicks-track-faces/defer) (erc-nicks-track-faces/nil, erc-nicks-track-faces/t): New tests. * test/lisp/erc/erc-track-tests.el (erc-track-tests--select-mode-line-face): Update expected type of mocked parameter. (erc-track-tests--modified-channels/baseline): New function. (erc-track-modified-channels/baseline) (erc-track-modified-channels/baseline/mention) (erc-track-modified-channels/baseline/ignore) (erc-track-modified-channels/baseline/mention/ignore) (erc-track-modified-channels/priority-only-all/baseline) (erc-track-modified-channels/priority-only-all/sans-notice): New tests. * test/lisp/erc/resources/erc-tests-common.el (erc-tests-common-track-modified-channels) (erc-tests-common-track-modified-channels-sans-setup): New functions. (Bug67767) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index b267db5502e..ea65a170b38 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -35,6 +35,19 @@ has been removed. Option 'erc-keep-place-indicator-truncation' manages the tension between truncation and place keeping, prioritizing one or the other. +** Updated defaults for the 'track' module's face-list options. +The default values of options 'erc-track-faces-priority-list' and +'erc-track-faces-normal-list' have both gained a face for buttonized +speaker names, with the latter option also gaining 'erc-notice-face'. +This was done to provide a more frequent and practical indication of +channel activity in keeping with the module's original design. + +** An arguably less distracting 'erc-nicks-track-faces' variant. +Setting this option to t tells the 'track' module to have the mode-line +indicator stick with the most recent speaker's face, even when they're +monologuing, instead of alternating between it and the highest ranked +'erc-track-faces-normal-list' member in a given message. + * Changes in ERC 5.6 diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el index a0d6d17d732..6282242f4ac 100644 --- a/lisp/erc/erc-nicks.el +++ b/lisp/erc/erc-nicks.el @@ -89,10 +89,10 @@ 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) +(defcustom erc-nicks-skip-faces '(erc-notice-face erc-my-nick-face) "Faces to avoid highlighting atop." - :type (erc--with-dependent-type-match (repeat face) erc-match)) + :type '(repeat face) + :package-version '(ERC . "5.6.1")) (defcustom erc-nicks-backing-face erc-button-nickname-face "Face to mix with generated one for emphasizing non-speakers." @@ -175,17 +175,20 @@ like \"@%-012n\"." (defcustom erc-nicks-track-faces 'prioritize "Show nick faces in the `track' module's portion of the mode line. -A value of nil means don't show nick faces at all. A value of -`defer' means have `track' consider nick faces only after those -ranked faces in `erc-track-faces-normal-list'. This has the -effect of \"alternating\" between a ranked \"normal\" and a nick. -The value `prioritize' means have `track' consider nick faces to -be \"normal\" unless the current speaker is the same as the -previous one, in which case pretend the value is `defer'. Like -most options in this module, updating the value mid-session is -not officially supported, although cycling \\[erc-nicks-mode] may -be worth a shot." - :type '(choice (const nil) (const defer) (const prioritize))) +A value of nil means don't show `nicks'-managed faces at all. A value +of t means treat them as non-\"normal\" faces ranked at or below +`erc-default-face'. This has the effect of always showing them while +suppressing the \"alternating\" behavior normally associated with +`erc-track-faces-normal-list' (including between the speaker and nicks +mentioned in the message body.) A value of `defer' means treat nicks as +unranked normals to favor alternating between them and ranked normals. +A value of `prioritize' exhibits the same alternating effect as `defer' +when speakers stay the same but allows a new speaker's face to +impersonate a ranked normal so that adjacent speakers alternate among +themselves before deferring to non-face normals. Like most options in +this module, updating the value mid-session is not officially supported, +although cycling \\[erc-nicks-mode] may be worth a shot." + :type '(choice boolean (const defer) (const prioritize))) (defvar erc-nicks--max-skip-search 3 ; make this an option? "Max number of faces to visit when testing `erc-nicks-skip-faces'.") @@ -597,7 +600,9 @@ Abandon search after examining LIMIT faces." (remove-function (local 'erc-button--modify-nick-function) #'erc-nicks--highlight-button) (remove-function (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals) + #'erc-nicks--track-prioritize) + (remove-function (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always) (remove-hook 'erc-track-mode-hook #'erc-nicks--setup-track-integration t) (setf (alist-get "Edit face" erc-button--nick-popup-alist nil 'remove #'equal) @@ -724,31 +729,57 @@ Expect PREFIX to be something like \"ansi-color-\" or \"font-lock-\"." ((facep next)) ((not (intern-soft next)))) (setq candidate (cdr candidate))) - (if (and (consp candidate) (not (cdr candidate))) (car candidate) candidate)) + (erc--solo candidate)) -(define-inline erc-nicks--oursp (face) +(define-inline erc-nicks--ours-p (face) + "Return uninterned `nicks'-created face if FACE is a known list of faces." (inline-quote (and-let* ((sym (car-safe ,face)) ((symbolp sym)) ((get sym 'erc-nicks--key))) sym))) -(defun erc-nicks--check-normals (current contender contenders normals) - "Return a viable `nicks'-owned face from NORMALS in CONTENDERS. -But only do so if the CURRENT face is also one of ours and in -NORMALS and if the highest ranked CONTENDER among new faces is -`erc-default-face'." - (and-let* (((eq contender 'erc-default-face)) - ((or (null current) (gethash current normals))) - (spkr (or (null current) (erc-nicks--oursp current)))) +(defvar erc-nicks-track-normal-max-rank 'erc-default-face + "Highest priority normal face still eligible to alternate with `nicks' faces. +Must appear in both `erc-track-faces-priority-list' and +`erc-track-faces-normal-list'.") + +(defun erc-nicks--assess-track-faces (current contender ranks normals) + "Return symbol face for CURRENT or t, to mean CURRENT is replaceable. +But only do so if CURRENT and CONTENDER are either nil or \"normal\" +faces ranking at or below `erc-nicks-track-normal-max-rank'. See +`erc-track--select-mode-line-face' for the expected types of RANKS and +NORMALS. Expect a non-nil CONTENDER to always be ranked." + (and-let* + (((or (null contender) (gethash contender normals))) + ((or (null current) (gethash current normals))) + (threshold (gethash erc-nicks-track-normal-max-rank (car ranks))) + ((or (null contender) (<= threshold (gethash contender (car ranks))))) + ((or (erc-nicks--ours-p current) + (null current) + (<= threshold (or (gethash current (car ranks)) 0))))))) + +(defun erc-nicks--track-prioritize (current contender contenders ranks normals) + "Return a viable non-CURRENT `nicks' face among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when-let + ((spkr (erc-nicks--assess-track-faces current contender ranks normals))) (catch 'contender - (dolist (candidate (cdr contenders) contender) + (dolist (candidate (cdr contenders)) (when-let (((not (equal candidate current))) - ((gethash candidate normals)) - (s (erc-nicks--oursp candidate)) + (s (erc-nicks--ours-p candidate)) ((not (eq s spkr)))) (throw 'contender candidate)))))) +(defun erc-nicks--track-always (current contender contenders ranks normals) + "Return a viable `nicks' face, possibly CURRENT, among CONTENDERS. +See `erc-track--select-mode-line-face' for parameter types." + (when (erc-nicks--assess-track-faces current contender ranks normals) + (catch 'contender + (dolist (candidate (reverse (cdr contenders))) + (when (erc-nicks--ours-p candidate) + (throw 'contender candidate)))))) + (defun erc-nicks--setup-track-integration () "Restore traditional \"alternating normal\" face functionality to mode-line." (when (bound-and-true-p erc-track-mode) @@ -756,7 +787,10 @@ NORMALS and if the highest ranked CONTENDER among new faces is ;; Variant `defer' is handled elsewhere. ('prioritize (add-function :override (local 'erc-track--alt-normals-function) - #'erc-nicks--check-normals)) + #'erc-nicks--track-prioritize)) + ('t + (add-function :override (local 'erc-track--alt-normals-function) + #'erc-nicks--track-always)) ('nil (add-function :override (local 'erc-track--face-reject-function) #'erc-nicks--reject-uninterned-faces))))) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index f40960e4a22..82e5f402910 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -161,25 +161,33 @@ The faces used are the same as used for text in the buffers. \(e.g. `erc-pal-face' is used if a pal sent a message to that channel.)" :type 'boolean) +;; In an emergency, users can opt out of this migration with: +;; +;; (put 'erc-track-faces-priority-list 'erc-track--obsolete-faces t) +;; (put 'erc-track-faces-normal-list 'erc-track--obsolete-faces t) +;; (defun erc-track--massage-nick-button-faces (sym val &optional set-fn) - "Transform VAL of face-list option SYM to have new defaults. -Use `set'-compatible SET-FN when given. If an update was -performed, set the symbol property `erc-track--obsolete-faces' of -SYM to t." - (let* ((changedp nil) - (new (mapcar - (lambda (f) - (if (and (eq (car-safe f) 'erc-nick-default-face) - (equal f '(erc-nick-default-face erc-default-face))) - (progn - (setq changedp t) - (put sym 'erc-track--obsolete-faces t) - (cons 'erc-button-nick-default-face (cdr f))) - f)) - val))) - (if set-fn - (funcall set-fn sym (if changedp new val)) - (set-default sym (if changedp new val))))) + "Transform VAL of face-list option SYM to remove/replace obsolete items. +Use `set'-compatible SET-FN when given. Record any migrations as cons +cells of (OLD . NEW) in the symbol property `erc-track--obsolete-faces' +of SYM." + (let* ((oldface '(erc-nick-default-face erc-default-face)) + (newface '(erc-button-nick-default-face erc-default-face)) + (migrations (get sym 'erc-track--obsolete-faces)) + (new (if migrations + val + (delq nil + (mapcar + (lambda (f) + (if (equal f oldface) + (setf (alist-get oldface migrations + nil nil #'equal) + (and (not (member newface val)) newface)) + f)) + val))))) + (when migrations + (put sym 'erc-track--obsolete-faces migrations)) + (if set-fn (funcall set-fn sym new) (set-default sym new)))) (defcustom erc-track-faces-priority-list '(erc-error-face @@ -191,6 +199,7 @@ SYM to t." (erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face erc-action-face @@ -204,7 +213,7 @@ be highlighted using that face. The first matching face is used. Note that ERC prioritizes certain faces reserved for critical messages regardless of this option's value." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -229,8 +238,10 @@ setting this variable might not be very useful." '((erc-button erc-default-face) erc-dangerous-host-face erc-nick-default-face + (erc-button-nick-default-face erc-nick-default-face) (erc-button-nick-default-face erc-default-face) erc-default-face + erc-notice-face erc-action-face) "A list of faces considered to be part of normal conversations. This list is used to highlight active buffer names in the mode line. @@ -246,7 +257,7 @@ module. To see your changes reflected mid-session, cycle \\[erc-track-mode]. The effect may be disabled by setting this variable to nil." - :package-version '(ERC . "5.6") + :package-version '(ERC . "5.6.1") :set #'erc-track--massage-nick-button-faces :type (erc--with-dependent-type-match (repeat (choice face (repeat :tag "Combination" face))) @@ -636,49 +647,79 @@ keybindings will not do anything useful." (erc-track-enable)) (set sym val)))) +(defvar-local erc-track--priority-faces nil + "Local copy of `erc-track-faces-priority-list' as a hash table. +Keys are faces and values are rank integers (smaller is more important).") + (defvar-local erc-track--normal-faces nil - "Local copy of `erc-track-faces-normal-list' as a hash table.") + "Local copy of `erc-track-faces-normal-list' as a hash table. +Keys and values are faces. The table is weak valued so it can double as +a buttonizing cache. See `erc-button-add-button' and `erc--merge-prop'.") (defun erc-track--setup () "Initialize a buffer for use with the `track' module. -If this is a server buffer or `erc-track-faces-normal-list' is -locally bound, create a new `erc-track--normal-faces' for the -current buffer. Otherwise, set the local value to the server -buffer's." +If this is a server buffer or either `erc-track-faces-normal-list' or +`erc-track-faces-priority-list' is locally bound, create a new cache +table with corresponding local variable `erc-track--normal-faces' or +`erc-track--priority-faces'. Otherwise, in target buffers with no local +binding, set the cache variable's local value to that of server's." (if erc-track-mode - (let ((existing (erc-with-server-buffer erc-track--normal-faces)) - (localp (and erc--target - (local-variable-p 'erc-track-faces-normal-list))) - (opts '(erc-track-faces-normal-list erc-track-faces-priority-list)) - warnp table) + (let (warnp) ;; Don't bother warning users who've disabled `button'. - (unless (or erc--target (not (or (bound-and-true-p erc-button-mode) - (memq 'button erc-modules)))) - (when (or localp (local-variable-p 'erc-track-faces-priority-list)) - (dolist (opt opts) + (unless (or erc--target + (not (or (bound-and-true-p erc-button-mode) + (memq 'button erc-modules)))) + (dolist (opt '(erc-track-faces-normal-list + erc-track-faces-priority-list)) + (when (local-variable-p opt) (erc-track--massage-nick-button-faces opt (symbol-value opt) - #'set))) - (dolist (opt opts) - (when (get opt 'erc-track--obsolete-faces) - (push opt warnp) + #'set)) + (when-let ((migrations (get opt 'erc-track--obsolete-faces)) + ((consp migrations))) + (push (cons opt + (mapcar (pcase-lambda (`(,old . ,new)) + (format (if new "changed %s to %s" + "removed %s") + old new)) + migrations)) + warnp) (put opt 'erc-track--obsolete-faces nil))) (when warnp - (erc--warn-once-before-connect 'erc-track-mode - (if (cdr warnp) "Options " "Option ") - (mapconcat (lambda (o) (format "`%S'" o)) warnp " and ") - (if (cdr warnp) " contain" " contains") - " an obsolete item, %S, intended to match buttonized nicknames." - " ERC has changed it to %S for the current session." - " Please save the current value to silence this message." - '(erc-nick-default-face erc-default-face) - '(erc-button-nick-default-face erc-default-face)))) - (when (or (null existing) localp) - (setq table (map-into (mapcar (lambda (f) (cons f f)) - erc-track-faces-normal-list) - '(hash-table :test equal :weakness value)))) - (setq erc-track--normal-faces (or table existing)) - (unless (or localp existing) - (erc-with-server-buffer (setq erc-track--normal-faces table)))) + (pcase-dolist (`(,opt . ,migrations) warnp) + (erc--warn-once-before-connect 'erc-track-mode + "Option `%S' contains " + (if (cdr migrations) "obsolete items." "an obsolete item.") + " ERC has done the following for the current session: %s." + " Please review these changes and, if convinced," + " silence this message by saving the current value." + opt (string-join migrations ", "))))) + ;; Set `erc-track--priority-faces' cache to new or shared value. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-priority-list))) + (existing (erc-with-server-buffer erc-track--priority-faces)) + (table (or (and (not localp) existing) + (let ((p 0)) + (map-into + (mapcar (lambda (f) (cons f (cl-incf p))) + (append erc-track--attn-faces + erc-track-faces-priority-list)) + `(hash-table :test equal)))))) + (setq erc-track--priority-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--priority-faces table)))) + ;; Likewise for `erc-track--normal-faces' cache. + (let* ((localp (and erc--target + (local-variable-p 'erc-track-faces-normal-list))) + (existing (erc-with-server-buffer erc-track--normal-faces)) + (table (or (and (not localp) existing) + (map-into (mapcar (lambda (f) (cons f f)) + erc-track-faces-normal-list) + `(hash-table :test equal + :weakness value))))) + (setq erc-track--normal-faces table) + (unless (or localp existing) + (erc-with-server-buffer (setq erc-track--normal-faces table))))) + (kill-local-variable 'erc-track--priority-faces) (kill-local-variable 'erc-track--normal-faces))) ;;; Visibility @@ -915,44 +956,54 @@ them, it can't be replaced." (defvar erc-track--alt-normals-function nil "A function to possibly elect a \"normal\" face. Called with the current incumbent and the worthiest new contender -followed by all new contending faces and so-called \"normal\" -faces. See `erc-track--select-mode-line-face' for their meanings -and expected types. This function should return a face or nil.") +followed by all new contending faces, ranked faces, and so-called +\"normal\" faces. See `erc-track--select-mode-line-face' for their +meanings and expected types. This function should return a face or nil.") (defun erc-track--select-mode-line-face (cur-face new-faces ranks normals) "Return CUR-FACE or a replacement for displaying in the mode-line, or nil. -Expect RANKS to be a list of faces and both NORMALS and the car -of NEW-FACES to be hash tables mapping faces to non-nil values. -Assume the latter's makeup and that of RANKS to resemble -`erc-track-faces-normal-list' and `erc-track-faces-priority-list'. -If NEW-FACES has a cdr, expect it to be its car's contents -ordered from most recently seen (later in the buffer) to -earliest. In general, act like `erc-track-select-mode-line-face' -except appeal to `erc-track--alt-normals-function' if it's -non-nil, falling back on reconsidering NEW-FACES when CUR-FACE -outranks all its members. That is, choose the first among RANKS -in NEW-FACES not equal to CUR-FACE. Failing that, choose the -first face in NEW-FACES that's also in NORMALS, assuming -NEW-FACES has a cdr." +Expect NEW-FACES to be a cons cell whose car is a hash table mapping +faces present in the applicable region to t and whose cdr is its car's +contents ordered from most recently seen (later in the buffer) to +earliest. Expect RANKS to be a cons cell whose car is a hash table +similar to `erc-track--priority-faces' and whose cdr is a list of +prioritized faces resembling `erc-track-faces-priority-list'. Expect +NORMALS to be a hash table mapping faces to themselves. In general, act +identically to `erc-track-select-mode-line-face', except appeal to +`erc-track--alt-normals-function' if it's non-nil, and fall back on +reconsidering only NEW-FACES appearing in NORMALS when CUR-FACE is +itself \"normal\" and outranks all NEW-FACES. That is, choose the first +among RANKS in both NEW-FACES and NORMALS not equal to CUR-FACE. +Failing that, choose the first face in both NEW-FACES and NORMALS." (cl-check-type erc-track-ignore-normal-contenders-p null) (cl-check-type new-faces cons) + ;; Choose the highest ranked face in `erc-track-faces-priority-list' + ;; that's either `cur-face' itself or one appearing in the region + ;; being processed. (when-let ((choice (catch 'face - (dolist (candidate ranks) + (dolist (candidate (cdr ranks)) (when (or (equal candidate cur-face) (gethash candidate (car new-faces))) (throw 'face candidate)))))) (or (and erc-track--alt-normals-function (funcall erc-track--alt-normals-function - cur-face choice new-faces normals)) + cur-face choice new-faces ranks normals)) + ;; If `choice' is still `cur-face' and also a "normal", attempt + ;; to choose another normal in order to produce the flickering + ;; effect mentioned in the doc of `erc-track-faces-normal-list'. (and (equal choice cur-face) (gethash choice normals) (catch 'face + ;; If ranked "normal" faces other than `choice' appear in + ;; the region, return the most important one. (progn - (dolist (candidate ranks) + (dolist (candidate (cdr ranks)) (when (and (not (equal candidate choice)) (gethash candidate (car new-faces)) (gethash choice normals)) (throw 'face candidate))) + ;; Otherwise, go with any "normal" face other than + ;; `choice' in the region. (dolist (candidate (cdr new-faces)) (when (and (not (equal candidate choice)) (gethash candidate normals)) @@ -996,14 +1047,24 @@ the current buffer is in `erc-mode'." (normals erc-track--normal-faces) (erc-track-faces-priority-list `(,@erc-track--attn-faces ,@erc-track-faces-priority-list)) - (ranks erc-track-faces-priority-list) + (ranks (cons erc-track--priority-faces + erc-track-faces-priority-list)) ((not (and (or (eq erc-track-priority-faces-only 'all) (member this-channel erc-track-priority-faces-only)) - (not (catch 'found - (dolist (f ranks) - (when (gethash f (or (car-safe faces) faces)) - (throw 'found t))))))))) + ;; Iterate over the shorter of `ranks' and `faces'. + (let* ((r>fp (or erc-track-ignore-normal-contenders-p + (> (hash-table-count (car ranks)) + (hash-table-count (car faces))))) + (elems (cond ((not r>fp) (cdr ranks)) ; f>=r + (erc-track-ignore-normal-contenders-p + faces) + ((cdr faces)))) + (table (if r>fp (car ranks) (car faces)))) + (not (catch 'found + (dolist (f elems) + (when (gethash f table) + (throw 'found t)))))))))) (progn ; FIXME remove `progn' on next major edit (if (not (assq (current-buffer) erc-modified-channels-alist)) ;; Add buffer, faces and counts @@ -1017,7 +1078,7 @@ the current buffer is in `erc-mode'." nil faces ranks normals)))) erc-modified-channels-alist)) ;; Else modify the face for the buffer, if necessary. - (when faces + (when (or erc-track-ignore-normal-contenders-p (cdr faces)) (let* ((cell (assq (current-buffer) erc-modified-channels-alist)) (old-face (cddr cell)) diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el index 08080d249d5..c865a902a0e 100644 --- a/test/lisp/erc/erc-nicks-tests.el +++ b/test/lisp/erc/erc-nicks-tests.el @@ -30,8 +30,11 @@ ;;; Code: -(require 'ert-x) (require 'erc-nicks) +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) ;; This function replicates the behavior of older "invert" strategy ;; implementations from EmacsWiki, etc. The values for the lower and @@ -568,4 +571,268 @@ (should (equal erc-nicks--colors-rejects '(t))))) +(declare-function erc-track-modified-channels "erc-track" ()) + +(defun erc-nicks-tests--track-faces (test) + (require 'erc-track) + (defvar erc-modified-channels-alist) + (defvar erc-track--normal-faces) + + (erc-tests-common-make-server-buf) + (erc-nicks-mode +1) + + (let ((erc-modules (cons 'nicks erc-modules)) + ;; Pretend these faces were added in response-handling during + ;; insertion modification by buttonizing hooks. See + ;; `erc-nicks--highlight-button'. + (add-face (lambda (face) + (erc-nicks--remember-face-for-track ; speaker + (list face 'erc-nick-default-face)) + (erc-nicks--remember-face-for-track ; mention + (list face 'erc-default-face)))) + ;; + bob-face alice-face assert-result) + + (with-current-buffer (erc--open-target "#chan") + (should erc-nicks-mode) + (should (setq bob-face (erc-nicks--get-face "bob" "bob@foonet"))) + (should (setq alice-face (erc-nicks--get-face "alice" "alice@foonet"))) + + (erc-tests-common-track-modified-channels-sans-setup + + (lambda (set-faces) + + (setq assert-result ; fixture binds `erc-modified-channels-alist' + (lambda (result) + (should (equal (alist-get (current-buffer) + erc-modified-channels-alist) + result)))) + + (funcall test set-faces assert-result add-face + bob-face alice-face))))) + + (erc-tests-common-kill-buffers)) + +(ert-deftest erc-nicks-track-faces/prioritize () + (should (eq erc-nicks-track-faces 'prioritize)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line changes to a `nicks' owned + ;; composite face for the speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes to + ;; another "normal" face in the message body. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,bob-face erc-nick-default-face)) + + ;; Now the same person mentions another server user, resulting in a + ;; change to *that* `nicks' owned face because it appears later in + ;; the message content (timestamp is last). + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. But + ;; instead of the normal "normals" processing preferring the ranked + ;; `erc-default-face', the `erc-nicks-track-faces' logic kicks in + ;; via `erc-track--alt-normals-function' and provides a `nicks' + ;; owned replacement. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(6 ,bob-face erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face))))) + +(ert-deftest erc-nicks-track-faces/defer () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces 'defer)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; highest ranked face in the message. (All `nicks' owned faces + ;; are unranked). + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and the mode-line indicator changes + ;; to a `nicks' owned face. It first reaches for the highest + ;; ranked face in the message but then applies the "normals" + ;; rules, resulting in a promoted alternate. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(4 . erc-default-face)) + + ;; The same person mentions another server user, resulting in a + ;; change to that `nicks' owned face because the logic from + ;; 3. again applies. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(5 ,alice-face erc-default-face)) + + ;; The mentioned user replies, mentioning the mentioner. + ;; However, the `nicks' module does not intercede in the decision + ;; making to overrule the ranked nominee. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) + (,alice-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(6 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(7 . erc-notice-face)))))) + +(ert-deftest erc-nicks-track-faces/nil () + (should (eq erc-nicks-track-faces 'prioritize)) + (let (erc-nicks-track-faces) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result _ bob-face alice-face) + + (defvar erc-track--face-reject-function) + (should erc-track--face-reject-function) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to the + ;; only ranked face in the message. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 . erc-default-face)) + + ;; That same someone speaks, and since no other "normals" exist + ;; in the message, the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result '(3 . erc-default-face)) + + ;; Now the same person mentions another server user, but the same + ;; logic applies, and the indicator is not updated. + (funcall set-faces `(erc-timestamp-face + (,alice-face erc-default-face) + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 . erc-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + +(ert-deftest erc-nicks-track-faces/t () + (should (eq erc-nicks-track-faces 'prioritize)) + (let ((erc-nicks-track-faces t)) + (erc-nicks-tests--track-faces + (lambda (set-faces assert-result add-face bob-face alice-face) + + (defvar erc-track--alt-normals-function) + (should erc-track--alt-normals-function) + + (funcall add-face bob-face) + (funcall add-face alice-face) + + ;; Simulate a JOIN. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(1 . erc-notice-face)) + + ;; Someone speaks, and the mode-line indicator changes to that + ;; someone's `nicks'-owned face. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(2 ,bob-face erc-nick-default-face)) + + ;; That same someone speaks, and though one other "normal" exists + ;; in the message, `erc-default-face', no update occurs. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(3 ,bob-face erc-nick-default-face)) + + ;; Another server user speaks, mentioning the previous speaker, + ;; and the indicator is updated to reflect the new speaker. + (funcall set-faces `(erc-timestamp-face + (,bob-face erc-default-face) ; bob: + (,alice-face erc-nick-default-face) ; + erc-default-face)) + (erc-track-modified-channels) + (funcall assert-result `(4 ,alice-face erc-nick-default-face)) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (funcall assert-result '(5 . erc-notice-face)))))) + ;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 8149138a971..c830c8b2016 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -227,6 +227,13 @@ (defun erc-track-tests--select-mode-line-face (ranked normals cases) (setq normals (map-into (mapcar (lambda (f) (cons f t)) normals) '(hash-table :test equal))) + + (setq ranked (cons (map-into (mapcar (let ((i 0)) + (lambda (f) (cons f (cl-incf i)))) + ranked) + '(hash-table :test equal)) + ranked)) + (pcase-dolist (`(,want ,cur-face ,new-faces) cases) (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}" @@ -235,8 +242,8 @@ (mapcar (lambda (f) (cons f t)) new-faces) '(hash-table :test equal)) (reverse new-faces))) - (should (equal want (funcall #'erc-track--select-mode-line-face - cur-face new-faces ranked normals)))))) + (should (equal want (erc-track--select-mode-line-face + cur-face new-faces ranked normals)))))) ;; The main difference between these variants is that with the above, ;; when given alternating lines like @@ -410,4 +417,255 @@ (when noninteractive (kill-buffer)))) +(defun erc-track-tests--modified-channels/baseline (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line face goes from ERC's generic + ;; "notice" face, `erc-notice-face', to the first face in the + ;; inserted message that outranks it, which happens to be the + ;; `button' module's composite face for buttonized speakers: + ;; (erc-button-nick-default-face erc-nick-default-face). It + ;; outranks both the previous occupant, `erc-notice-face', and its + ;; one cohabitant in the message text, `erc-default-face', in + ;; `erc-track-faces-priority-list'. Note that in the following + ;; list, `erc-default-face' appears first because it's used for the + ;; opening speaker bracket "<". The timestamp appears last because + ;; it's a right-sided stamp appended to the message body. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment changes to + ;; `erc-default-face', which appears later in the message, as + ;; normal body text. This happens because both `erc-default-face' + ;; and (erc-button-nick-default-face erc-nick-default-face) appear + ;; in `erc-track-faces-normal-list', meaning the lower-ranked + ;; former can replace the higher-ranked latter in the mode-line for + ;; the purpose of indicating channel activity. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 . erc-default-face))) + + ;; Note: if (erc-button-nick-default-face erc-nick-default-face) + ;; were removed from `erc-track-faces-priority-list' but kept in + ;; `erc-track-faces-normal-list', then replaying the sequence would + ;; result in the previous two results being switched: + ;; `erc-default-face' would replace `erc-notice-face' before being + ;; replaced by the buttonized composite. + + ;; The speaker speaks yet again, and the segment goes back to the + ;; higher ranking face. + (funcall set-faces '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. Although lower ranked, it also + ;; appears in `erc-track-faces-normal-list' and so is eligible to + ;; replace the incumbent. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))) + +(ert-deftest erc-track-modified-channels/baseline () + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline)) + +(ert-deftest erc-track-modified-channels/baseline/mention () + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to (erc-button-nick-default-face erc-nick-default-face) + ;; rather than (erc-button-nick-default-face erc-default-face) + ;; based on their rankings in `erc-track-faces-priority-list'. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(5 . erc-notice-face)))))) + +;; The compat-oriented option `erc-track-ignore-normal-contenders-p' +;; blinds track to `erc-track-faces-normal-list' for certain consecutive +;; messages with an identical face makeup. +(ert-deftest erc-track-modified-channels/baseline/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; The speaker speaks again immediately, and the segment doesn't + ;; change. + (funcall set-faces + '(erc-timestamp-face + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Compat-oriented option `erc-track-ignore-normal-contenders-p'. +(ert-deftest erc-track-modified-channels/baseline/mention/ignore () + (let ((erc-track-ignore-normal-contenders-p t)) + (erc-tests-common-track-modified-channels + (lambda (set-faces) + + ;; Simulate a JOIN, PART, etc. that's displayed in `erc-notice-face'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 . erc-notice-face))) + + ;; Someone speaks, and the mode-line indicator's face changes to + ;; that of a buttonized speaker. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body + ;; text, but the indicator stays the same. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(4 . erc-notice-face))))))) + +;; Option `erc-track-priority-faces-only' does not affect the behavior +;; of the baseline "normals" scenario because all faces appear in +;; `erc-track-faces-priority-list'. +(ert-deftest erc-track-modified-channels/priority-only-all/baseline () + (let ((erc-track-priority-faces-only 'all)) + (erc-tests-common-track-modified-channels + #'erc-track-tests--modified-channels/baseline))) + +;; This test simulates a common configuration that combines an +;; `erc-track-faces-priority-list' removed of `erc-notice-face' with +;; `erc-track-priority-faces-only' being `all'. It also features in the +;; sample configuration in ERC's manual. +(ert-deftest erc-track-modified-channels/priority-only-all/sans-notice () + (let ((erc-track-priority-faces-only 'all) + (erc-track-faces-priority-list + (remq 'erc-notice-face erc-track-faces-priority-list))) + + (erc-tests-common-track-modified-channels + (lambda (set-faces) + ;; Note: these messages don't have timestamps. + + ;; Simulate a message normally displayed in `erc-notice-face', + ;; which has been removed from `erc-track-faces-priority-list'. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should-not (alist-get (current-buffer) erc-modified-channels-alist)) + + ;; Someone speaks, mentioning someone else, and the mode-line + ;; changes to the buttonized speaker face rather than the + ;; buttonized mention face, due to their respective ranks. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(1 erc-button-nick-default-face erc-nick-default-face))) + + ;; Someone else speaks, again with a mention and additional body text. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(2 erc-button-nick-default-face erc-default-face))) + + ;; And yet again, which results in the indicator going back to one. + (funcall set-faces + '((erc-button-nick-default-face erc-default-face) + (erc-button-nick-default-face erc-nick-default-face) + erc-default-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face erc-nick-default-face))) + + ;; Finally, another notice arrives, which is ignored. + (funcall set-faces '(erc-notice-face)) + (erc-track-modified-channels) + (should (equal (alist-get (current-buffer) erc-modified-channels-alist) + '(3 erc-button-nick-default-face + erc-nick-default-face))))))) + ;;; erc-track-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 1cd54a1f715..91654467dae 100644 --- a/test/lisp/erc/resources/erc-tests-common.el +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -330,4 +330,47 @@ interspersing \"-l\" between members." (set-process-query-on-exit-flag proc t) proc)) +(declare-function erc-track--setup "erc-track" ()) + +(defun erc-tests-common-track-modified-channels (test) + (erc-tests-common-prep-for-insertion) + (setq erc--target (erc--target-from-string "#chan")) + (erc-tests-common-track-modified-channels-sans-setup test)) + +(defun erc-tests-common-track-modified-channels-sans-setup (test) + "Provide a fixture for testing `erc-track-modified-channels'. +Call function TEST with another function that sets the mocked return +value of `erc-track--collect-faces-in' to the given argument, a list of +faces in the reverse order they appear in an inserted message." + (defvar erc-modified-channels-alist) + (defvar erc-modified-channels-object) + (defvar erc-track--attn-faces) + (defvar erc-track--normal-faces) + (defvar erc-track--priority-faces) + (defvar erc-track-faces-normal-list) + (defvar erc-track-faces-priority-list) + (defvar erc-track-mode) + + (cl-letf* ((erc-track-mode t) + (erc-modified-channels-alist nil) + (erc-modified-channels-object erc-modified-channels-object) + (faces ()) + ((symbol-function 'force-mode-line-update) #'ignore) + ((symbol-function 'erc-faces-in) (lambda (_) faces)) + ((symbol-function 'erc-track--collect-faces-in) + (lambda () + (cons (map-into (mapcar (lambda (f) (cons f t)) faces) + '(hash-table :test equal)) + faces)))) + (erc-track--setup) + + ;; Faces from `erc-track--attn-faces' prepended. + (should (= (+ (length erc-track--attn-faces) + (length erc-track-faces-priority-list)) + (hash-table-count erc-track--priority-faces))) + (should (= (length erc-track-faces-normal-list) + (hash-table-count erc-track--normal-faces))) + + (funcall test (lambda (arg) (setq faces arg))))) + (provide 'erc-tests-common) commit 1de2c86317356dbbf5e7f935d3889b2698bc30f6 Author: F. Jason Park Date: Mon Sep 30 02:10:02 2024 -0700 Don't create directory in erc-truncate compat check * lisp/erc/erc-log.el (erc-log--check-writable-nocreate-p): New variable. (erc-logging-enabled): Use `erc-log--save-in-progress-p' flag to conditionally avoid creating a directory when checking if the location is writable. (erc-log--call-when-logging-enabled-sans-module) (erc-log--check-legacy-implicit-enabling-by-truncate): Rename former to latter, and guard against creating a ~/log directory just to see if it's writable when calling `erc-logging-enabled'. (erc-truncate-mode): Explain legacy "implicit logging" behavior in doc string. * lisp/erc/erc-truncate.el (erc-truncate--warn-about-logging): Make more concise, and defer to `erc-truncate-mode' doc string for particulars. * lisp/erc/erc.el (erc-directory-writable-p): Add comment to rename on next non-patch release. diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 6bb240f56d7..8311359ed09 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -307,6 +307,10 @@ Return nil if BUFFER is a server buffer." (erc-save-buffer-in-logs buffer))) (defvar erc-log--save-in-progress-p nil) +;; The function `erc-directory-writable-p' may signal when HOME is not +;; writable, such as when running the test suite (/nonexistent). This +;; flag tells `erc-logging-enabled' to use `file-writable-p' instead. +(defvar erc-log--check-writable-nocreate-p nil) ;;;###autoload (defun erc-logging-enabled (&optional buffer) @@ -319,7 +323,9 @@ is writable (it will be created as necessary) and (and erc-log-channels-directory (not erc-log--save-in-progress-p) (or (functionp erc-log-channels-directory) - (erc-directory-writable-p erc-log-channels-directory)) + (if erc-log--check-writable-nocreate-p + (file-writable-p erc-log-channels-directory) + (erc-directory-writable-p erc-log-channels-directory))) (if (functionp erc-enable-logging) (funcall erc-enable-logging buffer) (buffer-local-value 'erc-enable-logging buffer)))) @@ -452,14 +458,14 @@ You can save every individual message by putting this function on (defun erc-log--save-on-clear (_ end) (erc-save-buffer-in-logs end)) -;; This is a kludge to avoid littering erc-truncate.el with forward -;; declarations needed only for a corner-case compatibility check. -(defun erc-log--call-when-logging-enabled-sans-module (fn) - (when (and (erc-logging-enabled) - (not (or erc-log-mode (memq 'log erc-modules)))) - (let ((dirfile (and (stringp erc-log-channels-directory) - erc-log-channels-directory))) - (funcall fn dirfile)))) +;; This exists to avoid littering erc-truncate.el with forward +;; declarations needed only for a compatibility check. +(defun erc-log--check-legacy-implicit-enabling-by-truncate () + "Return non-nil when conditions for legacy \"implicit\" activation are met. +This only concerns the \\+`truncate' module." + (and (not (or erc-log-mode (memq 'log erc-modules))) + (let ((erc-log--check-writable-nocreate-p t)) + (erc-logging-enabled)))) (provide 'erc-log) diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index 393b2af2ba1..fd152707708 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -52,7 +52,18 @@ plus `erc-max-buffer-size'." "Truncate a query buffer if it gets too large. This prevents the query buffer from getting too large, which can bring any grown Emacs to its knees after a few days worth of -tracking heavy-traffic channels." +tracking heavy-traffic channels. + +Before ERC 5.6, this module performed logging whenever the \\+`log' +module's library, \\+`erc-log', happened to be loaded, regardless of +whether the \\+`log' module itself was enabled. (Loading can of course +happen in any number of ways, such as when browsing options via +\\[customize-group] or completing autoloaded symbol names at the +\\[describe-variable] prompt.) Users of \\+`truncate' who prefer the +old behavior can add \\+`log' to `erc-modules' to get the same effect. +Those who don't want logging but need to load the \\+`erc-log' library +for other purposes should customize either `erc-enable-logging' or +`erc-log-channels-directory' to avoid the annoying warning." ;;enable ((add-hook 'erc-insert-done-hook #'erc-truncate-buffer) (add-hook 'erc-connect-pre-hook #'erc-truncate--warn-about-logging) @@ -83,21 +94,13 @@ tracking heavy-traffic channels." (defun erc-truncate--warn-about-logging (&rest _) (when (and (not erc--target) - (fboundp 'erc-log--call-when-logging-enabled-sans-module)) - ;; We could also enable `erc-log-mode' here, but the risk of - ;; lasting damage is nonzero. - (erc-log--call-when-logging-enabled-sans-module - (lambda (dirfile) - ;; Emit a real Emacs warning because the message may be - ;; truncated away before it can be read if merely inserted. - (erc-button--display-error-notice-with-keys-and-warn - "The `truncate' module no longer enables logging implicitly." - " If you want ERC to write logs before truncating, add `log' to" - " `erc-modules' using something like \\[customize-option]." - " To silence this message, don't `require' `erc-log'." - (and dirfile " Alternatively, change the value of") - (and dirfile " `erc-log-channels-directory', or move ") - dirfile (and dirfile " elsewhere.")))))) + (fboundp 'erc-log--check-legacy-implicit-enabling-by-truncate) + (erc-log--check-legacy-implicit-enabling-by-truncate)) + ;; Emit a real Emacs warning because the message may be + ;; truncated away before it can be read if merely inserted. + (erc-button--display-error-notice-with-keys-and-warn + "The `truncate' module no longer enables logging implicitly." + " See the doc string for `erc-truncate-mode' for details."))) ;;;###autoload (defun erc-truncate-buffer-to-size (size &optional buffer) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 730ec2ebb22..63aeaea9c46 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -9001,6 +9001,8 @@ If S is nil or an empty string then return general CLIENTINFO." ;; Hook functions +;; FIXME rename this to something like `erc-ensure-directory-writable'. +;; Functions suffixed with "-p" probably shouldn't have side effects. (defun erc-directory-writable-p (dir) "Determine whether DIR is a writable directory. If it doesn't exist, create it." commit 3f1ce47fe7eb4809bfa9ef035caae748c3c5d729 Author: F. Jason Park Date: Wed Oct 2 16:41:39 2024 -0700 ; Add face customization to ERC's sample config * doc/misc/erc.texi (Sample Configuration): Move `erc-modules' twiddling from a `use-package' :config section to a :custom section. In the past, this would sometimes provoke module-loading issues, but it seems to work fine on Emacs 30, even with repeated eval'ing of the `use-package' form. This sample config is meant for users running the latest release anyhow. Also add a new `use-package' block for `erc-match' showing how to customize a face using inheritance. Add a corresponding section further down showing the same via Customize. diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 9cfb12c9231..9368c9ce070 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -1324,14 +1324,11 @@ settings (@pxref{Sample configuration via Customize}). ;;; My ERC configuration -*- lexical-binding: t -*- (use-package erc - :config - ;; Prefer SASL to NickServ, colorize nicknames, and show side panels - ;; with joined channels and members - (setopt erc-modules - (seq-union '(sasl nicks bufbar nickbar scrolltobottom) - erc-modules)) - :custom + ;; Prefer SASL to NickServ, colorize nicknames, and show side panels + ;; with joined channels and members. + (erc-modules (append '(sasl nicks bufbar nickbar scrolltobottom) + erc-modules)) ;; Protect me from accidentally sending excess lines. (erc-inhibit-multiline-input t) (erc-send-whitespace-lines t) @@ -1372,6 +1369,13 @@ settings (@pxref{Sample configuration via Customize}). :bind (:map erc-fill-wrap-mode-map ("C-c =" . #'erc-fill-wrap-nudge))) +(use-package erc-match + ;; Use the same face for my own nick wherever it appears. + :custom-face + (erc-current-nick-face ((t ( :weight unspecified + :foreground unspecified + :inherit erc-my-nick-face))))) + (use-package erc-track ;; Prevent JOINs and PARTs from lighting up the mode-line. :config (setopt erc-track-faces-priority-list @@ -1552,6 +1556,18 @@ function @code{erc-fill-wrap-nudge} in the minor-mode keymap @code{erc-fill-wrap-mode-hook}, and it's not a member of any customization group). +Try customizing another face, this time with inheritance. ERC's match +module highlights your nick whenever someone mentions you in +conversation. However, some users don't like that this face differs +from the one in your own messages. Let's change that. Type @kbd{M-x +customize-group @key{RET} erc-faces @key{RET}}. Either search for the +word ``Current'' or type @kbd{M-x customize-face @key{RET} +erc-current-nick-face @key{RET}}. Untick @samp{Weight} and +@samp{Foreground}, then click the ``Show All Attributes'' button below +them. Navigate down to the @samp{Inherit} box, tick it, hit +@samp{[INS]}, and type @code{erc-my-nick-face} in the @samp{Face} field. +Hit @kbd{C-x C-s} to save. + ERC users tend to be picky about the mode line. If you find that you'd rather not see changes when people join and leave channels, customize the option @code{erc-track-faces-priority-list}. When commit a30f115daada7633ac3f6d1b93e564c8b15612a3 Author: Stefan Monnier Date: Fri Oct 11 18:34:05 2024 -0400 * lisp/help-fns.el (help--load-prefixes): Fix bug#72787 diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 5cc8df6497f..98231614d71 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -112,6 +112,7 @@ current help buffer.") (pcase-dolist (`(,prefix . ,files) prefixes) (setq help-definition-prefixes (radix-tree-insert help-definition-prefixes prefix nil)) + (remhash prefix definition-prefixes) (dolist (file files) ;; FIXME: Should we scan help-definition-prefixes to remove ;; other prefixes of the same file? commit e0b9eba35c72d67d2223f4b59c39a6e2beb9af31 Author: Andreas Schwab Date: Fri Oct 11 20:48:59 2024 +0200 gnus-sum: fix missing space after prompt * lisp/gnus/gnus-sum.el (gnus-summary-limit-exclude-marks) (gnus-summary-limit-to-marks): Add space after prompt. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a9caa83b15c..33582ce5dbf 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -8501,7 +8501,7 @@ with MARKS. MARKS can either be a string of marks or a list of marks. Returns how many articles were removed." (interactive (list - (completing-read "Marks:" + (completing-read "Marks: " (let ((mark-list '())) (mapc (lambda (datum) (cl-pushnew (gnus-data-mark datum) mark-list)) @@ -8518,7 +8518,7 @@ list of marks. Returns how many articles were removed." (interactive (list - (completing-read "Marks:" + (completing-read "Marks: " (let ((mark-list '())) (mapc (lambda (datum) (cl-pushnew (gnus-data-mark datum) mark-list)) commit e631a3f30679d3c4e465a5765e261b068e9357dc Author: Robert Pluim Date: Wed Sep 25 16:52:57 2024 +0200 Remove buttons when disabling 'button-mode' * lisp/button.el (button-mode): Remove all buttons when disabling. * doc/lispref/display.texi (Button Buffer Commands): Document the change. (Bug#73175) diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index f877a6a5a27..e19354ec107 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -8053,6 +8053,7 @@ These are commands and functions for locating and operating on buttons in an Emacs buffer. @cindex buffer-button-map +@findex button-mode @code{push-button} is the command that a user uses to actually push a button, and is bound by default in the button itself to @key{RET} and to @key{mouse-2} using a local keymap in the button's overlay or @@ -8063,7 +8064,8 @@ additionally available in the keymap stored in @code{button-buffer-map} as a parent keymap for its keymap. Alternatively, the @code{button-mode} can be switched on for much the same effect: It's a minor mode that does nothing else than install -@code{button-buffer-map} as a minor mode keymap. +@code{button-buffer-map} as a minor mode keymap (note that disabling +@code{button-mode} will remove all the buttons in the current buffer). If the button has a non-@code{nil} @code{follow-link} property, and @code{mouse-1-click-follows-link} is set, a quick @key{mouse-1} click diff --git a/etc/NEWS b/etc/NEWS index 3d77612f304..c2919169bbf 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -228,6 +228,9 @@ response. *** New function 'unbuttonize-region'. It removes all the buttons in the specified region. ++++ +*** Disabling 'button-mode' now removes all buttons in the current buffer. + ** Eshell --- diff --git a/lisp/button.el b/lisp/button.el index de6ea8d966c..1a732bee98b 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -80,8 +80,15 @@ Mode-specific keymaps may want to use this as their parent keymap." "" #'push-button) (define-minor-mode button-mode - "A minor mode for navigating to buttons with the TAB key." - :keymap button-buffer-map) + "A minor mode for navigating to buttons with the TAB key. + +Disabling the mode will remove all buttons in the current buffer." + :keymap button-buffer-map + (when (not button-mode) + (save-excursion + (save-restriction + (widen) + (unbuttonize-region (point-min) (point-max)))))) ;; Default properties for buttons. (put 'default-button 'face 'button) commit 08ee074a6f140a82e327fba446c05c96fe64932c Author: Robert Pluim Date: Wed Sep 25 15:49:53 2024 +0200 Add unbuttonize-region * doc/lispref/display.texi (Making Buttons): Document it. * lisp/button.el (unbuttonize-region): New function, removes all buttons in the specified region. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 1948854003d..f877a6a5a27 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -7968,6 +7968,11 @@ between @var{start} and @var{end} into a button. Arguments @code{help-echo} property of the button. @end defun +@defun unbuttonize-region start end +This function removes all buttons between @var{start} and @var{end} in +the current buffer (both overlay and text-property based ones). +@end defun + @node Manipulating Buttons @subsection Manipulating Buttons @cindex manipulating buttons diff --git a/etc/NEWS b/etc/NEWS index e14efad8199..3d77612f304 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -222,6 +222,12 @@ When called with a prefix argument, accepting, declining, or tentatively accepting an icalendar event will prompt for a comment to add to the response. +** Button + ++++ +*** New function 'unbuttonize-region'. +It removes all the buttons in the specified region. + ** Eshell --- diff --git a/lisp/button.el b/lisp/button.el index c0584729172..de6ea8d966c 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -663,10 +663,22 @@ itself will be used instead as the function argument. If HELP-ECHO, use that as the `help-echo' property. -Also see `buttonize'." +Also see `buttonize' and `unbuttonize-region'." (add-text-properties start end (button--properties callback data help-echo)) (add-face-text-property start end 'button t)) +(defun unbuttonize-region (start end) + "Remove all the buttons between START and END. +This removes both text-property and overlay based buttons." + (dolist (o (overlays-in start end)) + (when (overlay-get o 'button) + (delete-overlay o))) + (with-silent-modifications + (remove-text-properties start end + (button--properties nil nil nil)) + (add-face-text-property start end + 'button nil))) + (provide 'button) ;;; button.el ends here commit e44f98b71bfd1f93d9b443a34e01a523ec34d3bb Merge: 8032423239a 3462b2b9d0c Author: Michael Albinus Date: Fri Oct 11 12:07:03 2024 +0200 Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs commit 8032423239ae2df6970c208a1b0166dcda65a445 Author: Michael Albinus Date: Fri Oct 11 12:06:08 2024 +0200 Make url-http thread-safe (Bug#73199) * lisp/url/url-http.el (url-http-open-connections): Adapt docstring. (current-thread, thread-live-p): Declare. (url-http-mark-connection-as-busy) (url-http-mark-connection-as-free) (url-http-find-free-connection): Use extended hash key. (Bug#73199) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 184c1278072..37f589a0b09 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -74,7 +74,9 @@ (defvar url-http-open-connections (make-hash-table :test 'equal :size 17) - "A hash table of all open network connections.") + "A hash table of all open network connections. +If Emacs is compiled with thread support, the key is a list `(host port +thread)'. Otherwise, it is a cons cell `(host . port)'.") (defvar url-http-version "1.1" "What version of HTTP we advertise, as a string. @@ -153,27 +155,46 @@ request.") (defsubst url-http-debug (&rest args) (apply #'url-debug 'http args)) +(declare-function current-thread "thread.c" ()) +(declare-function thread-live-p "thread.c" (thread)) + (defun url-http-mark-connection-as-busy (host port proc) - (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) - (set-process-query-on-exit-flag proc t) - (puthash (cons host port) - (delq proc (gethash (cons host port) url-http-open-connections)) - url-http-open-connections) - proc) + (let ((key (if main-thread + (list host port (current-thread)) + (cons host port)))) + (url-http-debug "Marking connection as busy: %s:%d %S" host port proc) + (set-process-query-on-exit-flag proc t) + (puthash key + (delq proc (gethash key url-http-open-connections)) + url-http-open-connections) + proc)) (defun url-http-mark-connection-as-free (host port proc) - (url-http-debug "Marking connection as free: %s:%d %S" host port proc) - (when (memq (process-status proc) '(open run connect)) - (set-process-buffer proc nil) - (set-process-sentinel proc 'url-http-idle-sentinel) - (set-process-query-on-exit-flag proc nil) - (puthash (cons host port) - (cons proc (gethash (cons host port) url-http-open-connections)) - url-http-open-connections)) - nil) + (let ((key (if main-thread + (list host port (current-thread)) + (cons host port)))) + (url-http-debug "Marking connection as free: %s:%d %S" host port proc) + (when (memq (process-status proc) '(open run connect)) + (set-process-buffer proc nil) + (set-process-sentinel proc 'url-http-idle-sentinel) + (set-process-query-on-exit-flag proc nil) + (puthash key + (cons proc (gethash key url-http-open-connections)) + url-http-open-connections)) + nil)) (defun url-http-find-free-connection (host port &optional gateway-method) - (let ((conns (gethash (cons host port) url-http-open-connections)) + (when main-thread + (maphash + (lambda (key _val) + (unless (thread-live-p (caddr key)) + (remhash key url-http-open-connections))) + url-http-open-connections)) + (let ((conns (gethash + (if main-thread + (list host port (current-thread)) + (cons host port)) + url-http-open-connections)) (connection nil)) (while (and conns (not connection)) (if (not (memq (process-status (car conns)) '(run open connect))) @@ -182,7 +203,8 @@ request.") host port (car conns)) (url-http-idle-sentinel (car conns) nil)) (setq connection (car conns)) - (url-http-debug "Found existing connection: %s:%d %S" host port connection)) + (url-http-debug + "Found existing connection: %s:%d %S" host port connection)) (pop conns)) (if connection (url-http-debug "Reusing existing connection: %s:%d" host port) @@ -232,7 +254,9 @@ request.") " "))) (defun url-http--get-referer (url) - (url-http-debug "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" (current-buffer) url url-current-lastloc) + (url-http-debug + "getting referer from buffer: buffer:%S target-url:%S lastloc:%S" + (current-buffer) url url-current-lastloc) (when url-current-lastloc (if (not (url-p url-current-lastloc)) (setq url-current-lastloc (url-generic-parse-url url-current-lastloc))) @@ -273,7 +297,8 @@ The string is based on `url-privacy-level' and `url-user-agent'." (cond ((functionp url-user-agent) (funcall url-user-agent)) ((stringp url-user-agent) url-user-agent) - ((eq url-user-agent 'default) (url-http--user-agent-default-string)))))) + ((eq url-user-agent 'default) + (url-http--user-agent-default-string)))))) (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) ""))) (defun url-http-create-request () @@ -297,7 +322,8 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." (url-get-authentication (or (and (boundp 'proxy-info) proxy-info) - url-http-target-url) nil 'any nil))) + url-http-target-url) + nil 'any nil))) (ref-url (url-http--encode-string url-http-referer))) (if (equal "" real-fname) (setq real-fname "/")) @@ -343,8 +369,9 @@ Use `url-http-referer' as the Referer-header (subject to `url-privacy-level')." ;; (maybe) Try to keep the connection open "Connection: " (if (or using-proxy (not url-http-attempt-keepalives)) - "close" "keep-alive") "\r\n" - ;; HTTP extensions we support + "close" "keep-alive") + "\r\n" + ;; HTTP extensions we support (if url-extensions-header (format "Extension: %s\r\n" url-extensions-header)) @@ -511,7 +538,8 @@ Return the number of characters removed." (defun url-http-parse-response () "Parse just the response code." (if (not url-http-end-of-headers) - (error "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) + (error + "Trying to parse HTTP response code in odd buffer: %s" (buffer-name))) (url-http-debug "url-http-parse-response called in (%s)" (buffer-name)) (goto-char (point-min)) (skip-chars-forward " \t\n") ; Skip any blank crap @@ -1273,7 +1301,8 @@ the end of the document." (url-http-activate-callback))) ((> nd url-http-end-of-headers) ;; Have some leftover data - (url-http-debug "Calling initial content-length for extra data at end of headers") + (url-http-debug + "Calling initial content-length for extra data at end of headers") (url-http-content-length-after-change-function (marker-position url-http-end-of-headers) nd @@ -1437,15 +1466,17 @@ The return value of this function is the retrieval buffer." ((= url-http-response-status 200) (if (gnutls-available-p) (condition-case e - (let ((tls-connection (gnutls-negotiate - :process proc - :hostname (puny-encode-domain (url-host url-current-object)) - :verify-error nil))) + (let ((tls-connection + (gnutls-negotiate + :process proc + :hostname (puny-encode-domain (url-host url-current-object)) + :verify-error nil))) ;; check certificate validity (setq tls-connection - (nsm-verify-connection tls-connection - (puny-encode-domain (url-host url-current-object)) - (url-port url-current-object))) + (nsm-verify-connection + tls-connection + (puny-encode-domain (url-host url-current-object)) + (url-port url-current-object))) (with-current-buffer process-buffer (erase-buffer)) (set-process-buffer tls-connection process-buffer) (setq url-http-after-change-function @@ -1484,9 +1515,11 @@ The return value of this function is the retrieval buffer." (message "HTTP error: %s" error))))) (t (setf (car url-callback-arguments) - (nconc (list :error (list 'error 'connection-failed why - :host (url-host (or url-http-proxy url-current-object)) - :service (url-port (or url-http-proxy url-current-object)))) + (nconc (list + :error + (list 'error 'connection-failed why + :host (url-host (or url-http-proxy url-current-object)) + :service (url-port (or url-http-proxy url-current-object)))) (car url-callback-arguments))) (url-http-activate-callback)))))) commit 3462b2b9d0ca6a483d5c3200ef71a8ca243225d1 Author: Martin Rudalics Date: Fri Oct 11 10:39:10 2024 +0200 Fix how 'no-other-window' window parameter is ignored (Bug#73706) * lisp/window.el (window-no-other-p): New function. (window-in-direction, get-lru-window, get-mru-window) (get-largest-window, other-window, window-at-x-y) (delete-window-choose-selected, delete-window): Use it to check whether 'ignore-window-parameters' should inhibit processing the 'no-other-window' parameter (Bug#73706). * lisp/erc/erc-speedbar.el (erc-speedbar-toggle-nicknames-window-lock): Use 'window-no-other-p'. * doc/lispref/windows.texi (Windows and Frames) (Deleting Windows, Cyclic Window Ordering): Describe new function 'window-no-other-p' and use it in description of functions that call it. (Window Parameters): Add cross references for 'no-other-window' parameter. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index d9e99d9ca5c..0b8d7d3b76d 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -427,13 +427,14 @@ window @var{window}. The argument @var{direction} must be one of argument @var{window} must denote a live window and defaults to the selected one. -This function does not return a window whose @code{no-other-window} -parameter is non-@code{nil} (@pxref{Window Parameters}). If the nearest -window's @code{no-other-window} parameter is non-@code{nil}, this -function tries to find another window in the indicated direction whose -@code{no-other-window} parameter is @code{nil}. If the optional -argument @var{ignore} is non-@code{nil}, a window may be returned even -if its @code{no-other-window} parameter is non-@code{nil}. +This function does not return a window for which +@code{window-no-other-p} (@pxref{Cyclic Window Ordering}) returns +non-@code{nil}. If the nearest window's @code{no-other-window} +parameter is non-@code{nil}, this function tries to find another window +in the indicated direction whose @code{no-other-window} parameter is +@code{nil}. However, if the optional argument @var{ignore} is +non-@code{nil}, a window may be returned even if its +@code{no-other-window} parameter is non-@code{nil}. If the optional argument @var{sign} is a negative number, it means to use the right or bottom edge of @var{window} as reference position @@ -1585,9 +1586,10 @@ choose the first window (the window returned by @code{frame-first-window}) on that frame. @end itemize -A window with a non-@code{nil} @code{no-other-window} parameter is -chosen only if all other windows on that frame have that parameter set -to a non-@code{nil} value too. +A window for which @code{window-no-other-p} (@pxref{Cyclic Window +Ordering}) returns non-@code{nil} is chosen only if all other windows on +that frame have their @code{no-other-window} parameter set to a +non-@code{nil} value too. @end defopt @deffn Command delete-other-windows &optional window @@ -2129,16 +2131,33 @@ The optional argument @var{all-frames} has the same meaning as in @code{next-window}, like a @code{nil} @var{minibuf} argument to @code{next-window}. -This function does not select a window that has a non-@code{nil} -@code{no-other-window} window parameter (@pxref{Window Parameters}), -provided that @code{ignore-window-parameters} is @code{nil}. - If the @code{other-window} parameter of the selected window is a function, and @code{ignore-window-parameters} is @code{nil}, that function will be called with the arguments @var{count} and @var{all-frames} instead of the normal operation of this function. + +Otherwise, this function does not select a window for which the function +@code{window-no-other-p} (see next) returns @code{nil}. @end deffn +@defun window-no-other-p &optional window +This function returns non-@code{nil} if @var{window} should not be used +as ``other'' window by commands like @code{other-window} or functions +like @code{get-lru-window} (see below). It's also called when deleting +the selected window (@pxref{Deleting Windows}) and a new selected window +has to be chosen. + +More precisely, this function returns non-@code{nil} if the +@code{no-other-window} parameter of @var{window} is non-@code{nil} and +@code{ignore-window-parameters} is @code{nil}. It returns @code{nil} in +any other case. + +Note that if this function returns @code{nil}, this does not necessarily +mean that @var{window} can be selected. A tooltip window (@pxref{Basic +Windows}), for example, has its @code{no-other-window} parameter set to +@code{t} by default but cannot be selected. +@end defun + @defun walk-windows fun &optional minibuf all-frames This function calls the function @var{fun} once for each live window, with the window as the argument. @@ -2186,8 +2205,9 @@ optional argument @var{dedicated} is non-@code{nil}. The selected window is never returned, unless it is the only candidate. However, if the optional argument @var{not-selected} is non-@code{nil}, this function returns @code{nil} in that case. The optional argument -@var{no-other}, if non-@code{nil}, means to never return a window whose -@code{no-other-window} parameter is non-@code{nil}. +@var{no-other}, if non-@code{nil}, means to never return a window for +which @code{window-no-other-p} (@pxref{Cyclic Window Ordering}) returns +non-@code{nil}. @end defun @cindex most recently used window @@ -6784,7 +6804,10 @@ This parameter affects the execution of @code{other-window} @item no-other-window @vindex no-other-window@r{, a window parameter} This parameter marks the window as not selectable by @code{other-window} -(@pxref{Cyclic Window Ordering}). +(@pxref{Cyclic Window Ordering}). It is by default @code{t} for tooltip +windows (@pxref{Basic Windows}). Use @code{window-no-other-p} +(@pxref{Cyclic Window Ordering}) to check whether it applies to a +specific window. @item clone-of @vindex clone-of@r{, a window parameter} diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index e45fb9a7adf..a281e13734c 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -652,8 +652,7 @@ unlock the window." (when-let ((window (get-buffer-window speedbar-buffer))) (let ((val (cond ((natnump arg) t) ((integerp arg) nil) - (t (not (window-parameter window - 'no-other-window)))))) + (t (not (window-no-other-p window)))))) (with-current-buffer speedbar-buffer (setq cursor-type (not val))) (set-window-parameter window 'no-other-window val) diff --git a/lisp/window.el b/lisp/window.el index 5822947f2fe..1b95b5c9500 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -428,6 +428,16 @@ The functions currently affected by this are `split-window', An application may bind this to a non-nil value around calls to these functions to inhibit processing of window parameters.") +(defun window-no-other-p (&optional window) + "Return non-nil if WINDOW should not be used as \"other\" window. +WINDOW must be a live window and defaults to the selected one. + +Return non-nil if the `no-other-window' parameter of WINDOW is non-nil +and `ignore-window-parameters' is nil. Return nil in any other case." + (setq window (window-normalize-window window t)) + (and (not ignore-window-parameters) + (window-parameter window 'no-other-window))) + ;; This must go to C, finally (or get removed). (defconst window-safe-min-height 1 "The absolute minimum number of lines of any window. @@ -2307,11 +2317,11 @@ as seen from the position of `window-point' in window WINDOW. DIRECTION should be one of `above', `below', `left' or `right'. WINDOW must be a live window and defaults to the selected one. -Do not return a window whose `no-other-window' parameter is -non-nil. If the nearest window's `no-other-window' parameter is -non-nil, try to find another window in the indicated direction. -If, however, the optional argument IGNORE is non-nil, return that -window even if its `no-other-window' parameter is non-nil. +Do not return a window for which `window-no-other-p' returns non-nil. +If `window-no-other-p' returns non-nil for the nearest window, try to +find another window in the indicated direction. If, however, the +optional argument IGNORE is non-nil, return the nearest window even if +`window-no-other-p' returns for it a non-nil value. Optional argument SIGN a negative number means to use the right or bottom edge of WINDOW as reference position instead of @@ -2375,7 +2385,7 @@ Return nil if no suitable window can be found." (cond ((or (eq window w) ;; Ignore ourselves. - (and (window-parameter w 'no-other-window) + (and (window-no-other-p w) ;; Ignore W unless IGNORE is non-nil. (not ignore)))) (hor @@ -2491,14 +2501,13 @@ and no others." (defun get-lru-window (&optional all-frames dedicated not-selected no-other) "Return the least recently used window on frames specified by ALL-FRAMES. -Return a full-width window if possible. A minibuffer window is -never a candidate. A dedicated window is never a candidate -unless DEDICATED is non-nil, so if all windows are dedicated, the -value is nil. Avoid returning the selected window if possible. -Optional argument NOT-SELECTED non-nil means never return the -selected window. Optional argument NO-OTHER non-nil means to -never return a window whose `no-other-window' parameter is -non-nil. +Return a full-width window if possible. A minibuffer window is never a +candidate. A dedicated window is never a candidate unless DEDICATED is +non-nil, so if all windows are dedicated, the value is nil. Avoid +returning the selected window if possible. Optional argument +NOT-SELECTED non-nil means never return the selected window. Optional +argument NO-OTHER non-nil means to never return a window for which +`window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2522,8 +2531,7 @@ selected frame and no others." (dolist (window windows) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window)))) + (or (not no-other) (not (window-no-other-p window)))) (setq time (window-use-time window)) (if (or (eq window (selected-window)) (not (window-full-width-p window))) @@ -2537,12 +2545,11 @@ selected frame and no others." (defun get-mru-window (&optional all-frames dedicated not-selected no-other) "Return the most recently used window on frames specified by ALL-FRAMES. -A minibuffer window is never a candidate. A dedicated window is -never a candidate unless DEDICATED is non-nil, so if all windows -are dedicated, the value is nil. Optional argument NOT-SELECTED -non-nil means never return the selected window. Optional -argument NO-OTHER non-nil means to never return a window whose -`no-other-window' parameter is non-nil. +A minibuffer window is never a candidate. A dedicated window is never a +candidate unless DEDICATED is non-nil, so if all windows are dedicated, +the value is nil. Optional argument NOT-SELECTED non-nil means never +return the selected window. Optional argument NO-OTHER non-nil means to +never return a window for which `window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2564,8 +2571,7 @@ selected frame and no others." (setq time (window-use-time window)) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window))) + (or (not no-other) (not (window-no-other-p window))) (or (not best-time) (> time best-time))) (setq best-time time) (setq best-window window))) @@ -2573,12 +2579,11 @@ selected frame and no others." (defun get-largest-window (&optional all-frames dedicated not-selected no-other) "Return the largest window on frames specified by ALL-FRAMES. -A minibuffer window is never a candidate. A dedicated window is -never a candidate unless DEDICATED is non-nil, so if all windows -are dedicated, the value is nil. Optional argument NOT-SELECTED -non-nil means never return the selected window. Optional -argument NO-OTHER non-nil means to never return a window whose -`no-other-window' parameter is non-nil. +A minibuffer window is never a candidate. A dedicated window is never a +candidate unless DEDICATED is non-nil, so if all windows are dedicated, +the value is nil. Optional argument NOT-SELECTED non-nil means never +return the selected window. Optional argument NO-OTHER non-nil means to +never return a window for which `window-no-other-p' returns non-nil. The following non-nil values of the optional argument ALL-FRAMES have special meanings: @@ -2602,8 +2607,7 @@ selected frame and no others." (dolist (window (window-list-1 nil 'nomini all-frames)) (when (and (or dedicated (not (window-dedicated-p window))) (or (not not-selected) (not (eq window (selected-window)))) - (or (not no-other) - (not (window-parameter window 'no-other-window)))) + (or (not no-other) (window-no-other-p window))) (setq size (* (window-pixel-height window) (window-pixel-width window))) (when (> size best-size) @@ -3963,12 +3967,10 @@ skip -COUNT windows backwards. COUNT zero means do not skip any window, so select the selected window. In an interactive call, COUNT is the numeric prefix argument. Return nil. -If the `other-window' parameter of the selected window is a -function and `ignore-window-parameters' is nil, call that -function with the arguments COUNT and ALL-FRAMES. - -This function does not select a window whose `no-other-window' -window parameter is non-nil. +If the `other-window' parameter of the selected window is a function and +`ignore-window-parameters' is nil, call that function with the arguments +COUNT and ALL-FRAMES. Otherwise, do not return a window for which +`window-no-other-p' returns non-nil. This function uses `next-window' for finding the window to select. The argument ALL-FRAMES has the same meaning as in @@ -3994,7 +3996,7 @@ always effectively nil." ;; Keep out of infinite loops. When COUNT has not changed ;; since we last looked at `window' we're probably in one. (throw 'exit nil))) - ((window-parameter window 'no-other-window) + ((window-no-other-p window) (unless old-window ;; The first non-selectable window `next-window' got us: ;; Remember it and the current value of COUNT. @@ -4010,7 +4012,7 @@ always effectively nil." ;; Keep out of infinite loops. When COUNT has not changed ;; since we last looked at `window' we're probably in one. (throw 'exit nil))) - ((window-parameter window 'no-other-window) + ((window-no-other-p window) (unless old-window ;; The first non-selectable window `previous-window' got ;; us: Remember it and the current value of COUNT. @@ -4183,10 +4185,10 @@ Tool-bar and tab-bar pseudo-windows are ignored by this function: if the specified coordinates are in any of these two windows, this function returns nil. -Optional argument FRAME must specify a live frame and defaults to -the selected one. Optional argument NO-OTHER non-nil means to -return nil if the window located at the specified coordinates has -a non-nil `no-other-window' parameter." +Optional argument FRAME must specify a live frame and defaults to the +selected one. Optional argument NO-OTHER non-nil means to return nil if +`window-no-other-p' returns non-nil for the window located at the +specified coordinates." (setq frame (window-normalize-frame frame)) (let* ((root-edges (window-edges (frame-root-window frame) nil nil t)) (root-left (nth 2 root-edges)) @@ -4199,7 +4201,7 @@ a non-nil `no-other-window' parameter." (or (< x (nth 2 edges)) (= x root-left)) (>= y (nth 1 edges)) (or (< y (nth 3 edges)) (= y root-bottom))) - (if (and no-other (window-parameter window 'no-other-window)) + (if (and no-other (window-no-other-p window)) (throw 'window nil) (throw 'window window))))) frame)))) @@ -4211,13 +4213,13 @@ another live window on that frame to serve as its selected window. This option controls the window that is selected in such a situation. -The possible choices are `mru' (the default) to select the most -recently used window on that frame, and `pos' to choose the -window at the frame coordinates of point of the previously -selected window. If this is nil, choose the frame's first window -instead. A window with a non-nil `no-other-window' parameter is -chosen only if all windows on that frame have that parameter set -to a non-nil value." +The possible choices are `mru' (the default) to select the most recently +used window on that frame, and `pos' to choose the window at the frame +coordinates of point of the previously selected window. If this is nil, +choose the frame's first window instead. A window for which +`window-no-other-p' returns non-nil is chosen only if all windows on +that frame have their `no-other-window' parameter set to a non-nil +value." :type '(choice (const :tag "Most recently used" mru) (const :tag "At position of deleted" pos) (const :tag "Frame's first " nil)) @@ -4340,15 +4342,14 @@ the option `delete-window-choose-selected'." (let ((mru-window (get-mru-window frame nil nil t))) (and mru-window (set-frame-selected-window frame mru-window))))) - ((and (window-parameter - (frame-selected-window frame) 'no-other-window) + ((and (window-no-other-p (frame-selected-window frame)) ;; If `delete-window-internal' selected a window with a ;; non-nil 'no-other-window' parameter as its frame's ;; selected window, try to choose another one. (catch 'found (walk-window-tree (lambda (other) - (unless (window-parameter other 'no-other-window) + (unless (window-no-other-p other) (set-frame-selected-window frame other) (throw 'found t))) frame))))