414 lines
18 KiB
EmacsLisp
414 lines
18 KiB
EmacsLisp
;;; erc-tests-common.el --- Common helpers for ERC tests -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2023-2024 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:
|
|
|
|
;; This file must *not* contain any `ert-deftest' definitions. See
|
|
;; top of test/lisp/erc/erc-tests.el for loading example.
|
|
;;
|
|
;; Environment variables:
|
|
;;
|
|
;; `ERC_PACKAGE_NAME': Name of the installed ERC package currently
|
|
;; running. ERC needs this in order to load the same package in
|
|
;; tests that run in a subprocess. Necessary even when the package
|
|
;; name is `erc' and not something like `erc-49860'.
|
|
;;
|
|
;; `ERC_TESTS_INIT': The name of an alternate init file. Mainly for
|
|
;; integrations tests involving starter kits.
|
|
;;
|
|
;; `ERC_TESTS_SNAPSHOT_SAVE': When set, ERC saves the current test's
|
|
;; snapshots to disk.
|
|
;;
|
|
|
|
;;; Code:
|
|
(require 'ert-x)
|
|
(require 'erc)
|
|
(eval-when-compile (require 'erc-stamp))
|
|
(eval-and-compile
|
|
(let ((load-path (cons (expand-file-name "../erc-d" (ert-resource-directory))
|
|
load-path)))
|
|
(require 'erc-d-i)))
|
|
|
|
(defmacro erc-tests-common-equal-with-props (a b)
|
|
"Compare strings A and B for equality including text props.
|
|
Use `ert-equal-including-properties' on older Emacsen."
|
|
(list (if (< emacs-major-version 29)
|
|
'ert-equal-including-properties
|
|
'equal-including-properties)
|
|
a b))
|
|
|
|
;; Caller should probably shadow `erc-insert-modify-hook' or populate
|
|
;; user tables for erc-button.
|
|
;; FIXME explain this comment ^ in more detail or delete.
|
|
(defun erc-tests-common-prep-for-insertion ()
|
|
"Initialize current buffer with essentials for message insertion.
|
|
Assume caller intends to use `erc-display-message'."
|
|
(erc-mode)
|
|
(erc--initialize-markers (point) nil)
|
|
(should (= (point) erc-input-marker)))
|
|
|
|
(defun erc-tests-common-init-server-proc (&rest args)
|
|
"Create a process with `start-process' from ARGS.
|
|
Assign the result to `erc-server-process' in the current buffer."
|
|
(setq erc-server-process
|
|
(apply #'start-process (car args) (current-buffer) args))
|
|
(set-process-query-on-exit-flag erc-server-process nil)
|
|
erc-server-process)
|
|
|
|
;; After dropping support for Emacs 27, callers can use
|
|
;; `get-buffer-create' with INHIBIT-BUFFER-HOOKS.
|
|
(defun erc-tests-common-kill-buffers (&rest extra-buffers)
|
|
"Kill all ERC buffers and possibly EXTRA-BUFFERS."
|
|
(let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook)
|
|
(dolist (buf (erc-buffer-list))
|
|
(kill-buffer buf))
|
|
(named-let doit ((buffers extra-buffers))
|
|
(dolist (buf buffers)
|
|
(if (consp buf) (doit buf) (kill-buffer buf))))))
|
|
|
|
(defun erc-tests-common-with-process-input-spy (test-fn)
|
|
"Mock `erc-process-input-line' and call TEST-FN.
|
|
Shadow `erc--input-review-functions' and `erc-pre-send-functions'
|
|
with `erc-add-to-input-ring' removed. Shadow other relevant
|
|
variables as nil, and bind `erc-last-input-time' to 0. Also mock
|
|
`erc-server-buffer' to return the current buffer. Call TEST-FN
|
|
with a utility function that returns the set of arguments most
|
|
recently passed to the mocked `erc-process-input-line'. Make
|
|
`inhibit-message' non-nil unless running interactively."
|
|
(with-current-buffer (get-buffer-create "FakeNet")
|
|
(let* ((erc--input-review-functions
|
|
(remove 'erc-add-to-input-ring erc--input-review-functions))
|
|
(erc-pre-send-functions
|
|
(remove 'erc-add-to-input-ring erc-pre-send-functions)) ; for now
|
|
(inhibit-message noninteractive)
|
|
(erc-server-current-nick "tester")
|
|
(erc-last-input-time 0)
|
|
erc-accidental-paste-threshold-seconds
|
|
erc-send-modify-hook
|
|
;;
|
|
calls)
|
|
(cl-letf (((symbol-function 'erc-process-input-line)
|
|
(lambda (&rest r) (push r calls)))
|
|
((symbol-function 'erc-server-buffer)
|
|
(lambda () (current-buffer))))
|
|
(funcall test-fn (lambda () (pop calls)))))
|
|
(when noninteractive (kill-buffer))))
|
|
|
|
(defun erc-tests-common-make-server-buf (&optional name)
|
|
"Return a server buffer named NAME, creating it if necessary.
|
|
Use NAME for the network and the session server as well."
|
|
(with-current-buffer (if name
|
|
(get-buffer-create name)
|
|
(and (string-search "temp" (buffer-name))
|
|
(setq name "foonet")
|
|
(buffer-name)))
|
|
(erc-tests-common-prep-for-insertion)
|
|
(erc-tests-common-init-server-proc "sleep" "1")
|
|
(setq erc-session-server (concat "irc." name ".org")
|
|
erc-server-announced-name (concat "west." name ".org")
|
|
erc-server-users (make-hash-table :test #'equal)
|
|
erc-server-parameters nil
|
|
erc--isupport-params (make-hash-table)
|
|
erc-session-port 6667
|
|
erc-network (intern name)
|
|
erc-networks--id (erc-networks--id-create name))
|
|
(current-buffer)))
|
|
|
|
(defun erc-tests-common-string-to-propertized-parts (string)
|
|
"Return a sequence of `propertize' forms for generating STRING.
|
|
Expect maintainers manipulating template catalogs to use this
|
|
with `pp-eval-last-sexp' or similar to convert back and forth
|
|
between literal strings."
|
|
`(concat
|
|
,@(mapcar
|
|
(pcase-lambda (`(,beg ,end ,plist))
|
|
;; At the time of writing, `propertize' produces a string
|
|
;; with the order of the input plist reversed.
|
|
`(propertize ,(substring-no-properties string beg end)
|
|
,@(let (out)
|
|
(while-let ((plist)
|
|
(k (pop plist))
|
|
(v (pop plist)))
|
|
(push (if (or (consp v) (symbolp v)) `',v v) out)
|
|
(push `',k out))
|
|
out)))
|
|
(object-intervals string))))
|
|
|
|
(defun erc-tests-common-pp-propertized-parts (arg)
|
|
"Convert literal string before point into a `propertize'd form.
|
|
For simplicity, assume string evaluates to itself."
|
|
(interactive "P")
|
|
(let ((sexp (erc-tests-common-string-to-propertized-parts (pp-last-sexp))))
|
|
(if arg (insert (pp-to-string sexp)) (pp-macroexpand-expression sexp))))
|
|
|
|
|
|
(cl-defun erc-tests-common-add-cmem
|
|
(nick &optional (host "fsf.org")
|
|
(user (concat "~" (substring nick 0 (min 10 (length nick)))))
|
|
(full-name (upcase-initials nick)))
|
|
"Create channel user for NICK with test-oriented defaults."
|
|
(erc-update-channel-member (erc-target) nick nick t nil nil nil nil nil
|
|
host user full-name))
|
|
|
|
(defun erc-tests-common-parse-line (line)
|
|
"Return a single `erc-response' parsed from line."
|
|
(let ((parsed (erc-d-i--parse-message line)))
|
|
(make-erc-response :unparsed (erc-d-i-message.unparsed parsed)
|
|
:sender (erc-d-i-message.sender parsed)
|
|
:command (erc-d-i-message.command parsed)
|
|
:command-args (erc-d-i-message.command-args parsed)
|
|
:contents (erc-d-i-message.contents parsed)
|
|
:tags (erc-d-i-message.tags parsed))))
|
|
|
|
(defun erc-tests-common-simulate-line (line)
|
|
"Run response handlers for raw IRC protocol LINE."
|
|
(let ((parsed (erc-tests-common-parse-line line))
|
|
(erc--msg-prop-overrides (or erc--msg-prop-overrides
|
|
'((erc--ts . 0)))))
|
|
(erc-call-hooks erc-server-process parsed)))
|
|
|
|
(defun erc-tests-common-simulate-privmsg (nick msg)
|
|
(erc-tests-common-simulate-line
|
|
(format ":%s PRIVMSG %s :%s"
|
|
(erc-user-spec (erc-get-server-user nick))
|
|
(erc-target)
|
|
msg)))
|
|
|
|
;; The following utilities are meant to help prepare tests for
|
|
;; `erc--get-inserted-msg-bounds' and friends.
|
|
(defun erc-tests-common-get-inserted-msg-setup ()
|
|
(erc-tests-common-prep-for-insertion)
|
|
(let ((parsed (make-erc-response :unparsed ":bob PRIVMSG #chan :hi"
|
|
:sender "bob"
|
|
:command "PRIVMSG"
|
|
:command-args (list "#chan" "hi")
|
|
:contents "hi"))
|
|
(erc--msg-prop-overrides '((erc--ts . 0))))
|
|
(erc-display-message parsed nil (current-buffer)
|
|
(erc-format-privmessage "bob" "hi" nil t)))
|
|
(goto-char 3)
|
|
(should (looking-at "<bob> hi")))
|
|
|
|
;; All these bounds-finding functions take an optional POINT argument.
|
|
;; So run each case with and without it at each pos in the message.
|
|
(defun erc-tests-common-assert-get-inserted-msg (from to assert-fn)
|
|
(dolist (pt-arg '(nil t))
|
|
(dolist (i (number-sequence from to))
|
|
(goto-char i)
|
|
(ert-info ((format "At %d (%c) %s param" i (char-after i)
|
|
(if pt-arg "with" "")))
|
|
(funcall assert-fn (and pt-arg i))))))
|
|
|
|
(defun erc-tests-common-assert-get-inserted-msg/basic (test-fn)
|
|
(erc-tests-common-get-inserted-msg-setup)
|
|
(goto-char 11)
|
|
(should (looking-back "<bob> hi"))
|
|
(erc-tests-common-assert-get-inserted-msg 3 11 test-fn))
|
|
|
|
(defun erc-tests-common-assert-get-inserted-msg/truncated (test-fn)
|
|
(erc-tests-common-get-inserted-msg-setup)
|
|
(with-silent-modifications (delete-region 1 3))
|
|
(goto-char 9)
|
|
(should (looking-back "<bob> hi"))
|
|
(erc-tests-common-assert-get-inserted-msg 1 9 test-fn))
|
|
|
|
;; This is a "mixin" and requires a base assertion function, like
|
|
;; `erc-tests-common-assert-get-inserted-msg/basic', to work.
|
|
(defun erc-tests-common-assert-get-inserted-msg-readonly-with
|
|
(assert-fn test-fn)
|
|
(defvar erc-readonly-mode)
|
|
(defvar erc-readonly-mode-hook)
|
|
(let ((erc-readonly-mode nil)
|
|
(erc-readonly-mode-hook nil)
|
|
(erc-send-post-hook erc-send-post-hook)
|
|
(erc-insert-post-hook erc-insert-post-hook))
|
|
(erc-readonly-mode +1)
|
|
(funcall assert-fn test-fn)))
|
|
|
|
(defun erc-tests--common-display-message (orig &rest args)
|
|
(require 'erc-stamp)
|
|
(defvar erc-stamp--deferred-date-stamp)
|
|
(let (erc-stamp--deferred-date-stamp)
|
|
(prog1 (apply orig args)
|
|
(when-let* ((inst erc-stamp--deferred-date-stamp)
|
|
(fn (erc-stamp--date-fn inst)))
|
|
(funcall fn)))))
|
|
|
|
(defun erc-tests-common-display-message (&rest args)
|
|
(apply #'erc-tests--common-display-message #'erc-display-message args))
|
|
|
|
(defmacro erc-tests-common-with-date-aware-display-message (&rest body)
|
|
`(progn
|
|
(advice-add 'erc-display-message
|
|
:around #'erc-tests--common-display-message)
|
|
(unwind-protect (progn ,@body)
|
|
(advice-remove 'erc-display-message
|
|
#'erc-tests--common-display-message))))
|
|
|
|
;;;; Buffer snapshots
|
|
|
|
;; Use this variable to generate new snapshots after carefully
|
|
;; reviewing the output of *each* snapshot (not just first and last).
|
|
;; Obviously, only run one test at a time.
|
|
(defvar erc-tests-common-snapshot-save-p (getenv "ERC_TESTS_SNAPSHOT_SAVE"))
|
|
|
|
(defun erc-tests-common-snapshot-compare (name dir trans-fn buf-init-fn)
|
|
"Compare `buffer-string' to snapshot NAME.eld in DIR, if present.
|
|
When non-nil, run TRANS-FN to filter the current buffer string,
|
|
and expect a similar string in return. Call BUF-INIT-FN, when
|
|
non-nil, in the preview buffer after inserting the filtered
|
|
string."
|
|
(let* ((expect-file (file-name-with-extension (expand-file-name name dir)
|
|
"eld"))
|
|
(erc--own-property-names
|
|
(seq-difference `(font-lock-face ,@erc--own-property-names)
|
|
`(field display wrap-prefix line-prefix
|
|
erc--msg erc--cmd erc--spkr erc--ts erc--ctcp
|
|
erc--ephemeral)
|
|
#'eq))
|
|
(print-circle t)
|
|
(print-escape-newlines t)
|
|
(print-escape-nonascii t)
|
|
(got (erc--remove-text-properties
|
|
(buffer-substring (point-min) erc-insert-marker)))
|
|
(repr (funcall (or trans-fn #'identity) (prin1-to-string got)))
|
|
(xstr (read (with-temp-buffer
|
|
(insert-file-contents-literally expect-file)
|
|
(buffer-string)))))
|
|
(with-current-buffer (generate-new-buffer name)
|
|
(with-silent-modifications
|
|
(insert (setq got (read repr))))
|
|
(when buf-init-fn (funcall buf-init-fn))
|
|
(erc-mode))
|
|
(unless noninteractive
|
|
(with-current-buffer (generate-new-buffer (format "%s-xpt" name))
|
|
(insert xstr)
|
|
(erc-mode)))
|
|
;; LHS is a string, RHS is a symbol.
|
|
(if (string= erc-tests-common-snapshot-save-p
|
|
(ert-test-name (ert-running-test)))
|
|
(let (inhibit-message)
|
|
(with-temp-file expect-file
|
|
(insert repr))
|
|
;; Limit writing snapshots to one test at a time.
|
|
(message "erc-tests-common-snapshot-compare: wrote %S" expect-file))
|
|
(if (file-exists-p expect-file)
|
|
;; Ensure string-valued properties, like timestamps, aren't
|
|
;; recursive (signals `max-lisp-eval-depth' exceeded).
|
|
(named-let assert-equal
|
|
((latest (read repr))
|
|
(expect xstr))
|
|
(pcase latest
|
|
((or "" 'nil) t)
|
|
((pred stringp)
|
|
(should (equal-including-properties latest expect))
|
|
(let ((latest-intervals (object-intervals latest))
|
|
(expect-intervals (object-intervals expect)))
|
|
(while-let ((l-iv (pop latest-intervals))
|
|
(x-iv (pop expect-intervals))
|
|
(l-tab (map-into (nth 2 l-iv) 'hash-table))
|
|
(x-tab (map-into (nth 2 x-iv) 'hash-table)))
|
|
(pcase-dolist (`(,l-k . ,l-v) (map-pairs l-tab))
|
|
(assert-equal l-v (gethash l-k x-tab))
|
|
(remhash l-k x-tab))
|
|
(should (zerop (hash-table-count x-tab))))))
|
|
((pred sequencep)
|
|
(assert-equal (seq-first latest) (seq-first expect))
|
|
(assert-equal (seq-rest latest) (seq-rest expect)))
|
|
(_ (should (equal latest expect)))))
|
|
(message "Snapshot file missing: %S" expect-file)))))
|
|
|
|
(defun erc-tests-common-create-subprocess (code switches libs)
|
|
"Return subprocess for running CODE in an inferior Emacs.
|
|
Include SWITCHES, like \"-batch\", as well as libs, after
|
|
interspersing \"-l\" between members."
|
|
(let* ((package (if-let* ((found (getenv "ERC_PACKAGE_NAME"))
|
|
((string-prefix-p "erc-" found)))
|
|
(intern found)
|
|
'erc))
|
|
;; For integrations testing with managed configs that use a
|
|
;; different package manager.
|
|
(init (and-let* ((found (getenv "ERC_TESTS_INIT"))
|
|
(files (split-string found ",")))
|
|
(mapcan (lambda (f) (list "-l" f)) files)))
|
|
(prog
|
|
`(progn
|
|
,@(and (not init) (featurep 'compat)
|
|
`((require 'package)
|
|
(let ((package-load-list '((compat t) (,package t))))
|
|
(package-initialize))))
|
|
(require 'erc)
|
|
(cl-assert (equal erc-version ,erc-version) t)
|
|
,code))
|
|
(proc (apply #'start-process
|
|
(symbol-name (ert-test-name (ert-running-test)))
|
|
(current-buffer)
|
|
(concat invocation-directory invocation-name)
|
|
`(,@(or init '("-Q"))
|
|
,@switches
|
|
,@(mapcan (lambda (f) (list "-l" f)) libs)
|
|
"-eval" ,(format "%S" prog)))))
|
|
(set-process-query-on-exit-flag proc t)
|
|
proc))
|
|
|
|
(declare-function erc-track--setup "erc-track" ())
|
|
|
|
(defun erc-tests-common-track-modified-channels (test)
|
|
(erc-tests-common-prep-for-insertion)
|
|
(setq erc--target (erc--target-from-string "#chan"))
|
|
(erc-tests-common-track-modified-channels-sans-setup test))
|
|
|
|
(defun erc-tests-common-track-modified-channels-sans-setup (test)
|
|
"Provide a fixture for testing `erc-track-modified-channels'.
|
|
Call function TEST with another function that sets the mocked return
|
|
value of `erc-track--collect-faces-in' to the given argument, a list of
|
|
faces in the reverse order they appear in an inserted message."
|
|
(defvar erc-modified-channels-alist)
|
|
(defvar erc-modified-channels-object)
|
|
(defvar erc-track--attn-faces)
|
|
(defvar erc-track--normal-faces)
|
|
(defvar erc-track--priority-faces)
|
|
(defvar erc-track-faces-normal-list)
|
|
(defvar erc-track-faces-priority-list)
|
|
(defvar erc-track-mode)
|
|
|
|
(cl-letf* ((erc-track-mode t)
|
|
(erc-modified-channels-alist nil)
|
|
(erc-modified-channels-object erc-modified-channels-object)
|
|
(faces ())
|
|
((symbol-function 'force-mode-line-update) #'ignore)
|
|
((symbol-function 'erc-faces-in) (lambda (_) faces))
|
|
((symbol-function 'erc-track--collect-faces-in)
|
|
(lambda ()
|
|
(cons (map-into (mapcar (lambda (f) (cons f t)) faces)
|
|
'(hash-table :test equal))
|
|
faces))))
|
|
(erc-track--setup)
|
|
|
|
;; Faces from `erc-track--attn-faces' prepended.
|
|
(should (= (+ (length erc-track--attn-faces)
|
|
(length erc-track-faces-priority-list))
|
|
(hash-table-count erc-track--priority-faces)))
|
|
(should (= (length erc-track-faces-normal-list)
|
|
(hash-table-count erc-track--normal-faces)))
|
|
|
|
(funcall test (lambda (arg) (setq faces arg)))))
|
|
|
|
(provide 'erc-tests-common)
|