From 78bba39e65b168a117c077518f2aee2a8465e470 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Wed, 21 Jun 2023 06:36:45 -0700 Subject: [PATCH 0/2] *** NOT A PATCH *** *** BLURB HERE *** F. Jason Park (2): Revert "Allow erc-reuse-frames to favor connections" [5.6] Allow custom display-buffer actions in ERC etc/ERC-NEWS | 20 +- lisp/erc/erc-backend.el | 9 +- lisp/erc/erc.el | 217 ++++++++++++--------- test/lisp/erc/erc-tests.el | 376 +++++++------------------------------ 4 files changed, 212 insertions(+), 410 deletions(-) Interdiff: diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 6cec2919460..9177f61f8cc 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -58,8 +58,8 @@ option (now known as 'erc-receive-query-display') is nil, ERC uses 'erc-interactive-display'. The old nil behavior can still be gotten via the new compatibility flag 'erc-receive-query-display-defer'. -A few subtleties affecting the display of new or reassociated buffers -have also been introduced. One involves buffers that already occupy +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 diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index a0e89795a57..f1dafd0dbf8 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1555,10 +1555,10 @@ erc--buffer-display-choices (const :tag "New frame" frame) (const :tag "Don't display" bury) (const :tag "Use current window" buffer) - (choice :tag "Show in granular, context-aware manner" - (function-item erc-display-buffer-in-existing-frame) - (function-item erc-display-buffer-ensuring-frame) - (function :tag "User-provided function"))) + (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) @@ -1576,24 +1576,23 @@ erc-buffer-display `frame' - in another frame, `bury' - bury it in a new buffer, `buffer' - in place of the current buffer, - DISPLAY-FUNCTION - called with a buffer and an ACTION-ALIST + DISPLAY-FUNCTION - a `display-buffer'-like function -Here, DISPLAY-FUNCTION should accept a buffer and an ACTION-ALIST -of the kind described by the Info node `(elisp) Buffer Display -Action Alists'. Note that unlike a full display \"action\", this -lacks a function (or list of functions) at its head. At times, -ERC may add hints about the calling context to this alist. Keys -are symbols of options themselves, like `erc-buffer-display'. -Values are chosen from a set of predefined constants. In the -case of this option specifically, ERC uses the symbols +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 of user options, like +`erc-buffer-display', and values are predefined 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, users may prefer to call -DISPLAY-FUNCTION directly on a returned buffer (in this case, -server buffer) because the context leading to its creation is +When dealing with the latter two, users may prefer to call +DISPLAY-FUNCTION directly on (server) buffers returned by these +entry points because the context leading to their creation is plainly obvious. Note that when the selected window already shows the current @@ -1614,9 +1613,9 @@ erc-interactive-display values. When the value is a user-provided function, ERC may inject a hint -about the invocation context as an extra item in the alist passed -as the second argument. The hint item's key is the symbol -`erc-interactive-display' and its value one of +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', `url', `erc', or `erc-tls'. @@ -1635,9 +1634,9 @@ erc-reconnect-display `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 second, \"action alist\" -argument. The item's key is the symbol `erc-reconnect-display' -and its value something non-nil." +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-reconnect-display' and its value something non-nil." :package-version '(ERC . "5.5") :group 'erc-buffers :type erc--buffer-display-choices) @@ -1666,13 +1665,13 @@ erc-frame-dedicated-flag (defcustom erc-reuse-frames t "Determines whether new frames are always created. Non-nil means only create a frame for undisplayed buffers. Nil -means always create a new frame. Regardless of its value, this -option is ignored unless `erc-join-buffer' is set to `frame'. -And like most options in the `erc-buffer' customize group, this -has no effect on server buffers while reconnecting because those -are always buried." +means always create a new frame. Regardless of its value, ERC +ignores this option unless `erc-join-buffer' is `frame'. And +like most options in the `erc-buffer' customize group, this has +no effect on server buffers while reconnecting because ERC always +buries those." :group 'erc-buffers - :type '(choice boolean)) + :type 'boolean) (defun erc-channel-p (channel) "Return non-nil if CHANNEL seems to be an IRC channel name." @@ -2125,74 +2124,6 @@ erc--updating-modules-p confidently call (erc-foo-mode 1) without having to learn anything about the dependency's implementation.") -(defun erc--setup-buffer-first-window (frame a b) - (catch 'found - (walk-window-tree - (lambda (w) - (when (cond ((functionp a) (with-current-buffer (window-buffer w) - (funcall a b))) - (t (eq (buffer-local-value a (window-buffer w)) b))) - (throw 'found t))) - frame nil 0))) - -(defun erc--display-buffer-use-some-frame (buffer alist) - "Maybe display BUFFER in an existing frame for the same connection. -If performed, return winning window; otherwise, return nil. -Forward ALIST to `display-buffer' machinery." - (let* ((idp (lambda (value) - (and erc-networks--id - (erc-networks--id-equal-p erc-networks--id value)))) - (procp (lambda (frame) - (erc--setup-buffer-first-window frame idp erc-networks--id))) - (anyp (assq 'erc--frame-any alist)) - (ercp (lambda (frame) - (let ((val (erc--setup-buffer-first-window frame 'major-mode - 'erc-mode))) - (if anyp val (not val))))) - new) - (when (or (cdr (frame-list)) - (funcall ercp (selected-frame)) - (and (not anyp) - (push `(pop-up-frame-parameters ,erc-frame-alist) alist) - (setq new t))) - (or (and new (display-buffer-pop-up-frame buffer alist)) - ;; Workaround to avoid calling `window--display-buffer' directly. - (display-buffer-use-some-frame buffer `((frame-predicate . ,procp) - ,@alist)) - (display-buffer-use-some-frame buffer `((frame-predicate . ,ercp) - ,@alist)))))) - -(defun erc-display-buffer-in-existing-frame (buffer alist) - "Display BUFFER in an existing frame with others from ERC. -Use any existing, potentially hidden frame already displaying a -buffer from the same network context or, failing that, a frame -showing any ERC buffer. As a last resort, use the selected -frame, except for brand new connections, which always get the -invoking frame. Pass ALIST along to `display-buffer'." - (unless (get-buffer-window buffer t) - (display-buffer buffer `((erc--display-buffer-use-some-frame) - (erc--frame-any . t) - (inhibit-switch-frame . t) - (inhibit-same-window . t) - ,@alist)))) - -(defun erc-display-buffer-ensuring-frame (buffer alist) - "Display BUFFER in a frame with others from its connection. -Use any frame already displaying a buffer from the same network -context. Failing that, create one unless some existing frame is -free of any ERC buffers, in which case, use that. Pass ALIST -along to `display-buffer'. - -WARNING: if a frame for the existing connection does not exist, -this function may raise a new one and steal focus." - (unless (get-buffer-window buffer t) - (let ((interactivep (alist-get 'erc-interactive-display alist))) - (display-buffer buffer `((erc--display-buffer-use-some-frame) - ,@(and (not interactivep) - '((inhibit-same-window . t))) - (inhibit-switch-frame . t) - ,@alist))))) - (defvar erc--setup-buffer-hook nil "Internal hook for module setup involving windows and frames.") @@ -2210,6 +2141,11 @@ erc-skip-displaying-selected-window-buffer (make-obsolete 'erc-show-already-displayed-buffer "non-nil behavior to be made permanent" "30.1") +(defvar-local erc--display-buffer-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 @@ -2219,7 +2155,7 @@ erc-setup-buffer ((and (pred functionp) disp-fn (let context erc--display-context)) (unless (zerop erc--server-last-reconnect-count) (push '(erc-reconnect-display . t) context)) - (funcall disp-fn buffer context)) + (funcall disp-fn buffer (cons nil context))) ((guard (and erc-skip-displaying-selected-window-buffer (eq (window-buffer) buffer)))) ('window @@ -2419,8 +2355,10 @@ erc-open ;; 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-action display-buffer-overriding-action))) + (erc-setup-buffer buffer) + (run-hooks 'erc--setup-buffer-hook))) buffer)) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 6e45a9731ed..6dbd0d4704f 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -503,309 +503,6 @@ erc--switch-to-buffer (dolist (b '("server" "other" "#chan" "#foo" "#fake")) (kill-buffer b)))) -(defun erc-tests--run-in-term (&optional debug) - (let* ((default-directory (getenv "EMACS_TEST_DIRECTORY")) - (emacs (expand-file-name invocation-name invocation-directory)) - (process-environment (cons "ERC_TESTS_SUBPROCESS=1" - process-environment)) - (name (ert-test-name (ert-running-test))) - (temp-file (make-temp-file "erc-term-test-")) - (cmd `(let ((stats 1)) - (setq enable-dir-local-variables nil) - (unwind-protect - (setq stats (ert-run-tests-batch ',name)) - (unless ',debug - (let ((buf (with-current-buffer (messages-buffer) - (buffer-string)))) - (with-temp-file ,temp-file - (insert buf))) - (kill-emacs (ert-stats-completed-unexpected stats)))))) - ;; `ert-test' object in Emacs 29 has a `file-name' field - (file-name (symbol-file name 'ert--test)) - (default-directory (expand-file-name (file-name-directory file-name))) - (package (if-let* ((found (getenv "ERC_PACKAGE_NAME")) - ((string-prefix-p "erc-" found))) - (intern found) - 'erc)) - (setup (and (featurep 'compat) - `(progn - (require 'package) - (let ((package-load-list '((compat t) (,package t)))) - (package-initialize))))) - ;; Make subprocess terminal bigger than controlling. - (buf (cl-letf (((symbol-function 'window-screen-lines) - (lambda () 20)) - ((symbol-function 'window-max-chars-per-line) - (lambda () 40))) - (make-term (symbol-name name) emacs nil "-Q" "-nw" - "-eval" (prin1-to-string setup) - "-l" file-name "-eval" (format "%S" cmd)))) - (proc (get-buffer-process buf)) - (err (lambda () - (with-temp-buffer - (insert-file-contents temp-file) - (message "Subprocess: %s" (buffer-string)) - (delete-file temp-file))))) - (with-current-buffer buf - (set-process-query-on-exit-flag proc nil) - (with-timeout (10 (funcall err) (error "Timed out awaiting result")) - (while (process-live-p proc) - (accept-process-output proc 0.1))) - (while (accept-process-output proc)) - (goto-char (point-min)) - ;; Otherwise gives process exited abnormally with exit-code >0 - (unless (search-forward (format "Process %s finished" name) nil t) - (funcall err) - (ert-fail (when (search-forward "exited" nil t) - (buffer-substring-no-properties (line-beginning-position) - (line-end-position))))) - (delete-file temp-file) - (when noninteractive - (kill-buffer))))) - -(defun erc-tests--servars (source &rest vars) - (unless (bufferp source) - (setq source (get-buffer source))) - (dolist (var vars) - (should (local-variable-if-set-p var)) - (set var (buffer-local-value var source)))) - -(defun erc-tests--erc-reuse-frames (test &optional debug) - (if (and (or debug noninteractive) (not (getenv "ERC_TESTS_SUBPROCESS"))) - (progn - (when (memq system-type '(windows-nt ms-dos)) - (ert-skip "System must be UNIX")) - (erc-tests--run-in-term debug)) - (should-not erc-frame-dedicated-flag) - (should (eq erc-reuse-frames t)) - (let ((erc-join-buffer 'frame) - (erc-reuse-frames t) - (erc-frame-alist nil) - (orig-frame (selected-frame)) - erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) - (delete-other-frames) - (delete-other-windows) - (set-window-buffer (selected-window) "*scratch*") - (funcall test orig-frame) - (delete-other-frames orig-frame) - (delete-other-windows)))) - -;; TODO add cases for frame-display behavior while reconnecting - -(defun erc-tests--erc-reuse-frames--t (_) - (ert-info ("New server buffer creates and raises second frame") - (with-current-buffer (generate-new-buffer "server") - (erc-mode) - (setq erc-server-process (start-process "server" - (current-buffer) "sleep" "10") - erc-frame-alist (cons '(name . "server") default-frame-alist) - erc-network 'foonet - erc-networks--id (erc-networks--id-create nil) - erc--server-last-reconnect-count 0) - (set-process-buffer erc-server-process (current-buffer)) - (set-process-query-on-exit-flag erc-server-process nil) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (should (equal "server" (frame-parameter (window-frame) 'name))) - (should (get-buffer-window (current-buffer) t)))) - - (ert-info ("New channel creates and raises third frame") - (with-current-buffer (generate-new-buffer "#chan") - (erc-mode) - (erc-tests--servars "server" 'erc-server-process 'erc-networks--id - 'erc-network) - (setq erc-frame-alist (cons '(name . "#chan") default-frame-alist) - erc-default-recipients '("#chan")) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (should (equal "#chan" (frame-parameter (window-frame) 'name))) - (should (get-buffer-window (current-buffer) t)) - (should (cddr (frame-list)))))) - -(ert-deftest erc-reuse-frames--t () - :tags '(:unstable :expensive-test) - (erc-tests--erc-reuse-frames - (lambda (orig-frame) - (erc-tests--erc-reuse-frames--t orig-frame) - (dolist (b '("server" "#chan")) - (kill-buffer b))))) - -(defun erc-tests--erc-reuse-frames--displayed-single (_ server-name chan-name) - - (should (eq erc-buffer-display #'erc-display-buffer-in-existing-frame)) - - (ert-info ("New server buffer shown in existing frame") - (with-current-buffer (generate-new-buffer server-name) - (erc-mode) - (setq erc-server-process (start-process server-name (current-buffer) - "sleep" "10") - erc-frame-alist (cons `(name . ,server-name) default-frame-alist) - erc-network (make-symbol server-name) - erc-server-current-nick "tester" - erc-networks--id (erc-networks--id-create nil) - erc--server-last-reconnect-count 0) - (set-process-buffer erc-server-process (current-buffer)) - (set-process-query-on-exit-flag erc-server-process nil) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (should-not (equal server-name (frame-parameter (window-frame) 'name))) - ;; New server buffer window appears in split below ERT/scratch - (should (get-buffer-window (current-buffer) t)))) - - (ert-info ("New channel shown in existing frame") - (with-current-buffer (generate-new-buffer chan-name) - (erc-mode) - (erc-tests--servars server-name 'erc-server-process 'erc-networks--id - 'erc-network) - (setq erc-frame-alist (cons `(name . ,chan-name) default-frame-alist) - erc-default-recipients (list chan-name)) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (should-not (equal chan-name (frame-parameter (window-frame) 'name))) - ;; New channel buffer replaces server in lower window - (should (get-buffer-window (current-buffer) t)) - (should-not (get-buffer-window server-name t))))) - -(ert-deftest erc-reuse-frames--displayed-single () - :tags '(:unstable :expensive-test) - (erc-tests--erc-reuse-frames - (lambda (orig-frame) - (let ((erc-buffer-display #'erc-display-buffer-in-existing-frame)) - (erc-tests--erc-reuse-frames--displayed-single orig-frame - "server" "#chan") - (should-not (cdr (frame-list)))) - (dolist (b '("server" "#chan")) - (kill-buffer b))))) - -(defun erc-tests--assert-server-split (buffer-or-name frame-name) - ;; Assert current buffer resides on one side of a horizontal split - ;; in the "server" frame but is not selected. - (let* ((buffer-window (get-buffer-window buffer-or-name t)) - (buffer-frame (window-frame buffer-window))) - (should (equal frame-name (frame-parameter buffer-frame 'name))) - (should (memq buffer-window (car-safe (window-tree buffer-frame)))) - (should-not (eq buffer-window (frame-selected-window))) - buffer-frame)) - -(defun erc-tests--erc-reuse-frames--displayed-double (_) - (should (eq erc-buffer-display #'erc-display-buffer-in-existing-frame)) - - (make-frame '((name . "other"))) - (select-frame (make-frame '((name . "server"))) 'no-record) - (set-window-buffer (selected-window) "*scratch*") ; invokes `erc' - - ;; A user invokes an entry point and switches immediately to a new - ;; frame before autojoin kicks in (bug#55540). - - (ert-info ("New server buffer shown in selected frame") - (with-current-buffer (generate-new-buffer "server") - (erc-mode) - (setq erc-server-process (start-process "server" (current-buffer) - "sleep" "10") - erc-network 'foonet - erc-server-current-nick "tester" - erc-networks--id (erc-networks--id-create nil) - erc--server-last-reconnect-count 0) - (set-process-buffer erc-server-process (current-buffer)) - (set-process-query-on-exit-flag erc-server-process nil) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (should (equal "server" (frame-parameter (window-frame) 'name))) - (should (get-buffer-window (current-buffer) t)))) - - (select-frame-by-name "other") - - (ert-info ("New channel shown in dedicated frame") - (with-current-buffer (generate-new-buffer "#chan") - (erc-mode) - (erc-tests--servars "server" 'erc-server-process 'erc-networks--id - 'erc-network) - (setq erc-frame-alist (cons '(name . "#chan") default-frame-alist) - erc-default-recipients '("#chan")) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - (erc-tests--assert-server-split (current-buffer) "server") - ;; New channel buffer replaces server in lower window of other frame - (should-not (get-buffer-window "server" t))))) - -(ert-deftest erc-reuse-frames--displayed-double () - :tags '(:unstable :expensive-test) - (erc-tests--erc-reuse-frames - (lambda (orig-frame) - (let ((erc-buffer-display #'erc-display-buffer-in-existing-frame)) - (erc-tests--erc-reuse-frames--displayed-double orig-frame)) - (dolist (b '("server" "#chan")) - (kill-buffer b))))) - -;; If a frame showing ERC buffers exists among other frames, new, -;; additional connections will use the existing IRC frame. However, -;; if two or more frames exist with ERC buffers unique to a particular -;; connection, the correct frame will be found. - -(defun erc-tests--erc-reuse-frames--displayed-full (orig-frame) - (erc-tests--erc-reuse-frames--displayed-double orig-frame) - ;; Server buffer is not displayed because #chan has replaced it in - ;; the "server" frame, which is not selected. - (should (equal "other" (frame-parameter (window-frame) 'name))) - (erc-tests--erc-reuse-frames--displayed-single orig-frame "ircd" "#spam") - (should (equal "other" (frame-parameter (window-frame) 'name))) - - ;; Buffer "#spam" has replaced "ircd", which earlier replaced - ;; "#chan" in frame "server". But this is confusing, so... - (ert-info ("Arrange windows for second connection in other frame") - (set-window-buffer (selected-window) "ircd") - (split-window-below) - (set-window-buffer (next-window) "#spam") - (should (equal (cddar (window-tree)) - (list (get-buffer-window "ircd" t) - (get-buffer-window "#spam" t))))) - - (ert-info ("Arrange windows for first connection in server frame") - (select-frame-by-name "server") - (set-window-buffer (selected-window) "server") - (set-window-buffer (next-window) "#chan") - (should (equal (cddar (window-tree)) - (list (get-buffer-window "server" t) - (get-buffer-window "#chan" t))))) - - ;; Select original ERT frame - (ert-info ("New target for connection server finds appropriate frame") - (select-frame orig-frame 'no-record) - (with-current-buffer (window-buffer (selected-window)) - (should (member (buffer-name) '("*ert*" "*scratch*"))) - (with-current-buffer (generate-new-buffer "alice") - (erc-mode) - (erc-tests--servars "server" 'erc-server-process 'erc-networks--id) - (setq erc-default-recipients '("alice")) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - ;; Window created in frame "server" - (should (eq (selected-frame) orig-frame)) - (erc-tests--assert-server-split (current-buffer) "server")))) - - (ert-info ("New target for connection ircd finds appropriate frame") - (select-frame orig-frame 'no-record) - (with-current-buffer (window-buffer (selected-window)) - (should (member (buffer-name) '("*ert*" "*scratch*"))) - (with-current-buffer (generate-new-buffer "bob") - (erc-mode) - (erc-tests--servars "ircd" 'erc-server-process 'erc-networks--id) - (setq erc-default-recipients '("bob")) - (should-not (get-buffer-window (current-buffer) t)) - (erc-setup-buffer (current-buffer)) - ;; Window created in frame "other" - (should (eq (selected-frame) orig-frame)) - (erc-tests--assert-server-split (current-buffer) "other"))))) - -(ert-deftest erc-reuse-frames--displayed-full () - :tags '(:unstable :expensive-test) - (erc-tests--erc-reuse-frames - (lambda (orig-frame) - (let ((erc-buffer-display #'erc-display-buffer-in-existing-frame)) - (erc-tests--erc-reuse-frames--displayed-full orig-frame)) - (dolist (b '("server" "ircd" "bob" "alice" "#spam" "#chan")) - (kill-buffer b))))) - (ert-deftest erc-setup-buffer--custom-action () (erc-mode) (erc-tests--set-fake-server-process "sleep" "1") @@ -832,7 +529,7 @@ erc-setup-buffer--custom-action (let ((erc--display-context '((erc-buffer-display . 1))) (erc-join-buffer 'erc--test-fun)) (erc-setup-buffer mbuf) - (should (equal `(erc--test-fun ,mbuf ((erc-buffer-display . 1))) + (should (equal `(erc--test-fun ,mbuf (nil (erc-buffer-display . 1))) (pop calls))) (should-not calls)) @@ -841,8 +538,8 @@ erc-setup-buffer--custom-action (erc--display-context '((erc-buffer-display . 1))) (erc-reconnect-display 'erc--test-fun)) (erc-setup-buffer mbuf) - (should (equal `(erc--test-fun ,mbuf ((erc-reconnect-display . t) - (erc-buffer-display . 1))) + (should (equal `(erc--test-fun ,mbuf (nil (erc-reconnect-display . t) + (erc-buffer-display . 1))) (pop calls))) (should-not calls))) -- 2.40.1