From fcade74066d82625e367c561a34971f52cf46a61 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 13 Jul 2023 20:11:55 -0400 Subject: [PATCH 01/22] src/comp.c: Use `pending_funcalls` to fix bug#64494 Make sure `comp.el` is never loaded synchronously by simply delaying all calls to `native--compile-async` via `pending_funcalls`. * lisp/startup.el (comp--compilable, comp--delayed-sources): Don't declare. (startup--require-comp-safely) (startup--honor-delayed-native-compilations): Delete functions. (normal-top-level): Don't call `startup--honor-delayed-native-compilations`. * src/comp.c (maybe_defer_native_compilation): Use `pending_funcalls`. (syms_of_comp): Delete `Vcomp__delayed_sources` and `comp__compilable`. Define `Qnative__compile_async`. --- lisp/emacs-lisp/comp.el | 1 + lisp/startup.el | 24 +----------------------- src/comp.c | 23 +++++------------------ 3 files changed, 7 insertions(+), 41 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 22fb08e4688..5f5e7f26446 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4226,6 +4226,7 @@ LOAD and SELECTOR work as described in `native--compile-async'." (string-match-p re file)) native-comp-jit-compilation-deny-list)))) +;;;###autoload (defun native--compile-async (files &optional recursively load selector) ;; BEWARE, this function is also called directly from C. "Compile FILES asynchronously. diff --git a/lisp/startup.el b/lisp/startup.el index 5a389294e78..7f601668369 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -520,27 +520,6 @@ DIRS are relative." xdg-dir) (t emacs-d-dir)))) -(defvar comp--compilable) -(defvar comp--delayed-sources) -(defun startup--require-comp-safely () - "Require the native compiler avoiding circular dependencies." - (when (featurep 'native-compile) - ;; Require comp with `comp--compilable' set to nil to break - ;; circularity. - (let ((comp--compilable nil)) - (require 'comp)) - (native--compile-async comp--delayed-sources nil 'late) - (setq comp--delayed-sources nil))) - -(declare-function native--compile-async "comp.el" - (files &optional recursively load selector)) -(defun startup--honor-delayed-native-compilations () - "Honor pending delayed deferred native compilations." - (when (and (native-comp-available-p) - comp--delayed-sources) - (startup--require-comp-safely)) - (setq comp--compilable t)) - (defvar native-comp-eln-load-path) (defvar native-comp-jit-compilation) (defvar native-comp-enable-subr-trampolines) @@ -846,8 +825,7 @@ It is the default value of the variable `top-level'." nil))) (setq env (cdr env))))) (when display - (setq process-environment (delete display process-environment))))) - (startup--honor-delayed-native-compilations)) + (setq process-environment (delete display process-environment)))))) ;; Precompute the keyboard equivalents in the menu bar items. ;; Command-line options supported by tty's: diff --git a/src/comp.c b/src/comp.c index 013ac6358c1..3c63cad18c7 100644 --- a/src/comp.c +++ b/src/comp.c @@ -5199,17 +5199,9 @@ maybe_defer_native_compilation (Lisp_Object function_name, Fputhash (function_name, definition, Vcomp_deferred_pending_h); - /* This is so deferred compilation is able to compile comp - dependencies breaking circularity. */ - if (comp__compilable) - { - /* Startup is done, comp is usable. */ - CALL0I (startup--require-comp-safely); - CALLN (Ffuncall, intern_c_string ("native--compile-async"), - src, Qnil, Qlate); - } - else - Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources); + pending_funcalls + = Fcons (list (Qnative__compile_async, src, Qnil, Qlate), + pending_funcalls); } @@ -5674,13 +5666,6 @@ void syms_of_comp (void) { #ifdef HAVE_NATIVE_COMP - DEFVAR_LISP ("comp--delayed-sources", Vcomp__delayed_sources, - doc: /* List of sources to be native-compiled when startup is finished. -For internal use. */); - DEFVAR_BOOL ("comp--compilable", comp__compilable, - doc: /* Non-nil when comp.el can be native compiled. -For internal use. */); - /* Compiler control customizes. */ DEFVAR_BOOL ("native-comp-jit-compilation", native_comp_jit_compilation, doc: /* If non-nil, compile loaded .elc files asynchronously. @@ -5798,6 +5783,8 @@ natively-compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + DEFSYM (Qnative__compile_async, "native--compile-async"); + defsubr (&Scomp__subr_signature); defsubr (&Scomp_el_to_eln_rel_filename); defsubr (&Scomp_el_to_eln_filename); From 4e8d579f3da93f3f4cb5ae52c179623e75957ee4 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Thu, 6 Jul 2023 11:50:41 +0300 Subject: [PATCH 02/22] Use 'emacs-lisp-compilation-mode' in native compilation buffers Re-install this commit 40492581f96, now that source of the recursive-load has been fixed (bug#64494). * lisp/emacs-lisp/comp.el (comp-log-to-buffer) (comp-run-async-workers): Use 'emacs-lisp-compilation-mode' in the buffers where we log the results of native compilation. Suggested by No Wayman . (Bug#64452) --- lisp/emacs-lisp/comp.el | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 5f5e7f26446..4892733d456 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1133,7 +1133,8 @@ with `message'. Otherwise, log with `comp-log-to-buffer'." (log-buffer (or (get-buffer comp-log-buffer-name) (with-current-buffer (get-buffer-create comp-log-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)))) (log-window (get-buffer-window log-buffer)) (inhibit-read-only t) @@ -4085,7 +4086,8 @@ display a message." :buffer (with-current-buffer (get-buffer-create comp-async-buffer-name) - (setf buffer-read-only t) + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (current-buffer)) :command (list (expand-file-name invocation-name @@ -4119,6 +4121,8 @@ display a message." (run-hooks 'native-comp-async-all-done-hook) (with-current-buffer (get-buffer-create comp-async-buffer-name) (save-excursion + (unless (derived-mode-p 'compilation-mode) + (emacs-lisp-compilation-mode)) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert "Compilation finished.\n")))) From b95bb644ec2b9bb9b0aa3ba2a88c828c3c33705a Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Fri, 7 Jul 2023 21:27:03 -0700 Subject: [PATCH 03/22] Fix command-line parsing regression in erc-cmd-DCC * lisp/erc/erc-compat.el (erc-compat--28-split-string-shell-command, erc-compat--split-string-shell-command): Remove unused function and macro. * lisp/erc/erc-dcc.el (erc-cmd-DCC): Use own arg-parsing function. * lisp/erc/erc.el (erc--shell-parse-regexp, erc--split-string-shell-cmd): New regexp constant and arg-parsing function based on those in shell.el. * test/lisp/erc/erc-dcc-tests.el (erc-dcc-tests--erc-dcc-do-GET-command): Accept new `nuh' argument representing message source/sender. (erc-dcc-do-GET-command): Add tests for regression involving pipe character. * test/lisp/erc/erc-tests.el (erc--split-string-shell-cmd): New test. (Bug#62444) Thanks to Fernando de Morais for reporting this bug. --- lisp/erc/erc-compat.el | 21 ---------------- lisp/erc/erc-dcc.el | 2 +- lisp/erc/erc.el | 36 ++++++++++++++++++++++++++ test/lisp/erc/erc-dcc-tests.el | 23 +++++++++++------ test/lisp/erc/erc-tests.el | 46 ++++++++++++++++++++++++++++++++++ 5 files changed, 99 insertions(+), 29 deletions(-) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 29892b78a39..f451aaee754 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -445,27 +445,6 @@ If START or END is negative, it counts from the end." existing)))))) -;;;; Misc 28.1 - -(defvar comint-file-name-quote-list) -(defvar shell-file-name-quote-list) -(declare-function shell--parse-pcomplete-arguments "shell" nil) - -(defun erc-compat--28-split-string-shell-command (string) - (require 'comint) - (require 'shell) - (with-temp-buffer - (insert string) - (let ((comint-file-name-quote-list shell-file-name-quote-list)) - (car (shell--parse-pcomplete-arguments))))) - -(defmacro erc-compat--split-string-shell-command (string) - ;; Autoloaded in Emacs 28. - (list (if (fboundp 'split-string-shell-command) - 'split-string-shell-command - 'erc-compat--28-split-string-shell-command) - string)) - (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index cc2dcc9a788..f05ae41fc51 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -399,7 +399,7 @@ where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." (if compat-args (setq cmd line args compat-args) - (setq args (delete "" (erc-compat--split-string-shell-command line)) + (setq args (delete "" (erc--split-string-shell-cmd line)) cmd (pop args))) (let ((fn (intern-soft (concat "erc-dcc-do-" (upcase cmd) "-command")))) (if fn diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index e23185934f7..1786c8924bd 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3213,6 +3213,42 @@ this function from interpreting the line as a command." (erc-display-message nil 'error (current-buffer) 'no-target) nil))))) +(defconst erc--shell-parse-regexp + (rx (or (+ (not (any ?\s ?\t ?\n ?\\ ?\" ?' ?\;))) + (: ?' (group (* (not ?'))) (? ?')) + (: ?\" (group (* (or (not (any ?\" ?\\)) (: ?\\ nonl)))) (? ?\")) + (: ?\\ (group (? (or nonl ?\n))))))) + +(defun erc--split-string-shell-cmd (string) + "Parse whitespace-separated arguments in STRING." + ;; From `shell--parse-pcomplete-arguments' and friends. Quirk: + ;; backslash-escaped characters appearing within spans of double + ;; quotes are unescaped. + (with-temp-buffer + (insert string) + (let ((end (point)) + args) + (goto-char (point-min)) + (while (and (skip-chars-forward " \t") (< (point) end)) + (let (arg) + (while (looking-at erc--shell-parse-regexp) + (goto-char (match-end 0)) + (cond ((match-beginning 3) ; backslash escape + (push (if (= (match-beginning 3) (match-end 3)) + "\\" + (match-string 3)) + arg)) + ((match-beginning 2) ; double quote + (push (replace-regexp-in-string (rx ?\\ (group nonl)) + "\\1" (match-string 2)) + arg)) + ((match-beginning 1) ; single quote + (push (match-string 1) arg)) + (t (push (match-string 0) arg)))) + (push (string-join (nreverse arg)) args))) + (nreverse args)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Input commands handlers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index f02ddf228a2..a750c96c80f 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -99,10 +99,11 @@ (ert-deftest erc-dcc-handle-ctcp-send--turbo () (erc-dcc-tests--dcc-handle-ctcp-send t)) -(defun erc-dcc-tests--erc-dcc-do-GET-command (file &optional sep) +(defun erc-dcc-tests--erc-dcc-do-GET-command (file &optional sep nuh) + (unless nuh (setq nuh "tester!~tester@fake.irc")) (with-temp-buffer (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) - (elt (list :nick "tester!~tester@fake.irc" + (elt (list :nick nuh :type 'GET :peer nil :parent proc @@ -110,6 +111,7 @@ :port "9899" :file file :size 1405135128)) + (nic (erc-extract-nick nuh)) (erc-dcc-list (list elt)) ;; erc-accidental-paste-threshold-seconds @@ -130,7 +132,7 @@ (ert-info ("No turbo") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET tester " (or sep "") (prin1-to-string file)) + (insert "/dcc GET " nic " " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should-not (plist-member (car erc-dcc-list) :turbo)) (should (equal (pop calls) (list elt file proc)))) @@ -138,7 +140,7 @@ (ert-info ("Arg turbo in pos 2") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET -t tester " (or sep "") (prin1-to-string file)) + (insert "/dcc GET -t " nic " " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) (should (equal (pop calls) (list elt file proc)))) @@ -147,7 +149,7 @@ (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester -t " (or sep "") (prin1-to-string file)) + (insert "/dcc GET " nic " -t " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) (should (equal (pop calls) (list elt file proc)))) @@ -156,7 +158,7 @@ (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester " (prin1-to-string file) " -t" (or sep "")) + (insert "/dcc GET " nic " " (prin1-to-string file) " -t" (or sep "")) (erc-send-current-line) (should (eq (if sep nil t) (plist-get (car erc-dcc-list) :turbo))) (should (equal (pop calls) (if sep nil (list elt file proc))))))))) @@ -165,7 +167,14 @@ (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin") (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin") (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin") - (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- ")) + (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- ") + + ;; Regression involving pipe character in nickname. + (let ((nuh "test|r!~test|r@fake.irc")) + (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- " nuh))) (defun erc-dcc-tests--pcomplete-common (test-fn &optional file) (with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*") diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 80c7c708fc5..f5c900df408 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1218,6 +1218,52 @@ (should-not calls)))))) +(ert-deftest erc--split-string-shell-cmd () + + ;; Leading and trailing space + (should (equal (erc--split-string-shell-cmd "1 2 3") '("1" "2" "3"))) + (should (equal (erc--split-string-shell-cmd " 1 2 3 ") '("1" "2" "3"))) + + ;; Empty string + (should (equal (erc--split-string-shell-cmd "\"\"") '(""))) + (should (equal (erc--split-string-shell-cmd " \"\" ") '(""))) + (should (equal (erc--split-string-shell-cmd "1 \"\"") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "1 \"\" ") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "\"\" 1") '("" "1"))) + (should (equal (erc--split-string-shell-cmd " \"\" 1") '("" "1"))) + + (should (equal (erc--split-string-shell-cmd "''") '(""))) + (should (equal (erc--split-string-shell-cmd " '' ") '(""))) + (should (equal (erc--split-string-shell-cmd "1 ''") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "1 '' ") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "'' 1") '("" "1"))) + (should (equal (erc--split-string-shell-cmd " '' 1") '("" "1"))) + + ;; Backslash + (should (equal (erc--split-string-shell-cmd "\\ ") '(" "))) + (should (equal (erc--split-string-shell-cmd " \\ ") '(" "))) + (should (equal (erc--split-string-shell-cmd "1\\ ") '("1 "))) + (should (equal (erc--split-string-shell-cmd "1\\ 2") '("1 2"))) + + ;; Embedded + (should (equal (erc--split-string-shell-cmd "\"\\\"\"") '("\""))) + (should (equal (erc--split-string-shell-cmd "1 \"2 \\\" \\\" 3\"") + '("1" "2 \" \" 3"))) + (should (equal (erc--split-string-shell-cmd "1 \"2 ' ' 3\"") + '("1" "2 ' ' 3"))) + (should (equal (erc--split-string-shell-cmd "1 '2 \" \" 3'") + '("1" "2 \" \" 3"))) + (should (equal (erc--split-string-shell-cmd "1 '2 \\ 3'") + '("1" "2 \\ 3"))) + (should (equal (erc--split-string-shell-cmd "1 \"2 \\\\ 3\"") + '("1" "2 \\ 3"))) ; see comment re ^ + + ;; Realistic + (should (equal (erc--split-string-shell-cmd "GET bob \"my file.txt\"") + '("GET" "bob" "my file.txt"))) + (should (equal (erc--split-string-shell-cmd "GET EXAMPLE|bob \"my file.txt\"") + '("GET" "EXAMPLE|bob" "my file.txt")))) ; regression + ;; The behavior of `erc-pre-send-functions' differs between versions ;; in how hook members see and influence a trailing newline that's From 96785a803776b4c5ca569d8283ce3fc1edaa2a76 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 29 Jun 2023 07:12:46 -0700 Subject: [PATCH 04/22] Deprecate erc-server-alist and erc-server-select * etc/ERC-NEWS: Announce deprecation of `erc-server-alist' and `erc-server-select'. * lisp/erc/erc-networks.el: Comment out call to `erc-get' at end of file. (erc-server-alist) Change shape to accommodate a fifth member: TLS ports. Add default TLS ports for Libera.Chat and OFTC. Deprecate option. (erc-ports-list): Overload for internal use to accept a number instead of a list, but don't advertise this fact. (erc-networks--server-select): Convert `erc-server-select' into a function that performs the same prompting but returns a full URL or a host name instead of calling `erc'. (erc-server-select): Move to erc.el. * lisp/erc/erc.el (erc--prompt-for-server-functions): New variable to allow callers of `erc-select-read-args' to affect how server-prompting is handled without adding additional params. (erc-select-read-args): Defer to `erc--prompt-for-server-function' when non-nil. (erc-server-select): New transplanted function, a deprecated, now TSL-aware version of the old quirky entry point from erc-networks.el. Reimplemented as a simple wrapper for `erc'. * test/lisp/erc/erc-networks-tests.el (erc-ports-list): New test. * test/lisp/erc/erc-tests.el (erc-server-select): New test. (Bug#64478) --- etc/ERC-NEWS | 16 ++++++ lisp/erc/erc-networks.el | 79 ++++++++++++++++------------- lisp/erc/erc.el | 16 +++++- test/lisp/erc/erc-networks-tests.el | 18 +++++++ test/lisp/erc/erc-tests.el | 35 +++++++++++++ 5 files changed, 128 insertions(+), 36 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 5665b760ea9..808d7dcb64f 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -75,6 +75,22 @@ the 'log' module may want to customize 'erc-log-filter-function' to 'erc-stamp-prefix-log-filter' to avoid ragged right-hand stamps appearing in their saved logs. +** Awkward entry point 'erc-server-select' improved but deprecated. +The alternate entry point 'erc-server-select' has mainly served to +confuse users in more recent years because it requires certain +options, like 'erc-nick', to be configured ahead of time, and it +doesn't support TLS. Its main selling point, historically, has been +interactive completion based on the option 'erc-server-alist', which +is a table of networks, servers, and ports. But most of the option's +400-odd entries are sadly defunct or otherwise outdated. And, these +days, most networks promote a well known load-balancing end point over +individual servers anyway. Regardless, the command has now been +improved to prompt for the same slate of parameters sought by +'erc-tls'. Similarly, 'erc-server-alist' entries now support a fifth +member in TLS ports (though this option too has been deprecated). If +you feel these deprecations rash or unwarranted, please file a bug +report and petition the maintainers for a reprieve. + ** Smarter reconnect handling for users on the move. ERC now offers a new, experimental reconnect strategy in the function 'erc-server-delayed-check-reconnect', which tests for underlying diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index dd481032e7e..7cc64614573 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -29,8 +29,6 @@ ;; ;; This is the "networks" module. ;; -;; M-x erc-server-select provides an alternative way to connect to servers by -;; choosing networks. ;; You can use (eq (erc-network) 'Network) if you'd like to set variables or do ;; certain actions according to which network you're connected to. ;; If a network you use is not listed in `erc-networks-alist', you can put @@ -258,6 +256,7 @@ ("IRChat: Random server" IRChat "irc.irchat.net" ((6660 6669))) ("IrcLordz: Random server" IrcLordz "irc.irclordz.com" 6667) ("IrcMalta: Random server" IrcMalta "irc.ircmalta.org" ((6660 6667))) + ;; This one is dead but used in testing. Please retain. ("IRCnet: EU, FR, Random" IRCnet "irc.fr.ircnet.net" 6667) ("IRCnet: EU, IT, Random" IRCnet "irc.ircd.it" ((6665 6669))) ("IRCnet: AS, IL, Haifa" IRCnet "ircnet.netvision.net.il" ((6661 6668))) @@ -318,13 +317,15 @@ ("LagNet: Random server" LagNet "irc.lagnet.org.za" 6667) ("LagNet: AF, ZA, Cape Town" LagNet "reaper.lagnet.org.za" 6667) ("LagNet: AF, ZA, Johannesburg" LagNet "mystery.lagnet.org.za" 6667) - ("Libera.Chat: Random server" Libera.Chat "irc.libera.chat" 6667) - ("Libera.Chat: Random Europe server" Libera.Chat "irc.eu.libera.chat" 6667) - ("Libera.Chat: Random US & Canada server" Libera.Chat "irc.us.libera.chat" 6667) - ("Libera.Chat: Random Australia & New Zealand server" Libera.Chat "irc.au.libera.chat" 6667) - ("Libera.Chat: Random East Asia server" Libera.Chat "irc.ea.libera.chat" 6667) - ("Libera.Chat: IPv4 only server" Libera.Chat "irc.ipv4.libera.chat" 6667) - ("Libera.Chat: IPv6 only server" Libera.Chat "irc.ipv6.libera.chat" 6667) + ("Libera.Chat: Random server" Libera.Chat "irc.libera.chat" + ((6665 6667) (8000 8002)) (6697 7000 7070)) + ;; If not deprecating this option, use ^ for the rest of these servers. + ("Libera.Chat: Random Europe server" Libera.Chat "irc.eu.libera.chat" 6667 6697) + ("Libera.Chat: Random US & Canada server" Libera.Chat "irc.us.libera.chat" 6667 6697) + ("Libera.Chat: Random Australia & New Zealand server" Libera.Chat "irc.au.libera.chat" 6667 6697) + ("Libera.Chat: Random East Asia server" Libera.Chat "irc.ea.libera.chat" 6667 6697) + ("Libera.Chat: IPv4 only server" Libera.Chat "irc.ipv4.libera.chat" 6667 6697) + ("Libera.Chat: IPv6 only server" Libera.Chat "irc.ipv6.libera.chat" 6667 6697) ("Librenet: Random server" Librenet "irc.librenet.net" 6667) ("LinkNet: Random server" LinkNet "irc.link-net.org" ((6667 6669))) ("LinuxChix: Random server" LinuxChix "irc.linuxchix.org" 6667) @@ -349,7 +350,7 @@ ("Novernet: Random server" Novernet "irc.novernet.com" ((6665 6669) 7000 )) ("Nullrouted: Random server" Nullrouted "irc.nullrouted.org" ((6666 6669) 7000 )) ("NullusNet: Random server" NullusNet "irc.nullus.net" 6667) - ("OFTC: Random server" OFTC "irc.oftc.net" ((6667 6670) 7000)) + ("OFTC: Random server" OFTC "irc.oftc.net" ((6667 6670) 7000) (6697 9999)) ("OpChat: Random server" OpChat "irc.opchat.org" ((6667 6669))) ("Othernet: Random server" Othernet "irc.othernet.org" 6667) ("Othernet: US, FL, Miami" Othernet "miami.fl.us.othernet.org" 6667) @@ -472,12 +473,13 @@ ("ZUHnet: Random server" ZUHnet "irc.zuh.net" 6667) ("Zurna: Random server" Zurna "irc.zurna.net" 6667)) "Alist of irc servers. -Each server is a list (NAME NET HOST PORTS) where +Each server is a list (NAME NET HOST PORTS TLS-PORTS) where NAME is a name for that server, NET is a symbol indicating to which network from `erc-networks-alist' this server corresponds, -HOST is the servers hostname and -PORTS is either a number, a list of numbers, or a list of port ranges." +HOST is the server's hostname, and (TLS-)PORTS is either a +number, a list of numbers, or a list of port ranges." + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(alist :key-type (string :tag "Name") :value-type (group symbol (string :tag "Hostname") @@ -486,7 +488,15 @@ PORTS is either a number, a list of numbers, or a list of port ranges." (repeat :tag "List of ports or ranges" (choice (integer :tag "Port number") (list :tag "Port range" - integer integer))))))) + integer integer)))) + (choice :tag "TLS ports" + (integer :tag "TLS port number") + (repeat :tag "List of TLS ports or ranges" + (choice (integer :tag "TLS port number") + (list :tag "TLS port range" + integer integer))))))) +(make-obsolete-variable 'erc-server-alist + "specify `:server' with `erc-tls'." "30.1") (defcustom erc-networks-alist '((4-irc "4-irc.com") @@ -1535,7 +1545,7 @@ As an example: (erc-ports-list \\='((1 5))) => (1 2 3 4 5) (erc-ports-list \\='(1 (3 5))) => (1 3 4 5)" (let (result) - (dolist (p ports) + (dolist (p (ensure-list ports)) (cond ((numberp p) (push p result)) ((listp p) @@ -1544,31 +1554,32 @@ As an example: result))))) (nreverse result))) -;;;###autoload -(defun erc-server-select () - "Interactively select a server to connect to using `erc-server-alist'." - (interactive) +(defun erc-networks--server-select () + "Prompt for a server in `erc-server-alist' and return its irc(s):// URL. +Choose port at random if multiple candidates exist, but always +prefer TLS without asking. When a port can't be determined, +return the host alone sans URL formatting (for compatibility)." (let* ((completion-ignore-case t) (net (intern (completing-read "Network: " (delete-dups (mapcar (lambda (x) - (list (symbol-name (nth 1 x)))) + (list (nth 1 x))) erc-server-alist))))) - (srv (assoc - (completing-read "Server: " - (delq nil - (mapcar (lambda (x) - (when (equal (nth 1 x) net) - x)) - erc-server-alist))) - erc-server-alist)) + (s-choose (lambda (entry) + (and (equal (nth 1 entry) net) + (if-let ((b (string-search ": " (car entry)))) + (cons (format "%s (%s)" (nth 2 entry) + (substring (car entry) (+ b 2))) + (cdr entry)) + entry)))) + (s-entries (delq nil (mapcar s-choose erc-server-alist))) + (srv (assoc (completing-read "Server: " s-entries) s-entries)) (host (nth 2 srv)) - (ports (if (listp (nth 3 srv)) - (erc-ports-list (nth 3 srv)) - (list (nth 3 srv)))) - (port (and ports (seq-random-elt ports)))) - (erc :server host :port port))) + (pspec (nthcdr 3 srv)) + (ports (erc-ports-list (or (cadr pspec) (car pspec)))) + (scheme (if (cdr pspec) "ircs" "irc"))) + (if ports (format "%s://%s:%d" scheme host (seq-random-elt ports)) host))) ;;; The following experimental ;; It does not work yet, help me with it if you @@ -1605,7 +1616,7 @@ VALUE is the options value.") items nil))))) val)) -(erc-get 'pals 'Libera.Chat) +;; (erc-get 'pals 'Libera.Chat) (provide 'erc-networks) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 1786c8924bd..7693947873e 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2354,13 +2354,17 @@ parameters SERVER and NICK." (setq input (concat "irc://" input))) input) +(defvar erc--prompt-for-server-function nil) + ;;;###autoload (defun erc-select-read-args () "Prompt the user for values of nick, server, port, and password. With prefix arg, also prompt for user and full name." (let* ((input (let ((d (erc-compute-server))) - (read-string (format "Server or URL (default is %S): " d) - nil 'erc-server-history-list d))) + (if erc--prompt-for-server-function + (funcall erc--prompt-for-server-function) + (read-string (format "Server or URL (default is %S): " d) + nil 'erc-server-history-list d)))) ;; For legacy reasons, also accept a URL without a scheme. (url (url-generic-parse-url (erc--ensure-url input))) (server (url-host url)) @@ -2419,6 +2423,14 @@ With prefix arg, also prompt for user and full name." (cl-progv ,syms ,vals ,@body)))) +;;;###autoload +(defun erc-server-select () + "Interactively connect to a server from `erc-server-alist'." + (declare (obsolete erc-tls "30.1")) + (interactive) + (let ((erc--prompt-for-server-function #'erc-networks--server-select)) + (call-interactively #'erc))) + ;;;###autoload (cl-defun erc (&key (server (erc-compute-server)) (port (erc-compute-port)) diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index f0fcbbc81c6..e95d99c128f 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -1750,4 +1750,22 @@ (should (eq (erc-networks--determine) erc-networks--name-missing-sentinel)))) +(ert-deftest erc-ports-list () + (with-suppressed-warnings ((obsolete erc-server-alist)) + (let* ((srv (assoc "Libera.Chat: Random server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) + '(6665 6666 6667 8000 8001 8002))) + (should (equal (erc-ports-list (nth 4 srv)) + '(6697 7000 7070)))) + + (let* ((srv (assoc "Libera.Chat: Random Europe server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) '(6667))) + (should (equal (erc-ports-list (nth 4 srv)) '(6697)))) + + (let* ((srv (assoc "OFTC: Random server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) + '(6667 6668 6669 6670 7000))) + (should (equal (erc-ports-list (nth 4 srv)) + '(6697 9999)))))) + ;;; erc-networks-tests.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index f5c900df408..449b8e0df42 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1703,6 +1703,41 @@ (erc-server-connect-function erc-open-network-stream)))))))) +(ert-deftest erc-server-select () + (let (calls env) + (cl-letf (((symbol-function 'user-login-name) + (lambda (&optional _) "tester")) + ((symbol-function 'erc-open) + (lambda (&rest r) + (push `((erc-join-buffer ,erc-join-buffer) + (erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) + + (ert-info ("Selects Libera.Chat Europe, automatic TSL") + (ert-simulate-keys "Libera.Chat\rirc.eu.\t\r\r\r" + (with-suppressed-warnings ((obsolete erc-server-select)) + (call-interactively #'erc-server-select))) + (should (equal (pop calls) + '("irc.eu.libera.chat" 6697 "tester" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Selects entry that doesn't support TLS") + (ert-simulate-keys "IRCnet\rirc.fr.\t\rdummy\r\r" + (with-suppressed-warnings ((obsolete erc-server-select)) + (call-interactively #'erc-server-select))) + (should (equal (pop calls) + '("irc.fr.ircnet.net" 6667 "dummy" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc-server-connect-function + erc-open-network-stream)))))))) + (defun erc-tests--make-server-buf (name) (with-current-buffer (get-buffer-create name) (erc-mode) From 4d6ed774fef6c6630738761356ea274b5a18fb62 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sun, 2 Jul 2023 20:58:37 -0700 Subject: [PATCH 05/22] Respect existing invisibility props in erc-stamp * etc/ERC-NEWS: mention `erc-match-toggle-hidden-fools' and new merging behavior when handling `invisible' text property. * lisp/erc/erc-match.el (erc-hide-fools): change `invisible' property to `erc-match' for all messages, not just those with offset bounds. (erc-match--modify-invisibility-spec): Fix error in doc string. (erc-match-toggle-hidden-fools): New command. * lisp/erc/erc-stamp.el (erc-stamp--invisible-property): Add new internal variable to hold existing `invisible' property merged with the one registered by this module, the non-namespaced `timestamp'. (erc-stamp--skip-when-invisible): Add new internal variable, an escape hatch for pre-ERC-5.6 behavior in which timestamps were not applied at all to invisible messages. This led to strange-looking, uneven logs, and it prevented other modules from offering toggle functionality for invisibility-spec members registered to them. (erc-add-timestamp): Merge with existing `invisible' property, when present, instead of clobbering, but only when escape hatch `erc-stamp--skip-when-invisible' is nil. (erc-insert-timestamp-left, erc-format-timestamp): Use possibly merged `invisible' prop value. Don't bother with `isearch-open-invisible', which only affects overlays. (erc-insert-timestamp-right): Bind `buffer-invisibility-spec' to nil when figuring `current-column'. Apply `invisible' text prop to white space around stamp. * test/lisp/erc/erc-scenarios-match.el: Require `erc-fill' and `erc-stamp'. (erc-scenarios-match--invisible-stamp): Move common setup and core assertions for some stamp and invisibility-related tests into a fixture-like helper. (erc-scenarios-match--stamp-left-fools-invisible): Fix temporarily disabled test and use fixture. (erc-scenarios-match--find-eol): New helper. (erc-scenarios-match--stamp-right-fools-invisible, erc-scenarios-match--stamp-right-invisible-fill-wrap, erc-scenarios-match--stamp-both-invisible-fill-static): New tests. (Bug#64301) --- etc/ERC-NEWS | 14 +- lisp/erc/erc-match.el | 18 +- lisp/erc/erc-stamp.el | 21 ++- test/lisp/erc/erc-scenarios-match.el | 257 ++++++++++++++++++++++++--- 4 files changed, 272 insertions(+), 38 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 808d7dcb64f..80885c3c874 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -160,11 +160,12 @@ the same effect by issuing a "/CLEAR" at the prompt. Some minor quality-of-life niceties have finally made their way to ERC. For example, the function 'erc-echo-timestamp' is now interactive and can be invoked on any message to view its timestamp in -the echo area. The command 'erc-button-previous' now moves to the -beginning instead of the end of buttons. A new command, 'erc-news', -can now be invoked to visit this very file. And the 'irccontrols' -module now supports additional colors and special handling for -"spoilers" (hidden text). +the echo area. Fool visibility has become togglable with the new +command 'erc-match-toggle-hidden-fools'. The 'button' module's +'erc-button-previous' now moves to the beginning instead of the end of +buttons. A new command, 'erc-news', can be invoked to visit this very +file. And the 'irccontrols' module now supports additional colors and +special handling for "spoilers" (hidden text). ** Changes in the library API. @@ -213,6 +214,9 @@ traversing messages. To compensate, a new property, 'erc-timestamp', now spans message bodies but not the newlines delimiting them. Somewhat relatedly, the function 'erc-insert-aligned' has been deprecated and removed from the primary client code path. +Additionally, the 'stamp' module now merges its 'invisible' property +with existing ones, when present, and it includes all white space +around stamps when doing so. *** The role of a module's Custom group is now more clearly defined. Associating built-in modules with Custom groups and provided library diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 2b7fff87ff0..cd2c55b0091 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -669,10 +669,9 @@ This function should be called from `erc-text-matched-hook'." (save-restriction (widen) (put-text-property (1- beg) (1- end) 'invisible 'erc-match))) - ;; The docs say `intangible' is deprecated, but this has been - ;; like this for ages. Should verify unneeded and remove if so. - (erc-put-text-properties (point-min) (point-max) - '(invisible intangible))))) + ;; Before ERC 5.6, this also used to add an `intangible' + ;; property, but the docs say it's now obsolete. + (put-text-property (point-min) (point-max) 'invisible 'erc-match)))) (defun erc-beep-on-match (match-type _nickuserhost _message) "Beep when text matches. @@ -681,12 +680,21 @@ This function is meant to be called from `erc-text-matched-hook'." (beep))) (defun erc-match--modify-invisibility-spec () - "Add an ellipsis property to the local spec." + "Add an `erc-match' property to the local spec." (if erc-match-mode (add-to-invisibility-spec 'erc-match) (erc-with-all-buffers-of-server nil nil (remove-from-invisibility-spec 'erc-match)))) +(defun erc-match-toggle-hidden-fools () + "Toggle fool visibility. +Expect `erc-hide-fools' or a function that does something similar +to be in `erc-text-matched-hook'." + (interactive) + (if (memq 'erc-match (ensure-list buffer-invisibility-spec)) + (remove-from-invisibility-spec 'erc-match) + (add-to-invisibility-spec 'erc-match))) + (provide 'erc-match) ;;; erc-match.el ends here diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 5035e60a87d..83ee4a200ed 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -179,6 +179,12 @@ from entering them and instead jump over them." (kill-local-variable 'erc-timestamp-last-inserted-left) (kill-local-variable 'erc-timestamp-last-inserted-right)))) +(defvar erc-stamp--invisible-property nil + "Existing `invisible' property value and/or symbol `timestamp'.") + +(defvar erc-stamp--skip-when-invisible nil + "Escape hatch for omitting stamps when first char is invisible.") + (defun erc-stamp--recover-on-reconnect () (when-let ((priors (or erc--server-reconnecting erc--target-priors))) (dolist (var '(erc-timestamp-last-inserted @@ -209,8 +215,11 @@ or `erc-send-modify-hook'." (progn ; remove this `progn' on next major refactor (let* ((ct (erc-stamp--current-time)) (invisible (get-text-property (point-min) 'invisible)) + (erc-stamp--invisible-property + ;; FIXME on major version bump, make this `erc-' prefixed. + (if invisible `(timestamp ,@(ensure-list invisible)) 'timestamp)) (erc-stamp--current-time ct)) - (unless invisible + (unless (setq invisible (and erc-stamp--skip-when-invisible invisible)) (funcall erc-insert-timestamp-function (erc-format-timestamp ct erc-timestamp-format))) ;; FIXME this will error when advice has been applied. @@ -380,7 +389,7 @@ message text so that stamps will be visible when yanked." (s (if ignore-p (make-string len ? ) string))) (unless ignore-p (setq erc-timestamp-last-inserted string)) (erc-put-text-property 0 len 'field 'erc-timestamp s) - (erc-put-text-property 0 len 'invisible 'timestamp s) + (erc-put-text-property 0 len 'invisible erc-stamp--invisible-property s) (insert s))) (defun erc-insert-aligned (string pos) @@ -428,6 +437,7 @@ printed just after each line's text (no alignment)." (goto-char (point-max)) (forward-char -1) ; before the last newline (let* ((str-width (string-width string)) + (buffer-invisibility-spec nil) ; `current-column' > 0 window ; used in computation of `pos' only (pos (cond (erc-timestamp-right-column erc-timestamp-right-column) @@ -477,6 +487,8 @@ printed just after each line's text (no alignment)." (put-text-property from (point) p v))) (erc-put-text-property from (point) 'field 'erc-timestamp) (erc-put-text-property from (point) 'rear-nonsticky t) + (erc-put-text-property from (point) 'invisible + erc-stamp--invisible-property) (when erc-timestamp-intangible (erc-put-text-property from (1+ (point)) 'cursor-intangible t))))) @@ -520,9 +532,8 @@ Return the empty string if FORMAT is nil." (let ((ts (format-time-string format time erc-stamp--tz))) (erc-put-text-property 0 (length ts) 'font-lock-face 'erc-timestamp-face ts) - (erc-put-text-property 0 (length ts) 'invisible 'timestamp ts) - (erc-put-text-property 0 (length ts) - 'isearch-open-invisible 'timestamp ts) + (erc-put-text-property 0 (length ts) 'invisible + erc-stamp--invisible-property ts) ;; N.B. Later use categories instead of this harmless, but ;; inelegant, hack. -- BPT (and erc-timestamp-intangible diff --git a/test/lisp/erc/erc-scenarios-match.el b/test/lisp/erc/erc-scenarios-match.el index 782907bfc30..8a718962c55 100644 --- a/test/lisp/erc/erc-scenarios-match.el +++ b/test/lisp/erc/erc-scenarios-match.el @@ -24,8 +24,12 @@ (let ((load-path (cons (ert-resource-directory) load-path))) (require 'erc-scenarios-common))) +(eval-when-compile + (require 'erc-join) + (require 'erc-match)) + (require 'erc-stamp) -(require 'erc-match) +(require 'erc-fill) ;; This defends against a regression in which all matching by the ;; `erc-match-message' fails when `erc-add-timestamp' precedes it in @@ -57,28 +61,23 @@ (should (eq (get-text-property (1- (point)) 'font-lock-face) 'erc-current-nick-face)))))) -;; This asserts that when stamps appear before a message, -;; some non-nil invisibility property spans the entire message. -(ert-deftest erc-scenarios-match--stamp-left-fools-invisible () - :tags '(:expensive-test) - (ert-skip "WIP: fix included in bug#64301") +;; When hacking on tests that use this fixture, it's best to run it +;; interactively, and check for wierdness before and after doing +;; M-: (remove-from-invisibility-spec 'erc-match) RET. +(defun erc-scenarios-match--invisible-stamp (hiddenp visiblep) + (unless noninteractive + (kill-new "(remove-from-invisibility-spec 'erc-match)")) + (erc-scenarios-common-with-cleanup ((erc-scenarios-common-dialog "join/legacy") (dumb-server (erc-d-run "localhost" t 'foonet)) (port (process-contact dumb-server :service)) (erc-server-flood-penalty 0.1) - (erc-insert-timestamp-function 'erc-insert-timestamp-left) (erc-timestamp-only-if-changed-flag nil) (erc-fools '("bob")) (erc-text-matched-hook '(erc-hide-fools)) (erc-autojoin-channels-alist '((FooNet "#chan"))) - (expect (erc-d-t-make-expecter)) - (hiddenp (lambda () - (and (eq (field-at-pos (pos-bol)) 'erc-timestamp) - (get-text-property (pos-bol) 'invisible) - (>= (next-single-property-change (pos-bol) - 'invisible nil) - (pos-eol)))))) + (expect (erc-d-t-make-expecter))) (ert-info ("Connect") (with-current-buffer (erc :server "127.0.0.1" @@ -94,30 +93,242 @@ (ert-info ("Ensure lines featuring \"bob\" are invisible") (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) (should (funcall expect 10 " tester, welcome!")) - (should (funcall hiddenp)) + (ert-info (" tester, welcome!") (funcall hiddenp)) ;; Alice's is the only one visible. (should (funcall expect 10 " tester, welcome!")) - (should (eq (field-at-pos (pos-bol)) 'erc-timestamp)) - (should (get-text-property (pos-bol) 'invisible)) - (should-not (get-text-property (point) 'invisible)) + (ert-info (" tester, welcome!") (funcall visiblep)) (should (funcall expect 10 " alice: But, as it seems")) - (should (funcall hiddenp)) + (ert-info (" alice: But, as it seems") (funcall hiddenp)) (should (funcall expect 10 " bob: Well, this is the forest")) - (should (funcall hiddenp)) + (ert-info (" bob: Well, this is the forest") (funcall hiddenp)) (should (funcall expect 10 " bob: And will you")) - (should (funcall hiddenp)) + (ert-info (" bob: And will you") (funcall hiddenp)) (should (funcall expect 10 " alice: Live, and be prosperous")) - (should (funcall hiddenp)) + (ert-info (" alice: Live, and be prosperous") (funcall hiddenp)) (should (funcall expect 10 "ERC>")) (should-not (get-text-property (pos-bol) 'invisible)) (should-not (get-text-property (point) 'invisible)))))) -(eval-when-compile (require 'erc-join)) +;; This asserts that when stamps appear before a message, registered +;; invisibility properties owned by modules span the entire message. +(ert-deftest erc-scenarios-match--stamp-left-fools-invisible () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-left)) + (erc-scenarios-match--invisible-stamp + + (lambda () + ;; This is a time-stamped message. + (should (eq (field-at-pos (pos-bol)) 'erc-timestamp)) + + ;; Leading stamp has combined `invisible' property value. + (should (equal (get-text-property (pos-bol) 'invisible) + '(timestamp erc-match))) + + ;; Message proper has the `invisible' property `erc-match'. + (let ((msg-beg (next-single-property-change (pos-bol) 'invisible))) + (should (eq (get-text-property msg-beg 'invisible) 'erc-match)) + (should (>= (next-single-property-change msg-beg 'invisible nil) + (pos-eol))))) + + (lambda () + ;; This is a time-stamped message. + (should (eq (field-at-pos (pos-bol)) 'erc-timestamp)) + (should (get-text-property (pos-bol) 'invisible)) + + ;; The entire message proper is visible. + (let ((msg-beg (next-single-property-change (pos-bol) 'invisible))) + (should + (= (next-single-property-change msg-beg 'invisible nil (pos-eol)) + (pos-eol)))))))) + +(defun erc-scenarios-match--find-eol () + (save-excursion + (goto-char (next-single-property-change (point) 'erc-command)) + (pos-eol))) + +;; In most cases, `erc-hide-fools' makes line endings invisible. +(ert-deftest erc-scenarios-match--stamp-right-fools-invisible () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right)) + (erc-scenarios-match--invisible-stamp + + (lambda () + (let ((end (erc-scenarios-match--find-eol))) + ;; The end of the message is a newline. + (should (= ?\n (char-after end))) + + ;; Every message has a trailing time stamp. + (should (eq (field-at-pos (1- end)) 'erc-timestamp)) + + ;; Stamps have a combined `invisible' property value. + (should (equal (get-text-property (1- end) 'invisible) + '(timestamp erc-match))) + + ;; The final newline is hidden by `match', not `stamps' + (should (equal (get-text-property end 'invisible) 'erc-match)) + + ;; The message proper has the `invisible' property `erc-match', + ;; and it starts after the preceding newline. + (should (eq (get-text-property (pos-bol) 'invisible) 'erc-match)) + + ;; It ends just before the timestamp. + (let ((msg-end (next-single-property-change (pos-bol) 'invisible))) + (should (equal (get-text-property msg-end 'invisible) + '(timestamp erc-match))) + + ;; Stamp's `invisible' property extends throughout the stamp + ;; and ends before the trailing newline. + (should (= (next-single-property-change msg-end 'invisible) end))))) + + (lambda () + (let ((end (erc-scenarios-match--find-eol))) + ;; This message has a time stamp like all the others. + (should (eq (field-at-pos (1- end)) 'erc-timestamp)) + + ;; The entire message proper is visible. + (should-not (get-text-property (pos-bol) 'invisible)) + (let ((inv-beg (next-single-property-change (pos-bol) 'invisible))) + (should (eq (get-text-property inv-beg 'invisible) + 'timestamp)))))))) + +;; This asserts that when `erc-fill-wrap-mode' is enabled, ERC hides +;; the preceding message's line ending. +(ert-deftest erc-scenarios-match--stamp-right-invisible-fill-wrap () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right) + (erc-fill-function #'erc-fill-wrap)) + (erc-scenarios-match--invisible-stamp + + (lambda () + ;; Every message has a trailing time stamp. + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + + ;; Stamps appear in the right margin. + (should (equal (car (get-text-property (1- (pos-eol)) 'display)) + '(margin right-margin))) + + ;; Stamps have a combined `invisible' property value. + (should (equal (get-text-property (1- (pos-eol)) 'invisible) + '(timestamp erc-match))) + + ;; The message proper has the `invisible' property `erc-match', + ;; which starts at the preceding newline... + (should (eq (get-text-property (1- (pos-bol)) 'invisible) 'erc-match)) + + ;; ... and ends just before the timestamp. + (let ((msgend (next-single-property-change (1- (pos-bol)) 'invisible))) + (should (equal (get-text-property msgend 'invisible) + '(timestamp erc-match))) + + ;; The newline before `erc-insert-marker' is still visible. + (should-not (get-text-property (pos-eol) 'invisible)) + (should (= (next-single-property-change msgend 'invisible) + (pos-eol))))) + + (lambda () + ;; This message has a time stamp like all the others. + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + + ;; Unlike hidden messages, the preceding newline is visible. + (should-not (get-text-property (1- (pos-bol)) 'invisible)) + + ;; The entire message proper is visible. + (let ((inv-beg (next-single-property-change (1- (pos-bol)) 'invisible))) + (should (eq (get-text-property inv-beg 'invisible) 'timestamp))))))) + +(ert-deftest erc-scenarios-match--stamp-both-invisible-fill-static () + :tags '(:expensive-test) + (should (eq erc-insert-timestamp-function + #'erc-insert-timestamp-left-and-right)) + + ;; Rewind the clock to known date artificially. + (let ((erc-stamp--current-time 704591940) + (erc-stamp--tz t) + (erc-fill-function #'erc-fill-static) + (bob-utterance-counter 0)) + + (erc-scenarios-match--invisible-stamp + + (lambda () + (ert-info ("Baseline check") + ;; False date printed initially before anyone speaks. + (when (zerop bob-utterance-counter) + (save-excursion + (goto-char (point-min)) + (search-forward "[Wed Apr 29 1992]") + (search-forward "[23:59]")))) + + (ert-info ("Line endings in Bob's messages are invisible") + ;; The message proper has the `invisible' property `erc-match'. + (should (eq (get-text-property (pos-bol) 'invisible) 'erc-match)) + (let* ((mbeg (next-single-property-change (pos-bol) 'erc-command)) + (mend (next-single-property-change mbeg 'erc-command))) + + (if (/= 1 bob-utterance-counter) + (should-not (field-at-pos mend)) + ;; For Bob's stamped message, check newline after stamp. + (should (eq (field-at-pos mend) 'erc-timestamp)) + (setq mend (field-end mend))) + + ;; The `erc-timestamp' property spans entire messages, + ;; including stamps and filled text, which makes for + ;; convenient traversal when `erc-stamp-mode' is enabled. + (should (get-text-property (pos-bol) 'erc-timestamp)) + (should (= (next-single-property-change (pos-bol) 'erc-timestamp) + mend)) + + ;; Line ending has the `invisible' property `erc-match'. + (should (= (char-after mend) ?\n)) + (should (eq (get-text-property mend'invisible) 'erc-match)))) + + ;; Only the message right after Alice speaks contains stamps. + (when (= 1 bob-utterance-counter) + + (ert-info ("Date stamp occupying previous line is invisible") + (save-excursion + (forward-line -1) + (goto-char (pos-bol)) + (should (looking-at (rx "[Mon May 4 1992]"))) + ;; Date stamp has a combined `invisible' property value + ;; that extends until the start of the message proper. + (should (equal (get-text-property (point) 'invisible) + '(timestamp erc-match))) + (should (= (next-single-property-change (point) 'invisible) + (1+ (pos-eol)))))) + + (ert-info ("Folding preserved despite invisibility") + ;; Message has a trailing time stamp, but it's been folded + ;; over to the next line. + (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + (save-excursion + (forward-line) + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))) + + ;; Stamp invisibility starts where message's ends. + (let ((msgend (next-single-property-change (pos-bol) 'invisible))) + ;; Stamp has a combined `invisible' property value. + (should (equal (get-text-property msgend 'invisible) + '(timestamp erc-match))) + + ;; Combined `invisible' property spans entire timestamp. + (should (= (next-single-property-change msgend 'invisible) + (save-excursion (forward-line) (pos-eol))))))) + + (cl-incf bob-utterance-counter)) + + ;; Alice. + (lambda () + ;; Set clock ahead a week or so. + (setq erc-stamp--current-time 704962800) + + ;; This message has no time stamp and is completely visible. + (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + (should-not (next-single-property-change (pos-bol) 'invisible)))))) ;;; erc-scenarios-match.el ends here From 4f3d036957a754f2e870fc54c7e3f539d215e57e Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Fri, 30 Jun 2023 23:42:01 -0700 Subject: [PATCH 06/22] Simplify erc-button-add-nickname-buttons * lisp/erc/erc-button.el (erc-button--nick): Remove `face' slot, which was set to `erc-button-face' by default. It's ignored when the button is a nick and thus useless and misleading. (erc-button-add-nickname-buttons): Rework and reflow for readability. Don't bind or set `erc-button' face because it's ignored when dealing with nicks. Don't return the value of face options when calling a `form' function because they can be nil in practice even though their Custom type specs do not say so. * lisp/erc/erc-common.el (erc--with-dependent-type-match): Add helper macro for Custom :type defs that incur warnings from `setopt' due to some missing dependency. This occurs when specifying a :type of `face' instead of `symbol' and the option's default value includes faces from another library that hasn't been loaded. * lisp/erc/erc.el (erc--get-speaker-bounds): New helper function to retrieve bounds of a speaker label when present. * test/lisp/erc/erc-tests.el (erc--with-dependent-type-match): Add test. (Bug#64301) --- lisp/erc/erc-button.el | 78 ++++++++++++++++++-------------------- lisp/erc/erc-common.el | 9 +++++ lisp/erc/erc.el | 10 +++++ test/lisp/erc/erc-tests.el | 9 +++++ 4 files changed, 65 insertions(+), 41 deletions(-) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 0c616a6026d..c30f7c10ca6 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -355,8 +355,6 @@ specified by `erc-button-alist'." ( cuser nil :type (or null erc-channel-user) ;; The CDR of a value from an `erc-channel-users' table. :documentation "A possibly nil `erc-channel-user'.") - ( face erc-button-face :type symbol - :documentation "Temp `erc-button-face' while buttonizing.") ( nickname-face erc-button-nickname-face :type symbol :documentation "Temp `erc-button-nickname-face' while buttonizing.") ( mouse-face erc-button-mouse-face :type symbol @@ -431,45 +429,43 @@ retrieve it during buttonizing via (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." - (let ((form (nth 2 entry)) - (fun (nth 3 entry)) - (erc-button-buttonize-nicks (and erc-button-buttonize-nicks - erc-button--modify-nick-function)) - bounds word) - (when (and form (setq form (erc-button--extract-form form))) - (goto-char (point-min)) - (while (erc-forward-word) - (when (setq bounds (erc-bounds-of-word-at-point)) - (setq word (buffer-substring-no-properties - (car bounds) (cdr bounds))) - (let* ((erc-button-face erc-button-face) - (erc-button-mouse-face erc-button-mouse-face) - (erc-button-nickname-face erc-button-nickname-face) - (down (erc-downcase word)) - (cuser (and erc-channel-users - (gethash down erc-channel-users))) - (user (or (and cuser (car cuser)) - (and erc-server-users - (gethash down erc-server-users)) - (funcall erc-button--fallback-user-function - down word bounds))) - (data (list word))) - (when (or (not (functionp form)) - (and-let* ((user) - (obj (funcall form (make-erc-button--nick - :bounds bounds :data data - :downcased down :user user - :cuser (cdr cuser))))) - (setq bounds (erc-button--nick-bounds obj) - data (erc-button--nick-data obj) - erc-button-mouse-face - (erc-button--nick-mouse-face obj) - erc-button-nickname-face - (erc-button--nick-nickname-face obj) - erc-button-face - (erc-button--nick-face obj)))) - (erc-button-add-button (car bounds) (cdr bounds) - fun t data)))))))) + (when-let ((form (nth 2 entry)) + ;; Spoof `form' slot of default legacy `nicknames' entry + ;; so `erc-button--extract-form' sees a function value. + (form (let ((erc-button-buttonize-nicks + (and erc-button-buttonize-nicks + erc-button--modify-nick-function))) + (erc-button--extract-form form))) + (seen 0)) + (goto-char (point-min)) + (while-let + (((erc-forward-word)) + (bounds (or (and (= 1 (cl-incf seen)) (erc--get-speaker-bounds)) + (erc-bounds-of-word-at-point))) + (word (buffer-substring-no-properties (car bounds) (cdr bounds))) + (down (erc-downcase word))) + (let* ((erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (cuser (and erc-channel-users (gethash down erc-channel-users))) + (user (or (and cuser (car cuser)) + (and erc-server-users (gethash down erc-server-users)) + (funcall erc-button--fallback-user-function + down word bounds))) + (data (list word))) + (when (or (not (functionp form)) + (and-let* ((user) + (obj (funcall form (make-erc-button--nick + :bounds bounds :data data + :downcased down :user user + :cuser (cdr cuser))))) + (setq erc-button-mouse-face ; might be null + (erc-button--nick-mouse-face obj) + erc-button-nickname-face ; might be null + (erc-button--nick-nickname-face obj) + data (erc-button--nick-data obj) + bounds (erc-button--nick-bounds obj)))) + (erc-button-add-button (car bounds) (cdr bounds) (nth 3 entry) + 'nickp data)))))) (defun erc-button-add-buttons-1 (regexp entry) "Search through the buffer for matches to ENTRY and add buttons." diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index f152a1a32d9..7bd549abfc1 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -465,6 +465,15 @@ Use the CASEMAPPING ISUPPORT parameter to determine the style." (inline-quote (erc-with-server-buffer (gethash (erc-downcase ,nick) erc-server-users))))) +(defmacro erc--with-dependent-type-match (type &rest features) + "Massage Custom :type TYPE with :match function that pre-loads FEATURES." + `(backquote (,(car type) + :match + ,(list '\, `(lambda (w v) + ,@(mapcar (lambda (ft) `(require ',ft)) features) + (,(widget-get (widget-convert type) :match) w v))) + ,@(cdr type)))) + (provide 'erc-common) ;;; erc-common.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 7693947873e..6c3dc82b133 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -5073,6 +5073,16 @@ and as second argument the event parsed as a vector." (and (erc-is-message-ctcp-p message) (not (string-match "^\C-aACTION.*\C-a$" message)))) +(define-inline erc--get-speaker-bounds () + "Return the bounds of `erc-speaker' property when present. +Assume buffer is narrowed to the confines of an inserted message." + (inline-quote + (and-let* + (((memq (get-text-property (point) 'erc-command) '(PRIVMSG NOTICE))) + (beg (or (and (get-text-property (point-min) 'erc-speaker) (point-min)) + (next-single-property-change (point-min) 'erc-speaker)))) + (cons beg (next-single-property-change beg 'erc-speaker))))) + (defvar erc--user-from-nick-function #'erc--examine-nick "Function to possibly consider unknown user. Must return either nil or a cons of an `erc-server-user' and a diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 449b8e0df42..8d63936b7c2 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -129,6 +129,15 @@ (advice-remove 'buffer-local-value 'erc-with-server-buffer))) +(ert-deftest erc--with-dependent-type-match () + (should (equal (macroexpand-1 + '(erc--with-dependent-type-match (repeat face) erc-match)) + '(backquote + (repeat :match ,(lambda (w v) + (require 'erc-match) + (widget-editable-list-match w v)) + face))))) + (defun erc-tests--send-prep () ;; Caller should probably shadow `erc-insert-modify-hook' or ;; populate user tables for erc-button. From 6a96b862680d4ab168259572545bc9d6a29352c7 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sat, 24 Jun 2023 18:33:20 -0700 Subject: [PATCH 07/22] Add text props for CTCP messages and speakers in ERC * etc/ERC-NEWS: Mention reduction in boldness of `erc-notice-face' and `erc-action-face'. * lisp/erc/erc-fill.el (erc-fill-spaced-commands, erc-fill--spaced-commands): Rename former to latter and demote from user option to internal variable. (erc-fill): Change `erc-fill-spaced-commands' to `erc-fill--spaced-commands'. (erc-fill--wrap-continued-message-p): Use more precise `erc-ctcp' text prop instead of face-based heuristic to detect CTCP ACTION message. (erc-fill--wrap-action-dedent-p): New variable to toggle whether `line-prefix' is applied to CTCP ACTION messages. This exists less to accommodate user preferences and more for third-party code that assumes the first non-whitespace span in every message is a nick. (erc-fill-wrap): Look for `erc-speaker' property before falling back on word at point. Use `erc-ctcp' to detect CTCP ACTION messages. * lisp/erc/erc.el (erc-notice-face, erc-action-face): Prefer weight of `semi-bold' when available so that buttonization is at least somewhat perceptible in notices and action messages. (erc-send-action): Ensure nickname passed to `erc-display-message' has `erc-speaker' property and `erc-ctcp' ACTION property. (erc--own-property-names): Add `erc-speaker' to lineup. (erc-format-privmessage): Don't clobber `erc-nick-prefix-face'. That is, retain face applied to a leading stretch of characters in the `nick' parameter, but continue to discard trailing faces. (erc-format-my-nick, erc-ctcp-query-ACTION): Add new text property `erc-speaker' to the nick portion of the formatted speaker label. Do this to assist modules, like `button' and `match', that currently re-parse speakers in inserted messages. (erc-process-ctcp-query): Add `erc-ctcp' property to entire message before insertion hooks see it. * test/lisp/erc/erc-fill-tests.el (erc-fill-tests--compare): Warn about certain unreliable comparisons if generalizing helper for use by other modules. * test/lisp/erc/erc-tests.el (erc-tests--equal-including-properties): New helper compat macro. (erc-format-privmessage): New test. (Bug#64301) --- etc/ERC-NEWS | 7 ++++++ lisp/erc/erc-fill.el | 25 +++++++++++++------ lisp/erc/erc.el | 40 +++++++++++++++++++++++------- test/lisp/erc/erc-fill-tests.el | 5 +++- test/lisp/erc/erc-tests.el | 43 +++++++++++++++++++++++++++++++++ 5 files changed, 102 insertions(+), 18 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 80885c3c874..3d062e2e9ab 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -145,6 +145,13 @@ been restored with a slightly revised role contingent on a few assumptions explained in its doc string. For clarity, it has been renamed 'erc-ensure-target-buffer-on-privmsg'. +** Subtle changes in two fundamental faces. +Users of the default theme may notice that 'erc-action-face' and +'erc-notice-face' now appear slightly less bold on systems supporting +a weight of 'semi-bold'. This was done to make buttons detectable and +to spare users from resorting to tweaking these faces, or options like +'erc-notice-highlight-type', just to achieve this effect. + ** Improved interplay between buffer truncation and message logging. While most of these improvements are subtle, some affect everyday use. For example, users of the 'truncate' module may notice that truncation diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 5115e45210d..a65c95f1d85 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -124,11 +124,9 @@ configured. Its value should be larger than that of the variable :package-version '(ERC . "5.6") ; FIXME sync on release :type '(choice (const nil) number)) -(defcustom erc-fill-spaced-commands '(PRIVMSG NOTICE) +(defvar erc-fill--spaced-commands '(PRIVMSG NOTICE) "Types of messages to add space between on graphical displays. -Only considered when `erc-fill-line-spacing' is non-nil." - :package-version '(ERC . "5.6") ; FIXME sync on release - :type '(repeat (choice integer symbol))) +Only considered when `erc-fill-line-spacing' is non-nil.") (defvar-local erc-fill--function nil "Internal copy of `erc-fill-function'. @@ -153,12 +151,12 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." (p (point-min))) (widen) (when (or (and-let* ((cmd (get-text-property p 'erc-command))) - (memq cmd erc-fill-spaced-commands)) + (memq cmd erc-fill--spaced-commands)) (and-let* ((cmd (save-excursion (forward-line -1) (get-text-property (point) 'erc-command)))) - (memq cmd erc-fill-spaced-commands))) + (memq cmd erc-fill--spaced-commands))) (put-text-property (1- p) p 'line-spacing erc-fill-line-spacing)))))))) @@ -384,8 +382,7 @@ parties.") (when (eq 'erc-timestamp (field-at-pos m)) (set-marker m (field-end m))) (and (eq 'PRIVMSG (get-text-property m 'erc-command)) - (not (eq (get-text-property m 'font-lock-face) - 'erc-action-face)) + (not (eq (get-text-property m 'erc-ctcp) 'ACTION)) (cons (get-text-property m 'erc-timestamp) (get-text-property (1+ m) 'erc-data))))) (ts (pop props)) @@ -418,6 +415,12 @@ parties.") `(space :width (- erc-fill--wrap-value ,width)))) args) +;; An escape hatch for third-party code expecting speakers of ACTION +;; messages to be exempt from `line-prefix'. This could be converted +;; into a user option if users feel similarly. +(defvar erc-fill--wrap-action-dedent-p t + "Whether to dedent speakers in CTCP \"ACTION\" lines.") + (defun erc-fill-wrap () "Use text props to mimic the effect of `erc-fill-static'. See `erc-fill-wrap-mode' for details." @@ -428,6 +431,12 @@ See `erc-fill-wrap-mode' for details." (let ((len (or (and erc-fill--wrap-length-function (funcall erc-fill--wrap-length-function)) (progn + (when-let ((e (erc--get-speaker-bounds)) + (b (pop e)) + ((or erc-fill--wrap-action-dedent-p + (not (eq (get-text-property b 'erc-ctcp) + 'ACTION))))) + (goto-char e)) (skip-syntax-forward "^-") (forward-char) ;; Using the `invisible' property might make more diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 6c3dc82b133..c10b39e9a1b 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1302,13 +1302,18 @@ See the variable `erc-command-indicator'." (defface erc-notice-face '((default :weight bold) + (((class color) (min-colors 88) (supports :weight semi-bold)) + :weight semi-bold :foreground "SlateBlue") (((class color) (min-colors 88)) :foreground "SlateBlue") (t :foreground "blue")) "ERC face for notices." + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc-faces) -(defface erc-action-face '((t :weight bold)) +(defface erc-action-face '((((supports :weight semi-bold)) :weight semi-bold) + (t :weight bold)) "ERC face for actions generated by /ME." + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc-faces) (defface erc-error-face '((t :foreground "red")) @@ -2735,10 +2740,13 @@ If ARG is non-nil, show the *erc-protocol* buffer." (erc-send-ctcp-message tgt (format "ACTION %s" str) force) (let ((erc-insert-pre-hook (cons (lambda (s) ; Leave newline be. - (put-text-property 0 (1- (length s)) 'erc-command 'PRIVMSG s)) - erc-insert-pre-hook))) + (put-text-property 0 (1- (length s)) 'erc-command 'PRIVMSG s) + (put-text-property 0 (1- (length s)) 'erc-ctcp 'ACTION s)) + erc-insert-pre-hook)) + (nick (erc-current-nick))) + (setq nick (propertize nick 'erc-speaker nick)) (erc-display-message nil 'input (current-buffer) - 'ACTION ?n (erc-current-nick) ?a str ?u "" ?h ""))) + 'ACTION ?n nick ?a str ?u "" ?h ""))) ;; Display interface @@ -4580,7 +4588,7 @@ Eventually add a # in front of it, if that turns it into a valid channel name." (concat "#" channel))) (defvar erc--own-property-names - '( tags erc-parsed display ; core + '( tags erc-speaker erc-parsed display ; core ;; `erc-display-prompt' rear-nonsticky erc-prompt field front-sticky read-only ;; stamp @@ -5099,11 +5107,19 @@ the parsed NUH, and the original `erc-response' object.") (mark-e (if msgp (if privp "*" ">") "-")) (str (format "%s%s%s %s" mark-s nick mark-e msg)) (nick-face (if privp 'erc-nick-msg-face 'erc-nick-default-face)) + (nick-prefix-face (get-text-property 0 'font-lock-face nick)) + (prefix-len (or (and nick-prefix-face (text-property-not-all + 0 (length nick) 'font-lock-face + nick-prefix-face nick)) + 0)) (msg-face (if privp 'erc-direct-msg-face 'erc-default-face))) ;; add text properties to text before the nick, the nick and after the nick (erc-put-text-property 0 (length mark-s) 'font-lock-face msg-face str) - (erc-put-text-property (length mark-s) (+ (length mark-s) (length nick)) - 'font-lock-face nick-face str) + (erc-put-text-properties (+ (length mark-s) prefix-len) + (+ (length mark-s) (length nick)) + '(font-lock-face erc-speaker) str + (list nick-face + (substring-no-properties nick prefix-len))) (erc-put-text-property (+ (length mark-s) (length nick)) (length str) 'font-lock-face msg-face str) str)) @@ -5155,7 +5171,7 @@ also `erc-format-nick-function'." (concat (propertize open 'font-lock-face 'erc-default-face) (propertize mode 'font-lock-face 'erc-my-nick-prefix-face) - (propertize nick 'font-lock-face 'erc-my-nick-face) + (propertize nick 'font-lock-face 'erc-my-nick-face 'erc-speaker nick) (propertize close 'font-lock-face 'erc-default-face))) (let ((prefix "> ")) (propertize prefix 'font-lock-face 'erc-default-face)))) @@ -5393,7 +5409,12 @@ See also `erc-display-message'." 'ctcp-empty ?n nick) (while queries (let* ((type (upcase (car (split-string (car queries))))) - (hook (intern-soft (concat "erc-ctcp-query-" type "-hook")))) + (hook (intern-soft (concat "erc-ctcp-query-" type "-hook"))) + (erc-insert-pre-hook + (cons (lambda (s) + (put-text-property 0 (1- (length s)) 'erc-ctcp + (intern type) s)) + erc-insert-pre-hook))) (if (and hook (boundp hook)) (if (string-equal type "ACTION") (run-hook-with-args-until-success @@ -5428,6 +5449,7 @@ See also `erc-display-message'." (buf (or (erc-get-buffer to proc) (erc-get-buffer nick proc) (process-buffer proc)))) + (setq nick (propertize nick 'erc-speaker nick)) (erc-display-message parsed 'action buf 'ACTION ?n nick ?u login ?h host ?a s)))) diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el index 15a8087f848..99ec4a9635e 100644 --- a/test/lisp/erc/erc-fill-tests.el +++ b/test/lisp/erc/erc-fill-tests.el @@ -153,7 +153,10 @@ (with-temp-file expect-file (insert repr)) (if (file-exists-p expect-file) - ;; Compare set-equal over intervals + ;; Compare set-equal over intervals. This comparison is + ;; less useful for messages treated by other modules because + ;; it doesn't compare "nested" props belonging to + ;; string-valued properties, like timestamps. (should (equal-including-properties (read repr) (read (with-temp-buffer diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 8d63936b7c2..fed25056b42 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1443,6 +1443,49 @@ (kill-buffer "ExampleNet") (kill-buffer "#chan"))) +(defmacro erc-tests--equal-including-properties (a b) + (list (if (< emacs-major-version 29) + 'ert-equal-including-properties + 'equal-including-properties) + a b)) + +(ert-deftest erc-format-privmessage () + ;; Basic PRIVMSG + (should (erc-tests--equal-including-properties + (erc-format-privmessage (copy-sequence "bob") + (copy-sequence "oh my") + nil 'msgp) + #(" oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc-speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face)))) + + ;; Basic NOTICE + (should (erc-tests--equal-including-properties + (erc-format-privmessage (copy-sequence "bob") + (copy-sequence "oh my") + nil nil) + #("-bob- oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc-speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face)))) + + ;; Prefixed PRIVMSG + (let* ((user (make-erc-server-user :nickname (copy-sequence "Bob"))) + (cuser (make-erc-channel-user :op t)) + (erc-channel-users (make-hash-table :test #'equal))) + (puthash "bob" (cons user cuser) erc-channel-users) + + (should (erc-tests--equal-including-properties + (erc-format-privmessage (erc-format-@nick user cuser) + (copy-sequence "oh my") + nil 'msgp) + #("<@Bob> oh my" + 0 1 (font-lock-face erc-default-face) + 1 2 (font-lock-face erc-nick-prefix-face help-echo "operator") + 2 5 (erc-speaker "Bob" font-lock-face erc-nick-default-face) + 5 12 (font-lock-face erc-default-face)))))) + (defvar erc-tests--ipv6-examples '("1:2:3:4:5:6:7:8" "::ffff:10.0.0.1" "::ffff:1.2.3.4" "::ffff:0.0.0.0" From d45770e8d03ae82d44d05086e22d552ab60e34e9 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Sat, 24 Jun 2023 18:33:20 -0700 Subject: [PATCH 08/22] Optionally combine faces in erc-display-message * etc/ERC-NEWS: Tell module authors that `erc-display-message' can now combine faces. * lisp/erc/erc-button.el (erc-button--display-error-notice-with-keys): Ask `erc-display-message' to compose `erc-notice-face' and `erc-error-face'. * lisp/erc/erc-match.el (erc-hide-fools): Merge `invisible' prop `erc-match' with existing, if present, and move body to helper for hiding matched messages. (erc-match--hide-message): New helper function to hide messages regardless of match type. * lisp/erc/erc-track.el: (erc-track-faces-priority-list): Note in doc string that faces reserved for critical messages are always prioritized. Wrap :type declaration in macro helper to ensure `erc-button' is loaded beforehand. Otherwise calling `setopt' with the option's default value fails. (erc-track--attn-faces): Add new internal variable for faces that should always appear in the mode line, at least in the default client. (erc-track-modified-channels, erc-track-face-priority): Prepend `erc-track--attn-faces' to `erc-track-faces-priority-list'. * lisp/erc/erc.el (erc-send-action): Ask `erc-display-message' to apply both `erc-input-face' and `erc-action-face' to messages. (erc--compose-text-properties): New internal variable to act as flag for altering behavior of `erc-put-text-property'. (erc--merge-prop): New function copied from `erc-button-add-face' for general internal use with any text property by all of ERC. (erc-display-message-highlight): Set fallback face to `erc-default-face' the symbol instead of the string. For this to break third-party code, callers would have to supply erroneous types for nonexistent or undefined handlers and then explicitly check for and depend on such misuse, which seems unlikely and therefore not worth mentioning in etc/ERC-NEWS. (erc-display-message): Explain how `type' param works when it's a list. Fix code in type-as-list branch so that it optionally combines faces instead of clobbers them. (erc-put-text-property): Unalias from `put-text-property', but fall back to the latter unless caller wants to combine faces, in which case, defer to `erc--merge-prop'. * test/lisp/erc/erc-button-tests.el (erc-button--display-error-notice-with-keys): Expect a combined "error notice" face. (Bug#64301) --- etc/ERC-NEWS | 13 ++++++++ lisp/erc/erc-button.el | 2 +- lisp/erc/erc-match.el | 13 ++++---- lisp/erc/erc-track.el | 21 +++++++++---- lisp/erc/erc.el | 49 ++++++++++++++++++++++++++----- test/lisp/erc/erc-button-tests.el | 2 +- 6 files changed, 79 insertions(+), 21 deletions(-) diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 3d062e2e9ab..9c94f68ce27 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -251,6 +251,19 @@ The 'fill' module is now defined by 'define-erc-module'. The same goes for ERC's imenu integration, which has 'imenu' now appearing in the default value of 'erc-modules'. +*** 'erc-display-message' optionally combines faces. +Users may notice that ERC now inserts some important error messages in +a combination of 'erc-error-face' and 'erc-notice-face'. This is +merely a consequence of 'erc-display-message' getting smarter about +how it treats face properties when its 'type' parameter is a list that +starts with t. Originally, ERC's authors intended to display both +server-originating and ERC-generated errors in this style, but that +intent was never realized. Though now possible, the effect has been +limited to special errors involving usage and internal state. For +third-party code, the key takeaway is that more 'font-lock-face' +properties encountered in the wild may be combinations of faces rather +than lone ones. + *** Prompt input is split before 'erc-pre-send-functions' has a say. Hook members are now treated to input whose lines have already been adjusted to fall within the allowed length limit. For convenience, diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c30f7c10ca6..89a6cd131c0 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -815,7 +815,7 @@ non-strings, concatenate leading string members before applying erc-button--display-error-with-buttons erc-button-describe-symbol 1) ,@erc-button-alist))) - (erc-display-message parsed '(notice error) (or buffer 'active) string) + (erc-display-message parsed '(t notice error) (or buffer 'active) string) string)) ;;;###autoload diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index cd2c55b0091..a5b0af41b2a 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -657,21 +657,22 @@ See `erc-log-match-format'." (defvar-local erc-match--hide-fools-offset-bounds nil) -;; FIXME this should merge with instead of overwrite existing -;; `invisible' values. (defun erc-hide-fools (match-type _nickuserhost _message) - "Hide foolish comments. -This function should be called from `erc-text-matched-hook'." + "Hide comments from designated fools." (when (eq match-type 'fool) + (erc-match--hide-message))) + +(defun erc-match--hide-message () + (progn ; FIXME raise sexp (if erc-match--hide-fools-offset-bounds (let ((beg (point-min)) (end (point-max))) (save-restriction (widen) - (put-text-property (1- beg) (1- end) 'invisible 'erc-match))) + (erc--merge-prop (1- beg) (1- end) 'invisible 'erc-match))) ;; Before ERC 5.6, this also used to add an `intangible' ;; property, but the docs say it's now obsolete. - (put-text-property (point-min) (point-max) 'invisible 'erc-match)))) + (erc--merge-prop (point-min) (point-max) 'invisible 'erc-match)))) (defun erc-beep-on-match (match-type _nickuserhost _message) "Beep when text matches. diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index e060b7039bd..8101183ce3d 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -184,9 +184,13 @@ The faces used are the same as used for text in the buffers. erc-prompt-face) "A list of faces used to highlight active buffer names in the mode line. If a message contains one of the faces in this list, the buffer name will -be highlighted using that face. The first matching face is used." - :type '(repeat (choice face - (repeat :tag "Combination" face)))) +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." + :type (erc--with-dependent-type-match + (repeat (choice face (repeat :tag "Combination" face))) + erc-button)) (defcustom erc-track-priority-faces-only nil "Only track text highlighted with a priority face. @@ -309,6 +313,8 @@ important." (const leastactive) (const mostactive))) +(defconst erc-track--attn-faces '((erc-error-face erc-notice-face)) + "Faces whose presence always triggers mode-line inclusion.") (defun erc-track-remove-from-mode-line () "Remove `erc-track-modified-channels' from the mode-line." @@ -736,6 +742,9 @@ Use `erc-make-mode-line-buffer-name' to create buttons." (declare (obsolete erc-track-select-mode-line-face "28.1")) (erc-track-select-mode-line-face (car faces) (cdr faces))) +;; Note that unless called by `erc-track-modified-channels', +;; `erc-track-faces-priority-list' will not begin with +;; `erc-track--attn-faces'. (defun erc-track-select-mode-line-face (cur-face new-faces) "Return the face to use in the mode line. @@ -802,7 +811,9 @@ the current buffer is in `erc-mode'." ;; (in the car), change its face attribute (in the cddr) if ;; necessary. See `erc-modified-channels-alist' for the ;; exact data structure used. - (let ((faces (erc-faces-in (buffer-string)))) + (let ((faces (erc-faces-in (buffer-string))) + (erc-track-faces-priority-list + `(,@erc-track--attn-faces ,@erc-track-faces-priority-list))) (unless (and (or (eq erc-track-priority-faces-only 'all) (member this-channel erc-track-priority-faces-only)) @@ -873,7 +884,7 @@ If face is not in `erc-track-faces-priority-list', it will have a higher number than any other face in that list." (let ((count 0)) (catch 'done - (dolist (item erc-track-faces-priority-list) + (dolist (item `(,@erc-track--attn-faces ,@erc-track-faces-priority-list)) (if (equal item face) (throw 'done t) (setq count (1+ count))))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index c10b39e9a1b..f2ea69f6bba 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2745,7 +2745,7 @@ If ARG is non-nil, show the *erc-protocol* buffer." erc-insert-pre-hook)) (nick (erc-current-nick))) (setq nick (propertize nick 'erc-speaker nick)) - (erc-display-message nil 'input (current-buffer) + (erc-display-message nil '(t action input) (current-buffer) 'ACTION ?n nick ?a str ?u "" ?h ""))) ;; Display interface @@ -2899,6 +2899,25 @@ If STRING is nil, the function does nothing." (process-buffer erc-server-process) (current-buffer)))))) +(defvar erc--compose-text-properties nil + "Non-nil when `erc-put-text-property' defers to `erc--merge-prop'.") + +(defun erc--merge-prop (from to prop val &optional object) + "Compose existing PROP values with VAL between FROM and TO in OBJECT. +For spans where PROP is non-nil, cons VAL onto the existing +value, ensuring a proper list. Otherwise, just set PROP to VAL. +See also `erc-button-add-face'." + (let ((old (get-text-property from prop object)) + (pos from) + (end (next-single-property-change from prop object to)) + new) + (while (< pos to) + (setq new (if old (cons val (ensure-list old)) val)) + (put-text-property pos end prop new object) + (setq pos end + old (get-text-property pos prop object) + end (next-single-property-change pos prop object to))))) + (defun erc-display-message-highlight (type string) "Highlight STRING according to TYPE, where erc-TYPE-face is an ERC face. @@ -2910,7 +2929,7 @@ See also `erc-make-notice'." 0 (length string) 'font-lock-face (or (intern-soft (concat "erc-" (symbol-name type) "-face")) - "erc-default-face") + 'erc-default-face) string) string))) @@ -3114,6 +3133,17 @@ returns non-nil." ARGS, PARSED, and TYPE are used to format MSG sensibly. +When TYPE is a list of symbols, call handlers from left to right +without influencing how they behave when encountering existing +faces. As of ERC 5.6, expect a TYPE of (notice error) to insert +MSG with `font-lock-face' as `erc-error-face' throughout. +However, when the list of symbols begins with t, tell compatible +handlers to compose rather than clobber faces. For example, as +of ERC 5.6, expect a TYPE of (t notice error) to result in MSG's +`font-lock-face' being (erc-error-face erc-notice-face) +throughout when `erc-notice-highlight-type' is set to its default +`all'. + See also `erc-format-message' and `erc-display-line'." (let ((string (if (symbolp msg) (apply #'erc-format-message msg args) @@ -3124,10 +3154,10 @@ See also `erc-format-message' and `erc-display-line'." ((null type) string) ((listp type) - (mapc (lambda (type) - (setq string - (erc-display-message-highlight type string))) - type) + (let ((erc--compose-text-properties + (and (eq (car type) t) (setq type (cdr type))))) + (dolist (type type) + (setq string (erc-display-message-highlight type string)))) string) ((symbolp type) (erc-display-message-highlight type string)))) @@ -6129,7 +6159,7 @@ See also variable `erc-notice-highlight-type'." (erc-put-text-property 0 (length s) 'font-lock-face 'erc-error-face s) s) -(defalias 'erc-put-text-property 'put-text-property +(defun erc-put-text-property (start end property value &optional object) "Set text-property for an object (usually a string). START and END define the characters covered. PROPERTY is the text-property set, usually the symbol `face'. @@ -6139,7 +6169,10 @@ OBJECT is a string which will be modified and returned. OBJECT is modified without being copied first. You can redefine or `defadvice' this function in order to add -EmacsSpeak support.") +EmacsSpeak support." + (if erc--compose-text-properties + (erc--merge-prop start end property value object) + (put-text-property start end property value object))) (defalias 'erc-list 'ensure-list) diff --git a/test/lisp/erc/erc-button-tests.el b/test/lisp/erc/erc-button-tests.el index 6a6f6934389..3dacf95a59f 100644 --- a/test/lisp/erc/erc-button-tests.el +++ b/test/lisp/erc/erc-button-tests.el @@ -265,7 +265,7 @@ (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k (erc-button-next 1) (should (equal (get-text-property (point) 'font-lock-face) - '(erc-button erc-error-face))) + '(erc-button erc-error-face erc-notice-face))) (should (eq (get-text-property (point) 'mouse-face) 'highlight)) (should (eq erc-button-face 'erc-button))) ; extent evaporates From b354b3a53bfbb30dc4f98fe9947f3ba939e1436d Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 30 May 2023 23:27:12 -0700 Subject: [PATCH 09/22] Allow custom display-buffer actions in ERC * doc/misc/erc.texi: Add new section under "Integrations" chapter describing `display-buffer' Custom function choice for ERC's many buffer-display options. * etc/ERC-NEWS: Mention new function variant for all buffer-display options. * lisp/erc/erc-backend.el: Add forward declaration for `erc--called-as-input-p' and `erc--display-context'. (erc--server-reconnect-display-timer, erc--server-last-reconnect-display-reset): Use new name for option `erc-reconnect-display', now `erc-auto-reconnect-display'. (erc--server-determine-join-display-context): New generic function to determine value of `erc--display-context' during JOINs. (erc-server-JOIN, erc-server-PRIVMSG): Set `erc--display-context' to a symbol for the handler's IRC command, like `JOIN', for the benefit of custom `display-buffer'-like functions running in `erc-setup-buffer'. (erc-server-471, erc-server-471-functions, erc-server-473, erc-server-473-functions): New handlers for JOIN rejections. Also remove 471 and 473 from comment at bottom of file. (erc-server-475): Bind `erc--called-as-input-p' so that `erc-cmd-JOIN' sets `erc-interactive-display' context. * lisp/erc/erc-join.el (erc-autojoin-mode, erc-autojoin-enable, erc-autojoin-disable): Kill local variable `erc-join--requested-channels'. Add and remove `erc-join--remove-requested-channels' to/from various server-handler hooks for JOIN rejection numerics. (erc-join--requested-channels): New local variable to remember channels we've attempted to JOIN this session that haven't yet been confirmed by the server. (erc-join--remove-requested-channel): New JOIN rejection handler to stop tracking channel in `erc-join--requested-channels'. (erc--server-determine-join-display-context): module-specific implementation of generic function for `erc-autojoin-mode'. (erc-autojoin--join): Remember channels slated for JOIN'ing. * lisp/erc/erc.el (erc--buffer-display-choices): New helper constant for defining common `:type' for all buffer-display options. (erc-buffer-display, erc-interactive-display, erc-auto-reconnect-display, erc-receive-query-display): Use helper `erc--buffer-display-choices' for defining `:type', which includes a new choice for a `display-buffer'-like function. (erc-reconnect-display, erc-auto-reconnect-display): Alias former to latter, now the preferred name. (erc-reconnect-timeout, erc-auto-reconnect-timeout): Change name from former to latter. This option is new in ERC 5.6. (erc-reconnect-display-server-buffers): New option. (erc-buffer-do): Revise doc string. (erc--display-context): New variable, an alist of "context tokens" to be forwarded as the "action alist" to `erc-buffer-display' functions. (erc-skip-displaying-selected-window-buffer): New variable, deprecated at birth, to act as an escape hatch for folks who don't want to skip the displaying of buffers already showing in the selected window. (erc--display-buffer-overriding-action): Local variable allowing modules to influence the displaying of new ERC buffers independently of user options. (erc-setup-buffer): Do nothing when the selected window already shows current buffer unless user has provided a custom display function. Accommodate new Custom choice function values, like `display-buffer' and `pop-to-buffer'. (erc-open): Run `erc-setup-buffer' when option `erc-reconnect-display-server-buffers' is non-nil, even for existing server buffers. Bind `display-buffer-overriding-action' to the value of `erc--display-buffer-overriding-action' around calls to `erc-setup-buffer'. (erc-select-read-args): Add `erc--display-context' to environment. (erc, erc-tls): Bind `erc--display-context' around calls to `erc-select-read-args' and main body. (erc-cmd-JOIN, erc-cmd-QUERY, erc--cmd-reconnect, erc-handle-irc-url): Add item for `erc-interactive-display' to `erc--display-context'. (erc-connection-established): Update name of `erc-reconnect-display-timeout' to `erc-auto-reconnect-display-timeout'. (erc-message-english-s471, erc-message-english-s473): New variables, format templates for JOIN rejection messages. * test/lisp/erc/erc-scenarios-base-buffer-display.el (erc-scenarios-base-buffer-display--defwin-recbury-intbuf, erc-scenarios-base-buffer-display--defwino-recbury-intbuf, erc-scenarios-base-buffer-display--count-reset-timeout): Use preferred name `erc-auto-reconnect-display' for `erc-reconnect-display'. * test/lisp/erc/erc-scenarios-join-display-context.el: New file. * test/lisp/erc/erc-tests.el (erc--initialize-markers): Fix unrealistic call to `erc-open'. (erc-setup-buffer--custom-action): New test. (erc-select-read-args, erc-tls, erc--interactive, erc-server-select): Expect new environment binding for `erc--display-context'. * test/lisp/erc/resources/join/buffer-display/mode-context.eld: New file. (Bug#62833) --- doc/misc/erc.texi | 181 +++++++++++++++ etc/ERC-NEWS | 16 +- lisp/erc/erc-backend.el | 36 ++- lisp/erc/erc-join.el | 39 +++- lisp/erc/erc.el | 206 +++++++++++++----- .../erc/erc-scenarios-base-buffer-display.el | 28 +-- .../erc/erc-scenarios-join-display-context.el | 66 ++++++ test/lisp/erc/erc-tests.el | 90 +++++++- .../join/buffer-display/mode-context.eld | 38 ++++ 9 files changed, 617 insertions(+), 83 deletions(-) create mode 100644 test/lisp/erc/erc-scenarios-join-display-context.el create mode 100644 test/lisp/erc/resources/join/buffer-display/mode-context.eld diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index ddfdb2e2b64..00aa34e51fa 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -613,6 +613,7 @@ Integrations * URL:: Opening IRC URLs in ERC. * SOCKS:: Connecting to IRC with a SOCKS proxy. * auth-source:: Retrieving auth-source entries with ERC. +* display-buffer:: Controlling how ERC displays buffers. @end detailmenu @end menu @@ -1226,6 +1227,7 @@ stuff, to the current ERC buffer." @menu * auth-source:: Retrieving auth-source entries with ERC. +* display-buffer:: Controlling how ERC displays buffers. @end menu @anchor{URL} @@ -1468,6 +1470,185 @@ required by certain channels you join. When modifying a traditional @samp{user} field (for example, @samp{login "#fsf"}, in netrc's case). The actual key goes in the @samp{password} (or @samp{secret}) field. +@node display-buffer +@subsection display-buffer +@cindex display-buffer + +ERC supports the ``action'' interface used by @code{display-buffer} +and friends from @file{window.el}. @xref{Displaying Buffers,,, elisp, +Emacs Lisp}, for specifics. When ERC displays a new or +``reassociated'' buffer, it consults its various buffer-display +options, such as @code{erc-buffer-display}, to decide whether and how +the buffer ought to appear in a window. Exactly which one it consults +depends on the context in which the buffer is being manifested. + +For some buffer-display options, the context is pretty cut and dry. +For instance, in the case of @code{erc-receive-query-display}, you're +receiving a query from someone you haven't yet chatted with in the +current session. For other options, like +@code{erc-interactive-display}, the precise context varies. For +example, you might be opening a query buffer with the command +@kbd{/QUERY bob @key{RET}} or joining a new channel with @kbd{/JOIN +#chan @key{RET}}. Power users wishing to distinguish between such +nuanced contexts or just exercise more control over buffer-display +behavior generally can elect to override these options by setting one +or more to a ``@code{display-buffer}-like'' function that accepts a +@var{buffer} and an @var{action} argument. + +@subsubheading Examples + +In this first example, a user-provided buffer-display function +displays new server buffers in the current window when issuing an +@kbd{M-x erc-tls @key{RET}} and in a split window for all other +interactve contexts covered by the option +@code{erc-interactive-display}, like clicking an @samp{irc://}-style +@acronym{URL} (@pxref{URL}). + +@lisp +(defun my-erc-interactive-display-buffer (buffer action) + "Pop to BUFFER when running \\[erc-tls], clicking a link, etc." + (when-let ((alist (cdr action)) + (found (alist-get 'erc-interactive-display alist))) + (if (eq found 'erc-tls) + (pop-to-buffer-same-window buffer action) + (pop-to-buffer buffer action)))) + +(setopt erc-interactive-display #'my-erc-interactive-display-buffer) +@end lisp + +@noindent +Observe that ERC supplies the names of buffer-display options as +@var{action} alist keys and pairs them with contextual constants, like +the symbols @samp{erc-tls} or @samp{url}, the full lineup of which are +listed below. + +In this second example, the user writes three predicates that somewhat +resemble the ``@code{display-buffer}-like'' function above. These too +look for @var{action} alist keys sharing the names of buffer-display +options (and, in one case, a module's minor mode). + +@lisp +(defun my-erc-disp-entry-p (_ action) + (memq (cdr (or (assq 'erc-buffer-display action) + (assq 'erc-interactive-display action))) + '(erc-tls url))) + +(defun my-erc-disp-query-p (_ action) + (or (eq (cdr (assq 'erc-interactive-display action)) '/QUERY) + (and (eq (cdr (assq 'erc-receive-query-display action)) 'PRIVMSG) + (member (erc-default-target) '("bob" "alice"))))) + +(defun my-erc-disp-chan-p (_ action) + (or (assq 'erc-autojoin-mode action) + (and (memq (cdr (assq 'erc-buffer-display alist)) 'JOIN) + (member (erc-default-target) '("#emacs" "#fsf"))))) +@end lisp + +@noindent +You'll notice we ignore the @var{buffer} parameter of these predicates +because ERC ensures that @var{buffer} is already current (which is why +we can freely call @code{erc-default-target}). Note also that we +cheat a little by treating the @var{action} parameter like an alist +when it's really a cons of one or more functions and an alist. + +@noindent +To complement our predicates, we set all three buffer-display options +referenced in their @var{action}-alist lookups to +@code{display-buffer}. This tells ERC to defer to that function in +the display contexts covered by these options. + +@lisp +(setopt erc-buffer-display #'display-buffer + erc-interactive-display #'display-buffer + erc-receive-query-display #'display-buffer + ;; + erc-auto-reconnect-display 'bury) +@end lisp + +@noindent +The last option above just tells ERC to avoid any buffer-display +machinery when auto-reconnecting. (For historical reasons, ERC's +buffer-display options use the term ``bury'' to mean ``ignore'' rather +than @code{bury-buffer}.) + +Finally, we compose our predicates into @code{buffer-match-p} +conditions and pair them with various well known @code{display-buffer} +action functions and action-alist members. + +@lisp +(setopt display-buffer-alist + + ;; Create new frame with M-x erc-tls RET or (erc-tls ...) + '(((and (major-mode . erc-mode) my-erc-disp-entry-p) + display-buffer-pop-up-frame + (reusable-frames . visible)) + + ;; Show important chans and queries in a split. + ((and (major-mode . erc-mode) + (or my-erc-disp-chan-p my-erc-disp-query-p)) + display-buffer-pop-up-window) + + ;; Ignore everything else. + ((major-mode . erc-mode) + display-buffer-no-window + (allow-no-window . t)))) +@end lisp + +@noindent +Of course, we could just as well set our buffer-display options to one +or more homespun functions instead of bothering with +@code{display-buffer-alist} at all (in what would make for a more +complicated version of our first example). But perhaps we already +have a growing menagerie of similar predicates and like to keep +everything in one place in our @file{init.el}. + +@subsubheading Action alist items + +@table @asis +@item Option-based keys: +All keys are symbols, as are values, unless otherwise noted. + +@itemize @bullet +@item @code{erc-buffer-display} +@itemize @minus +@item @samp{JOIN} +@item @samp{NOTICE} +@item @samp{PRIVMSG} +@item @samp{erc} (entry point called non-interactively) +@item @samp{erc-tls} +@end itemize + +@item @code{erc-interactive-display} +@itemize @minus +@item @samp{/QUERY} +@item @samp{/JOIN} +@item @samp{/RECONNECT} +@item @samp{url} (hyperlink clicked) +@item @samp{erc} (entry point called interactively) +@item @samp{erc-tls} +@end itemize + +@item @code{erc-receive-query-display} +@itemize @minus +@item @samp{NOTICE} +@item @samp{PRIVMSG} +@end itemize + +@item @code{erc-auto-reconnect-display} +@itemize @minus +@item something non-@code{nil} +@end itemize +@end itemize + +@item Module-based (minor-mode) keys: + +@itemize @bullet +@item @code{erc-autojoin-mode} +@itemize @minus +@item channel name as a string, e.g., @code{"#chan"} +@end itemize +@end itemize +@end table @node Options @section Options diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 9c94f68ce27..64d73ef7481 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -37,7 +37,7 @@ decade overdue, this is no longer the case. Other UX improvements in this area aim to make the process of connecting interactively slightly more streamlined and less repetitive, even for veteran users. -** Revised buffer-display handling for interactive commands. +** Revised buffer-display handling. A point of friction for new users and one only just introduced with ERC 5.5 has been the lack of visual feedback when first connecting via M-x erc or when issuing a "/JOIN" command at the prompt. As explained @@ -56,7 +56,19 @@ reported as being difficult to discover and remember. When the latter option (now known as 'erc-receive-query-display') is nil, ERC uses 'erc-join-buffer' in its place, much like it does for 'erc-interactive-display'. The old nil behavior can still be gotten -via the new compatibility flag 'erc-receive-query-display-defer'. +via the new compatibility flag 'erc-receive-query-display-defer'. The +relatively new option 'erc-reconnect-display' has likewise been +renamed, this time for clarity, to 'erc-auto-reconnect-display'. + +This release also introduces a few subtleties affecting the display of +new or reassociated buffers. One involves buffers that already occupy +the selected window. ERC now treats these as deserving of an implicit +'bury'. An escape hatch for this and most other baked-in behaviors is +now available in the form of a new type variant recognized by all such +options. That is, users can now specify their own function to +exercise full control over nearly all buffer-display related +decisions. See the newly expanded doc strings of 'erc-buffer-display' +and friends, as well as Info node '(erc) display-buffer', for details. ** Setting a module's mode variable via Customize earns a warning. Trying and failing to activate a module via its minor mode's Custom diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index f1b51f9234a..363509d17fa 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -101,6 +101,8 @@ (eval-when-compile (require 'cl-lib)) (require 'erc-common) +(defvar erc--called-as-input-p) +(defvar erc--display-context) (defvar erc--target) (defvar erc--user-from-nick-function) (defvar erc-channel-list) @@ -304,7 +306,7 @@ function `erc-server-process-alive' instead.") "Timer that resets `erc--server-last-reconnect-count' to zero. Becomes non-nil in all server buffers when an IRC connection is first \"established\" and carries out its duties -`erc-reconnect-display-timeout' seconds later.") +`erc-auto-reconnect-display-timeout' seconds later.") (defvar-local erc--server-last-reconnect-count 0 "Snapshot of reconnect count when the connection was established.") @@ -957,7 +959,7 @@ EVENT is the message received from the closed connection process." (erc--server-last-reconnect-display-reset (current-buffer))) (defun erc--server-last-reconnect-display-reset (buffer) - "Deactivate `erc-reconnect-display'." + "Deactivate `erc-auto-reconnect-display'." (when (buffer-live-p buffer) (with-current-buffer buffer (when erc--server-reconnect-display-timer @@ -1684,6 +1686,12 @@ add things to `%s' instead." parsed 'notice 'active 'INVITE ?n nick ?u login ?h host ?c chnl))))) +(cl-defmethod erc--server-determine-join-display-context (_channel alist) + "Determine `erc--display-context' for JOINs." + (if (assq 'erc-buffer-display alist) + alist + `((erc-buffer-display . JOIN) ,@alist))) + (define-erc-response-handler (JOIN) "Handle join messages." nil @@ -1698,7 +1706,11 @@ add things to `%s' instead." (let* ((str (cond ;; If I have joined a channel ((erc-current-nick-p nick) - (when (setq buffer (erc--open-target chnl)) + (let ((erc--display-context + (erc--server-determine-join-display-context + chnl erc--display-context))) + (setq buffer (erc--open-target chnl))) + (when buffer (set-buffer buffer) (with-suppressed-warnings ((obsolete erc-add-default-channel)) @@ -1887,6 +1899,8 @@ add things to `%s' instead." (noticep (string= cmd "NOTICE")) ;; S.B. downcase *both* tgt and current nick (privp (erc-current-nick-p tgt)) + (erc--display-context `((erc-buffer-display . ,(intern cmd)) + ,@erc--display-context)) s buffer fnick) (setf (erc-response.contents parsed) msg) @@ -1901,6 +1915,8 @@ add things to `%s' instead." (and erc-ensure-target-buffer-on-privmsg (or erc-receive-query-display erc-join-buffer))))) + (push `(erc-receive-query-display . ,(intern cmd)) + erc--display-context) (setq buffer (erc--open-target nick))) ;; A channel buffer has been killed but is still joined. (when erc-ensure-target-buffer-on-privmsg @@ -2486,6 +2502,17 @@ See `erc-display-server-message'." nil parsed (erc-response.contents parsed))) +(define-erc-response-handler (471) + "ERR_CHANNELISFULL: channel full." nil + (erc-display-message parsed '(notice error) nil 's471 + ?c (cadr (erc-response.command-args parsed)) + ?s (erc-response.contents parsed))) + +(define-erc-response-handler (473) + "ERR_INVITEONLYCHAN: channel invitation only." nil + (erc-display-message parsed '(notice error) nil 's473 + ?c (cadr (erc-response.command-args parsed)))) + (define-erc-response-handler (474) "Banned from channel errors." nil (erc-display-message parsed '(notice error) nil @@ -2499,6 +2526,7 @@ See `erc-display-server-message'." nil ?c (cadr (erc-response.command-args parsed))) (when erc-prompt-for-channel-key (let ((channel (cadr (erc-response.command-args parsed))) + (erc--called-as-input-p t) (key (read-from-minibuffer (format "Channel %s is mode +k. Enter key (RET to cancel): " (cadr (erc-response.command-args parsed)))))) @@ -2567,7 +2595,7 @@ See `erc-display-error-notice'." nil ;; 200 201 202 203 204 205 206 208 209 211 212 213 ;; 214 215 216 217 218 219 241 242 243 244 249 261 ;; 262 302 342 351 407 409 411 413 414 415 -;; 423 424 436 441 443 444 467 471 472 473 KILL) +;; 423 424 436 441 443 444 467 472 KILL) ;; nil nil ;; (ignore proc parsed)) diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index 45cfd565f89..2a57e77a622 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -44,11 +44,23 @@ ((add-hook 'erc-after-connect #'erc-autojoin-channels) (add-hook 'erc-nickserv-identified-hook #'erc-autojoin-after-ident) (add-hook 'erc-server-JOIN-functions #'erc-autojoin-add) - (add-hook 'erc-server-PART-functions #'erc-autojoin-remove)) + (add-hook 'erc-server-PART-functions #'erc-autojoin-remove) + (add-hook 'erc-server-405-functions #'erc-join--remove-requested-channel) + (add-hook 'erc-server-471-functions #'erc-join--remove-requested-channel) + (add-hook 'erc-server-473-functions #'erc-join--remove-requested-channel) + (add-hook 'erc-server-474-functions #'erc-join--remove-requested-channel) + (add-hook 'erc-server-475-functions #'erc-join--remove-requested-channel)) ((remove-hook 'erc-after-connect #'erc-autojoin-channels) (remove-hook 'erc-nickserv-identified-hook #'erc-autojoin-after-ident) (remove-hook 'erc-server-JOIN-functions #'erc-autojoin-add) - (remove-hook 'erc-server-PART-functions #'erc-autojoin-remove))) + (remove-hook 'erc-server-PART-functions #'erc-autojoin-remove) + (remove-hook 'erc-server-405-functions #'erc-join--remove-requested-channel) + (remove-hook 'erc-server-471-functions #'erc-join--remove-requested-channel) + (remove-hook 'erc-server-473-functions #'erc-join--remove-requested-channel) + (remove-hook 'erc-server-474-functions #'erc-join--remove-requested-channel) + (remove-hook 'erc-server-475-functions #'erc-join--remove-requested-channel) + (erc-buffer-do (lambda () + (kill-local-variable 'erc-join--requested-channels))))) (defcustom erc-autojoin-channels-alist nil "Alist of channels to autojoin on IRC networks. @@ -138,6 +150,28 @@ network or a network ID). Return nil on failure." (string-match-p candidate (or erc-server-announced-name erc-session-server))))) +(defvar-local erc-join--requested-channels nil + "List of channels for which an outgoing JOIN was sent.") + +;; Assume users will update their `erc-autojoin-channels-alist' when +;; encountering errors, like a 475 ERR_BADCHANNELKEY. +(defun erc-join--remove-requested-channel (_ parsed) + "Remove channel from `erc-join--requested-channels'." + (when-let ((channel (cadr (erc-response.command-args parsed))) + ((member channel erc-join--requested-channels))) + (setq erc-join--requested-channels + (delete channel erc-join--requested-channels))) + nil) + +(cl-defmethod erc--server-determine-join-display-context + (channel alist &context (erc-autojoin-mode (eql t))) + "Add item to `erc-display-context' ALIST if CHANNEL was autojoined." + (when (member channel erc-join--requested-channels) + (setq erc-join--requested-channels + (delete channel erc-join--requested-channels)) + (push (cons 'erc-autojoin-mode channel) alist)) + (cl-call-next-method channel alist)) + (defun erc-autojoin--join () ;; This is called in the server buffer (pcase-dolist (`(,name . ,channels) erc-autojoin-channels-alist) @@ -146,6 +180,7 @@ network or a network ID). Return nil on failure." (let ((buf (erc-get-buffer chan erc-server-process))) (unless (and buf (with-current-buffer buf (erc--current-buffer-joined-p))) + (push chan erc-join--requested-channels) (erc-server-join-channel nil chan))))))) (defun erc-autojoin-after-ident (_network _nick) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index f2ea69f6bba..d3bec98e14c 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1553,9 +1553,26 @@ Defaults to the server buffer." "IRC port to use for encrypted connections if it cannot be \ detected otherwise.") +(defconst erc--buffer-display-choices + `(choice (const :tag "Use value of `erc-buffer-display'" nil) + (const :tag "Split window and select" window) + (const :tag "Split window but don't select" window-noselect) + (const :tag "New frame" frame) + (const :tag "Don't display" bury) + (const :tag "Use current window" buffer) + (choice :tag "Defer to a display function" + (function-item display-buffer) + (function-item pop-to-buffer) + (function :tag "User-defined"))) + "Common choices for buffer-display options.") + (defvaralias 'erc-join-buffer 'erc-buffer-display) (defcustom erc-buffer-display 'bury "How to display a newly created ERC buffer. +This determines ERC's baseline, \"catch-all\" buffer-display +behavior. It takes a backseat to more specific options, like +`erc-interactive-display', `erc-auto-reconnect-display', and +`erc-receive-query-display'. The available choices are: @@ -1564,17 +1581,34 @@ The available choices are: `frame' - in another frame, `bury' - bury it in a new buffer, `buffer' - in place of the current buffer, + DISPLAY-FUNCTION - a `display-buffer'-like function -See related options `erc-interactive-display', -`erc-reconnect-display', and `erc-receive-query-display'." +Here, DISPLAY-FUNCTION should accept a buffer and an ACTION of +the kind described by the Info node `(elisp) Choosing Window'. +At times, ERC may add hints about the calling context to the +ACTION's alist. Keys are symbols such as user options, like +`erc-buffer-display', or module minor modes, like +`erc-autojoin-mode'. Values are non-nil constants specific to +each. For this particular option, possible values include the +symbols + + `JOIN', `PRIVMSG', `NOTICE', `erc', and `erc-tls'. + +The first three signify IRC commands received from the server and +the rest entry-point commands responsible for the connection. +When dealing with the latter two, users may prefer to set this +option to `bury' and instead call DISPLAY-FUNCTION directly +on (server) buffers returned by these entry points because the +context leading to their creation is plainly obvious. For +additional details, see the Info node `(erc) display-buffer'. + +Note that when the selected window already shows the current +buffer, ERC pretends this option's value is `bury' unless the +variable `erc-skip-displaying-selected-window-buffer' is nil or +the value of this option is DISPLAY-FUNCTION." :package-version '(ERC . "5.5") :group 'erc-buffers - :type '(choice (const :tag "Split window and select" window) - (const :tag "Split window, don't select" window-noselect) - (const :tag "New frame" frame) - (const :tag "Bury in new buffer" bury) - (const :tag "Use current buffer" buffer) - (const :tag "Use current buffer" t))) + :type (cons 'choice (nthcdr 2 erc--buffer-display-choices))) (defvaralias 'erc-query-display 'erc-interactive-display) (defcustom erc-interactive-display 'window @@ -1583,38 +1617,58 @@ This affects commands like /QUERY and /JOIN when issued interactively at the prompt. It does not apply when calling a handler for such a command, like `erc-cmd-JOIN', from lisp code. See `erc-buffer-display' for a full description of available -values." +values. + +When the value is a user-provided function, ERC may inject a hint +about the invocation context as an extra item in the \"action +alist\" included as part of the second argument. The item's key +is the symbol `erc-interactive-display' and its value one of + + `/QUERY', `/JOIN', `/RECONNECT', `url', `erc', or `erc-tls'. + +All are symbols indicating an inciting user action, such as the +issuance of a slash command, the clicking of a URL hyperlink, or +the invocation of an entry-point command. See Info node `(erc) +display-buffer' for more." :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc-buffers - :type '(choice (const :tag "Use value of `erc-buffer-display'" nil) - (const :tag "Split window and select" window) - (const :tag "Split window, don't select" window-noselect) - (const :tag "New frame" frame) - (const :tag "Bury new and don't display existing" bury) - (const :tag "Use current buffer" buffer))) + :type erc--buffer-display-choices) -(defcustom erc-reconnect-display nil - "How and whether to display a channel buffer when auto-reconnecting. -This only affects automatic reconnections and is ignored, like -all other buffer-display options, when issuing a /RECONNECT or -successfully reinvoking `erc-tls' with similar arguments. See -`erc-buffer-display' for a description of possible values." +(defvaralias 'erc-reconnect-display 'erc-auto-reconnect-display) +(defcustom erc-auto-reconnect-display nil + "How to display a channel buffer when automatically reconnecting. +ERC ignores this option when a user issues a /RECONNECT or +successfully reinvokes `erc-tls' with similar arguments to those +from the prior connection. See `erc-buffer-display' for a +description of possible values. + +When the value is function, ERC may inject a hint about the +calling context as an extra item in the alist making up the tail +of the second, \"action\" argument. The item's key is the symbol +`erc-auto-reconnect-display' and its value something non-nil." :package-version '(ERC . "5.5") :group 'erc-buffers - :type '(choice (const :tag "Use value of `erc-buffer-display'" nil) - (const :tag "Split window and select" window) - (const :tag "Split window, don't select" window-noselect) - (const :tag "New frame" frame) - (const :tag "Bury in new buffer" bury) - (const :tag "Use current buffer" buffer))) + :type erc--buffer-display-choices) -(defcustom erc-reconnect-display-timeout 10 - "Duration `erc-reconnect-display' remains active. +(defcustom erc-auto-reconnect-display-timeout 10 + "Duration `erc-auto-reconnect-display' remains active. The countdown starts on MOTD and is canceled early by any \"slash\" command." + :package-version '(ERC . "5.6") ; FIXME sync on release :type 'integer :group 'erc-buffers) +(defcustom erc-reconnect-display-server-buffers nil + "Apply buffer-display options to server buffers when reconnecting. +By default, ERC does not consider `erc-auto-reconnect-display' +for server buffers when automatically reconnecting, nor does it +consider `erc-interactive-display' when users issue a /RECONNECT. +Enabling this tells ERC to always display server buffers +according to those options." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean + :group 'erc-buffers) + (defcustom erc-frame-alist nil "Alist of frame parameters for creating erc frames. A value of nil means to use `default-frame-alist'." @@ -1824,9 +1878,8 @@ server connection, or nil which means all open connections." (defalias 'erc-buffer-do 'erc-buffer-filter "Call FUNCTION in all ERC buffers or only those for PROC. -Expect users to prefer this alias to `erc-buffer-filter' in cases -where the latter would only be called for effect and its return -value thrown away. +Expect to be preferred over `erc-buffer-filter' in cases where +the return value goes unused. \(fn FUNCTION &optional PROC)") @@ -2094,12 +2147,43 @@ anything about the dependency's implementation.") (defvar erc--setup-buffer-hook nil "Internal hook for module setup involving windows and frames.") +(defvar erc--display-context nil + "Extra action alist items passed to `display-buffer'. +Non-nil when a user specifies a custom display action for certain +buffer-display options, like `erc-auto-reconnect-display'. ERC +pairs the option's symbol with a context-dependent value and adds +the entry to the user-provided alist when calling `pop-to-buffer' +or `display-buffer'.") + +(defvar erc-skip-displaying-selected-window-buffer t + "Whether to forgo showing a buffer that's already being displayed. +But only in the selected window. This is intended as a crutch +for non-user third-party code that might be slow to adopt the +`display-buffer' function variant available to all buffer-display +options starting in ERC 5.6. Users with rare requirements, like +wanting to change the window buffer to something other than the +one being processed, should see the Info node `(erc) +display-buffer'.") +(make-obsolete 'erc-show-already-displayed-buffer + "non-nil behavior to be made permanent" "30.1") + +(defvar-local erc--display-buffer-overriding-action nil + "The value of `display-buffer-overriding-action' when non-nil. +Influences the displaying of new or reassociated ERC buffers. +Reserved for use by built-in modules.") + (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." (pcase (if (zerop (erc-with-server-buffer erc--server-last-reconnect-count)) erc-join-buffer - (or erc-reconnect-display erc-join-buffer)) + (or erc-auto-reconnect-display erc-join-buffer)) + ((and (pred functionp) disp-fn (let context erc--display-context)) + (unless (zerop erc--server-last-reconnect-count) + (push '(erc-auto-reconnect-display . t) context)) + (funcall disp-fn buffer (cons nil context))) + ((guard (and erc-skip-displaying-selected-window-buffer + (eq (window-buffer) buffer)))) ('window (if (active-minibuffer-window) (display-buffer buffer) @@ -2292,13 +2376,18 @@ Returns the buffer for the given server or channel." (erc-update-mode-line)) ;; Now display the buffer in a window as per user wishes. - (unless (eq buffer old-buffer) + (when (eq buffer old-buffer) (cl-assert (and connect (not target)))) + (unless (and (not erc-reconnect-display-server-buffers) + (eq buffer old-buffer)) (when erc-log-p ;; we can't log to debug buffer, it may not exist yet (message "erc: old buffer %s, switching to %s" old-buffer buffer)) - (erc-setup-buffer buffer) - (run-hooks 'erc--setup-buffer-hook)) + (let ((display-buffer-overriding-action + (or erc--display-buffer-overriding-action + display-buffer-overriding-action))) + (erc-setup-buffer buffer) + (run-hooks 'erc--setup-buffer-hook))) buffer)) @@ -2410,6 +2499,8 @@ With prefix arg, also prompt for user and full name." env) (when erc-interactive-display (push `(erc-join-buffer . ,erc-interactive-display) env)) + (when erc--display-context + (push `(erc--display-context . ,erc--display-context) env)) (when opener (push `(erc-server-connect-function . ,opener) env)) (when (and passwd (string= "" passwd)) @@ -2471,7 +2562,12 @@ for the values of the other parameters. See `erc-tls' for the meaning of ID. \(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" - (interactive (erc-select-read-args)) + (interactive (let ((erc--display-context `((erc-interactive-display . erc) + ,@erc--display-context))) + (erc-select-read-args))) + (unless (assq 'erc--display-context --interactive-env--) + (push '(erc--display-context . ((erc-buffer-display . erc))) + --interactive-env--)) (erc--with-entrypoint-environment --interactive-env-- (erc-open server port nick full-name t password nil nil nil nil user id))) @@ -2536,8 +2632,11 @@ CLIENT-CERTIFICATE, this parameter cannot be specified interactively. \(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" - (interactive (let ((erc-default-port erc-default-port-tls)) - (erc-select-read-args))) + (interactive + (let ((erc-default-port erc-default-port-tls) + (erc--display-context `((erc-interactive-display . erc-tls) + ,@erc--display-context))) + (erc-select-read-args))) ;; Bind `erc-server-connect-function' to `erc-open-tls-stream' ;; around `erc-open' when a non-default value hasn't been specified ;; by the user or the interactive form. And don't bother checking @@ -2546,6 +2645,9 @@ interactively. (not (eq erc-server-connect-function #'erc-open-network-stream))) (push '(erc-server-connect-function . erc-open-tls-stream) --interactive-env--)) + (unless (assq 'erc--display-context --interactive-env--) + (push '(erc--display-context . ((erc-buffer-display . erc-tls))) + --interactive-env--)) (erc--with-entrypoint-environment --interactive-env-- (erc-open server port nick full-name t password nil nil nil client-certificate user id))) @@ -3769,7 +3871,10 @@ were most recently invited. See also `invitation'." (sn (erc-extract-nick (erc-response.sender parsed))) ((erc-nick-equal-p sn (erc-current-nick))) (erc-join-buffer (or erc-interactive-display - erc-join-buffer))) + erc-join-buffer)) + (erc--display-context `((erc-interactive-display + . /JOIN) + ,@erc--display-context))) (run-hook-with-args-until-success 'erc-server-JOIN-functions proc parsed) t)))) @@ -4153,7 +4258,9 @@ on the value of `erc-interactive-display'." ;; currently broken, evil hack to display help anyway ;(erc-delete-query)))) (signal 'wrong-number-of-arguments '(erc-cmd-QUERY 0))) - (let ((erc-join-buffer erc-interactive-display)) + (let ((erc-join-buffer erc-interactive-display) + (erc--display-context `((erc-interactive-display . /QUERY) + ,@erc--display-context))) (erc-with-server-buffer (erc--open-target user)))) @@ -4273,6 +4380,9 @@ the message given by REASON." (defun erc--cmd-reconnect () (let ((buffer (erc-server-buffer)) + (erc-join-buffer erc-interactive-display) + (erc--display-context `((erc-interactive-display . /RECONNECT) + ,@erc--display-context)) (process nil)) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) @@ -4937,13 +5047,7 @@ compatibility flag `erc-receive-query-display-defer' to nil. Use :package-version '(ERC . "5.6") :group 'erc-buffers :group 'erc-query - :type '(choice (const :tag "Defer to value of `erc-buffer-display'" nil) - (const :tag "Split window and select" window) - (const :tag "Split window, don't select" window-noselect) - (const :tag "New frame" frame) - (const :tag "Bury in new buffer" bury) - (const :tag "Use current buffer" buffer) - (const :tag "Use current buffer" t))) + :type erc--buffer-display-choices) (defvar erc-receive-query-display-defer t "How to interpret a null `erc-receive-query-display'. @@ -5389,7 +5493,7 @@ Set user modes and run `erc-after-connect' hook." (setq erc--server-last-reconnect-count erc-server-reconnect-count erc-server-reconnect-count 0) (setq erc--server-reconnect-display-timer - (run-at-time erc-reconnect-display-timeout nil + (run-at-time erc-auto-reconnect-display-timeout nil #'erc--server-last-reconnect-display-reset (current-buffer))) (add-hook 'erc-disconnected-hook @@ -7769,6 +7873,8 @@ All windows are opened in the current frame." (s463 . "Your host isn't among the privileged") (s464 . "Password incorrect") (s465 . "You are banned from this server") + (s471 . "Max occupancy for channel %c exceeded: %s") + (s473 . "Channel %c is invitation only") (s474 . "You can't join %c because you're banned (+b)") (s475 . "You must specify the correct channel key (+k) to join %c") (s481 . "Permission Denied - You're not an IRC operator") @@ -7970,6 +8076,8 @@ Beginning with ERC 5.5, new connections require human intervention. Customize `erc-url-connect-function' to override this." (when (eql port 0) (setq port nil)) (let* ((net (erc-networks--determine host)) + (erc--display-context `((erc-interactive-display . url) + ,@erc--display-context)) (server-buffer ;; Viable matches may slip through the cracks for unknown ;; networks. Additional passes could likely improve things. diff --git a/test/lisp/erc/erc-scenarios-base-buffer-display.el b/test/lisp/erc/erc-scenarios-base-buffer-display.el index 548ad00e2d9..df292a8c113 100644 --- a/test/lisp/erc/erc-scenarios-base-buffer-display.el +++ b/test/lisp/erc/erc-scenarios-base-buffer-display.el @@ -26,8 +26,8 @@ (eval-when-compile (require 'erc-join)) -;; These first couple `erc-reconnect-display' tests used to live in -;; erc-scenarios-base-reconnect but have since been renamed. +;; These first couple `erc-auto-reconnect-display' tests used to live +;; in erc-scenarios-base-reconnect but have since been renamed. (defun erc-scenarios-base-buffer-display--reconnect-common (assert-server assert-chan assert-rest) @@ -80,11 +80,11 @@ :tags '(:expensive-test) (should (eq erc-buffer-display 'bury)) (should (eq erc-interactive-display 'window)) - (should-not erc-reconnect-display) + (should-not erc-auto-reconnect-display) (let ((erc-buffer-display 'window) (erc-interactive-display 'buffer) - (erc-reconnect-display 'bury)) + (erc-auto-reconnect-display 'bury)) (erc-scenarios-base-buffer-display--reconnect-common @@ -104,7 +104,7 @@ ;; A manual /JOIN command tells ERC we're done auto-reconnecting (with-current-buffer "FooNet" (erc-scenarios-common-say "/JOIN #spam")) - (ert-info ("#spam ignores `erc-reconnect-display'") + (ert-info ("#spam ignores `erc-auto-reconnect-display'") ;; Uses `erc-interactive-display' instead. (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) (should (eq (window-buffer) (get-buffer "#spam"))) @@ -115,10 +115,10 @@ :tags '(:expensive-test) (should (eq erc-buffer-display 'bury)) (should (eq erc-interactive-display 'window)) - (should-not erc-reconnect-display) + (should-not erc-auto-reconnect-display) (let ((erc-buffer-display 'window-noselect) - (erc-reconnect-display 'bury) + (erc-auto-reconnect-display 'bury) (erc-interactive-display 'buffer)) (erc-scenarios-base-buffer-display--reconnect-common @@ -155,7 +155,7 @@ (should (eq (window-buffer) (get-buffer "bob"))) (should (frame-root-window-p (selected-window))))) - (ert-info ("Newly joined chan ignores `erc-reconnect-display'") + (ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'") (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) (should (eq (window-buffer) (get-buffer "bob"))) (should-not (frame-root-window-p (selected-window))) @@ -165,13 +165,13 @@ :tags '(:expensive-test) (should (eq erc-buffer-display 'bury)) (should (eq erc-interactive-display 'window)) - (should (eq erc-reconnect-display-timeout 10)) - (should-not erc-reconnect-display) + (should (eq erc-auto-reconnect-display-timeout 10)) + (should-not erc-auto-reconnect-display) (let ((erc-buffer-display 'window-noselect) - (erc-reconnect-display 'bury) + (erc-auto-reconnect-display 'bury) (erc-interactive-display 'buffer) - (erc-reconnect-display-timeout 0.5)) + (erc-auto-reconnect-display-timeout 0.5)) (erc-scenarios-base-buffer-display--reconnect-common #'ignore #'ignore ; These two are identical to the previous test. @@ -188,10 +188,10 @@ (erc-d-t-wait-for 1 (null erc--server-reconnect-display-timer)) (erc-cmd-JOIN "#spam"))) - (ert-info ("Newly joined chan ignores `erc-reconnect-display'") + (ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'") (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) (should (eq (window-buffer) (messages-buffer))) - ;; If `erc-reconnect-display-timeout' were left alone, this + ;; If `erc-auto-reconnect-display-timeout' were left alone, this ;; would be (frame-root-window-p #). (should-not (frame-root-window-p (selected-window))) (should (eq (current-buffer) (window-buffer (next-window)))))))))) diff --git a/test/lisp/erc/erc-scenarios-join-display-context.el b/test/lisp/erc/erc-scenarios-join-display-context.el new file mode 100644 index 00000000000..32b782d2af1 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-join-display-context.el @@ -0,0 +1,66 @@ +;;; erc-scenarios-join-display-context.el --- buffer-display autojoin ctx -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-join-display-context--errors () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "join/buffer-display") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'mode-context)) + (port (process-contact dumb-server :service)) + (erc-buffer-display (lambda (buf action) + (when (equal + (alist-get 'erc-autojoin-mode action) + "#chan") + (pop-to-buffer buf)))) + (erc-autojoin-channels-alist '((foonet "#chan" "#spam" "#foo"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect without password") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + ;; FIXME test for effect rather than inspecting interval variables. + (erc-d-t-wait-for 10 (equal erc-join--requested-channels + '("#foo" "#spam" "#chan"))) + (funcall expect 10 "Max occupancy for channel #spam exceeded") + (funcall expect 10 "Channel #foo is invitation only"))) + + (ert-info ("New #chan buffer displayed in new window") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (should (eq (window-buffer) (current-buffer))) + (funcall expect 10 "#chan was created on"))) + + ;; FIXME find a less dishonest way to do this than inspecting + ;; interval variables. + (ert-info ("Ensure channels no longer tracked") + (should-not erc-join--requested-channels)))) + +;;; erc-scenarios-join-display-context.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index fed25056b42..0e4ea1b1db6 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -427,8 +427,9 @@ (should (looking-at-p (regexp-quote "*** Welcome")))) (ert-info ("Reconnect") - (erc-open "localhost" 6667 "tester" "Tester" nil - "fake" nil "#chan" proc nil "user" nil) + (with-current-buffer (erc-server-buffer) + (erc-open "localhost" 6667 "tester" "Tester" nil + "fake" nil "#chan" proc nil "user" nil)) (should-not (get-buffer "#chan<2>"))) (ert-info ("Existing prompt respected") @@ -512,6 +513,50 @@ (dolist (b '("server" "other" "#chan" "#foo" "#fake")) (kill-buffer b)))) +(ert-deftest erc-setup-buffer--custom-action () + (erc-mode) + (erc-tests--set-fake-server-process "sleep" "1") + (setq erc--server-last-reconnect-count 0) + (let ((owin (selected-window)) + (obuf (window-buffer)) + (mbuf (messages-buffer)) + calls) + (cl-letf (((symbol-function 'switch-to-buffer) ; regression + (lambda (&rest r) (push (cons 'switch-to-buffer r) calls))) + ((symbol-function 'erc--test-fun) + (lambda (&rest r) (push (cons 'erc--test-fun r) calls))) + ((symbol-function 'display-buffer) + (lambda (&rest r) (push (cons 'display-buffer r) calls)))) + + ;; Baseline + (let ((erc-join-buffer 'bury)) + (erc-setup-buffer mbuf) + (should-not calls)) + + (should-not erc--display-context) + + ;; `display-buffer' + (let ((erc--display-context '((erc-buffer-display . 1))) + (erc-join-buffer 'erc--test-fun)) + (erc-setup-buffer mbuf) + (should (equal `(erc--test-fun ,mbuf (nil (erc-buffer-display . 1))) + (pop calls))) + (should-not calls)) + + ;; `pop-to-buffer' with `erc-auto-reconnect-display' + (let* ((erc--server-last-reconnect-count 1) + (erc--display-context '((erc-buffer-display . 1))) + (erc-auto-reconnect-display 'erc--test-fun)) + (erc-setup-buffer mbuf) + (should (equal `(erc--test-fun ,mbuf + (nil (erc-auto-reconnect-display . t) + (erc-buffer-display . 1))) + (pop calls))) + (should-not calls))) + + (should (eq owin (selected-window))) + (should (eq obuf (window-buffer))))) + (ert-deftest erc-lurker-maybe-trim () (let (erc-lurker-trim-nicks (erc-lurker-ignore-chars "_`")) @@ -1537,14 +1582,18 @@ (erc-join-buffer . window)))))) (ert-info ("Switches to TLS when URL is ircs://") - (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r" - (erc-select-read-args)) - (list :server "irc.gnu.org" - :port 6697 - :nick (user-login-name) - '&interactive-env - '((erc-server-connect-function . erc-open-tls-stream) - (erc-join-buffer . window)))))) + (let ((erc--display-context '((erc-interactive-display . erc)))) + (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r" + (erc-select-read-args)) + (list :server "irc.gnu.org" + :port 6697 + :nick (user-login-name) + '&interactive-env + '((erc-server-connect-function + . erc-open-tls-stream) + (erc--display-context + . ((erc-interactive-display . erc))) + (erc-join-buffer . window))))))) (setq-local erc-interactive-display nil) ; cheat to save space @@ -1624,6 +1673,7 @@ ((symbol-function 'erc-open) (lambda (&rest r) (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) (erc-server-connect-function ,erc-server-connect-function)) env) @@ -1636,6 +1686,7 @@ nil nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Full") @@ -1652,6 +1703,7 @@ "bob:changeme" nil nil nil t "bobo" GNU.org))) (should (equal (pop env) '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) (erc-server-connect-function erc-open-tls-stream))))) ;; Values are often nil when called by lisp code, which leads to @@ -1671,6 +1723,7 @@ "bob:changeme" nil nil nil nil "bobo" nil))) (should (equal (pop env) '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Interactive") @@ -1681,6 +1734,8 @@ nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer window) + (erc--display-context + (erc-interactive-display . erc-tls)) (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Custom connect function") @@ -1691,6 +1746,8 @@ nil nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer bury) + (erc--display-context + (erc-buffer-display . erc-tls)) (erc-server-connect-function my-connect-func)))))) (ert-info ("Advised default function overlooked") ; intentional @@ -1702,6 +1759,7 @@ nil nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) (erc-server-connect-function erc-open-tls-stream)))) (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls)) @@ -1715,6 +1773,8 @@ '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) `((erc-join-buffer bury) + (erc--display-context + (erc-buffer-display . erc-tls)) (erc-server-connect-function ,f)))) (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls))))))) @@ -1729,6 +1789,7 @@ ((symbol-function 'erc-open) (lambda (&rest r) (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) (erc-server-connect-function ,erc-server-connect-function)) env) @@ -1741,8 +1802,9 @@ '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-join-buffer window) (erc-server-connect-function - erc-open-tls-stream))))) + '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) + (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Nick supplied, decline TLS upgrade") (ert-simulate-keys "\r\rdummy\r\rn\r" @@ -1752,6 +1814,7 @@ nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) (erc-server-connect-function erc-open-network-stream)))))))) @@ -1762,6 +1825,7 @@ ((symbol-function 'erc-open) (lambda (&rest r) (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) (erc-server-connect-function ,erc-server-connect-function)) env) @@ -1776,6 +1840,7 @@ nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Selects entry that doesn't support TLS") @@ -1787,6 +1852,7 @@ nil nil nil nil "user" nil))) (should (equal (pop env) '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) (erc-server-connect-function erc-open-network-stream)))))))) diff --git a/test/lisp/erc/resources/join/buffer-display/mode-context.eld b/test/lisp/erc/resources/join/buffer-display/mode-context.eld new file mode 100644 index 00000000000..6ebbdc7e824 --- /dev/null +++ b/test/lisp/erc/resources/join/buffer-display/mode-context.eld @@ -0,0 +1,38 @@ +;; -*- mode: lisp-data; -*- +((nick 1 "NICK tester")) +((user 1 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.00 ":irc.foonet.org 003 tester :This server was created Tue, 24 May 2022 05:28:42 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode 6 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.") + (0.02 ":irc.foonet.org 221 tester +i")) + +((join-chan 10 "JOIN #chan") + (0.03 ":tester!~u@w9rfqveugz722.irc JOIN #chan")) + +((~mode-chan 10 "MODE #chan") + (0.01 ":irc.foonet.org 353 tester = #chan :@tester") + (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.01 ":irc.foonet.org 324 tester #chan +nt") + (0.03 ":irc.foonet.org 329 tester #chan 1653370308")) + +((~join-spam 10 "JOIN #spam") + (0.03 ":irc.foonet.org 471 tester #spam :Cannot join channel (+l)")) + +((~join-foo 10 "JOIN #foo") + (0.03 ":irc.foonet.org 473 tester #foo :Cannot join channel (+i)")) From 9bdc5c62049f471ec4cb370aaad8cd238525d54c Mon Sep 17 00:00:00 2001 From: David Leatherman Date: Sun, 18 Dec 2022 19:01:40 -0800 Subject: [PATCH 10/22] Add module for colorizing nicknames to ERC * doc/misc/erc.texi: Add `nicks' to module lineup. * etc/ERC-NEWS: Mention new module `nicks'. * lisp/erc/erc-nicks.el: New file. * lisp/erc/erc.el: (erc-modules): Add `nicks'. * test/lisp/erc/erc-nicks-tests.el: New file. * test/lisp/erc/erc-tests (erc-tests--modules): Add `nicks' to inventory of available modules. (Bug#63569) Special thanks to Corwin Brust for doing much of the administrative legwork to bring this addition to ERC. Co-authored-by: Andy Stewart Co-authored-by: F. Jason Park --- doc/misc/erc.texi | 4 + etc/ERC-NEWS | 8 + lisp/erc/erc-nicks.el | 633 +++++++++++++++++++++++++++++++ lisp/erc/erc.el | 1 + test/lisp/erc/erc-nicks-tests.el | 538 ++++++++++++++++++++++++++ test/lisp/erc/erc-tests.el | 2 +- 6 files changed, 1185 insertions(+), 1 deletion(-) create mode 100644 lisp/erc/erc-nicks.el create mode 100644 test/lisp/erc/erc-nicks-tests.el diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 00aa34e51fa..52a1d57fd45 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -459,6 +459,10 @@ Display a menu in ERC buffers @item netsplit Detect netsplits +@cindex modules, nicks +@item nicks +Automatically colorize nicks + @cindex modules, noncommands @item noncommands Don't display non-IRC commands after evaluation diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 64d73ef7481..fde4c64c32d 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -30,6 +30,14 @@ helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get started. +** A new module for nickname highlighting has joined ERC. +Automatic nickname coloring has come to ERC core. Users familiar with +'erc-hl-nicks', from which this module directly descends, will already +be familiar with its suite of handy options. By default, each +nickname in an ERC session receives a unique face with a unique (or +evenly dealt) foreground color. Add 'nicks' to 'erc-modules' to get +started. + ** A unified interactive entry point. New users are often dismayed to discover that M-x ERC doesn't connect to its default network, Libera.Chat, over TLS. Though perhaps a diff --git a/lisp/erc/erc-nicks.el b/lisp/erc/erc-nicks.el new file mode 100644 index 00000000000..3f753adc625 --- /dev/null +++ b/lisp/erc/erc-nicks.el @@ -0,0 +1,633 @@ +;;; erc-nicks.el -- Nick colors for ERC -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: David Leatherman +;; Andy Stewart + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This file provides the `nicks' module for automatic nickname +;; highlighting. Add `nicks' to `erc-modules' to get started. +;; +;; Use the command `erc-nicks-refresh' to review changes after +;; adjusting an option, like `erc-nicks-contrast-range'. To change +;; the color of a nickname in a target buffer, click on it and choose +;; "Edit face" from the completion interface, and then perform your +;; adjustments in the resulting Customize menu. Non-Customize users +;; on Emacs 28+ can persist changes permanently by clicking on the +;; face's "location" hyperlink and copying the generated code snippet +;; (`defface' or `use-package') to their init.el. Customize users +;; need only click "Apply and Save", as usual. + +;;; History: + +;; This module has enjoyed a number of contributors across several +;; variants over the years, including: +;; +;; Thibault Polge +;; Jay Kamat +;; Alex Kost +;; Antoine Levitt +;; Adam Porter +;; +;; To those not mentioned, your efforts are no less appreciated. + +;; 2023/05 - erc-nicks +;; Rewrite using internal API, and rebrand for ERC 5.6 +;; 2020/03 - erc-hl-nicks 1.3.4 +;; Final release, see [1] for intervening history +;; 2014/05 - erc-highlight-nicknames.el +;; Final release, see [2] for intervening history +;; 2011/08 - erc-hl-nicks 1.0 +;; Initial release forked from erc-highlight-nicknames.el +;; 2008/12 - erc-highlight-nicknames.el +;; First release from Andy Stewart +;; 2007/09 - erc-highlight-nicknames.el +;; Initial release by by André Riemann + +;; [1] +;; [2] + +;;; Code: + +(require 'erc-button) +(require 'color) + +(defgroup erc-nicks nil + "Colorize nicknames in ERC target buffers." + :package-version '(ERC . "5.6") ; FIXME sync on release + :group 'erc) + +(defcustom erc-nicks-ignore-chars ",`'_-" + "Trailing characters in a nick to ignore while highlighting. +Value should be a string containing characters typically appended +by IRC clients to secure a nickname after a rejection (see option +`erc-nick-uniquifier'). A value of nil means don't trim +anything." + :type '(choice (string :tag "Chars to trim") + (const :tag "Don't trim" nil))) + +(defcustom erc-nicks-skip-nicks nil + "Nicks to avoid highlighting. +ERC only considers this option during module activation, so users +should adjust it before connecting." + :type '(repeat string)) + +(defcustom erc-nicks-skip-faces '( erc-notice-face erc-current-nick-face + erc-my-nick-face erc-pal-face erc-fool-face) + "Faces to avoid highlighting atop." + :type (erc--with-dependent-type-match (repeat face) erc-match)) + +(defcustom erc-nicks-backing-face erc-button-nickname-face + "Face to mix with generated one for emphasizing non-speakers." + :type '(choice face (const nil))) + +(defcustom erc-nicks-bg-color + (frame-parameter (selected-frame) 'background-color) + "Background color for calculating contrast. +Set this explicitly when the background color isn't discoverable, +which may be the case in terminal Emacs." + :type 'string) + +(defcustom erc-nicks-color-adjustments + '(erc-nicks-add-contrast erc-nicks-cap-contrast erc-nicks-ensaturate) + "Treatments applied to improve aesthetics or visibility. +For example, the function `erc-nicks-invert' inverts a nick when +it's too close to the background, and `erc-nicks-add-contrast' +attempts to find a decent contrast ratio by brightening or +darkening. When `erc-nicks-colors' is set to the symbol +`defined' or a user-provided list of colors, ERC uses this option +as a guide for culling any colors that don't fall within +`erc-nicks-contrast-range' or `erc-nicks-saturation-range', as +appropriate. For example, if `erc-nicks-cap-contrast' is present +in this option's value, and a color's contrast exceeds the CDR of +`erc-nicks-contrast-range', ERC will purge that color from its +rolls when initializing this module. Specify a value of nil to +inhibit this process." + :type '(repeat + (choice (function-item :tag "Invert" erc-nicks-invert) + (function-item :tag "Add contrast" erc-nicks-add-contrast) + (function-item :tag "Cap contrast" erc-nicks-cap-contrast) + (function-item :tag "Bound saturation" erc-nicks-ensaturate) + function))) + +(defcustom erc-nicks-contrast-range '(4.3 . 12.5) + "Desired range of contrast as a cons of (MIN . MAX). +When `erc-nicks-add-contrast' and/or `erc-nicks-invert' appear in +`erc-nicks-color-adjustments', MIN specifies the minimum amount +of contrast allowed between a buffer's background and its +foreground colors. Depending on the background, nicks may appear +tinted in pastels or shaded with muted grays. MAX works +similarly for reducing contrast, but only when +`erc-nicks-cap-contrast' is active. Users with lighter +backgrounds may want to lower MAX significantly. Either value +can range from 1.0 to 21.0(:1) but may produce unsatisfactory +results toward either extreme." + :type '(cons float float)) + +(defcustom erc-nicks-saturation-range '(0.2 . 0.8) + "Desired range for constraining saturation. +Expressed as a cons of decimal proportions. Only matters when +`erc-nicks-ensaturate' appears in `erc-nicks-color-adjustments'." + :type '(cons float float)) + +(defcustom erc-nicks-colors 'all + "Pool of colors. +List of colors as strings (hex or named) or, alternatively, a +single symbol representing a set of colors, like that produced by +the function `defined-colors', which ERC associates with the +symbol `defined'. Similarly, `all' tells ERC to use any 24-bit +color. When specifying a list, users may want to set the option +`erc-nicks-color-adjustments' to nil to prevent unwanted culling." + :type '(choice (const all) (const defined) (repeat string))) + +(defcustom erc-nicks-key-suffix-format "@%n" + "Template for latter portion of keys to generate colors from. +ERC passes this to `format-spec' with the following specifiers: +%n for the current network and %m for your nickname (not the one +being colorized). If you don't like the generated palette, try +adding extra characters or padding, for example, with something +like \"@%-012n\"." + :type 'string) + +(defvar erc-nicks--max-skip-search 3 ; make this an option? + "Max number of faces to visit when testing `erc-nicks-skip-faces'.") + +(defvar erc-nicks--colors-rejects nil) +(defvar erc-nicks--custom-keywords '(:group erc-nicks :group erc-faces)) +(defvar erc-nicks--grad-steps 9) + +(defvar-local erc-nicks--face-table nil + "Hash table mapping nicks to unique, named faces. +Keys are nonempty strings but need not be valid nicks.") + +(defvar-local erc-nicks--downcased-skip-nicks nil + "Case-mapped copy of `erc-nicks-skip-nicks'.") + +(defvar-local erc-nicks--bg-luminance nil) +(defvar-local erc-nicks--bg-mode-value nil) +(defvar-local erc-nicks--colors-len nil) +(defvar-local erc-nicks--colors-pool nil) +(defvar-local erc-nicks--fg-rgb nil) + +(defvar help-xref-stack) +(defvar help-xref-stack-item) + +;; https://stackoverflow.com/questions/596216#answer-56678483 +(defun erc-nicks--get-luminance (color) + "Return relative luminance of COLOR. +COLOR can be a list of normalized values or a name. This is the +same as the Y component returned by `color-srgb-to-xyz'." + (let ((out 0) + (coefficients '(0.2126 0.7152 0.0722)) + (chnls (if (stringp color) (color-name-to-rgb color) color))) + (dolist (ch chnls out) + (cl-incf out (* (pop coefficients) + (if (<= ch 0.04045) + (/ ch 12.92) + (expt (/ (+ ch 0.055) 1.055) 2.4))))))) + +(defun erc-nicks--get-contrast (fg &optional bg) + "Return a float between 1 and 21 for colors FG and BG. +If FG or BG are floats, interpret them as luminance values." + (let* ((lum-fg (if (numberp fg) fg (erc-nicks--get-luminance fg))) + (lum-bg (if bg + (if (numberp bg) bg (erc-nicks--get-luminance bg)) + (or erc-nicks--bg-luminance + (setq erc-nicks--bg-luminance + (erc-nicks--get-luminance erc-nicks-bg-color)))))) + (when (< lum-fg lum-bg) (cl-rotatef lum-fg lum-bg)) + (/ (+ 0.05 lum-fg) (+ 0.05 lum-bg)))) + +(defmacro erc-nicks--bg-mode () + `(or erc-nicks--bg-mode-value + (setq erc-nicks--bg-mode-value + ,(cond ((fboundp 'frame--current-background-mode) + '(frame--current-background-mode (selected-frame))) + ((fboundp 'frame--current-backround-mode) + '(frame--current-backround-mode (selected-frame))) + (t + '(frame-parameter (selected-frame) 'background-mode)))))) + +;; https://www.w3.org/TR/UNDERSTANDING-WCAG20/visual-audio-contrast-contrast.html +(defun erc-nicks--adjust-contrast (color target &optional decrease) + (let* ((lum-bg (or erc-nicks--bg-luminance + (setq erc-nicks--bg-luminance + (erc-nicks--get-luminance erc-nicks-bg-color)))) + (stop (if decrease + (color-name-to-rgb erc-nicks-bg-color) + erc-nicks--fg-rgb)) + ;; From `color-gradient' in color.el + (r (nth 0 color)) + (g (nth 1 color)) + (b (nth 2 color)) + (interval (float (1+ (expt 2 erc-nicks--grad-steps)))) + (r-step (/ (- (nth 0 stop) r) interval)) + (g-step (/ (- (nth 1 stop) g) interval)) + (b-step (/ (- (nth 2 stop) b) interval)) + (maxtries erc-nicks--grad-steps) + started) + ;; FIXME stop when sufficiently close instead of exhausting. + (while (let* ((lum-fg (erc-nicks--get-luminance (list r g b))) + (darker (if (< lum-bg lum-fg) lum-bg lum-fg)) + (lighter (if (= darker lum-bg) lum-fg lum-bg)) + (cur (/ (+ 0.05 lighter) (+ 0.05 darker))) + (scale (expt 2 maxtries))) + (cond ((if decrease (> cur target) (< cur target)) + (setq r (+ r (* r-step scale)) + g (+ g (* g-step scale)) + b (+ b (* b-step scale)))) + (started + (setq r (- r (* r-step scale)) + g (- g (* g-step scale)) + b (- b (* b-step scale)))) + (t (setq maxtries 1))) + (unless started + (setq started t)) + (setq r (min 1.0 (max 0 r)) + g (min 1.0 (max 0 g)) + b (min 1.0 (max 0 b))) + (not (zerop (cl-decf maxtries))))) + (list r g b))) + +(defun erc-nicks-add-contrast (color) + "Increase COLOR's contrast by blending it with the foreground. +Unless sufficient contrast exists between COLOR and the +background, raise it to meet the lower bound of +`erc-nicks-contrast-range'." + (erc-nicks--adjust-contrast color (car erc-nicks-contrast-range))) + +(defun erc-nicks-cap-contrast (color) + "Reduce COLOR's contrast by blending it with the background. +If excessive contrast exists between COLOR and the background, +lower it to the upper bound of `erc-nicks-contrast-range'." + (erc-nicks--adjust-contrast color (cdr erc-nicks-contrast-range) 'remove)) + +(defun erc-nicks-invert (color) + "Invert COLOR based on the CAR of `erc-nicks-contrast-range'. +Don't bother if the inverted color has less contrast than the +input." + (if-let ((con-input (erc-nicks--get-contrast color)) + ((< con-input (car erc-nicks-contrast-range))) + (flipped (mapcar (lambda (c) (- 1.0 c)) color)) + ((> (erc-nicks--get-contrast flipped) con-input))) + flipped + color)) + +(defun erc-nicks-ensaturate (color) + "Ensure COLOR falls within `erc-nicks-saturation-range'." + (pcase-let ((`(,min . ,max) erc-nicks-saturation-range) + (`(,h ,s ,l) (apply #'color-rgb-to-hsl color))) + (cond ((> s max) (setq color (color-hsl-to-rgb h max l))) + ((< s min) (setq color (color-hsl-to-rgb h min l))))) + color) + +;; From https://elpa.gnu.org/packages/ement. The bit depth has been +;; scaled up to try and avoid components being exactly 0.0, which our +;; contrast function doesn't seem to like. +(defun erc-nicks--gen-color (string) + "Generate normalized RGB color from STRING." + (let* ((ratio (/ (float (abs (random string))) (float most-positive-fixnum))) + (color-num (round (* #xffffffffffff ratio)))) + (list (/ (float (logand color-num #xffff)) #xffff) + (/ (float (ash (logand color-num #xffff0000) -16)) #xffff) + (/ (float (ash (logand color-num #xffff00000000) -32)) #xffff)))) + +;; This doesn't add an entry to the face table because "@" faces are +;; interned in the global `obarray' and thus easily accessible. +(defun erc-nicks--revive (new-face old-face nick net) + (put new-face 'erc-nicks--custom-face t) + (put new-face 'erc-nicks--nick nick) + (put new-face 'erc-nicks--netid erc-networks--id) + (put old-face 'erc-nicks--key nil) + (apply #'custom-declare-face new-face (face-user-default-spec old-face) + (format "Persistent `erc-nicks' color for %s on %s." nick net) + erc-nicks--custom-keywords)) + +(defun erc-nicks--create-defface-template (face) + (pop-to-buffer (get-buffer-create (format "*New face %s*" face))) + (erase-buffer) + (lisp-interaction-mode) + (insert ";; If you *don't* use Customize, put something like this in your\n" + (substitute-command-keys + ";; init.el and use \\[eval-last-sexp] to apply any edits.\n\n") + (format "(defface %s\n '%S\n %S" + face (face-user-default-spec face) (face-documentation face)) + (cl-loop for (k v) on erc-nicks--custom-keywords by #'cddr + concat (format "\n %s %S" k (list 'quote v))) + ")\n\n;; Or, if you use use-package\n(use-package erc-nicks\n" + " :custom-face\n" + (format " (%s %S)" face (face-user-default-spec face)) + ")\n")) + +(defun erc-nicks--redirect-face-widget-link (args) + (pcase args + (`(,widget face-link . ,plist) + (when-let ((face (widget-value widget)) + ((get face 'erc-nicks--custom-face))) + (unless (symbol-file face) + (setf (plist-get plist :action) + (lambda (&rest _) (erc-nicks--create-defface-template face)))) + (setf (plist-get plist :help-echo) "Create or edit `defface'." + (cddr args) plist)))) + args) + +(defun erc-nicks--reduce (color) + "Fold adjustment strategies over COLOR, a string or normalized triple. +Return a hex string." + (apply #'color-rgb-to-hex + (seq-reduce (lambda (color strategy) (funcall strategy color)) + erc-nicks-color-adjustments + (if (stringp color) (color-name-to-rgb color) color)))) + +(defun erc-nicks--create-pool (adjustments colors) + "Return COLORS that fall within parameters indicated by ADJUSTMENTS." + (let (addp capp satp pool) + (dolist (adjustment adjustments) + (pcase adjustment + ((or 'erc-nicks-invert 'erc-nicks-add-contrast) (setq addp t)) + ('erc-nicks-cap-contrast (setq capp t)) + ('erc-nicks-ensaturate (setq satp t)))) + (dolist (color colors) + (let* ((rgb (color-name-to-rgb color)) + (contrast (and (or addp capp) (erc-nicks--get-contrast rgb)))) + (if (or (and addp (< contrast (car erc-nicks-contrast-range))) + (and capp (> contrast (cdr erc-nicks-contrast-range))) + (and-let* ((satp) + (s (cadr (apply #'color-rgb-to-hsl rgb)))) + (or (< s (car erc-nicks-saturation-range)) + (> s (cdr erc-nicks-saturation-range))))) + (when erc-nicks--colors-rejects + (push color erc-nicks--colors-rejects)) + (push color pool)))) + (nreverse pool))) + +(defun erc-nicks--init-pool () + "Initialize colors and optionally display faces or color palette." + (unless (eq erc-nicks-colors 'all) + (let* ((colors (or (and (listp erc-nicks-colors) erc-nicks-colors) + (defined-colors))) + (pool (erc-nicks--create-pool erc-nicks-color-adjustments colors))) + (setq erc-nicks--colors-pool pool + erc-nicks--colors-len (length pool))))) + +(defun erc-nicks--determine-color (key) + (if (eq erc-nicks-colors 'all) + (erc-nicks--reduce (erc-nicks--gen-color key)) + (let ((pool (erc-with-server-buffer erc-nicks--colors-pool)) + (len (erc-with-server-buffer erc-nicks--colors-len))) + (nth (% (abs (random key)) len) pool)))) + +(defun erc-nicks--get-face (nick key) + "Retrieve a face for trimmed and downcased NICK. +If NICK is new, use KEY to derive color, and store under NICK. +Favor a custom erc-nicks-NICK@NETWORK-face when defined." + (let ((table (erc-with-server-buffer erc-nicks--face-table))) + (or (gethash nick table) + (and-let* ((face (intern-soft (concat "erc-nicks-" nick "@" + (erc-network-name) "-face"))) + ((or (and (facep face) face) + (erc-nicks--revive face face nick (erc-network)))))) + (let ((color (erc-nicks--determine-color key)) + (new-face (make-symbol (concat "erc-nicks-" nick "-face")))) + (put new-face 'erc-nicks--nick nick) + (put new-face 'erc-nicks--netid erc-networks--id) + (put new-face 'erc-nicks--key key) + (face-spec-set new-face `((t :foreground ,color)) 'face-defface-spec) + (set-face-documentation + new-face (format "Internal face for %s on %s." nick (erc-network))) + (puthash nick new-face table))))) + +(define-inline erc-nicks--anon-face-p (face) + (inline-quote (and (consp ,face) (pcase (car ,face) + ((pred keywordp) t) + ('foreground-color t) + ('background-color t))))) + +(defun erc-nicks--skip-p (prop option limit) + "Return non-nil if a face in PROP appears in OPTION. +Abandon search after examining LIMIT faces." + (setq prop (if (erc-nicks--anon-face-p prop) (list prop) (ensure-list prop))) + (catch 'found + (while-let (((> limit 0)) + (elem (pop prop))) + (while (and (consp elem) (not (erc-nicks--anon-face-p elem))) + (when (cdr elem) + (push (cdr elem) prop)) + (setq elem (car elem))) + (when elem + (cl-decf limit) + (when (if (symbolp elem) (memq elem option) (member elem option)) + (throw 'found elem)))))) + +(defun erc-nicks--trim (nickname) + "Return downcased NICKNAME sans trailing `erc-nicks-ignore-chars'." + (erc-downcase + (if erc-nicks-ignore-chars + (string-trim-right nickname + (rx-to-string + `(: (+ (any ,erc-nicks-ignore-chars)) eot))) + nickname))) + +(defun erc-nicks--gen-key-from-format-spec (nickname) + "Generate key for NICKNAME according to `erc-nicks-key-suffix-format'." + (concat nickname (format-spec erc-nicks-key-suffix-format + `((?n . ,(erc-network)) + (?m . ,(erc-current-nick)))))) + +(defun erc-nicks--highlight (nickname &optional base-face) + "Return face for NICKNAME unless it or BASE-FACE is blacklisted." + (when-let ((trimmed (erc-nicks--trim nickname)) + ((not (member trimmed erc-nicks--downcased-skip-nicks))) + ((not (and base-face + (erc-nicks--skip-p base-face erc-nicks-skip-faces + erc-nicks--max-skip-search)))) + (key (erc-nicks--gen-key-from-format-spec trimmed)) + (out (erc-nicks--get-face trimmed key))) + (if (or (null erc-nicks-backing-face) + (eq base-face erc-nicks-backing-face)) + out + (cons out (erc-list erc-nicks-backing-face))))) + +(defun erc-nicks--highlight-button (nick-object) + "Possibly add face to `erc-button--nick-user' NICK-OBJECT." + (when-let + ((nick-object) + (face (get-text-property (car (erc-button--nick-bounds nick-object)) + 'font-lock-face)) + (nick (erc-server-user-nickname (erc-button--nick-user nick-object))) + (out (erc-nicks--highlight nick face))) + (setf (erc-button--nick-nickname-face nick-object) out)) + nick-object) + +(define-erc-module nicks nil + "Uniquely colorize nicknames in target buffers." + ((if erc--target + (progn + (setq erc-nicks--downcased-skip-nicks + (mapcar #'erc-downcase erc-nicks-skip-nicks)) + (add-function :filter-return (local 'erc-button--modify-nick-function) + #'erc-nicks--highlight-button '((depth . 80))) + (erc-button--phantom-users-mode +1)) + (unless erc-button-mode + (unless (memq 'button erc-modules) + (erc--warn-once-before-connect 'erc-nicks-mode + "Enabling default global module `button' needed by local" + " module `nicks'. This will impact \C-]all\C-] ERC" + " sessions. Add `button' to `erc-modules' to avoid this" + " warning. See Info:\"(erc) Modules\" for more.")) + (erc-button-mode +1)) + (when (equal erc-nicks-bg-color "unspecified-bg") + (let ((temp (if (eq (erc-nicks--bg-mode) 'light) "white" "black"))) + (erc-button--display-error-notice-with-keys + "Module `nicks' unable to determine background color. Setting to \"" + temp "\" globally. Please see `erc-nicks-bg-color'.") + (custom-set-variables (list 'erc-nicks-bg-color temp)))) + (erc-nicks--init-pool) + (erc--restore-initialize-priors erc-nicks-mode + erc-nicks--face-table (make-hash-table :test #'equal))) + (setq erc-nicks--fg-rgb + (or (color-name-to-rgb + (face-foreground 'erc-default-face nil 'default)) + (color-name-to-rgb + (readable-foreground-color erc-nicks-bg-color)))) + (setf (alist-get "Edit face" erc-button--nick-popup-alist nil nil #'equal) + #'erc-nicks-customize-face) + (advice-add 'widget-create-child-and-convert :filter-args + #'erc-nicks--redirect-face-widget-link)) + ((kill-local-variable 'erc-nicks--face-table) + (kill-local-variable 'erc-nicks--bg-mode-value) + (kill-local-variable 'erc-nicks--bg-luminance) + (kill-local-variable 'erc-nicks--fg-rgb) + (kill-local-variable 'erc-nicks--colors-len) + (kill-local-variable 'erc-nicks--colors-pool) + (kill-local-variable 'erc-nicks--downcased-skip-nicks) + (when (fboundp 'erc-button--phantom-users-mode) + (erc-button--phantom-users-mode -1)) + (remove-function (local 'erc-button--modify-nick-function) + #'erc-nicks--highlight-button) + (setf (alist-get "Edit face" + erc-button--nick-popup-alist nil 'remove #'equal) + nil) + (unless erc-button--nick-popup-alist + (kill-local-variable 'erc-button--nick-popup-alist))) + 'local) + +(defun erc-nicks-customize-face (nick) + "Customize or create persistent face for NICK." + (interactive (list (or (car (get-text-property (point) 'erc-data)) + (completing-read "nick: " (or erc-channel-users + erc-server-users))))) + (setq nick (erc-nicks--trim (substring-no-properties nick))) + (let* ((net (erc-network)) + (key (erc-nicks--gen-key-from-format-spec nick)) + (old-face (erc-nicks--get-face nick key)) + (new-face (intern (format "erc-nicks-%s@%s-face" nick net)))) + (unless (eq new-face old-face) + (erc-nicks--revive new-face old-face nick net) + (set-face-attribute old-face nil :foreground 'unspecified) + (set-face-attribute old-face nil :inherit new-face)) + (customize-face new-face))) + +(defun erc-nicks--list-faces-help-button-action (face) + (when-let (((or (get face 'erc-nicks--custom-face) + (y-or-n-p (format "Create new persistent face for %s?" + (get face 'erc-nicks--key))))) + (nid (get face 'erc-nicks--netid)) + (foundp (lambda () + (erc-networks--id-equal-p nid erc-networks--id))) + (server-buffer (car (erc-buffer-filter foundp)))) + (with-current-buffer server-buffer + (erc-nicks-customize-face (get face 'erc-nicks--nick))))) + +(defun erc-nicks-list-faces () + "Show faces owned by ERC-nicks in a help buffer." + (interactive) + (save-excursion + (list-faces-display (rx bot "erc-nicks-")) + (with-current-buffer "*Faces*" + (setq help-xref-stack nil + help-xref-stack-item '(erc-nicks-list-faces)) + (with-silent-modifications + (goto-char (point-min)) + (while (zerop (forward-line)) + (when (and (get-text-property (point) 'button) + (facep (car (button-get (point) 'help-args)))) + (button-put (point) 'help-function + #'erc-nicks--list-faces-help-button-action) + (if-let ((face (car (button-get (point) 'help-args))) + ((not (get face 'erc-nicks--custom-face))) + ((not (get face 'erc-nicks--key)))) + (progn (delete-region (pos-bol) (1+ (pos-eol))) + (forward-line -1)) + (when-let ((nid (get face 'erc-nicks--netid)) + (net (symbol-name (erc-networks--id-symbol nid)))) + (goto-char (button-end (point))) + (skip-syntax-forward "-") + (put-text-property (point) (1+ (point)) 'rear-nonsticky nil) + (forward-char) + (when (stringp (face-foreground face)) + (setq net (format "%-13.13s %s" (substring-no-properties + (face-foreground face)) + net))) + (insert-and-inherit net) + (delete-region (button-start (point)) + (1+ (button-start (point)))) + (delete-region (point) (pos-eol)))))))))) + +(defun erc-nicks-refresh (debug) + "Recompute faces for all nicks on current network. +With DEBUG, review affected faces or colors. Which one depends +on the value of `erc-nicks-colors'." + (interactive "P") + (unless (derived-mode-p 'erc-mode) + (user-error "Not an ERC buffer")) + (erc-with-server-buffer + (unless erc-nicks-mode (user-error "Module `nicks' disabled")) + (let ((erc-nicks--colors-rejects (and debug (list t)))) + (erc-nicks--init-pool) + (dolist (nick (hash-table-keys erc-nicks--face-table)) + ;; User-tuned faces do not have an `erc-nicks--key' property. + (when-let ((face (gethash nick erc-nicks--face-table)) + (key (get face 'erc-nicks--key))) + (setq key (erc-nicks--gen-key-from-format-spec nick)) + (put face 'erc-nicks--key key) + (set-face-foreground face (erc-nicks--determine-color key)))) + (when debug + (if (eq erc-nicks-colors 'all) + (erc-nicks-list-faces) + (pcase-dolist (`(,name ,pool) + `(("*erc-nicks-pool*" ,erc-nicks--colors-pool) + ("*erc-nicks-rejects*" + ,(cdr (nreverse erc-nicks--colors-rejects))))) + (when (buffer-live-p (get-buffer name)) + (kill-buffer name)) + (when pool + (save-excursion + (list-colors-display + pool name + (lambda (c) + (message "contrast: %.3f :saturation: %.3f" + (erc-nicks--get-contrast c) + (cadr (apply #'color-rgb-to-hsl + (color-name-to-rgb c)))))))))))))) + +(provide 'erc-nicks) + +;;; erc-nicks.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index d3bec98e14c..07c62c935c3 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2066,6 +2066,7 @@ removed from the list will be disabled." move-to-prompt) (const :tag "netsplit: Detect netsplits" netsplit) (const :tag "networks: Provide data about IRC networks" networks) + (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks) (const :tag "noncommands: Don't display non-IRC commands after evaluation" noncommands) (const :tag "notifications: Desktop alerts on PRIVMSG or mentions" diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el new file mode 100644 index 00000000000..3e5804734ec --- /dev/null +++ b/test/lisp/erc/erc-nicks-tests.el @@ -0,0 +1,538 @@ +;;; erc-nicks-tests.el --- Tests for erc-nicks -*- lexical-binding:t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Unlike most of ERC's tests, the ones in this file can be run +;; interactively in the same session. + +;; TODO: +;; +;; * Add mock session (or scenario) with buffer snapshots, like those +;; in erc-fill-tests.el. (Should probably move helpers to a common +;; library under ./resources.) + +;;; Code: + +(require 'ert-x) +(require 'erc-nicks) + +;; This function replicates the behavior of older "invert" strategy +;; implementations from EmacsWiki, etc. The values for the lower and +;; upper bounds (0.33 and 0.66) are likewise inherited. See +;; `erc-nicks--invert-classic--dark' below for one reason its results +;; may not be plainly obvious. +(defun erc-nicks-tests--invert-classic (color) + (if (pcase (erc-nicks--bg-mode) + ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0))) + ('light (> (erc-nicks--get-luminance color) (/ 2 3.0)))) + (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color))) + color)) + + +(ert-deftest erc-nicks--get-luminance () + (should (eql 0.0 (erc-nicks--get-luminance "black"))) + (should (eql 1.0 (erc-nicks--get-luminance "white"))) + (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0)))) + + ;; RGB floats from a `display-graphic-p' session. + (let ((a (erc-nicks--get-luminance ; #9439ad + '(0.5803921568627451 0.2235294117647059 0.6784313725490196))) + (b (erc-nicks--get-luminance ; #ae54c7 + '(0.6823529411764706 0.32941176470588235 0.7803921568627451))) + (c (erc-nicks--get-luminance ; #d19ddf + '(0.8196078431372549 0.615686274509804 0.8745098039215686))) + (d (erc-nicks--get-luminance ; #f5e8f8 + '(0.9607843137254902 0.9098039215686274 0.9725490196078431)))) + ;; Low, med, high contrast comparisons against known values from + ;; an external source. + (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0))) + (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0))) + (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0))))) + +(ert-deftest erc-nicks-invert--classic () + (let ((convert (lambda (n) (apply #'color-rgb-to-hex + (erc-nicks-tests--invert-classic + (color-name-to-rgb n)))))) + (let ((erc-nicks--bg-mode-value 'dark)) + (should (equal (funcall convert "white") "#ffffffffffff")) + (should (equal (funcall convert "black") "#ffffffffffff")) + (should (equal (funcall convert "green") "#0000ffff0000"))) + (let ((erc-nicks--bg-mode-value 'light)) + (should (equal (funcall convert "white") "#000000000000")) + (should (equal (funcall convert "black") "#000000000000")) + (should (equal (funcall convert "green") "#ffff0000ffff"))))) + +(ert-deftest erc-nicks--get-contrast () + (should (= 21.0 (erc-nicks--get-contrast "white" "black"))) + (should (= 21.0 (erc-nicks--get-contrast "black" "white"))) + (should (= 1.0 (erc-nicks--get-contrast "black" "black"))) + (should (= 1.0 (erc-nicks--get-contrast "white" "white")))) + +(defun erc-nicks-tests--print-contrast (fn color) + (let* ((erc-nicks-color-adjustments (list fn)) + (result (erc-nicks--reduce color)) + (start (point))) + (insert (format "%16s%-16s%16s%-16s\n" + (concat color "-") + (concat ">" result) + (concat color " ") + (concat " " result))) + (put-text-property (+ start 32) (+ start 48) 'face + (list :background color :foreground result)) + (put-text-property (+ start 48) (+ start 64) 'face + (list :background result :foreground color)) + result)) + +(ert-deftest erc-nicks--invert-classic--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +;; This shows that the output can be darker (have less contrast) than +;; the input. +(ert-deftest erc-nicks--invert-classic--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#777777777777" (funcall show "#888888888888"))) + (should (equal "#666666666666" (funcall show "#999999999999"))) + (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa")))) + + (when noninteractive + (kill-buffer))))) + +;; These are the same as the legacy version but work in terms of +;; contrast ratios. Converting the original bounds to contrast ratios +;; (assuming pure white and black backgrounds) gives: +;; +;; min-lum of 0.33 ~~> 1.465 +;; max-lum of 0.66 ~~> 7.666 +;; +(ert-deftest erc-nicks-invert--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks-contrast-range '(1.465)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-invert--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (erc-nicks-contrast-range '(7.666)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#888888888888" (funcall show "#888888888888"))) + (should (equal "#999999999999" (funcall show "#999999999999")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-add-contrast () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (erc-nicks-contrast-range '(3.5)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-add-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*") + (should (equal "#893a893a893a" (funcall show "white"))) + (should (equal "#893a893a893a" (funcall show "#893a893a893a"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#0000a12e0000" (funcall show "green"))) + (should (equal "#00000000ffff" (funcall show "blue"))) + + ;; When the input is already near the desired ratio, the result + ;; may not be in bounds, only close. But the difference is + ;; usually imperceptible. + (unless noninteractive + ;; Well inside (light slate gray) + (should (equal "#777788889999" (funcall show "#777788889999"))) + ;; Slightly outside -> just outside + (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa"))) + ;; Just outside -> just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c"))) + ;; Just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-cap-contrast () + (should (= 12.5 (cdr erc-nicks-contrast-range))) + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-cap-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*") + (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14 + (should ; 12.32 -> 12.32 (same) + (equal (funcall show "#34e534e534e5") "#34e534e534e5")) + (should (equal (funcall show "white") "#ffffffffffff")) + + (unless noninteractive + (should (equal (funcall show "DarkRed") "#8b8b00000000")) + (should (equal (funcall show "DarkGreen") "#000064640000")) + ;; 15.29 -> 12.38 + (should (equal (funcall show "DarkBlue") "#1cf11cf198b5")) + + ;; 12.50 -> 12.22 + (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab")) + ;; 12.57 -> 12.28 + (should (equal (funcall show "#338033803380") "#344c344c344c")) + ;; 12.67 -> 12.37 + (should (equal (funcall show "#330033003300") "#33cc33cc33cc"))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks--skip-p () + ;; Baseline + (should-not (erc-nicks--skip-p 'bold nil 10000000)) + (should-not (erc-nicks--skip-p '(bold) nil 10000000)) + (should-not (erc-nicks--skip-p nil '(bold) 10000000)) + (should-not (erc-nicks--skip-p 'bold '(bold) 0)) + (should-not (erc-nicks--skip-p '(bold) '(bold) 0)) + (should-not (erc-nicks--skip-p 'bold '(foo bold) 0)) + (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(fake bold) 1)) + (should (erc-nicks--skip-p 'bold '(foo bar bold) 1)) + (should (erc-nicks--skip-p '(bold) '(bold) 1)) + (should (erc-nicks--skip-p '((bold)) '(bold) 1)) + (should (erc-nicks--skip-p '((((bold)))) '(bold) 1)) + (should (erc-nicks--skip-p '(bold) '(foo bold) 1)) + (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1)) + + ;; Composed + (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1)) + (should (erc-nicks--skip-p '(italic bold) '(bold) 2)) + (should (erc-nicks--skip-p '((italic) bold) '(bold) 2)) + (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2)) + + (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2)) + (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3)) + (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3))) + +(ert-deftest erc-nicks--trim () + (should (equal (erc-nicks--trim "Bob`") "bob")) + (should (equal (erc-nicks--trim "Bob``") "bob")) + + ;; `erc--casemapping-rfc1459' + (let ((erc-nicks-ignore-chars "^")) + (should (equal (erc-nicks--trim "Bob~") "bob^")) + (should (equal (erc-nicks--trim "Bob^") "bob")))) + +(defvar erc-nicks-tests--fake-face-list nil) + +;; Since we can't delete faces, mock `face-list' to only return those +;; in `erc-nicks--face-table' created by the current test. +(defun erc-nicks-tests--face-list () + (let ((table (buffer-local-value 'erc-nicks--face-table + (get-buffer "foonet"))) + out) + (maphash (lambda (k v) + (when (member k erc-nicks-tests--fake-face-list) + (push v out))) + table) + (nreverse out))) + +(defun erc-nicks-tests--create-session (test alice bob) + (should-not (memq 'nicks erc-modules)) + (advice-add 'face-list :override #'erc-nicks-tests--face-list) + (let ((erc-modules (cons 'nicks erc-modules)) + (inhibit-message noninteractive) + (erc-nicks-tests--fake-face-list + (list (downcase alice) (downcase bob))) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer + (cl-letf + (((symbol-function 'erc-server-connect) + (lambda (&rest _) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil)))) + + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester")) + + (let ((inhibit-message noninteractive)) + (dolist (line (split-string "\ +:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456 +:irc.foonet.org 005 tester NETWORK=foonet :are supported +:irc.foonet.org 376 tester :End of /MOTD command." + "\n")) + (erc-parse-server-response erc-server-process line))) + + (with-current-buffer (erc--open-target "#chan") + (erc-update-channel-member + "#chan" alice alice t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-update-channel-member + "#chan" bob bob t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-display-message + nil 'notice (current-buffer) + (concat "This server is in debug mode and is logging all user I/O. " + "Blah " alice " (1) " bob " (2) blah.")) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage bob "Hi Alice" nil t)) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage alice "Hi Bob" nil t))) + + (funcall test) + + (when noninteractive + (kill-buffer "#chan") + (when (get-buffer " *Custom-Work*") + (kill-buffer " *Custom-Work*")) + (kill-buffer)))) + (advice-remove 'face-list #'erc-nicks-tests--face-list)) + +(ert-deftest erc-nicks-list-faces () + (erc-nicks-tests--create-session + (lambda () + (erc-nicks-list-faces) + (let ((table (buffer-local-value 'erc-nicks--face-table + (get-buffer "foonet"))) + calls) + (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action) + (lambda (&rest r) (push r calls)))) + (with-current-buffer "*Faces*" + (set-window-buffer (selected-window) (current-buffer)) + (goto-char (point-min)) + + (ert-info ("Clicking on face link runs action function") + (forward-button 1) + (should (looking-at "erc-nicks-alice1-face")) + (push-button) + (should (eq (car (car calls)) (gethash "alice1" table)))) + + (ert-info ("Clicking on sample text describes face") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (push-button) + (should (search-forward-regexp + (rx "Foreground: #" (group (+ xdigit)) eol))) + (forward-button 1) + (push-button)) + + (ert-info ("First entry's sample is rendered correctly") + (let ((hex (match-string 1))) + (should (looking-at (concat "#" hex))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls))) + + (ert-info ("Clicking on another entry's face link runs action") + (forward-button 1) + (should (looking-at "erc-nicks-bob1-face")) + (push-button) + (should (eq (car (car calls)) (gethash "bob1" table)))) + + (ert-info ("Second entry's sample is rendered correctly") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls)) + + (when noninteractive + (kill-buffer)))))) + "Alice1" "Bob1")) + +(ert-deftest erc-nicks-customize-face () + (unless (>= emacs-major-version 28) + (ert-skip "Face link required in customize-face buffers")) + (erc-nicks-tests--create-session + (lambda () + (erc-nicks-list-faces) + (with-current-buffer "*Faces*" + (set-window-buffer (selected-window) (current-buffer)) + (goto-char (point-min)) + + (ert-info ("Clicking on face link runs action function") + (forward-button 1) + (should (looking-at "erc-nicks-alice2")) + (ert-simulate-keys "y\r" + (call-interactively #'push-button nil))) + + (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*" + (should (search-forward "Erc Nicks Alice2@Foonet Face" nil t)) + (widget-button-press (1- (point)))) + + (with-current-buffer "*New face erc-nicks-alice2@foonet-face*" + (goto-char (point-min)) + (should (search-forward "(use-package erc-nicks" nil t)) + (should (search-forward ":foreground \"#" nil t)) + (when noninteractive + (kill-buffer))) + + (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*" + (should (search-forward "Foreground: #" nil t)) + (when noninteractive + (kill-buffer))) + + (when noninteractive + (kill-buffer)))) + "Alice2" "Bob2")) + +(ert-deftest erc-nicks--gen-key-from-format-spec () + (let ((erc-network 'OFTC) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@OFTC00000000"))) + + (let ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat0"))) + + (let* ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%n/%m") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat/tester")))) + +(ert-deftest erc-nicks--create-pool () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + ;; + (erc-nicks--colors-rejects '(t))) + + ;; Reject + (should-not (erc-nicks--create-pool '(erc-nicks-invert) '("white"))) + (should (equal (pop erc-nicks--colors-rejects) "white")) ; too close + (should-not (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("black"))) + (should (equal (pop erc-nicks--colors-rejects) "black")) ; too far + (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("white"))) + (should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color + (should-not (erc-nicks--create-pool '(erc-nicks-ensaturate) '("red"))) + (should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color + + ;; Safe + (should + (equal (erc-nicks--create-pool '(erc-nicks-invert) '("black")) + '("black"))) + (should + (equal (erc-nicks--create-pool '(erc-nicks-add-contrast) '("black")) + '("black"))) + (should + (equal (erc-nicks--create-pool '(erc-nicks-cap-contrast) '("white")) + '("white"))) + (let ((erc-nicks-saturation-range '(0.5 . 1.0))) + (should + (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("green")) + '("green")))) + (let ((erc-nicks-saturation-range '(0.0 . 0.5))) + (should + (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("gray")) + '("gray")))) + (unless noninteractive + (should + (equal (erc-nicks--create-pool '(erc-nicks-ensaturate) '("firebrick")) + '("firebrick")))) + (should (equal erc-nicks--colors-rejects '(t))))) + +;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 0e4ea1b1db6..3f36e7c94f6 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1953,7 +1953,7 @@ (defconst erc-tests--modules '( autoaway autojoin button capab-identify completion dcc fill identd imenu irccontrols keep-place list log match menu move-to-prompt netsplit - networks noncommands notifications notify page readonly + networks nicks noncommands notifications notify page readonly replace ring sasl scrolltobottom services smiley sound spelling stamp track truncate unmorse xdcc)) From e51e43b7046b56c58310854182a1d589ee4c770c Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Wed, 17 May 2023 19:48:02 -0700 Subject: [PATCH 11/22] Fix buffer-mismatch bug in erc-scroll-to-bottom * lisp/erc/erc-goodies.el (erc-scroll-to-bottom): Only `recenter' when the selected window's buffer is current. Previously, the module `scrolltobottom' signaled an "Error in `post-command-hook'" when a user clicked a channel indicator in the mode line from a window showing another ERC buffer. * lisp/erc/erc-track.el (erc-track--switch-fallback-blockers): New internal variable used by `erc-track--switch-buffer' in deciding whether to set `erc-track-last-non-erc-buffer' to the current buffer. (erc-track--switch-buffer): Consult list of `buffer-match-p' conditions in `erc-track--switch-fallback-blockers' to decide whether to set `erc-track-last-non-erc-buffer' to the current buffer. (Bug#63595) --- lisp/erc/erc-goodies.el | 1 + lisp/erc/erc-track.el | 9 ++++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index afc05148506..96083de2c22 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -91,6 +91,7 @@ variable `erc-input-line-position'." (save-restriction (widen) (when (and erc-insert-marker + (eq (current-buffer) (window-buffer)) ;; we're editing a line. Scroll. (> (point) erc-insert-marker)) (save-excursion diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 8101183ce3d..64e59a90047 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -923,13 +923,20 @@ is relative to `erc-track-switch-direction'." (setq offset 0))) (car (nth offset erc-modified-channels-alist)))) +(defvar erc-track--switch-fallback-blockers '((derived-mode . erc-mode)) + "List of `buffer-match-p' conditions OR'd together. +ERC sets `erc-track-last-non-erc-buffer' to the current buffer +unless any passes.") + (defun erc-track--switch-buffer (fun arg) (if (not erc-track-mode) (message (concat "Enable the ERC track module if you want to use the" " tracking minor mode")) (cond (erc-modified-channels-alist ;; if we're not in erc-mode, set this buffer to return to - (unless (eq major-mode 'erc-mode) + (unless (buffer-match-p (cons 'or + erc-track--switch-fallback-blockers) + (current-buffer)) (setq erc-track-last-non-erc-buffer (current-buffer))) ;; and jump to the next active channel (if-let ((buf (erc-track-get-active-buffer arg)) From 30fe8703e60d0b756c19f52a6758889600b7b396 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Mon, 15 May 2023 00:16:00 -0700 Subject: [PATCH 12/22] Allow ERC's module toggles access to the prefix arg * lisp/erc/erc-common.el (erc--module-toggle-prefix-arg): Add internal variable for preserving the `arg' passed to a module's minor-mode toggle, which was previously discarded. Doing this lets modules that are more interactive in nature overload their mode toggles with alternate behaviors. (define-erc-module): Bind `erc--module-toggle-prefix-arg' to the `arg' parameter, which is normally defined inside a `define-minor-mode' body form. * test/lisp/erc/erc-tests.el (define-erc-module--global, define-erc-module--local): Expect activation body to be wrapped by a let form binding `erc--module-toggle-prefix-arg'. (Bug#63595) --- lisp/erc/erc-common.el | 14 +++++++++++--- test/lisp/erc/erc-tests.el | 14 ++++++++------ 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 7bd549abfc1..08c11d518a8 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -289,6 +289,15 @@ instead of a `set' state, which precludes any actual saving." (intern (file-name-base file)))) (v v))) +(defvar erc--module-toggle-prefix-arg nil + "The interpreted prefix arg of the minor-mode toggle. +Non-nil inside an ERC module's activation (or deactivation) +command, such as `erc-spelling-enable', when it's been called +indirectly via the module's minor-mode toggle, i.e., +`erc-spelling-mode'. Nil otherwise. Its value is either the +symbol `toggle' or an integer produced by `prefix-numeric-value'. +See Info node `(elisp) Defining Minor Modes' for more.") + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -337,9 +346,8 @@ if ARG is omitted or nil. :group (erc--find-group ',name ,(and alias (list 'quote alias))) ,@(unless local-p `(:require ',(erc--find-feature name alias))) ,@(unless local-p `(:type ,(erc--prepare-custom-module-type name))) - (if ,mode - (,enable) - (,disable))) + (let ((erc--module-toggle-prefix-arg arg)) + (if ,mode (,enable) (,disable)))) ,(erc--assemble-toggle local-p name enable mode t enable-body) ,(erc--assemble-toggle local-p name disable mode nil disable-body) ,@(and-let* ((alias) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 3f36e7c94f6..cc69641fb0b 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -2204,9 +2204,10 @@ Some docstring." :group (erc--find-group 'mname 'malias) :require 'nil :type "mname" - (if erc-mname-mode - (erc-mname-enable) - (erc-mname-disable))) + (let ((erc--module-toggle-prefix-arg arg)) + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable)))) (defun erc-mname-enable () "Enable ERC mname mode." @@ -2259,9 +2260,10 @@ ARG is omitted or nil. Some docstring." :global nil :group (erc--find-group 'mname nil) - (if erc-mname-mode - (erc-mname-enable) - (erc-mname-disable))) + (let ((erc--module-toggle-prefix-arg arg)) + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable)))) (defun erc-mname-enable (&optional ,arg-en) "Enable ERC mname mode. From 3c70e85d362262d096301e7663a11ca8c392f526 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 4 May 2023 00:01:11 -0700 Subject: [PATCH 13/22] Add preset styles to erc-status-sidebar * lisp/erc/erc-networks.el (erc-networks--rename-server-buffer): Store `erc-networks--id' in process object's plist. * lisp/erc/erc-status-sidebar.el (erc-status-sidebar): Change group parent from `convenience' to `erc'. (erc-status-sidebar-channel-format): Mention in doc string that it depends on new option `erc-status-sidebar-style'. (erc-status-sidebar-highlight-active-buffer): New option to control whether the current window's target is highlighted in the status bar. (erc-status-sidebar-style): New option to determine whether servers and queries also appear in the sidebar. (erc-status-sidebar-click-display-action, erc-status-sidebar-singular): New options. (erc-status-sidebar-get-window): Consider `erc-status-sidebar-singular'. (erc-status-sidebar-open): Fix toggle functionality that somehow fell through the cracks after the adoption of the package into ERC proper. (erc-bufbar-mode, erc-bufbar-enable, erc-bufbar-disable): New module named `bufbar' instead of `sidebar', which is more easily confusable with `speedbar'. The preferred name, `status-sidebar' was unavailable because its minor-mode would have been `erc-status-sidebar-mode', which is already taken by the major mode used for status-bar buffers themselves. (erc-status-sidebar-toggle): Ignore `erc-status-sidebar-singular'. (erc-status-sidebar--trimpat, erc-status-sidebar--prechan): Add helper vars for new sorting function, allowing it to honor the existing interface, which only expects one argument. (erc-status-sidebar-prefer-target-as-name): New function for determining buffer name, preferring targets for target buffers. (erc-status-sidebar-get-channame): Use internal API to help determine name of buffer in sidebar. (erc-status-sidebar-prefer-target-as-name, erc-status-sidebar--show-disconnected, erc-status-sidebar-all-target-buffers, erc-status-sidebar-default-allsort): Add new naming and sorting functions and associated helper functions and variables. (erc-status-sidebar--active-marker, erc-status-sidebar--set-active-line): New variable and function for highlighting the active target in the status bar. (erc-status-sidebar-default-insert, erc-status-sidebar-pad-hierarchy): New functions for visiting various stages of buffer modification when rendering sidebar. (erc-status-sidebar-refresh): Consider presets and new options when rendering sidebar. (erc-status-sidebar-kill): Disable `erc-bufbar-mode' when active. (erc-status-sidebar-click): Appeal to option `erc-status-sidebar-display-action' for `pop-to-buffer' action. (erc-status-sidebar-scroll-up, erc-status-sidebar-scroll-down, erc-status-sidebar-recenter): Add commands to scroll and recenter sidebar from a target buffer's window. (erc-status-sidebar-set-window-preserve-size): Ignore `erc-status-sidebar-singular'. (erc-status-sidebar-mode): Make non-interactive to avoid confusion when folks run "M-x erc-status-sidebar-mode" expecting a module toggle. * test/lisp/erc/erc-scenarios-status-sidebar.el: New file. * test/lisp/erc/resources/base/gapless-connect/foonet.eld: Fix wrong manifest for channel and extend PASS timeout. (Bug#63595) --- lisp/erc/erc-networks.el | 1 + lisp/erc/erc-status-sidebar.el | 329 ++++++++++++++++-- test/lisp/erc/erc-scenarios-status-sidebar.el | 93 +++++ .../resources/base/gapless-connect/foonet.eld | 8 +- 4 files changed, 401 insertions(+), 30 deletions(-) create mode 100644 test/lisp/erc/erc-scenarios-status-sidebar.el diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 7cc64614573..bf4ef1d35a9 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -1469,6 +1469,7 @@ to be a false alarm. If `erc-reuse-buffers' is nil, let ;; When this ends up being the current buffer, either we have ;; a "given" ID or the buffer was reused on reconnecting. (existing (get-buffer name))) + (process-put new-proc 'erc-networks--id erc-networks--id) (cond ((or (not existing) (erc-networks--id-given erc-networks--id) (eq existing (current-buffer))) diff --git a/lisp/erc/erc-status-sidebar.el b/lisp/erc/erc-status-sidebar.el index f11faa3db10..b8bd7b0065e 100644 --- a/lisp/erc/erc-status-sidebar.el +++ b/lisp/erc/erc-status-sidebar.el @@ -45,6 +45,13 @@ ;; Use M-x erc-status-sidebar-kill RET to kill the sidebar buffer and ;; close the sidebar on all frames. +;; In addition to the commands above, you can also try the all-in-one, +;; "DWIM" command, `erc-bufbar-mode'. See its doc string for usage. + +;; If you want the status sidebar enabled whenever you use ERC, add +;; `bufbar' to `erc-modules'. Note that this library also has a major +;; mode, `erc-status-sidebar-mode', which is for internal use. + ;;; Code: (require 'erc) @@ -53,8 +60,15 @@ (require 'seq) (defgroup erc-status-sidebar nil - "A sidebar for ERC channel status." - :group 'convenience) + "A responsive side window listing all connected ERC buffers. +More commonly known as a window list or \"buflist\", this side +panel displays clickable buffer names for switching to with the +mouse. By default, ERC highlights the name corresponding to the +selected window's buffer, if any. In this context, \"connected\" +just means associated with the same IRC session, even one that +has ceased communicating with its server. For information on how +the window itself works, see Info node `(elisp) Side Windows'." + :group 'erc) (defcustom erc-status-sidebar-buffer-name "*ERC Status*" "Name of the sidebar buffer." @@ -80,9 +94,78 @@ (defcustom erc-status-sidebar-channel-format 'erc-status-sidebar-default-chan-format - "Function used to format channel names for display in the sidebar." + "Function used to format channel names for display in the sidebar. +Only consulted for certain values of `erc-status-sidebar-style'." :type 'function) +(defcustom erc-status-sidebar-highlight-active-buffer t + "Whether to highlight the selected window's buffer in the sidebar. +ERC uses the same instance across all frames. May not be +compatible with all values of `erc-status-sidebar-style'." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defcustom erc-status-sidebar-style 'all-queries-first + "Preset style for rendering the sidebar. + +When set to `channels-only', ERC limits the items in the +status bar to uniquified channels. It uses the options +and functions + + `erc-channel-list', + `erc-status-sidebar-channel-sort', + `erc-status-sidebar-get-channame', + `erc-status-sidebar-channel-format' + `erc-status-sidebar-default-insert' + +for selecting, formatting, naming, and inserting entries. When +set to one of the various `all-*' values, such as `all-mixed', +ERC shows channels and queries under their respective server +buffers, using the functions + + `erc-status-sidebar-all-target-buffers', + `erc-status-sidebar-default-allsort', + `erc-status-sidebar-prefer-target-as-name', + `erc-status-sidebar-default-chan-format', + `erc-status-sidebar-pad-hierarchy' + +for the above-mentioned purposes. ERC also accepts a list of +functions to preform these roles a la carte. See doc strings for +a description of their expected arguments and return values." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const channels-only) + (const all-mixed) + (const all-queries-first) + (const all-channels-first) + (list (function :tag "Buffer lister") + (function :tag "Buffer sorter") + (function :tag "Name extractor") + (function :tag "Name formatter") + (function :tag "Name inserter")))) + +(defcustom erc-status-sidebar-click-display-action t + "How to display a buffer when clicked. +Values can be anything recognized by `display-buffer' for its +ACTION parameter." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const :tag "Always use/create other window" t) + (const :tag "Let `display-buffer' decide" nil) + (const :tag "Same window" (display-buffer-same-window + (inhibit-same-window . nil))) + (cons :tag "Action" + (choice function (repeat function)) + (alist :tag "Action arguments" + :key-type symbol + :value-type (sexp :tag "Value"))))) + +(defcustom erc-status-sidebar-singular t + "Whether to show the sidebar on all frames or just one (default)." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defvar hl-line-mode) +(declare-function hl-line-highlight "hl-line" nil) + (defun erc-status-sidebar-display-window () "Display the status buffer in a side window. Return the new window." (display-buffer @@ -94,7 +177,8 @@ "Return the created/existing window displaying the status buffer. If NO-CREATION is non-nil, the window is not created." - (let ((sidebar-window (get-buffer-window erc-status-sidebar-buffer-name))) + (let ((sidebar-window (get-buffer-window erc-status-sidebar-buffer-name + erc-status-sidebar-singular))) (unless (or sidebar-window no-creation) (with-current-buffer (erc-status-sidebar-get-buffer) (setq-local vertical-scroll-bar nil)) @@ -144,22 +228,51 @@ containing it on the current frame is closed. See "Open or create a sidebar." (interactive) (save-excursion - (let ((sidebar-exists (erc-status-sidebar-buffer-exists-p)) - (sidebar-buffer (erc-status-sidebar-get-buffer)) - ;; (sidebar-window (erc-status-sidebar-get-window)) - ) - (unless sidebar-exists - (with-current-buffer sidebar-buffer - (erc-status-sidebar-mode) - (erc-status-sidebar-refresh)))))) + (if (erc-status-sidebar-buffer-exists-p) + (erc-status-sidebar-get-window) + (with-current-buffer (erc-status-sidebar-get-buffer) + (erc-status-sidebar-mode) + (erc-status-sidebar-refresh))))) + +;;;###autoload(autoload 'erc-bufbar-mode "erc-status-sidebar" nil t) +(define-erc-module bufbar nil + "Show `erc-track'-like activity in a side window. +When enabling, show the sidebar immediately if called from a +connected ERC buffer. Otherwise, arrange for doing so on connect +or whenever next displaying a new ERC buffer. When disabling, +hide the status window if it's showing. With a negative prefix +arg, also shutdown the session." + ((unless erc-track-mode + (unless (memq 'track erc-modules) + (erc--warn-once-before-connect 'erc-bufbar-mode + "Module `bufbar' needs global module `track'. Enabling now." + " This will affect \C-]all\C-] ERC sessions." + " Add `track' to `erc-modules' to silence this message.")) + (erc-track-mode +1)) + (add-hook 'erc--setup-buffer-hook #'erc-status-sidebar-open) + (unless erc--updating-modules-p + (if (erc-with-server-buffer erc-server-connected) + (erc-status-sidebar-open) + (setq erc-bufbar-mode nil) + (when (derived-mode-p 'erc-mode) + (erc-error "Not initializing `erc-bufbar-mode' in %s" + (current-buffer)))))) + ((remove-hook 'erc--setup-buffer-hook #'erc-status-sidebar-open) + (erc-status-sidebar-close erc-status-sidebar-singular) + (when-let ((arg erc--module-toggle-prefix-arg) + ((numberp arg)) + ((< arg 0))) + (erc-status-sidebar-kill)))) ;;;###autoload (defun erc-status-sidebar-toggle () - "Toggle the sidebar open/closed on the current frame." + "Toggle the sidebar open/closed on the current frame. +Do this regardless of `erc-status-sidebar-singular'." (interactive) (if (get-buffer-window erc-status-sidebar-buffer-name nil) (erc-status-sidebar-close) - (erc-status-sidebar-open))) + (let (erc-status-sidebar-singular) + (erc-status-sidebar-open)))) (defun erc-status-sidebar-get-channame (buffer) "Return name of BUFFER with all leading \"#\" characters removed." @@ -174,6 +287,98 @@ containing it on the current frame is closed. See (string< (erc-status-sidebar-get-channame x) (erc-status-sidebar-get-channame y))))) +(defvar erc-status-sidebar--trimpat nil) +(defvar erc-status-sidebar--prechan nil) + +(defun erc-status-sidebar-prefer-target-as-name (buffer) + "Return some name to represent buffer in the sidebar." + (if-let ((target (buffer-local-value 'erc--target buffer))) + (cond ((and erc-status-sidebar--trimpat (erc--target-channel-p target)) + (string-trim-left (erc--target-string target) + erc-status-sidebar--trimpat)) + ((and erc-status-sidebar--prechan (erc--target-channel-p target)) + (concat erc-status-sidebar--prechan + (erc--target-string target))) + (t (erc--target-string target))) + (buffer-name buffer))) + +;; This could be converted into an option if people want. +(defvar erc-status-sidebar--show-disconnected t) + +(defun erc-status-sidebar-all-target-buffers (process) + (erc-buffer-filter (lambda () + (and erc--target + (or erc-status-sidebar--show-disconnected + (erc-server-process-alive)))) + process)) + +;; FIXME profile this. Rebuilding the graph every time track updates +;; seems wasteful for occasions where server messages are processed +;; unthrottled, such as during history playback. If it's a problem, +;; we should look into rewriting this using `ewoc' or some other +;; solution that maintains a persistent model. +(defun erc-status-sidebar-default-allsort (target-buffers) + "Return a list of servers interspersed with their targets." + (mapcan (pcase-lambda (`(,proc . ,chans)) + (cons (process-buffer proc) + (let ((erc-status-sidebar--trimpat + (and (eq erc-status-sidebar-style 'all-mixed) + (with-current-buffer (process-buffer proc) + (when-let ((ch-pfxs (erc--get-isupport-entry + 'CHANTYPES 'single))) + (regexp-quote ch-pfxs))))) + (erc-status-sidebar--prechan + (and (eq erc-status-sidebar-style + 'all-queries-first) + "\C-?"))) + (sort chans + (lambda (x y) + (string< + (erc-status-sidebar-prefer-target-as-name x) + (erc-status-sidebar-prefer-target-as-name y))))))) + (sort (seq-group-by (lambda (b) + (buffer-local-value 'erc-server-process b)) + target-buffers) + (lambda (a b) + (string< (buffer-name (process-buffer (car a))) + (buffer-name (process-buffer (car b)))))))) + +(defvar-local erc-status-sidebar--active-marker nil + "Marker indicating currently active buffer.") + +(defun erc-status-sidebar--set-active-line (erc-buffer) + (when (and erc-status-sidebar-highlight-active-buffer + (eq (window-buffer (and (minibuffer-window-active-p + (selected-window)) + (minibuffer-selected-window))) + erc-buffer)) + (set-marker erc-status-sidebar--active-marker (point)))) + +(defun erc-status-sidebar-default-insert (channame chanbuf _chanlist) + "Insert CHANNAME followed by a newline. +Maybe arrange to highlight line if CHANBUF is showing in the +focused window." + (erc-status-sidebar--set-active-line chanbuf) + (insert channame "\n")) + +(defun erc-status-sidebar-pad-hierarchy (bufname buffer buflist) + "Prefix BUFNAME to emphasize BUFFER's role in BUFLIST." + (if (and (buffer-live-p buffer) (buffer-local-value 'erc--target buffer)) + (insert " ") + (unless (eq buffer (car buflist)) + (insert "\n"))) ; ^L + (when bufname + (erc-status-sidebar--set-active-line buffer)) + (insert (or bufname + (and-let* (((not (buffer-live-p buffer))) + (next (cadr (member buffer buflist))) + ((buffer-live-p next)) + (proc (buffer-local-value 'erc-server-process next)) + (id (process-get proc 'erc-networks--id))) + (symbol-name (erc-networks--id-symbol id))) + "???") + "\n")) + (defun erc-status-sidebar-default-chan-format (channame &optional num-messages erc-face) "Format CHANNAME for display in the sidebar. @@ -193,43 +398,111 @@ name stand out." (defun erc-status-sidebar-refresh () "Update the content of the sidebar." (interactive) - (let ((chanlist (apply erc-status-sidebar-channel-sort - (erc-channel-list nil) nil))) + (pcase-let* ((`(,list-fn ,sort-fn ,name-fn ,fmt-fn ,insert-fn) + (pcase erc-status-sidebar-style + ('channels-only (list #'erc-channel-list + erc-status-sidebar-channel-sort + #'erc-status-sidebar-get-channame + erc-status-sidebar-channel-format + #'erc-status-sidebar-default-insert)) + ((or 'all-mixed 'all-queries-first 'all-channels-first) + '(erc-status-sidebar-all-target-buffers + erc-status-sidebar-default-allsort + erc-status-sidebar-prefer-target-as-name + erc-status-sidebar-default-chan-format + erc-status-sidebar-pad-hierarchy)) + (v v))) + (chanlist (apply sort-fn (funcall list-fn nil) nil)) + (window nil) + (winstart nil)) (with-current-buffer (erc-status-sidebar-get-buffer) + (setq window (get-buffer-window nil erc-status-sidebar-singular) + winstart (and window (window-start window))) (erc-status-sidebar-writable (delete-region (point-min) (point-max)) (goto-char (point-min)) + (if erc-status-sidebar--active-marker + (set-marker erc-status-sidebar--active-marker nil) + (setq erc-status-sidebar--active-marker (make-marker))) (dolist (chanbuf chanlist) (let* ((tup (seq-find (lambda (tup) (eq (car tup) chanbuf)) erc-modified-channels-alist)) (count (if tup (cadr tup))) (face (if tup (cddr tup))) - (channame (apply erc-status-sidebar-channel-format - (buffer-name chanbuf) count face nil)) + (face (if (or (not (buffer-live-p chanbuf)) + (not (erc-server-process-alive chanbuf))) + `(shadow ,face) + face)) + (channame (apply fmt-fn + (copy-sequence (funcall name-fn chanbuf)) + count face nil)) (cnlen (length channame))) (put-text-property 0 cnlen 'erc-buf chanbuf channame) (put-text-property 0 cnlen 'mouse-face 'highlight channame) (put-text-property 0 cnlen 'help-echo "mouse-1: switch to buffer in other window" channame) - (insert channame "\n"))))))) + (funcall insert-fn channame chanbuf chanlist))) + (when winstart + (set-window-point window winstart) + (with-selected-window window (recenter 0))) + (when (and erc-status-sidebar-highlight-active-buffer + (marker-buffer erc-status-sidebar--active-marker)) + (goto-char erc-status-sidebar--active-marker) + (require 'hl-line) + (unless hl-line-mode (hl-line-mode +1)) + (hl-line-highlight)))))) (defun erc-status-sidebar-kill () "Close the ERC status sidebar and its buffer." (interactive) + (when (and erc-bufbar-mode (not erc--module-toggle-prefix-arg)) + (erc-bufbar-mode -1)) (ignore-errors (kill-buffer erc-status-sidebar-buffer-name))) (defun erc-status-sidebar-click (event) "Handle click EVENT in `erc-status-sidebar-mode-map'." (interactive "e") (save-excursion - (let ((window (posn-window (event-end event))) + (let ((window (posn-window (event-start event))) (pos (posn-point (event-end event)))) - (set-buffer (window-buffer window)) - (let ((buf (get-text-property pos 'erc-buf))) - (when buf - (select-window window) - (switch-to-buffer-other-window buf)))))) + ;; Current buffer is "ERC Status" and its window is selected + (cl-assert (eq major-mode 'erc-status-sidebar-mode)) + (cl-assert (eq (selected-window) window)) + (cl-assert (eq (window-buffer window) (current-buffer))) + (when-let ((buf (get-text-property pos 'erc-buf))) + ;; Option operates relative to last selected window + (select-window (get-mru-window nil nil 'not-selected)) + (pop-to-buffer buf erc-status-sidebar-click-display-action))))) + +(defun erc-status-sidebar-scroll-up (lines) + "Scroll sidebar buffer's content LINES linse upward. +If LINES is nil, scroll up a full screen's worth." + (interactive "P") + (let ((other-window-scroll-buffer (erc-status-sidebar-get-buffer))) + (scroll-other-window lines))) + +(defun erc-status-sidebar-scroll-down (lines) + "Scroll sidebar buffer's content LINES lines downward. +If LINES is nil, scroll down a full screen's worth." + (interactive "P") + (let ((other-window-scroll-buffer (erc-status-sidebar-get-buffer))) + (scroll-other-window-down lines))) + +(defun erc-status-sidebar-recenter (arg) + "Recenter the status sidebar. +Expect `erc-status-sidebar-highlight-active-buffer' to be non-nil +and to be invoked in a buffer matching the line currently +highlighted." + (interactive "P") + (let* ((buf (erc-status-sidebar-get-buffer)) + (win (get-buffer-window buf))) + (with-current-buffer buf + (when (and erc-status-sidebar--active-marker + (marker-position erc-status-sidebar--active-marker)) + (with-selected-window win + (goto-char erc-status-sidebar--active-marker) + (recenter arg t)))))) (defvar erc-status-sidebar-mode-map (let ((map (make-sparse-keymap))) @@ -268,13 +541,17 @@ hooks that invoke it with arguments." Note that preserve status needs to be reset when the window is manually resized, so `erc-status-sidebar-mode' adds this function to the `window-configuration-change-hook'." - (when (and (eq (selected-window) (erc-status-sidebar-get-window)) + (when (and (eq (selected-window) (let (erc-status-sidebar-singular) + (erc-status-sidebar-get-window))) (fboundp 'window-preserve-size)) (unless (eq (window-total-width) (window-min-size nil t)) (apply #'window-preserve-size (selected-window) t t nil)))) (define-derived-mode erc-status-sidebar-mode special-mode "ERC Sidebar" "Major mode for ERC status sidebar." + ;; Users invoking M-x erc-status-sidebar-mode most likely expect to + ;; summon the module's minor-mode, `erc-bufbar-mode'. + :interactive nil ;; Don't scroll the buffer horizontally, if a channel name is ;; obscured then the window can be resized. (setq-local auto-hscroll-mode nil) diff --git a/test/lisp/erc/erc-scenarios-status-sidebar.el b/test/lisp/erc/erc-scenarios-status-sidebar.el new file mode 100644 index 00000000000..5144069ec0e --- /dev/null +++ b/test/lisp/erc/erc-scenarios-status-sidebar.el @@ -0,0 +1,93 @@ +;;; erc-scenarios-status-sidebar.el --- erc-sidebar/speedbar tests -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-status-sidebar) + + +(ert-deftest erc-scenarios-status-sidebar--bufbar () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/gapless-connect") + (erc-server-flood-penalty 0.1) + (erc-server-flood-penalty erc-server-flood-penalty) + (erc-modules `(bufbar ,@erc-modules)) + (dumb-server (erc-d-run "localhost" t 'foonet 'barnet)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to two different endpoints") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (funcall expect 10 "MOTD File is missing")) + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "barnet:changeme" + :full-name "tester") + (funcall expect 10 "marked as being away"))) + + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar")) + (funcall expect 10 "was created on") + (funcall expect 2 "his second fit")) + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo")) + (funcall expect 10 "was created on") + (funcall expect 2 "no use of him") + (ert-info ("Activity marker is in the right spot") + (let ((obuf (window-buffer))) ; *scratch* + (set-window-buffer (selected-window) "#foo") + (erc-d-t-wait-for 5 + (when noninteractive + (erc-status-sidebar-refresh)) + (with-current-buffer "*ERC Status*" + (and (marker-position erc-status-sidebar--active-marker) + (goto-char erc-status-sidebar--active-marker) + ;; The " [N]" suffix disappears because it's selected + (search-forward "#foo" (pos-eol) t)))) + (set-window-buffer (selected-window) obuf)))) + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "*ERC Status*")) + (ert-info ("Hierarchy printed correctly") + (funcall expect 10 "barnet [") + (funcall expect 10 "#bar [") + (funcall expect 10 "foonet [") + (funcall expect 10 "#foo"))) + + (with-current-buffer "#foo" + (ert-info ("Core toggle and kill commands work") + ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p', + ;; etc. for testing commands that call those same functions. + (should (get-buffer-window "*ERC Status*")) + (erc-bufbar-mode -1) + (should-not (get-buffer-window "*ERC Status*")) + (erc-status-sidebar-kill) + (should-not (get-buffer "*ERC Status*")))))) + +;;; erc-scenarios-status-sidebar.el ends here diff --git a/test/lisp/erc/resources/base/gapless-connect/foonet.eld b/test/lisp/erc/resources/base/gapless-connect/foonet.eld index 4ac4a3e5968..10b742fdb34 100644 --- a/test/lisp/erc/resources/base/gapless-connect/foonet.eld +++ b/test/lisp/erc/resources/base/gapless-connect/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") @@ -21,7 +21,7 @@ ;; No mode answer (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@xrir8fpe4d7ak.irc JOIN #foo") - (0 ":irc.foonet.org 353 tester = #foo :joe @mike tester") + (0 ":irc.foonet.org 353 tester = #foo :alice @bob tester") (0 ":irc.foonet.org 366 tester #foo :End of /NAMES list.") (0 ":***!znc@znc.in PRIVMSG #foo :Buffer Playback...") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :[07:02:41] bob: To-morrow is the joyful day, Audrey; to-morrow will we be married.") From ded35c2da4da52641ec99927347cd50b736b9577 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 4 May 2023 00:01:11 -0700 Subject: [PATCH 14/22] Add erc-status-sidebar integration to erc-speedbar * lisp/erc/erc-speedbar.el: Require `erc-button' atop file and don't bother loading `dframe', which `speedbar' handles for us. (erc-speedbar): Explain that `nickbar' is the module for this group and library for the benefit of those who run M-x customize-group. (erc-speedbar-nicknames-window-width): New option. (erc-speedbar-hide-mode-topic): New option determining whether to hide the mode and topic. (erc-speedbar-my-nick-face): New option for determining face to use when displaying user's current nick. (erc-speedbar-browser): Call `erc-install-speedbar-variables' explicitly and remove top-level `with-eval-after-load'. (erc-speedbar-insert-target): Add parenthesized channel count after channel name in server and channel views. (erc-speedbar-expand-channel): Hide mode and topic depending on option `erc-speedbar-hide-mode-topic' and pass buffer to `erc-speedbar-insert-user'. (erc-speedbar--nick-face-function): New internal function-valued variable. (erc-speedbar--highlight-self-and-ops): New function to serve as default value for `erc-speedbar--nick-face-function'. (erc-speedbar--on-click): Dispatch `erc-nick-popup' after trimming status chars. (erc-speedbar-insert-user): Revise doc string. Call `erc-speedbar--nick-face-function' to determine face. Change token for both expansion and on-click text props. Assign `erc-speedbar--on-click' as the mouse handler for nick items. (erc-speedbar--buffer-options): Variable to override options locally in speedbar buffer. (erc-speedbar--hidden-speedbar-frame): Add variable to hold original `speedbar-frame' before spoofing by setting to selected frame containing window showing ERC buffer. (erc-speedbar--emulate-sidebar-set-window-preserve-size, erc-speedbar--status-sidebar-mode--unhook): Add function to ensure status sidebar is showing correctly and helper to unregister from hook on teardown. (erc-speedbar--emulate-sidebar): Add function to control sidebar nicknames setup. (erc-speedbar--toggle-nicknames-sidebar): Add toggle function for speedbar or emulated sidebar. (erc-speedbar--ensure): Add helper function to show speedbar if it's hidden or create one if none exists. (erc-nickbar-mode, erc-nickbar-enable, erc-nickbar-disable): Add new mini module. (erc-speedbar--dframe-controlled) Add function to overwrite `speedbar-frame-mode' as `dframe-controlled' in speedbar buffer. (erc-speedbar-toggle-nicknames-window-lock, erc-speedbar-close-nicknames-window): Add commands to close speedbar window and toggle its cyclability. (erc-speedbar--compose-nicks-face): Add helper for nicks integration. * test/lisp/erc/erc-scenarios-status-sidebar.el (erc-scenarios-status-sidebar--nickbar): New test. (Bug#63595) --- lisp/erc/erc-speedbar.el | 287 ++++++++++++++++-- test/lisp/erc/erc-scenarios-status-sidebar.el | 76 +++++ 2 files changed, 345 insertions(+), 18 deletions(-) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index a9443e0ea17..f5fbaac767d 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -32,20 +32,31 @@ ;; update-channel, update-nick, remove-nick-from-channel, ... ;; * Use indicator-strings for op/voice ;; * Extract/convert face notes field from bbdb if available +;; * Write tests that run in a term-mode subprocess ;; ;;; Code: (require 'erc) (require 'erc-goodies) +(require 'erc-button) (require 'speedbar) -(condition-case nil (require 'dframe) (error nil)) ;;; Customization: (defgroup erc-speedbar nil - "Integration of ERC in the Speedbar." + "Speedbar integration for ERC. +To open an ERC-flavored speedbar in a separate frame, run the +command `erc-speedbar-browser'. To use a window-based proxy +instead, run \\[erc-nickbar-mode] in a connected ERC buffer or +put `nickbar' in `erc-modules' before connecting. See Info +node `(speedbar) Top' for more about the underlying integration." :group 'erc) +(defcustom erc-speedbar-nicknames-window-width 18 + "Default width of the nicknames sidebar (in columns)." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'integer) + (defcustom erc-speedbar-sort-users-type 'activity "How channel nicknames are sorted. @@ -56,6 +67,23 @@ nil - Do not sort users" (const :tag "Sort users alphabetically" alphabetical) (const :tag "Do not sort users" nil))) +(defcustom erc-speedbar-hide-mode-topic 'headerline + "Hide mode and topic lines." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const :tag "Always show" nil) + (const :tag "Always hide" t) + (const :tag "Omit when headerline visible" headerline))) + +(defcustom erc-speedbar-my-nick-face t + "A face to use for your nickname. +When the value is t, ERC uses `erc-current-nick-face' if +`erc-match' has been loaded and `erc-my-nick-face' otherwise. +When using the `nicks' module, you can see your nick as it +appears to others by coordinating with the option +`erc-nicks-skip-faces'." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice face (const :tag "Current nick or own speaker face" t))) + (defvar erc-speedbar-key-map nil "Keymap used when in erc display mode.") @@ -88,10 +116,6 @@ nil - Do not sort users" (looking-at "[0-9]+: *.-. "))]) "Additional menu-items to add to speedbar frame.") -;; Make sure our special speedbar major mode is loaded -(with-eval-after-load 'speedbar - (erc-install-speedbar-variables)) - ;;; ERC hierarchy display method ;;;###autoload (defun erc-speedbar-browser () @@ -99,6 +123,7 @@ nil - Do not sort users" This will add a speedbar major display mode." (interactive) (require 'speedbar) + (erc-install-speedbar-variables) ;; Make sure that speedbar is active (speedbar-frame-mode 1) ;; Now, throw us into Info mode on speedbar. @@ -169,12 +194,18 @@ This will add a speedbar major display mode." t))))) (defun erc-speedbar-insert-target (buffer depth) - (if (with-current-buffer buffer - (erc-channel-p (erc-default-target))) - (speedbar-make-tag-line - 'bracket ?+ 'erc-speedbar-expand-channel buffer - (buffer-name buffer) 'erc-speedbar-goto-buffer buffer nil - depth) + (if (erc--target-channel-p (buffer-local-value 'erc--target buffer)) + (progn + (speedbar-make-tag-line + 'bracket ?+ 'erc-speedbar-expand-channel buffer + (erc--target-string (buffer-local-value 'erc--target buffer)) + 'erc-speedbar-goto-buffer buffer nil + depth) + (save-excursion + (forward-line -1) + (let ((table (buffer-local-value 'erc-channel-users buffer))) + (speedbar-add-indicator (format "(%d)" (hash-table-count table))) + (rx "(" (+ (any "0-9")) ")")))) ;; Query target (speedbar-make-tag-line nil nil nil nil @@ -220,6 +251,13 @@ INDENT is the current indentation level." 'angle ?i nil nil (concat "Topic: " topic) nil nil nil (1+ indent))) + (unless (pcase erc-speedbar-hide-mode-topic + ('nil 'show) + ('headerline (null erc-header-line-format))) + (save-excursion + (goto-char (point-max)) + (forward-line (if (string= topic "") -1 -2)) + (put-text-property (pos-bol) (point-max) 'invisible t))) (let ((names (cond ((eq erc-speedbar-sort-users-type 'alphabetical) (erc-sort-channel-users-alphabetically (with-current-buffer channel @@ -233,17 +271,52 @@ INDENT is the current indentation level." (when names (speedbar-with-writable (dolist (entry names) - (erc-speedbar-insert-user entry ?+ (1+ indent)))))))))) + (erc-speedbar-insert-user entry ?+ (1+ indent) channel))))))))) ((string-search "-" text) (speedbar-change-expand-button-char ?+) (speedbar-delete-subblock indent)) (t (error "Ooops... not sure what to do"))) (speedbar-center-buffer-smartly)) -(defun erc-speedbar-insert-user (entry exp-char indent) +(defvar erc-speedbar--nick-face-function #'erc-speedbar--highlight-self-and-ops + "Function called when finding a face for fontifying nicks. +Called with the proposed nick, the `erc-server-user', and the +`erc-channel-user'. Should return any valid face, possibly +composed or anonymous, or nil.") + +(defun erc-speedbar--highlight-self-and-ops (buffer user cuser) + "Highlight own nick and op'd users in the speedbar." + (with-current-buffer buffer + (if (erc-current-nick-p (erc-server-user-nickname user)) + (pcase erc-speedbar-my-nick-face + ('t (if (facep 'erc-current-nick-face) + 'erc-current-nick-face + 'erc-my-nick-face)) + (v v)) + ;; FIXME overload `erc-channel-user-owner-p' and friends to + ;; accept an `erc-channel-user' object and replace this unrolled + ;; stuff with a single call to `erc-get-user-mode-prefix'. + (and cuser (or (erc-channel-user-owner cuser) + (erc-channel-user-admin cuser) + (erc-channel-user-op cuser) + (erc-channel-user-halfop cuser) + (erc-channel-user-voice cuser)) + erc-button-nickname-face)))) + +(defun erc-speedbar--on-click (nick sbtoken _indent) + ;; 0: finger, 1: name, 2: info, 3: buffer-name + (with-current-buffer (nth 3 sbtoken) + (erc-nick-popup (string-trim-left nick "[~&@%+]+")))) + +(defun erc-speedbar-insert-user (entry exp-char indent &optional buffer) "Insert one user based on the channel member list ENTRY. -EXP-CHAR is the expansion character to use. -INDENT is the current indentation level." +Expect EXP-CHAR to be the expansion character to use, INDENT the +current indentation level, and BUFFER the associated channel or +query buffer. Set the `speedbar-function' text property to +`erc-speedbar--on-click', which is called with the formatted +nick, a so-called \"token\", and the indent level. The token is +a list of four items: the userhost, the GECOS, the current +`erc-server-user' info slot, and the associated buffer." (let* ((user (car entry)) (cuser (cdr entry)) (nick (erc-server-user-nickname user)) @@ -255,11 +328,12 @@ INDENT is the current indentation level." (op (and cuser (erc-channel-user-op cuser))) (nick-str (concat (if op "@" "") (if voice "+" "") nick)) (finger (concat login (when (or login host) "@") host)) - (sbtoken (list finger name info))) + (sbtoken (list finger name info (buffer-name buffer)))) (if (or login host name info) ; we want to be expandable (speedbar-make-tag-line 'bracket ?+ 'erc-speedbar-expand-user sbtoken - nick-str nil sbtoken nil + nick-str #'erc-speedbar--on-click sbtoken + (funcall erc-speedbar--nick-face-function buffer user cuser) indent) (when (equal exp-char ?-) (forward-line -1) @@ -357,6 +431,183 @@ The INDENT level is ignored." (t (message "%s" txt))))) + +;;;; Status-sidebar integration + +(defvar erc-track-mode) +(defvar erc-track--switch-fallback-blockers) +(defvar erc-status-sidebar-buffer-name) +(declare-function erc-status-sidebar-set-window-preserve-size + "erc-status-sidebar" nil) +(declare-function erc-status-sidebar-mode--unhook "erc-status-sidebar" nil) + +(defvar erc-speedbar--buffer-options + '((speedbar-update-flag . t) + (speedbar-use-images . nil) + (speedbar-hide-button-brackets-flag . t))) + +(defvar erc-speedbar--hidden-speedbar-frame nil) + +(defun erc-speedbar--emulate-sidebar-set-window-preserve-size () + (let ((erc-status-sidebar-buffer-name (buffer-name speedbar-buffer)) + (display-buffer-overriding-action + `(display-buffer-in-side-window + . ((side . right) + (window-width . ,erc-speedbar-nicknames-window-width))))) + (erc-status-sidebar-set-window-preserve-size) + (when-let ((window (get-buffer-window speedbar-buffer))) + (set-window-parameter window 'no-other-window nil) + (internal-show-cursor window t)))) + +(defun erc-speedbar--status-sidebar-mode--unhook () + "Remove hooks installed by `erc-status-sidebar-mode'." + (remove-hook 'window-configuration-change-hook + #'erc-speedbar--emulate-sidebar-set-window-preserve-size)) + +(defun erc-speedbar--emulate-sidebar () + (require 'erc-status-sidebar) + (cl-assert speedbar-frame) + (cl-assert (eq speedbar-buffer (current-buffer))) + (cl-assert (eq speedbar-frame (selected-frame))) + (setq erc-speedbar--hidden-speedbar-frame speedbar-frame + dframe-controlled #'erc-speedbar--dframe-controlled) + (add-hook 'window-configuration-change-hook + #'erc-speedbar--emulate-sidebar-set-window-preserve-size nil t) + (add-hook 'kill-buffer-hook + #'erc-speedbar--status-sidebar-mode--unhook nil t) + (with-current-buffer speedbar-buffer + (pcase-dolist (`(,var . ,val) erc-speedbar--buffer-options) + (set (make-local-variable var) val))) + (when (memq 'nicks erc-modules) + (with-current-buffer speedbar-buffer + (add-function :around (local 'erc-speedbar--nick-face-function) + #'erc-speedbar--compose-nicks-face)))) + +(defun erc-speedbar--toggle-nicknames-sidebar (arg) + (let ((force (numberp arg))) + (if speedbar-buffer + (progn + (cl-assert (buffer-live-p speedbar-buffer)) + (if (or (and force (< arg 0)) + (and (not force) (get-buffer-window speedbar-buffer nil))) + (erc-speedbar-close-nicknames-window nil) + (when (or (not force) (>= arg 0)) + (with-selected-frame speedbar-frame + (erc-speedbar--emulate-sidebar-set-window-preserve-size))))) + (when (or (not force) (>= arg 0)) + (let ((speedbar-frame-parameters (backquote-list* + '(visibility . nil) + '(no-other-frame . t) + speedbar-frame-parameters)) + (speedbar-after-create-hook #'erc-speedbar--emulate-sidebar)) + (erc-speedbar-browser) + ;; If we put the remaining parts in the "create hook" along + ;; with everything else, the frame with `window-main-window' + ;; gets raised and steals focus if you've switched away from + ;; Emacs in the meantime. + (make-frame-invisible speedbar-frame) + (select-frame (setq speedbar-frame (previous-frame))) + (erc-speedbar--emulate-sidebar-set-window-preserve-size)))))) + +(defun erc-speedbar--ensure (&optional force) + (when (or (erc-server-buffer) force) + (when erc-track-mode + (cl-pushnew '(derived-mode . speedbar-mode) + erc-track--switch-fallback-blockers :test #'equal)) + (erc-speedbar--toggle-nicknames-sidebar +1) + (speedbar-enable-update))) + +;;;###autoload(autoload 'erc-nickbar-mode "erc-speedbar" nil t) +(define-erc-module nickbar nil + "Show nicknames in a side window. +When enabling, create a speedbar session if one doesn't exist and +show its buffer in an `erc-status-sidebar' window instead of a +separate frame. When disabling, close the window or, with a +negative prefix arg, destroy the session. + +WARNING: this module may produce unwanted side effects, like the +raising of frames or the stealing of input focus. If you witness +such an occurrence, and can reproduce it, please file a bug +report with \\[erc-bug]." + ((add-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (erc-speedbar--ensure) + (unless (or erc--updating-modules-p + (and-let* ((speedbar-buffer) + (win (get-buffer-window speedbar-buffer 'all-frames)) + ((eq speedbar-frame (window-frame win)))))) + (if speedbar-buffer + (erc-speedbar--ensure 'force) + (setq erc-nickbar-mode nil) + (when (derived-mode-p 'erc-mode) + (erc-error "Not initializing `erc-nickbar-mode' in %s" + (current-buffer)))))) + ((remove-hook 'erc--setup-buffer-hook #'erc-speedbar--ensure) + (speedbar-disable-update) + (when erc-track-mode + (setq erc-track--switch-fallback-blockers + (remove '(derived-mode . speedbar-mode) + erc-track--switch-fallback-blockers))) + (erc-speedbar--toggle-nicknames-sidebar -1) + (when-let ((arg erc--module-toggle-prefix-arg) + ((numberp arg)) + ((< arg 0))) + (erc-speedbar-close-nicknames-window 'kill)))) + +(defun erc-speedbar--dframe-controlled (arg) + (when (and erc-speedbar--hidden-speedbar-frame (numberp arg) (< arg 0)) + (when erc-nickbar-mode + (erc-nickbar-mode -1)) + (setq speedbar-frame erc-speedbar--hidden-speedbar-frame + erc-speedbar--hidden-speedbar-frame nil) + ;; It's unknown whether leaving the frame invisible interferes + ;; with the upstream teardown procedure. + (when (display-graphic-p) + (make-frame-visible speedbar-frame)) + (speedbar-frame-mode arg) + (when speedbar-buffer + (kill-buffer speedbar-buffer) + (setq speedbar-buffer nil)))) + +(defun erc-speedbar-toggle-nicknames-window-lock () + "Toggle whether nicknames window is selectable with \\[other-window]." + (interactive) + (unless erc-nickbar-mode + (user-error "`erc-nickbar-mode' inactive")) + (when-let ((window (get-buffer-window speedbar-buffer))) + (let ((val (window-parameter window 'no-other-window))) + (set-window-parameter window 'no-other-window (not val)) + (message "nick-window: %s" (if val "selectable" "protected"))))) + +(defun erc-speedbar-close-nicknames-window (kill) + (interactive "P") + (if kill + (with-current-buffer speedbar-buffer + (dframe-close-frame) + (cl-assert (not erc-nickbar-mode)) + (setq erc-speedbar--hidden-speedbar-frame nil)) + (dolist (window (get-buffer-window-list speedbar-buffer nil t)) + (unless (frame-root-window-p window) + (when erc-speedbar--hidden-speedbar-frame + (cl-assert (not (eq (window-frame window) + erc-speedbar--hidden-speedbar-frame)))) + (delete-window window))))) + + +;;;; Nicks integration + +(declare-function erc-nicks--highlight "erc-nicks" (nickname &optional face)) + +(defun erc-speedbar--compose-nicks-face (orig buffer user cuser) + (require 'erc-nicks) + (let ((rv (funcall orig buffer user cuser))) + (if-let ((nick (erc-server-user-nickname user)) + (face (with-current-buffer buffer + (erc-nicks--highlight nick rv))) + ((not (eq face erc-button-nickname-face)))) + (cons face (ensure-list rv)) + rv))) + + (provide 'erc-speedbar) ;;; erc-speedbar.el ends here ;; diff --git a/test/lisp/erc/erc-scenarios-status-sidebar.el b/test/lisp/erc/erc-scenarios-status-sidebar.el index 5144069ec0e..92229121c9f 100644 --- a/test/lisp/erc/erc-scenarios-status-sidebar.el +++ b/test/lisp/erc/erc-scenarios-status-sidebar.el @@ -90,4 +90,80 @@ (erc-status-sidebar-kill) (should-not (get-buffer "*ERC Status*")))))) +;; We can't currently run this on EMBA because it needs a usable +;; terminal, and we lack a fixture for that. Please try running this +;; test interactively with both graphical Emacs and non. +(declare-function erc-nickbar-mode "erc-speedbar" (arg)) +(declare-function erc-speedbar-close-nicknames-window "erc-speedbar" (kill)) +(declare-function speedbar-timer-fn "speedbar" nil) +(defvar erc-nickbar-mode) +(defvar speedbar-buffer) + +(ert-deftest erc-scenarios-status-sidebar--nickbar () + :tags '(:unstable :expensive-test) + (when noninteractive (ert-skip "Interactive only")) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/gapless-connect") + (erc-server-flood-penalty 0.1) + (erc-server-flood-penalty erc-server-flood-penalty) + (erc-modules `(nickbar ,@erc-modules)) + (dumb-server (erc-d-run "localhost" t 'foonet 'barnet)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to two different endpoints") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (funcall expect 10 "MOTD File is missing")) + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "barnet:changeme" + :full-name "tester") + (funcall expect 10 "marked as being away"))) + + (erc-d-t-wait-for 20 (get-buffer "#bar")) + (with-current-buffer (pop-to-buffer "#bar") + (funcall expect 10 "was created on") + (funcall expect 2 "his second fit") + (erc-d-t-wait-for 10 (and speedbar-buffer (get-buffer speedbar-buffer))) + (speedbar-timer-fn) + (with-current-buffer speedbar-buffer + (funcall expect 10 "#bar (3)") + (funcall expect 10 '(| "@mike" "joe")) + (funcall expect 10 '(| "@mike" "joe")) + (funcall expect 10 "tester"))) + + (erc-d-t-wait-for 20 (get-buffer "#foo")) + (with-current-buffer (pop-to-buffer "#foo") + (delete-other-windows) + (funcall expect 10 "was created on") + (funcall expect 2 "no use of him") + (speedbar-timer-fn) + (with-current-buffer speedbar-buffer + (funcall expect 10 "#foo (3)") + (funcall expect 10 '(| "alice" "@bob")) + (funcall expect 10 '(| "alice" "@bob")) + (funcall expect 10 "tester"))) + + (with-current-buffer "#foo" + (ert-info ("Core toggle and kill commands work") + ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p', + ;; etc. for testing commands that call those same functions. + (erc-nickbar-mode -1) + (should-not (and speedbar-buffer + (get-buffer-window speedbar-buffer))) + (erc-nickbar-mode +1) + (should (and speedbar-buffer + (get-buffer-window speedbar-buffer))) + (should (get-buffer " SPEEDBAR")) + (erc-speedbar-close-nicknames-window 'kill) + (should-not (get-buffer " SPEEDBAR")) + (should-not erc-nickbar-mode) + (should-not (cdr (frame-list))))))) + ;;; erc-scenarios-status-sidebar.el ends here From 08515350faff03e4206e7ed4dfacffc55a4779cd Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 4 May 2023 00:01:11 -0700 Subject: [PATCH 15/22] Add mini modules bufbar and nickbar to ERC * doc/misc/erc.texi: Add `bufbar' and `nickbar' to known modules. Also add `keep-place', which was missing, and remove `bbdb', which is not part of ERC. Add new section "Auxiliary Modules" for listing experimental modules or those typically managed by some other feature. * erc/ERC-NEWS: Mention new mini modules for libraries erc-status-sidebar.el and erc-speedbar.el. * lisp/erc/erc.el (erc-modules): Add `bufbar' and `nickbar' to selection of offered modules. * test/lisp/erc/erc-tests.el (erc-tests--modules): Add `bufbar' and `nickbar'. (Bug#63595) --- doc/misc/erc.texi | 43 +++++++++++++++++++++++++++++++++++--- etc/ERC-NEWS | 16 ++++++++++++++ lisp/erc/erc.el | 2 ++ test/lisp/erc/erc-tests.el | 4 ++-- 4 files changed, 60 insertions(+), 5 deletions(-) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 52a1d57fd45..d59c6d8a6c6 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -414,9 +414,10 @@ Set away status automatically @item autojoin Join channels automatically -@cindex modules, bbdb -@item bbdb -Integrate with the Big Brother Database +@cindex modules, bufbar +@item bufbar +List buffers belonging to a connection in a side window; part of +Custom group @code{erc-status-sidebar} @cindex modules, button @item button @@ -443,6 +444,10 @@ Launch an identd server on port 8113 @item irccontrols Highlight or remove IRC control characters +@cindex modules, keep-place +@item keep-place +Remember your position in buffers + @cindex modules, log @item log Save buffers in logs @@ -463,6 +468,11 @@ Detect netsplits @item nicks Automatically colorize nicks +@cindex modules, nickbar +@item nickbar +List participating nicks for the current target buffer in a side +window; part of Custom group @code{erc-speedbar} + @cindex modules, noncommands @item noncommands Don't display non-IRC commands after evaluation @@ -534,6 +544,33 @@ Translate morse code in messages @end table +@anchor{Auxiliary Modules} +@subheading Auxiliary Modules +@cindex auxiliary modules + +For various reasons, the following modules aren't currently listed in +the Custom interface for @code{erc-modules}, but feel free to add them +explicitly. They may be managed by another module or considered more +useful when toggled interactively or just deemed experimental. + +@table @code + +@cindex modules, fill-wrap +@item fill-wrap +Wrap long lines using @code{visual-line-mode} + +@cindex modules, keep-place-indicator +@item keep-place-indicator +Remember your place in buffers with a visible reminder; activated +interactively or via something like @code{erc-join-hook} + +@cindex modules, services-regain +@item services-regain +Automatically ask NickServ to reclaim your nick when reconnecting; +experimental as of ERC 5.6 + +@end table + @anchor{Required Modules} @subheading Required Modules @cindex required modules diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index fde4c64c32d..65fee9e05cd 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -84,6 +84,22 @@ widget has been an age-old annoyance for new users. Previously ineffective, this method now actually works, but it also admonishes users to edit the 'erc-modules' widget instead. +** ERC's status-sidebar has gained an accompanying module. +Users can now add 'bufbar' to 'erc-modules' to achieve the same effect +as toggling 'erc-status-sidebar-open' manually at the start of an IRC +session. The module has also been outfitted to show channels and +queries under their respective servers by default. To avoid +confusion, the major mode used for the sidebar buffer itself, +'erc-status-sidebar-mode', is no longer available interactively. + +** A new spin on a classic integration in erc-speedbar. +Add 'nickbar' to 'erc-modules' to spawn a dynamically updating side +window listing all the users in any target buffer. It's powered by +the same speedbar.el integration you've always known, except this +one's optionally accessible from the keyboard, just like any other +side window. Hit '' over a nick to spawn a "/QUERY" or a +"Lastlog" (Occur) session. See 'erc-nickbar-mode' for more. + ** The option 'erc-timestamp-use-align-to' is more versatile. While this option has always offered to right-align stamps via the 'display' text property, it's now more effective at doing so when set diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 07c62c935c3..03c21059a92 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2046,6 +2046,7 @@ removed from the list will be disabled." :greedy t (const :tag "autoaway: Set away status automatically" autoaway) (const :tag "autojoin: Join channels automatically" autojoin) + (const :tag "bufbar: Show ERC buffers in a side window" bufbar) (const :tag "button: Buttonize URLs, nicknames, and other text" button) (const :tag "capab: Mark unidentified users on servers supporting CAPAB" capab-identify) @@ -2066,6 +2067,7 @@ removed from the list will be disabled." move-to-prompt) (const :tag "netsplit: Detect netsplits" netsplit) (const :tag "networks: Provide data about IRC networks" networks) + (const :tag "nickbar: Show nicknames in a dyamic side window" nickbar) (const :tag "nicks: Uniquely colorize nicknames in target buffers" nicks) (const :tag "noncommands: Don't display non-IRC commands after evaluation" noncommands) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index cc69641fb0b..b5db5fe8764 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1951,9 +1951,9 @@ (kill-buffer "#chan"))) (defconst erc-tests--modules - '( autoaway autojoin button capab-identify completion dcc fill identd + '( autoaway autojoin bufbar button capab-identify completion dcc fill identd imenu irccontrols keep-place list log match menu move-to-prompt netsplit - networks nicks noncommands notifications notify page readonly + networks nickbar nicks noncommands notifications notify page readonly replace ring sasl scrolltobottom services smiley sound spelling stamp track truncate unmorse xdcc)) From 80e5e9ddc8d76993fa44a659307174b778aa60b7 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Thu, 29 Jun 2023 07:12:46 -0700 Subject: [PATCH 16/22] Improve walkthrough and sample config in ERC manual * doc/misc/erc.texi: Improve "Sample Session" and "Sample Configuration" sections. Move introductory paragraph detailing the history of official GNU IRC channels to the "History" chapter (from "Sample Sessoin"), and leave a link in its place. Silence strange warning in "Getting Help and Reporting Bugs" about lack of punctuation after xref. --- doc/misc/erc.texi | 447 +++++++++++++++++++++++++++++++++++----------- 1 file changed, 342 insertions(+), 105 deletions(-) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index d59c6d8a6c6..63ea94d9b2e 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -144,11 +144,11 @@ the @samp{#emacs} channels where you can chat with other Emacs users, and if you're having trouble with ERC, you can join the @samp{#erc} channel and ask for help there. -If you want to place ERC settings in their own file, you can place them -in @file{~/.emacs.d/.ercrc.el}, creating it if necessary. - -If you would rather use the Customize interface to change how ERC -works, do @kbd{M-x customize-group @key{RET} erc @key{RET}}. In +At some point in your ERC journey, you'll inevitably want to change +how the client looks and behaves. As with other Emacs applications, +the typical place to store your settings is your @file{init.el}. If +you would rather use the Customize interface, a good place to start is +by running @kbd{M-x customize-group @key{RET} erc @key{RET}}. In particular, ERC comes with lots of modules that may be enabled or disabled; to select which ones you want, do @kbd{M-x customize-variable @key{RET} erc-modules @key{RET}}. @@ -161,69 +161,90 @@ customize-variable @key{RET} erc-modules @key{RET}}. @node Sample Session @section Sample Session -This is an example ERC session which shows how to connect to the -@samp{#emacs} channel on Libera.Chat. Another IRC channel on -Libera.Chat that may be of interest is @samp{#erc}, which is a channel -where ERC users and developers hang out. These channels used to live -on the Freenode IRC network until June 2021, when they---along with -the official IRC channels of the GNU Project, the Free Software -Foundation, and many other free software communities---relocated to -the Libera.Chat network in the aftermath of changes in governance and -policies of Freenode in May and June 2021. GNU and FSF's -announcements about this are at -@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00005.html}, -@uref{https://lists.gnu.org/archive/html/info-gnu/2021-06/msg00007.html}, -and -@uref{https://lists.gnu.org/archive/html/info-gnu-emacs/2021-06/msg00000.html}. +This example ERC session describes how to connect to the @samp{#emacs} +channel on Libera.Chat. Also worth checking out is Libera's own +introductory guide to IRC, @uref{https://libera.chat/guides/basics}, +which presents a more comprehensive overview without instructions +specific to ERC. @itemize @bullet @item Connect to Libera.Chat -Run @kbd{M-x erc}. Use ``irc.libera.chat'' as the IRC server, ``6667'' -as the port, and choose a nickname. +Run @kbd{M-x erc @key{RET}}. Use @samp{irc.libera.chat} for the +server and @samp{6667} for the port. Choose a nickname, and hit +@key{y} when asked if you'd prefer to connect over @acronym{TLS}. @item Get used to the interface -Switch to the ``irc.libera.chat:6667'' buffer, if you're not already -there. You will see first some messages about checking for ident, and -then a bunch of other messages that describe the current IRC server. +Switch to the @file{Libera.Chat} buffer if you're not already there. +ERC calls this a @dfn{server buffer}, and it must exist for the +duration of the session. You will likely see some messages about +``ident'', authentication, and the like, followed by information +describing the current server and the network. @item Join the #emacs channel -In that buffer, type ``/join @key{SPC} #emacs'' and hit @kbd{RET}. Depending -on how you've set up ERC, either a new buffer for ``#emacs'' will be -displayed, or a new buffer called ``#emacs'' will be created in the -background. If the latter, switch to the ``#emacs'' buffer. You will -see the channel topic and a list of the people who are currently on the -channel. +In the server buffer, type @kbd{/join #emacs @key{RET}} at the prompt. +ERC will create a new buffer called @file{#emacs}. If you've already +configured ERC, you may need to switch to it manually. Once there, +you will see the channel's ``topic'' in the buffer's header line +(@pxref{Header Lines,,,elisp,}) and a list of people currently in the +channel. If you can't see the full topic, mouse over it or type +@kbd{/topic @key{RET}} at the prompt. @item Register your nickname with Libera.Chat -If you would like to be able to talk with people privately on the -Libera.Chat network, you will have to ``register'' your nickname. -To do so, switch to the ``irc.libera.chat:6667'' buffer and type -``/msg NickServ register '', replacing ``'' with -your desired password. It should tell you that the operation was -successful. +In order to access essential network features, like speaking in +certain channels and participating in private conversations, you'll +likely have to ``register'' your nickname. To do so, switch to the +@file{Libera.Chat} buffer and type @kbd{/msg NickServ register +@samp{} @samp{} @key{RET}}, replacing +@samp{} and @samp{} with your desired account +password and contact email (both sans quotes). The server should tell +you that the operation was successful. See the official Libera.Chat +docs if you encounter problems. + +In addition to creating an account, this process also +``authenticates'' you to the network's ``account services'' system for +the duration of the session. In other words, you're now logged in. +However, when you connect in the future, you'll need to authenticate +again by providing the same credentials somehow. When you're finished +with this walk through, see ``Next Steps'', below, to learn some ways +to do that. @item Talk to people in the channel -If you switch back to the ``#emacs'' buffer, you can type a message, and -everyone on the channel will see it. +Switch back to the @file{#emacs} buffer and type a message at the +prompt, hitting @kbd{RET} once satisfied. Everyone in the channel +will now see your message. @item Open a query buffer to talk to someone -If you want to talk with someone in private (this should usually not be -done for technical help, only for personal questions), type ``/query -'', replacing ``'' with the nickname of the person you would -like to talk to. Depending on how ERC is set up, you will either see a -new buffer with the name of the person, or such a buffer will be created -in the background and you will have to switch to it. Begin typing -messages, and you will be able to have a conversation. +If you want to talk with someone in private, type @kbd{/query +@samp{} @key{RET}}, replacing @samp{} with the their +nickname. As before, with the server buffer, if this new @dfn{query +buffer} doesn't appear in the current window, you may have to switch +to it. Regardless, its name should match @samp{}. Once there, +type something at the prompt and hit @kbd{RET}, and the other party +will see it. -Note that if the other person is not registered, you will not be able to -talk with them. +Keep in mind that if either party isn't authenticated, you may not be +able to converse at all. Also, depending on the network, certain +social conventions may apply to the practice of direct messaging. As +a general rule, queries should usually be reserved for personal +matters rather than technical help, which can often benefit (and +benefit @emph{from}) a larger audience. + +@item Next steps + +Try joining another channel, such as @samp{#erc}, where ERC users and +developers hang out (@pxref{Official IRC channels} for more on the +history of @samp{#emacs}). For ideas on various options to customize, +@pxref{Sample Configuration}. To learn how ERC can authenticate you +to the network automatically whenever you connect, @pxref{SASL}. As +always, if you encounter problems, @pxref{Getting Help and Reporting +Bugs}. @end itemize @@ -1192,76 +1213,277 @@ case, you'll probably want to temporarily disable @section Sample Configuration @cindex configuration, sample -Here is an example of configuration settings for ERC@. This can go into -your Emacs configuration file. Everything after the @code{(require -'erc)} command can optionally go into @file{~/.emacs.d/.ercrc.el}. +Here is an example configuration for ERC@. @strong{Don't panic} if +you aren't familiar with @samp{use-package} or have no interest in +learning it. For our purposes, it's just a means of presenting +configuration details in a tidy, standardized format. If it helps, +just pretend it's some make-believe, pseudo configuration language. +Although the syntax below is easy enough to intuit and adapt to your +setup, you may wish to keep the following in mind (or @pxref{Top,,, +use-package,}): + +@itemize @bullet +@item +Each @code{use-package} ``declaration'' focuses on a library +``feature'', which is just a symbol you'd normally @code{require} in +your config @pxref{Named Features,,, elisp,}). + +@item +Emacs loads anything in a @code{:config} section @emph{after} loading +whatever library @code{provide}s the declaration's feature. + +@item +Everything in a @code{:custom} or @code{:custom-face} section is +basically something you'd find in your @code{custom-file}. +@end itemize + +@noindent +The following would typically go in your init file. Experienced users +may opt to keep any non-settings, like commands and functions, in a +dedicated @file{~/.emacs.d/.ercrc.el}. Whatever the case, please keep +in mind that you can replace nearly all of the following with Custom +settings (@pxref{Sample configuration via Customize}). @lisp -;;; Sample ERC configuration +;;; My ERC configuration -*- lexical-binding: t -*- -;; Load authentication info from an external source. Put sensitive -;; passwords and the like in here. -(load "~/.emacs.d/.erc-auth") +(use-package erc + :config + ;; Prefer SASL to NickServ, colorize nicknames, interpret mIRC colors, + ;; and list buffers and channel members in separate side panels. + (setopt erc-modules + (seq-union '(sasl nicks irccontrols bufbar nickbar scrolltobottom) + erc-modules)) -;; This is an example of how to make a new command. Type "/uptime" to -;; use it. -(defun erc-cmd-UPTIME (&rest ignore) - "Display the uptime of the system, as well as some load-related -stuff, to the current ERC buffer." - (let ((uname-output - (replace-regexp-in-string - ", load average: " "] @{Load average@} [" - ;; Collapse spaces, remove - (replace-regexp-in-string - " +" " " - ;; Remove beginning and trailing whitespace - (replace-regexp-in-string - "^ +\\|[ \n]+$" "" - (shell-command-to-string "uptime")))))) - (erc-send-message - (concat "@{Uptime@} [" uname-output "]")))) + :custom + ;; Protect me from accidentally sending excess lines. + (erc-inhibit-multiline-input t) + (erc-send-whitespace-lines t) + (erc-ask-about-multiline-input t) -;; This causes ERC to connect to the Libera.Chat network upon hitting -;; C-c e f. Replace MYNICK with your IRC nick. -(global-set-key "\C-cef" (lambda () (interactive) - (erc :server "irc.libera.chat" :port "6667" - :nick "MYNICK"))) + ;; Reconnect automatically using a fancy strategy. + (erc-server-reconnect-function #'erc-server-delayed-check-reconnect) + (erc-server-reconnect-timeout 30) -;; This causes ERC to connect to the IRC server on your own machine (if -;; you have one) upon hitting C-c e b. Replace MYNICK with your IRC -;; nick. Often, people like to run bitlbee (https://bitlbee.org/) as an -;; AIM/Jabber/MSN to IRC gateway, so that they can use ERC to chat with -;; people on those networks. -(global-set-key "\C-ceb" (lambda () (interactive) - (erc :server "localhost" :port "6667" - :nick "MYNICK"))) + ;; Insert a newline when I hit at the prompt, and prefer + ;; something more deliberate for actually sending messages. + :bind (:map erc-mode-map + ("RET" . nil) + ("C-c C-c" . #'erc-send-current-line)) -;; Make C-c RET (or C-c C-RET) send messages instead of RET. This has -;; been commented out to avoid confusing new users. -;; (define-key erc-mode-map (kbd "RET") nil) -;; (define-key erc-mode-map (kbd "C-c RET") 'erc-send-current-line) -;; (define-key erc-mode-map (kbd "C-c C-RET") 'erc-send-current-line) + ;; Emphasize buttonized text in notices. + :custom-face (erc-notice-face ((t (:slant italic :weight unspecified))))) -;;; Options +(use-package erc-sasl + ;; Since my account name is the same as my nick, free me from having + ;; to hit C-u before M-x erc to trigger a username prompt. + :custom (erc-sasl-user :nick)) -;; Join the #emacs and #erc channels whenever connecting to -;; Libera.Chat. -(setq erc-autojoin-channels-alist - '(("Libera.Chat" "#emacs" "#erc"))) +(use-package erc-join + ;; Join #emacs and #erc whenever I connect to Libera.Chat. + :custom (erc-autojoin-channels-alist '((Libera.Chat "#emacs" "#erc")))) -;; Interpret mIRC-style color commands in IRC chats -(setq erc-interpret-mirc-color t) +(use-package erc-fill + :custom + ;; Prefer one message per line without continuation indicators. + (erc-fill-function #'erc-fill-wrap) + (erc-fill-static-center 18) + + :bind (:map erc-fill-wrap-mode-map ("C-c =" . #'erc-fill-wrap-nudge))) + +(use-package erc-track + ;; Prevent JOINs and PARTs from lighting up the mode-line. + :config (setopt erc-track-faces-priority-list + (remq 'erc-notice-face erc-track-faces-priority-list)) + + :custom (erc-track-priority-faces-only 'all)) + +(use-package erc-goodies + ;; Turn on read indicators when joining channels. + :hook (erc-join . my-erc-enable-read-indicator-on-join)) + +(defvar my-erc-read-indicator-channels '("#emacs") + "Channels in which to show a `keep-place-indicator'.") + +(defun my-erc-enable-read-indicator-on-join () + "Enable read indicators for certain queries or channels." + (when (member (erc-default-target) my-erc-read-indicator-channels) + (erc-keep-place-indicator-mode +1))) + +;; Handy commands from the Emacs Wiki. +(defun erc-cmd-TRACK (&optional target) + "Start tracking TARGET or that of current buffer." + (setq erc-track-exclude (delete (or target (erc-default-target)) + erc-track-exclude))) + +(defun erc-cmd-UNTRACK (&optional target) + "Stop tracking TARGET or that of current buffer." + (setq erc-track-exclude (cl-pushnew (or target (erc-default-target)) + erc-track-exclude + :test #'equal))) -;; The following are commented out by default, but users of other -;; non-Emacs IRC clients might find them useful. -;; Kill buffers for channels after /part -;; (setq erc-kill-buffer-on-part t) -;; Kill buffers for private queries after quitting the server -;; (setq erc-kill-queries-on-quit t) -;; Kill buffers for server messages after quitting the server -;; (setq erc-kill-server-buffer-on-quit t) @end lisp +@noindent +Those familiar with @code{use-package} may have noticed the lack of +@code{:defer} keyword args. This was done to conserve space, but you +can just pretend that this user has enabled +@code{use-package-always-defer} elsewhere. + +@anchor{Sample configuration via Customize} +@subheading Via Customize +@cindex configuration, via customize + +As mentioned, Customize users can accomplish nearly all of the above +via the Customize interface. Start by running @kbd{M-x +customize-group @key{RET} erc @key{RET}}, and search for ``Modules'' +with @kbd{C-s modules @key{RET}}. Toggle open the flyout menu to +reveal the full ``widget'' panel, a web-form-like interface for ``Erc +Modules''. Tick the boxes for @samp{bufbar}, @samp{irccontrols}, +@samp{nickbar}, @samp{nicks}, @samp{sasl}, and @samp{scrolltobottom}. + +Next, search for the phrases ``Erc Ask About Multiline Input'', ``Erc +Inhibit Mulitline Input'', and ``Erc Send Whitespace Lines''. These +are the print names of three Boolean options that control how ERC +treats prompt input containing line breaks. When visiting each +option's section, twirl open its triangle icon to reveal its widget +UI, and click its @samp{[Toggle]} button to set its value to @code{t}. +While going about this, you may find it helpful to glance at the +descriptions just in case you want to disable them later. When +finished, hit @kbd{C-x C-s} or click @samp{[Apply and Save]} atop the +buffer. + +Now do the same for another couple options, this time having to do +with automatic reconnection. But instead of searching for their print +names, try running @kbd{M-x customize-option @key{RET} @samp{