master 0e4c07dc744 36/37: Allow erc-reuse-frames to favor connections

[F. Jason Park]

branch: master
commit 0e4c07dc7448aafd2aa5f6e101d7b7aac23d8a6b
Author: F. Jason Park <jp@neverwas.me>
Commit: F. Jason Park <jp@neverwas.me>

    Allow erc-reuse-frames to favor connections
    
    * lisp/erc/erc.el (erc-reuse-frames): Add alternate value to favor
    existing frames already displaying buffers from the same connection.
    (erc--setup-buffer-first-window, erc--display-buffer-use-some-frame):
    Add helpers to support 'display' variant of `erc-resuse-frames'
    * test/lisp/erc/erc-tests.el (erc-tests--run-in-term,
    erc-tests--servars, erc-reuse-frames, erc-tests--erc-reuse-frames,
    erc-tests--erc-reuse-frames--t, erc-resuse-frames--t,
    erc-tests--erc-reuse-frames--displayed-single,
    erc-reuse-frames--displayed-single, erc-tests--assert-server-split,
    erc-tests--erc-reuse-frames--displayed-double,
    erc-reuse-frames--displayed-double,
    erc-tests--erc-reuse-frames--displayed-full,
    erc-reuse-frames--displayed-full): Add test case and supporting
    fixtures.  (Bug#55540.)
---
 lisp/erc/erc.el            |  61 +++++++--
 test/lisp/erc/erc-tests.el | 303 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 357 insertions(+), 7 deletions(-)

diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el
index 5aa460241cd..284990e2d43 100644
--- a/lisp/erc/erc.el
+++ b/lisp/erc/erc.el
@@ -1573,11 +1573,23 @@ This only has effect when `erc-join-buffer' is set to 
`frame'."
 
 (defcustom erc-reuse-frames t
   "Determines whether new frames are always created.
-Non-nil means that a new frame is not created to display an ERC
-buffer if there is already a window displaying it.  This only has
-effect when `erc-join-buffer' is set to `frame'."
+
+A value of t means only create a frame for undisplayed buffers.
+`displayed' means 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,
+`displayed' defaults to the selected frame, except for brand new
+connections, for which the invoking frame is always used.  When
+this option is nil, a new frame is always created.
+
+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."
+  :package-version '(ERC . "5.6") ; FIXME sync on release
   :group 'erc-buffers
-  :type 'boolean)
+  :type '(choice boolean
+                 (const displayed)))
 
 (defun erc-channel-p (channel)
   "Return non-nil if CHANNEL seems to be an IRC channel name."
@@ -2003,6 +2015,35 @@ Except ignore all local modules, which were introduced 
in ERC 5.5."
             (push mode local-modes))
         (error "`%s' is not a known ERC module" module)))))
 
+(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 window used; otherwise, return nil.  Forward ALIST
+to display-buffer machinery."
+  (when-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)))
+       (ercp (lambda (frame)
+               (erc--setup-buffer-first-window frame 'major-mode 'erc-mode)))
+       ((or (cdr (frame-list)) (funcall ercp (selected-frame)))))
+    ;; Workaround to avoid calling `window--display-buffer' directly
+    (or (display-buffer-use-some-frame buffer
+                                       `((frame-predicate . ,procp) ,@alist))
+        (display-buffer-use-some-frame buffer
+                                       `((frame-predicate . ,ercp) ,@alist)))))
+
 (defun erc-setup-buffer (buffer)
   "Consults `erc-join-buffer' to find out how to display `BUFFER'."
   (pcase (if (zerop (erc-with-server-buffer
@@ -2018,15 +2059,21 @@ Except ignore all local modules, which were introduced 
in ERC 5.5."
     ('bury
      nil)
     ('frame
-     (when (or (not erc-reuse-frames)
-               (not (get-buffer-window buffer t)))
+     (cond
+      ((and (eq erc-reuse-frames 'displayed)
+            (not (get-buffer-window buffer t)))
+       (display-buffer buffer '((erc--display-buffer-use-some-frame)
+                                (inhibit-switch-frame . t)
+                                (inhibit-same-window . t))))
+      ((or (not erc-reuse-frames)
+           (not (get-buffer-window buffer t)))
        (let ((frame (make-frame (or erc-frame-alist
                                     default-frame-alist))))
          (raise-frame frame)
          (select-frame frame))
        (switch-to-buffer buffer)
        (when erc-frame-dedicated-flag
-         (set-window-dedicated-p (selected-window) t))))
+         (set-window-dedicated-p (selected-window) t)))))
     (_
      (if (active-minibuffer-window)
          (display-buffer buffer)
diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el
index 43a5b54dcc7..29bda7e742d 100644
--- a/test/lisp/erc/erc-tests.el
+++ b/test/lisp/erc/erc-tests.el
@@ -399,6 +399,309 @@
     (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-reuse-frames 'displayed))
+
+  (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-reuse-frames 'displayed))
+       (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-reuse-frames 'displayed))
+
+  (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-reuse-frames 'displayed))
+       (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-reuse-frames 'displayed))
+       (erc-tests--erc-reuse-frames--displayed-full orig-frame))
+     (dolist (b '("server" "ircd" "bob" "alice" "#spam" "#chan"))
+       (kill-buffer b)))))
+
 (ert-deftest erc-lurker-maybe-trim ()
   (let (erc-lurker-trim-nicks
         (erc-lurker-ignore-chars "_`"))