branch: elpa/jabber
commit ac15ff345bc09089dc97c9211d87951f954079d9
Author: Thanos Apollo <[email protected]>
Commit: Thanos Apollo <[email protected]>
chatbuffer: Add all-window scroll-to-bottom policy
---
lisp/jabber-chat.el | 9 +-
lisp/jabber-chatbuffer.el | 71 +++++++++++++--
lisp/jabber-muc.el | 92 +++++++++++---------
tests/jabber-test-chatbuffer.el | 188 ++++++++++++++++++++++++++++++++++++++++
4 files changed, 308 insertions(+), 52 deletions(-)
diff --git a/lisp/jabber-chat.el b/lisp/jabber-chat.el
index db95e0fe19..21e94a0331 100644
--- a/lisp/jabber-chat.el
+++ b/lisp/jabber-chat.el
@@ -660,10 +660,11 @@ _XML-DATA is reserved for future use by OMEMO."
(self-p (string= (jabber-jid-user from)
(jabber-connection-bare-jid jc))))
(with-current-buffer chat-buffer
- (jabber-chatstates--clear-typing)
- (jabber-maybe-print-rare-time
- (jabber-chat-ewoc-enter
- (list (if error-p :error :foreign) msg-plist)))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-chatstates--clear-typing)
+ (jabber-maybe-print-rare-time
+ (jabber-chat-ewoc-enter
+ (list (if error-p :error :foreign) msg-plist))))
(when (and (not error-p) (not self-p))
(let ((inhibit-message jabber-chat-mam-syncing))
(dolist (hook '(jabber-message-hooks jabber-alert-message-hooks))
diff --git a/lisp/jabber-chatbuffer.el b/lisp/jabber-chatbuffer.el
index 5983335200..41e9cbfd8a 100644
--- a/lisp/jabber-chatbuffer.el
+++ b/lisp/jabber-chatbuffer.el
@@ -34,6 +34,15 @@
(defvar jabber-point-insert nil
"Position where the message being composed starts.")
+(defcustom jabber-scrolltobottom-all nil
+ "Non-nil means keep the input area at the bottom in all chat windows.
+This recenters all visible windows displaying the current chat buffer
+whose window point is in the input area, at or after
+`jabber-point-insert'. The default nil preserves the current behavior
+of recentering only one visible window."
+ :type 'boolean
+ :group 'jabber-chat)
+
(defun jabber-chat-buffer--recenter-input-p (window)
"Return non-nil when WINDOW should recenter to the input area."
(and (window-live-p window)
@@ -43,14 +52,66 @@
(window-buffer window))
(>= (window-point window) jabber-point-insert)))))
-(defun jabber-chat-buffer-recenter-input ()
- "Recenter the visible current buffer window to the input area."
- (when-let* ((window (get-buffer-window (current-buffer))))
- (when (jabber-chat-buffer--recenter-input-p window)
- (with-selected-window window
+(defun jabber-chat-buffer--recenter-input-window (window)
+ "Recenter WINDOW so the input area is at the bottom."
+ (with-selected-window window
+ (let ((resize-mini-windows nil))
+ (save-excursion
(goto-char jabber-point-insert)
(recenter -1)))))
+(defun jabber-chat-buffer--recenter-input-all ()
+ "Recenter all visible `current-buffer' windows following the input area."
+ (dolist (window (get-buffer-window-list (current-buffer) nil 'visible))
+ (when (jabber-chat-buffer--recenter-input-p window)
+ (jabber-chat-buffer--recenter-input-window window))))
+
+(defun jabber-chat-buffer-recenter-input ()
+ "Recenter visible `current-buffer' window(s) to the input area."
+ (if jabber-scrolltobottom-all
+ (jabber-chat-buffer--recenter-input-all)
+ (when-let* ((window (get-buffer-window (current-buffer))))
+ (when (jabber-chat-buffer--recenter-input-p window)
+ (jabber-chat-buffer--recenter-input-window window)))))
+
+(defvar-local jabber-chat-buffer--scrolltobottom-window-info nil
+ "Pre-insert scroll-to-bottom state for visible chat windows.
+Each entry is (WINDOW . FOLLOWING-P), where FOLLOWING-P records
+whether WINDOW was following the input area before message insertion.")
+
+(defun jabber-chat-buffer--scrolltobottom-windows ()
+ "Return windows eligible for pre-insert scroll-to-bottom state."
+ (if jabber-scrolltobottom-all
+ (get-buffer-window-list (current-buffer) nil 'visible)
+ (when-let* ((window (get-buffer-window (current-buffer))))
+ (list window))))
+
+(defun jabber-chat-buffer--scrolltobottom-before-insert ()
+ "Record pre-insert follow state for eligible `current-buffer' windows."
+ (setq jabber-chat-buffer--scrolltobottom-window-info
+ (mapcar (lambda (window)
+ (cons window
+ (and (jabber-chat-buffer--recenter-input-p window) t)))
+ (jabber-chat-buffer--scrolltobottom-windows))))
+
+(defun jabber-chat-buffer--scrolltobottom-after-insert ()
+ "Recenter windows that followed before insertion, then clear state."
+ (unwind-protect
+ (dolist (entry jabber-chat-buffer--scrolltobottom-window-info)
+ (when (and (cdr entry)
+ (window-live-p (car entry)))
+ (jabber-chat-buffer--recenter-input-window (car entry))))
+ (setq jabber-chat-buffer--scrolltobottom-window-info nil)))
+
+(defmacro jabber-chat-buffer-with-scrolltobottom (&rest body)
+ "Run BODY with ERC-like pre/post scroll-to-bottom state."
+ (declare (indent 0) (debug t))
+ `(progn
+ (jabber-chat-buffer--scrolltobottom-before-insert)
+ (unwind-protect
+ (progn ,@body)
+ (jabber-chat-buffer--scrolltobottom-after-insert))))
+
(defvar jabber-send-function nil
"Function for sending a message from a chat buffer.")
diff --git a/lisp/jabber-muc.el b/lisp/jabber-muc.el
index 7db2d2b91b..837eb79ece 100644
--- a/lisp/jabber-muc.el
+++ b/lisp/jabber-muc.el
@@ -1705,8 +1705,9 @@ messages."
printers))
(not (and (jabber-muc--history-message-p xml-data)
jabber-chat-earliest-backlog)))
- (jabber-maybe-print-rare-time
- (jabber-chat-ewoc-enter (list type msg-plist))))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-maybe-print-rare-time
+ (jabber-chat-ewoc-enter (list type msg-plist)))))))
;; Alert hooks run regardless of buffer existence, but not for
;; history messages.
(unless (jabber-muc--history-message-p xml-data)
@@ -1785,13 +1786,14 @@ STATUS-CODES, ERROR-NODE, ACTOR and REASON come from
the stanza."
(let ((buffer (get-buffer (jabber-muc-get-buffer group jc))))
(if buffer
(with-current-buffer buffer
- (jabber-maybe-print-rare-time
- (jabber-chat-ewoc-enter
- (list (if (string= type "error")
- :muc-error
- :muc-notice)
- message
- :time (current-time)))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-maybe-print-rare-time
+ (jabber-chat-ewoc-enter
+ (list (if (string= type "error")
+ :muc-error
+ :muc-notice)
+ message
+ :time (current-time))))))
(message "%s: %s" (jabber-jid-displayname group) message)))
;; Stagger: skip failed room and try the next one.
;; Defer via timer so Emacs can redisplay between joins.
@@ -1813,28 +1815,29 @@ come from the stanza."
(jabber-muc-remove-participant group nickname)
(when-let* ((buffer (jabber-muc-find-buffer group)))
(with-current-buffer buffer
- (when (and (fboundp 'jabber-chatstates--muc-remove-nick)
- (fboundp 'jabber-chatstates--delete-typing-node))
- (jabber-chatstates--muc-remove-nick nickname)
- (jabber-chatstates--delete-typing-node))
- (jabber-maybe-print-rare-time
- (jabber-chat-ewoc-enter
- (list :muc-notice
- (cond
- ((member jabber-muc-status-banned status-codes)
- (concat name " has been banned"
- (jabber-muc--format-actor-reason actor reason)))
- ((member jabber-muc-status-kicked status-codes)
- (concat name " has been kicked"
- (jabber-muc--format-actor-reason actor reason)))
- ((member jabber-muc-status-nick-changed status-codes)
- (concat name " changes nickname to "
- (jabber-xml-get-attribute item 'nick)))
- (t
- (concat name " has left the chatroom")))
- :time (current-time))))
- (when (fboundp 'jabber-chatstates--muc-reinsert-typing)
- (jabber-chatstates--muc-reinsert-typing))))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (when (and (fboundp 'jabber-chatstates--muc-remove-nick)
+ (fboundp 'jabber-chatstates--delete-typing-node))
+ (jabber-chatstates--muc-remove-nick nickname)
+ (jabber-chatstates--delete-typing-node))
+ (jabber-maybe-print-rare-time
+ (jabber-chat-ewoc-enter
+ (list :muc-notice
+ (cond
+ ((member jabber-muc-status-banned status-codes)
+ (concat name " has been banned"
+ (jabber-muc--format-actor-reason actor reason)))
+ ((member jabber-muc-status-kicked status-codes)
+ (concat name " has been kicked"
+ (jabber-muc--format-actor-reason actor reason)))
+ ((member jabber-muc-status-nick-changed status-codes)
+ (concat name " changes nickname to "
+ (jabber-xml-get-attribute item 'nick)))
+ (t
+ (concat name " has left the chatroom")))
+ :time (current-time))))
+ (when (fboundp 'jabber-chatstates--muc-reinsert-typing)
+ (jabber-chatstates--muc-reinsert-typing)))))))
(defun jabber-muc--room-created-message ()
"Return a string with buttons for configuring a newly created room."
@@ -1855,19 +1858,21 @@ come from the stanza."
"Insert extra ewoc notices for STATUS-CODES into the current MUC buffer.
NICKNAME is the entering user. Assumes `jabber-chat-ewoc' is current."
(when (member jabber-muc-status-nick-modified status-codes)
- (jabber-chat-ewoc-enter
- (list :muc-notice
- (concat "Your nick was changed to " nickname " by the server")
- :time (current-time))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-chat-ewoc-enter
+ (list :muc-notice
+ (concat "Your nick was changed to " nickname " by the server")
+ :time (current-time)))))
(when (member jabber-muc-status-room-created status-codes)
(if jabber-muc--auto-configure
(progn
(setq jabber-muc--auto-configure nil)
(jabber-muc-get-config jabber-buffer-connection jabber-group))
- (jabber-chat-ewoc-enter
- (list :muc-notice
- (jabber-muc--room-created-message)
- :time (current-time))))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-chat-ewoc-enter
+ (list :muc-notice
+ (jabber-muc--room-created-message)
+ :time (current-time)))))))
(defun jabber-muc--query-affiliations (jc group)
"On JC, query member, admin, and owner affiliation lists for GROUP.
@@ -1942,10 +1947,11 @@ X-MUC, ACTOR, REASON and OUR-NICKNAME come from the
stanza."
reason actor)))
(when report
(with-current-buffer buffer
- (jabber-maybe-print-rare-time
- (jabber-chat-ewoc-enter
- (list :muc-notice report
- :time (current-time)))))))
+ (jabber-chat-buffer-with-scrolltobottom
+ (jabber-maybe-print-rare-time
+ (jabber-chat-ewoc-enter
+ (list :muc-notice report
+ :time (current-time))))))))
;; Extra notices (status 201/210) fire for self-presence regardless
;; of whether there was an affiliation delta report.
(when self-p
diff --git a/tests/jabber-test-chatbuffer.el b/tests/jabber-test-chatbuffer.el
index 4e8ab6fb31..f329c522e7 100644
--- a/tests/jabber-test-chatbuffer.el
+++ b/tests/jabber-test-chatbuffer.el
@@ -16,6 +16,16 @@
(defvar jabber-muc-xmlns-user "http://jabber.org/protocol/muc#user";)
(defvar jabber-group nil)
(defvar jabber-muc-participants nil)
+(defvar jabber-scrolltobottom-all nil)
+(defvar jabber-chat-buffer--scrolltobottom-window-info nil)
+
+(declare-function jabber-chat-buffer-recenter-input "jabber-chatbuffer" ())
+(declare-function jabber-chat-buffer--recenter-input-window
+ "jabber-chatbuffer" (window))
+(declare-function jabber-chat-buffer--scrolltobottom-after-insert
+ "jabber-chatbuffer" ())
+(declare-function jabber-chat-buffer--scrolltobottom-before-insert
+ "jabber-chatbuffer" ())
;;; Test helpers
@@ -548,6 +558,184 @@ again, and the ewoc created on the first call must
survive."
(jabber-chat-buffer-refresh)
(should-not events)))))
+;;; Group 12: scroll-to-bottom window policy
+
+(ert-deftest jabber-test-chatbuffer-recenter-input-default-uses-one-window ()
+ "Default scroll-to-bottom behavior recenters only one visible window."
+ (with-temp-buffer
+ (let ((jabber-scrolltobottom-all nil)
+ (seen-buffers nil)
+ (checked nil)
+ (recentered nil))
+ (cl-letf (((symbol-function 'get-buffer-window)
+ (lambda (buffer &optional _all-frames)
+ (push buffer seen-buffers)
+ 'win-a))
+ ((symbol-function 'get-buffer-window-list)
+ (lambda (&rest _)
+ (error "get-buffer-window-list should not be called")))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-p)
+ (lambda (window)
+ (push window checked)
+ t))
+ ((symbol-function 'window-live-p)
+ (lambda (_window) t))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer-recenter-input)
+ (should (equal (list (current-buffer)) seen-buffers))
+ (should (equal '(win-a) checked))
+ (should (equal '(win-a) recentered))))))
+
+(ert-deftest jabber-test-chatbuffer-recenter-input-all-uses-visible-windows ()
+ "All-window scroll-to-bottom checks every visible chat buffer window."
+ (with-temp-buffer
+ (let ((jabber-scrolltobottom-all t)
+ (seen-buffers nil)
+ (checked nil)
+ (recentered nil))
+ (cl-letf (((symbol-function 'get-buffer-window)
+ (lambda (&rest _)
+ (error "get-buffer-window should not be called")))
+ ((symbol-function 'get-buffer-window-list)
+ (lambda (buffer &optional _minibuf _all-frames)
+ (push buffer seen-buffers)
+ '(win-a win-b win-c)))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-p)
+ (lambda (window)
+ (push window checked)
+ (memq window '(win-a win-c))))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer-recenter-input)
+ (should (equal (list (current-buffer)) seen-buffers))
+ (should (equal '(win-c win-b win-a) checked))
+ (should (equal '(win-c win-a) recentered))))))
+
+(ert-deftest jabber-test-chatbuffer-pre-post-recenters-following-window ()
+ "Post-insert nil mode recenters only the single selected chat window."
+ (with-temp-buffer
+ (let ((jabber-scrolltobottom-all nil)
+ (seen-buffers nil)
+ (checked nil)
+ (recentered nil))
+ (cl-letf (((symbol-function 'get-buffer-window)
+ (lambda (buffer &optional _all-frames)
+ (push buffer seen-buffers)
+ 'win-a))
+ ((symbol-function 'get-buffer-window-list)
+ (lambda (&rest _)
+ (error "get-buffer-window-list should not be called")))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-p)
+ (lambda (window)
+ (push window checked)
+ t))
+ ((symbol-function 'window-live-p)
+ (lambda (_window) t))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer--scrolltobottom-before-insert)
+ (should (equal (list (current-buffer)) seen-buffers))
+ (should (equal '((win-a . t))
+ jabber-chat-buffer--scrolltobottom-window-info))
+ (should (equal '(win-a) checked))
+ (jabber-chat-buffer--scrolltobottom-after-insert)
+ (should (equal '(win-a) recentered))
+ (should-not jabber-chat-buffer--scrolltobottom-window-info)))))
+
+(ert-deftest jabber-test-chatbuffer-pre-post-all-records-visible-windows ()
+ "Post-insert all mode records and checks every visible chat window."
+ (with-temp-buffer
+ (let ((jabber-scrolltobottom-all t)
+ (seen-buffers nil)
+ (checked nil)
+ (recentered nil))
+ (cl-letf (((symbol-function 'get-buffer-window)
+ (lambda (&rest _)
+ (error "get-buffer-window should not be called")))
+ ((symbol-function 'get-buffer-window-list)
+ (lambda (buffer &optional _minibuf _all-frames)
+ (push buffer seen-buffers)
+ '(win-a win-b win-c)))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-p)
+ (lambda (window)
+ (push window checked)
+ (memq window '(win-a win-c))))
+ ((symbol-function 'window-live-p)
+ (lambda (_window) t))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer--scrolltobottom-before-insert)
+ (should (equal (list (current-buffer)) seen-buffers))
+ (should (equal '((win-a . t) (win-b) (win-c . t))
+ jabber-chat-buffer--scrolltobottom-window-info))
+ (should (equal '(win-c win-b win-a) checked))
+ (jabber-chat-buffer--scrolltobottom-after-insert)
+ (should (equal '(win-c win-a) recentered))
+ (should-not jabber-chat-buffer--scrolltobottom-window-info)))))
+
+(ert-deftest jabber-test-chatbuffer-pre-post-preserves-history-window ()
+ "Post-insert does not move a window reading history before insertion."
+ (with-temp-buffer
+ (let ((jabber-scrolltobottom-all nil)
+ (recentered nil))
+ (cl-letf (((symbol-function 'get-buffer-window)
+ (lambda (&rest _) 'win-a))
+ ((symbol-function 'get-buffer-window-list)
+ (lambda (&rest _)
+ (error "get-buffer-window-list should not be called")))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-p)
+ (lambda (_window) nil))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer--scrolltobottom-before-insert)
+ (jabber-chat-buffer--scrolltobottom-after-insert)
+ (should-not recentered)
+ (should-not jabber-chat-buffer--scrolltobottom-window-info)))))
+
+(ert-deftest jabber-test-chatbuffer-recenter-input-window-preserves-point ()
+ "Recentering moves temporarily to the input marker and restores point."
+ (let ((buffer (generate-new-buffer " *test-chat-recenter*"))
+ (previous-buffer (window-buffer (selected-window)))
+ (recenter-point nil)
+ typed-point)
+ (unwind-protect
+ (progn
+ (switch-to-buffer buffer)
+ (insert "history\n")
+ (setq-local jabber-point-insert (point-marker))
+ (insert "typed input")
+ (setq typed-point (point))
+ (cl-letf (((symbol-function 'recenter)
+ (lambda (&rest _)
+ (setq recenter-point (point)))))
+ (jabber-chat-buffer--recenter-input-window (selected-window)))
+ (should (= recenter-point jabber-point-insert))
+ (should (= (point) typed-point)))
+ (set-window-buffer (selected-window) previous-buffer)
+ (kill-buffer buffer))))
+
+(ert-deftest jabber-test-chatbuffer-after-insert-skips-dead-windows ()
+ "Post-insert does not recenter windows that are no longer live."
+ (with-temp-buffer
+ (let ((jabber-chat-buffer--scrolltobottom-window-info
+ '((win-live . t) (win-dead . t)))
+ (recentered nil))
+ (cl-letf (((symbol-function 'window-live-p)
+ (lambda (window)
+ (eq window 'win-live)))
+ ((symbol-function 'jabber-chat-buffer--recenter-input-window)
+ (lambda (window)
+ (push window recentered))))
+ (jabber-chat-buffer--scrolltobottom-after-insert)
+ (should (equal '(win-live) recentered))
+ (should-not jabber-chat-buffer--scrolltobottom-window-info)))))
+
(provide 'jabber-test-chatbuffer)
;;; jabber-test-chatbuffer.el ends here
