diff options
Diffstat (limited to 'test/lisp/erc/erc-fill-tests.el')
| -rw-r--r-- | test/lisp/erc/erc-fill-tests.el | 452 |
1 files changed, 452 insertions, 0 deletions
diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el new file mode 100644 index 00000000000..df83466cbc3 --- /dev/null +++ b/test/lisp/erc/erc-fill-tests.el @@ -0,0 +1,452 @@ +;;; erc-fill-tests.el --- Tests for erc-fill -*- 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 <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; FIXME these tests are brittle and error prone. Replace with +;; scenarios. + +;;; Code: +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(require 'erc-fill) + +(defvar erc-fill-tests--buffers nil) +(defvar erc-fill-tests--current-time-value nil) + +(cl-defmethod erc-stamp--current-time + (&context (erc-fill-tests--current-time-value integer)) + erc-fill-tests--current-time-value) + +(defun erc-fill-tests--insert-privmsg (speaker &rest msg-parts) + (declare (indent 1)) + (let* ((erc--msg-prop-overrides `((erc--msg . msg))) + (msg (erc-format-privmessage speaker + (apply #'concat msg-parts) nil t)) + (parsed (make-erc-response :unparsed (format ":%s PRIVMSG #chan :%s" + speaker msg) + :sender speaker + :command "PRIVMSG" + :command-args (list "#chan" msg) + :contents msg))) + (erc-display-message parsed nil (current-buffer) msg))) + +(defun erc-fill-tests--wrap-populate (test) + (let ((original-window-buffer (window-buffer (selected-window))) + (erc-stamp--tz t) + (erc-fill-function 'erc-fill-wrap) + (pre-command-hook pre-command-hook) + (inhibit-message noninteractive) + (erc-fill-tests--current-time-value 0) + erc-insert-post-hook + extended-command-history + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (cl-letf (((symbol-function 'erc-server-connect) + (lambda (&rest _) + (erc-tests-common-init-server-proc "sleep" "1")))) + (with-current-buffer + (car (push (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" 'foonet) + erc-fill-tests--buffers)) + (setq erc-network 'foonet + erc-server-connected t) + (with-current-buffer (erc--open-target "#chan") + (set-window-buffer (selected-window) (current-buffer)) + + (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. " + "If you do not wish for everything you send to be readable " + "by the server owner(s), please disconnect.")) + + (erc-fill-tests--insert-privmsg "alice" + "bob: come, you are a tedious fool: to the purpose. " + "What was done to Elbow's wife, that he hath cause to complain of?" + " Come me to what was done to her.") + + ;; Introduce an artificial gap in properties `line-prefix' and + ;; `wrap-prefix' and later ensure they're not incremented twice. + (save-excursion + (forward-line -1) + (search-forward "? ") + (with-silent-modifications + (remove-text-properties (1- (point)) (point) + '(line-prefix t wrap-prefix t)))) + + (erc-fill-tests--insert-privmsg "bob" + "alice: Either your unparagoned mistress is dead, " + "or she's outprized by a trifle.") + + ;; Defend against non-local exits from `ert-skip' + (unwind-protect + (funcall test) + (when set-transient-map-timer + (timer-event-handler set-transient-map-timer)) + (set-window-buffer (selected-window) original-window-buffer) + (when (or noninteractive (getenv "ERC_TESTS_GRAPHICAL")) + (erc-tests-common-kill-buffers erc-fill-tests--buffers) + (setq erc-fill-tests--buffers nil)))))))) + +(defun erc-fill-tests--wrap-check-prefixes (&rest prefixes) + ;; Check that prefix props are applied over correct intervals. + (save-excursion + (goto-char (point-min)) + (dolist (prefix prefixes) + (should (search-forward prefix nil t)) + (should (get-text-property (pos-bol) 'line-prefix)) + (should (get-text-property (1- (pos-eol)) 'line-prefix)) + (should-not (get-text-property (pos-eol) 'line-prefix)) + ;; Spans entire line uninterrupted. + (let* ((val (get-text-property (pos-bol) 'line-prefix)) + (end (text-property-not-all (pos-bol) (point-max) + 'line-prefix val))) + (when (and (/= end (pos-eol)) (= ?? (char-before end))) + (setq end (text-property-not-all (1+ end) (point-max) + 'line-prefix val))) + (should (eq end (pos-eol)))) + (should (equal (get-text-property (pos-bol) 'wrap-prefix) + '(space :width erc-fill--wrap-value))) + (should-not (get-text-property (pos-eol) 'wrap-prefix)) + (should (equal (get-text-property (1- (pos-eol)) 'wrap-prefix) + '(space :width erc-fill--wrap-value)))))) + +;; On graphical displays, echo .graphic >> .git/info/exclude +(defvar erc-fill-tests--graphic-dir "fill/snapshots/.graphic/") + +(defun erc-fill-tests--compare (name) + (let ((dir (expand-file-name (if (display-graphic-p) + erc-fill-tests--graphic-dir + "fill/snapshots/" ) + (ert-resource-directory))) + (transform-fn (lambda (got) + (string-replace "erc-fill--wrap-value" + (number-to-string erc-fill--wrap-value) + got))) + (buffer-setup-fn (lambda () + (push (current-buffer) erc-fill-tests--buffers)))) + (erc-tests-common-snapshot-compare name dir transform-fn buffer-setup-fn))) + +;; To inspect variable pitch, set `erc-mode-hook' to +;; +;; (lambda () (face-remap-add-relative 'default :family "Sans Serif")) +;; +;; or similar. + +(ert-deftest erc-fill-wrap--monospace () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (let ((erc-prompt (lambda () "ABC>"))) + (erc-fill-tests--wrap-populate + + (lambda () + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ") + (erc-fill-tests--compare "monospace-01-start") + + (ert-info ("Shift right by one (plus)") + ;; Args are all `erc-fill-wrap-nudge' +1 because interactive "p" + (ert-with-message-capture messages + ;; M-x erc-fill-wrap-nudge RET = + (ert-simulate-command '(erc-fill-wrap-nudge 2)) + (should (string-match (rx "for further adjustment") messages))) + (should (= erc-fill--wrap-value 29)) + (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ") + (erc-fill-tests--compare "monospace-02-right")) + + (ert-info ("Shift left by five") + ;; "M-x erc-fill-wrap-nudge RET -----" + (ert-simulate-command '(erc-fill-wrap-nudge -4)) + (should (= erc-fill--wrap-value 25)) + (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ") + (erc-fill-tests--compare "monospace-03-left")) + + (ert-info ("Reset") + ;; M-x erc-fill-wrap-nudge RET 0 + (ert-simulate-command '(erc-fill-wrap-nudge 0)) + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes "*** " "<alice> " "<bob> ") + (erc-fill-tests--compare "monospace-04-reset")) + + (erc--assert-input-bounds))))) + +(defun erc-fill-tests--simulate-refill () + ;; Simulate `erc-fill-wrap-refill-buffer' synchronously and without + ;; a progress reporter. + (save-excursion + (with-silent-modifications + (erc-fill--wrap-rejigger-region (point-min) erc-insert-marker nil nil)))) + +(ert-deftest erc-fill-wrap--merge () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (erc-fill-tests--wrap-populate + + (lambda () + (erc-update-channel-member + "#chan" "Dummy" "Dummy" t nil nil nil nil nil "fake" "~u" nil nil t) + + ;; Set this here so that the first few messages are from 1970. + ;; Following the current date stamp, the speaker isn't merged + ;; even though it's continued: "<bob> zero." + (let ((erc-fill-tests--current-time-value 1680332400)) + (erc-fill-tests--insert-privmsg "bob" "zero.") + (erc-fill-tests--insert-privmsg "alice" "one.") + (erc-fill-tests--insert-privmsg "alice" "two.") + (erc-fill-tests--insert-privmsg "bob" "three.") + (erc-fill-tests--insert-privmsg "bob" "four.") + (erc-fill-tests--insert-privmsg "Dummy" "five.") + (erc-fill-tests--insert-privmsg "Dummy" "six.")) + + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes + "*** " "<alice> " "<bob> " + "<bob> " "<alice> " "<alice> " "<bob> " "<bob> " "<Dummy> " "<Dummy> ") + (erc-fill-tests--compare "merge-01-start") + + (ert-info ("Shift right by one (plus)") + (ert-simulate-command '(erc-fill-wrap-nudge 2)) + (should (= erc-fill--wrap-value 29)) + (erc-fill-tests--wrap-check-prefixes + "*** " "<alice> " "<bob> " + "<bob> " "<alice> " "<alice> " "<bob> " "<bob> " "<Dummy> " "<Dummy> ") + (erc-fill-tests--compare "merge-02-right") + + (ert-info ("Command `erc-fill-wrap-refill-buffer' is idempotent") + (kill-buffer (pop erc-fill-tests--buffers)) + (erc-fill-tests--simulate-refill) ; idempotent + (erc-fill-tests--compare "merge-02-right")))))) + +(defun erc-fill-wrap-tests--merge-action (compare-file) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (erc-fill-tests--wrap-populate + + (lambda () + ;; Allow prior messages to be from 1970. + (let ((erc-fill-tests--current-time-value 1680332400)) + (erc-fill-tests--insert-privmsg "bob" "zero.") + (erc-fill-tests--insert-privmsg "bob" "0.5") + + (erc-process-ctcp-query + erc-server-process + (make-erc-response + :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION one.\1" + :sender "bob!~u@fake" + :command "PRIVMSG" + :command-args '("#chan" "\1ACTION one.\1") + :contents "\1ACTION one.\1") + "bob" "~u" "fake") + + (erc-fill-tests--insert-privmsg "bob" "two.") + (erc-fill-tests--insert-privmsg "bob" "2.5") + + ;; Compat switch to opt out of overhanging speaker. + (let (erc-fill--wrap-action-dedent-p) + (erc-process-ctcp-query + erc-server-process + (make-erc-response + :unparsed ":bob!~u@fake PRIVMSG #chan :\1ACTION three\1" + :sender "bob!~u@fake" :command "PRIVMSG" + :command-args '("#chan" "\1ACTION three\1") + :contents "\1ACTION three\1") + "bob" "~u" "fake")) + + (erc-fill-tests--insert-privmsg "bob" "four.")) + + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes + "*** " "<alice> " "<bob> " "<bob> " "* bob " "<bob> " "* " "<bob> ") + (erc-fill-tests--compare compare-file)))) + +(ert-deftest erc-fill-wrap--merge-action () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (erc-fill-wrap-tests--merge-action "merge-wrap-01")) + +(ert-deftest erc-fill-wrap--merge-action/indicator-pre () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (let ((erc-fill-wrap-merge-indicator '(pre ?> shadow))) + (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-pre-01"))) + +;; One crucial thing this test asserts is that the indicator is +;; omitted when the previous line ends in a stamp. +(ert-deftest erc-fill-wrap--merge-action/indicator-post () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (let ((erc-fill-wrap-merge-indicator '(post ?~ shadow))) + (erc-fill-wrap-tests--merge-action "merge-wrap-indicator-post-01"))) + +(ert-deftest erc-fill-line-spacing () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (let ((erc-fill-line-spacing 0.5)) + (erc-fill-tests--wrap-populate + (lambda () + (erc-fill-tests--insert-privmsg "bob" "This buffer is for text.") + (erc-display-message nil 'notice (current-buffer) "one two three") + (erc-display-message nil 'notice (current-buffer) "four five six") + (erc-fill-tests--insert-privmsg "bob" "Somebody stop me") + (erc-fill-tests--compare "spacing-01-mono"))))) + +(ert-deftest erc-fill-wrap-visual-keys--body () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (erc-fill-tests--wrap-populate + + (lambda () + (ert-info ("Value: non-input") + (should (eq erc-fill--wrap-visual-keys 'non-input)) + (goto-char (point-min)) + (should (search-forward "that he hath" nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx "<alice> "))) + (execute-kbd-macro "\C-e") + (should (search-backward "tedious fool" nil t)) + (should-not (looking-back "done to her\\.")) + (forward-char) + (execute-kbd-macro "\C-e") + (should (search-forward "done to her." nil t))) + + (ert-info ("Value: nil") + (execute-kbd-macro "\C-ca") + (should-not erc-fill--wrap-visual-keys) + (goto-char (point-min)) + (should (search-forward "in debug mode" nil t)) + (execute-kbd-macro "\C-a") + (should (looking-at (rx "*** "))) + (execute-kbd-macro "\C-e") + (should (eql ?\] (char-before (point))))) + + (ert-info ("Value: t") + (execute-kbd-macro "\C-ca") + (should (eq erc-fill--wrap-visual-keys t)) + (goto-char (point-min)) + (should (search-forward "that he hath" nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx "<alice> "))) + (should (search-backward "tedious fool" nil t)) + (execute-kbd-macro "\C-e") + (should-not (looking-back (rx "done to her\\."))) + (should (search-forward "done to her." nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx "<alice> "))))))) + +(ert-deftest erc-fill-wrap-visual-keys--prompt () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (erc-fill-tests--wrap-populate + + (lambda () + (set-window-buffer (selected-window) (current-buffer)) + (goto-char erc-input-marker) + (insert "This buffer is for text that is not saved, and for Lisp " + "evaluation. To create a file, visit it with C-x C-f and " + "enter text in its buffer.") + + (ert-info ("Value: non-input") + (should (eq erc-fill--wrap-visual-keys 'non-input)) + (execute-kbd-macro "\C-a") + (should (looking-at "This buffer")) + (execute-kbd-macro "\C-e") + (should (looking-back "its buffer\\.")) + (execute-kbd-macro "\C-a") + (execute-kbd-macro "\C-k") + (should (eobp))) + + (ert-info ("Value: nil") ; same + (execute-kbd-macro "\C-ca") + (should-not erc-fill--wrap-visual-keys) + (execute-kbd-macro "\C-y") + (should (looking-back "its buffer\\.")) + (execute-kbd-macro "\C-a") + (should (looking-at "This buffer")) + (execute-kbd-macro "\C-k") + (should (eobp))) + + (ert-info ("Value: non-input") + (execute-kbd-macro "\C-ca") + (should (eq erc-fill--wrap-visual-keys t)) + (execute-kbd-macro "\C-y") + (execute-kbd-macro "\C-a") + (should-not (looking-at "This buffer")) + (execute-kbd-macro "\C-p") + (should-not (looking-back "its buffer\\.")) + (should (search-forward "its buffer." nil t)) + (should (search-backward "ERC> " nil t)) + (execute-kbd-macro "\C-a"))))) + +(ert-deftest erc-fill--left-hand-stamps () + :tags `(:unstable + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (let ((erc-timestamp-only-if-changed-flag nil) + (erc-insert-timestamp-function #'erc-insert-timestamp-left)) + (erc-fill-tests--wrap-populate + (lambda () + (should (= 8 left-margin-width)) + (pcase-let ((`((margin left-margin) ,displayed) + (get-text-property erc-insert-marker 'display))) + (should (equal-including-properties + displayed #(" ERC>" 4 8 + ( read-only t + front-sticky t + field erc-prompt + erc-prompt t + rear-nonsticky t + font-lock-face erc-prompt-face))))) + (erc-fill-tests--compare "stamps-left-01") + + (ert-info ("Shrink left margin by 1 col") + (erc-stamp--adjust-margin -1) + (with-silent-modifications (erc--refresh-prompt)) + (should (= 7 left-margin-width)) + (pcase-let ((`((margin left-margin) ,displayed) + (get-text-property erc-insert-marker 'display))) + (should (equal-including-properties + displayed #(" ERC>" 3 7 + ( read-only t + front-sticky t + field erc-prompt + erc-prompt t + rear-nonsticky t + font-lock-face erc-prompt-face)))))))))) + +;;; erc-fill-tests.el ends here |