diff options
Diffstat (limited to 'test/lisp')
293 files changed, 20679 insertions, 2324 deletions
diff --git a/test/lisp/align-resources/align-post.c b/test/lisp/align-resources/align-post.c deleted file mode 100644 index 157e1d6242a..00000000000 --- a/test/lisp/align-resources/align-post.c +++ /dev/null @@ -1,3 +0,0 @@ -int -main (int argc, - char *argv[]); diff --git a/test/lisp/align-resources/align-post.java b/test/lisp/align-resources/align-post.java deleted file mode 100644 index e0ea8e727f1..00000000000 --- a/test/lisp/align-resources/align-post.java +++ /dev/null @@ -1,9 +0,0 @@ -class X -{ - String field1; - String[] field2; - int field3; - int[] field4; - X field5; - X[] field6; -} diff --git a/test/lisp/align-resources/align-pre.c b/test/lisp/align-resources/align-pre.c deleted file mode 100644 index b1774181a40..00000000000 --- a/test/lisp/align-resources/align-pre.c +++ /dev/null @@ -1,3 +0,0 @@ -int -main (int argc, - char *argv[]); diff --git a/test/lisp/align-resources/align-pre.java b/test/lisp/align-resources/align-pre.java deleted file mode 100644 index fe7a87a9393..00000000000 --- a/test/lisp/align-resources/align-pre.java +++ /dev/null @@ -1,9 +0,0 @@ -class X -{ - String field1; - String[] field2; - int field3; - int[] field4; - X field5; - X[] field6; -} diff --git a/test/lisp/align-resources/align-regexp.erts b/test/lisp/align-resources/align-regexp.erts new file mode 100644 index 00000000000..fbbd6d6bd33 --- /dev/null +++ b/test/lisp/align-resources/align-regexp.erts @@ -0,0 +1,13 @@ +Name: align function declaration + +=-= +Fred (123) 456-7890 +Alice (123) 456-7890 +Mary-Anne (123) 456-7890 +Joe (123) 456-7890 +=-= +Fred (123) 456-7890 +Alice (123) 456-7890 +Mary-Anne (123) 456-7890 +Joe (123) 456-7890 +=-=-= diff --git a/test/lisp/align-resources/c-mode.erts b/test/lisp/align-resources/c-mode.erts new file mode 100644 index 00000000000..a28c2bdbed0 --- /dev/null +++ b/test/lisp/align-resources/c-mode.erts @@ -0,0 +1,23 @@ +Name: align function declaration + +=-= +int +main (int argc, + char *argv[]); +=-= +int +main (int argc, + char *argv[]); +=-=-= + +Name: example from Commentary + +=-= + int a = 1; + short foo = 2; + double blah = 4; +=-= + int a = 1; + short foo = 2; + double blah = 4; +=-=-= diff --git a/test/lisp/align-resources/conf-toml-mode.erts b/test/lisp/align-resources/conf-toml-mode.erts new file mode 100644 index 00000000000..d1fcbd58708 --- /dev/null +++ b/test/lisp/align-resources/conf-toml-mode.erts @@ -0,0 +1,45 @@ +Name: align key-value pairs + +=-= +[foo] +foo1=10 +foo22=20 + +[bar] +bar333="example.org" +bar4444 = "zzz" +=-= +[foo] +foo1 = 10 +foo22 = 20 + +[bar] +bar333 = "example.org" +bar4444 = "zzz" +=-=-= + +Name: align list values + +=-= +[foo] +a = 1 +some_list = [ + true, + false, +] +some_other_list = [ + 1, + 2, +] +=-= +[foo] +a = 1 +some_list = [ + true, + false, +] +some_other_list = [ + 1, + 2, +] +=-=-= diff --git a/test/lisp/align-resources/css-mode.erts b/test/lisp/align-resources/css-mode.erts new file mode 100644 index 00000000000..e4455601083 --- /dev/null +++ b/test/lisp/align-resources/css-mode.erts @@ -0,0 +1,23 @@ +Name: align attributes + +=-= +div { + border: 1px solid black; + padding: 25px 50px 75px 100px; + background-color: lightblue; +} +p.center { + text-align: center; + color: red; +} +=-= +div { + border: 1px solid black; + padding: 25px 50px 75px 100px; + background-color: lightblue; +} +p.center { + text-align: center; + color: red; +} +=-=-= diff --git a/test/lisp/align-resources/java-mode.erts b/test/lisp/align-resources/java-mode.erts new file mode 100644 index 00000000000..693a4123121 --- /dev/null +++ b/test/lisp/align-resources/java-mode.erts @@ -0,0 +1,23 @@ +Name: align class fields + +=-= +class X +{ + String field1; + String[] field2; + int field3; + int[] field4; + X field5; + X[] field6; +} +=-= +class X +{ + String field1; + String[] field2; + int field3; + int[] field4; + X field5; + X[] field6; +} +=-=-= diff --git a/test/lisp/align-resources/latex-mode.erts b/test/lisp/align-resources/latex-mode.erts new file mode 100644 index 00000000000..cdc93e4a925 --- /dev/null +++ b/test/lisp/align-resources/latex-mode.erts @@ -0,0 +1,29 @@ +Name: tex-record-separator and basic-line-continuation + +=-= +\documentclass{} + +\begin{document} + +\begin{tabular}{l|l} + \textit{Player name} &\textit{Career home runs} \\ + \hline + Hank Aaron &755 \\ + Babe Ruth &714 +\end{tabular} + +\end{document} +=-= +\documentclass{} + +\begin{document} + +\begin{tabular}{l|l} + \textit{Player name} & \textit{Career home runs} \\ + \hline + Hank Aaron & 755 \\ + Babe Ruth & 714 +\end{tabular} + +\end{document} +=-=-= diff --git a/test/lisp/align-resources/lua-ts-mode.erts b/test/lisp/align-resources/lua-ts-mode.erts new file mode 100644 index 00000000000..b0473ad6cdf --- /dev/null +++ b/test/lisp/align-resources/lua-ts-mode.erts @@ -0,0 +1,67 @@ +Name: align assignments + +=-= +local first=1 +local s <const> =2 +local last=3 +=-= +local first = 1 +local s <const> = 2 +local last = 3 +=-=-= + +Name: align fields + +=-= +local Table={ +first=1, +second=2, +last=3, +} +=-= +local Table = { + first = 1, + second = 2, + last = 3, +} +=-=-= + +Name: align comments + +=-= +local first-- 1 +local second -- 2 +local last -- 3 +=-= +local first -- 1 +local second -- 2 +local last -- 3 +=-=-= + +Name: align assignments and comments + +=-= +local first=1-- one +local second=2 -- two +local last=3 -- three +=-= +local first = 1 -- one +local second = 2 -- two +local last = 3 -- three +=-=-= + +Name: align fields and comments + +=-= +local T={ +first=1,--one +second=2, --two +last=3, --three +} +=-= +local T = { + first = 1, --one + second = 2, --two + last = 3, --three +} +=-=-= diff --git a/test/lisp/align-resources/python-mode.erts b/test/lisp/align-resources/python-mode.erts new file mode 100644 index 00000000000..1ce50b32dba --- /dev/null +++ b/test/lisp/align-resources/python-mode.erts @@ -0,0 +1,29 @@ +Name: align assignments + +=-= +foo = "bar" +x = 1 +zzzzz = True +y = None +=-= +foo = "bar" +x = 1 +zzzzz = True +y = None +=-=-= + +Name: python-chain-logic and basic-line-continuation + +=-= +if foo or\ + b and \ + bcxxx and \ + c: + pass +=-= +if foo or \ + b and \ + bcxxx and \ + c: + pass +=-=-= diff --git a/test/lisp/align-tests.el b/test/lisp/align-tests.el index 62ef9cf27fa..f8dd7dcfb9b 100644 --- a/test/lisp/align-tests.el +++ b/test/lisp/align-tests.el @@ -25,22 +25,56 @@ (require 'ert-x) (require 'align) -(defun test-align-compare (file function) - (should (equal - (with-temp-buffer - (insert-file-contents (ert-resource-file (format file "pre"))) - (funcall function) - (align (point-min) (point-max)) - (buffer-substring-no-properties (point-min) (point-max))) - (with-temp-buffer - (insert-file-contents (ert-resource-file (format file "post"))) - (buffer-string))))) +;;;; align -(ert-deftest align-java () - (test-align-compare "align-%s.java" #'java-mode)) +(defun test-align-transform-fun (function) + (lambda () + (funcall function) + (align (point-min) (point-max)))) (ert-deftest align-c () - (test-align-compare "align-%s.c" #'c-mode)) + (ert-test-erts-file (ert-resource-file "c-mode.erts") + (test-align-transform-fun #'c-mode))) + +(ert-deftest align-css () + (let ((indent-tabs-mode nil)) + (ert-test-erts-file (ert-resource-file "css-mode.erts") + (test-align-transform-fun #'css-mode)))) + +(ert-deftest align-java () + (ert-test-erts-file (ert-resource-file "java-mode.erts") + (test-align-transform-fun #'java-mode))) + +(ert-deftest align-latex () + (ert-test-erts-file (ert-resource-file "latex-mode.erts") + (test-align-transform-fun #'latex-mode))) + +(autoload 'treesit-ready-p "treesit") + +(ert-deftest align-lua () + (skip-unless (treesit-ready-p 'lua)) + (let ((comment-column 20) + (indent-tabs-mode nil)) + (ert-test-erts-file (ert-resource-file "lua-ts-mode.erts") + (test-align-transform-fun #'lua-ts-mode)))) + +(ert-deftest align-python () + (ert-test-erts-file (ert-resource-file "python-mode.erts") + (test-align-transform-fun #'python-mode))) + +(ert-deftest align-toml () + (let ((indent-tabs-mode nil)) + (ert-test-erts-file (ert-resource-file "conf-toml-mode.erts") + (test-align-transform-fun #'conf-toml-mode)))) + +;;;; align-regexp + +(ert-deftest align-regexp () + (let ((indent-tabs-mode nil)) + (ert-test-erts-file (ert-resource-file "align-regexp.erts") + (lambda () + (align-regexp (point-min) (point-max) + "\\(\\s-*\\)("))))) (provide 'align-tests) diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index 32bce1b71bd..c42fd8d432c 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -46,6 +46,85 @@ (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer)) (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer))))) +(ert-deftest arc-mode-test-zip-ensure-ext () + "Regression test for bug#61326." + (skip-unless (executable-find "zip")) + (let* ((default-directory arc-mode-tests-data-directory) + (created-files nil) + (base-zip-1 "base-1.zip") + (base-zip-2 "base-2.zip") + (content-1 '("1" "2")) + (content-2 '("3" "4")) + (make-file (lambda (name) + (push name created-files) + (with-temp-buffer + (insert name) + (write-file name)))) + (make-zip + (lambda (zip files) + (delete-file zip nil) + (push zip created-files) + (funcall (archive--act-files '("zip") files) zip))) + (update-fn + (lambda (zip-nonempty) + (with-current-buffer (find-file-noselect zip-nonempty) + (save-excursion + (goto-char archive-file-list-start) + (save-current-buffer + (archive-extract) + (save-excursion + (goto-char (point-max)) + (insert ?a) + (save-buffer)) + (kill-buffer (current-buffer))) + (archive-extract) + ;; [2] must be ?a; [3] must be (eobp) + (should (eq (char-after 2) ?a)) + (should (eq (point-max) 3)))))) + (delete-fn + (lambda (zip-nonempty) + (with-current-buffer (find-file-noselect zip-nonempty) + ;; mark delete and expunge first entry + (save-excursion + (goto-char archive-file-list-start) + (should (length= archive-files 2)) + (archive-flag-deleted 1) + (archive--expunge-maybe-force t) + (should (length= archive-files 1)))))) + (test-modify + (lambda (zip mod-fn) + (let ((zip-base (concat zip ".zip")) + (tag (gensym))) + (push zip created-files) + (copy-file base-zip-1 zip t) + (push zip-base created-files) + (copy-file base-zip-2 zip-base t) + (file-has-changed-p zip tag) + (file-has-changed-p zip-base tag) + (funcall mod-fn zip) + (should-not (file-has-changed-p zip-base tag)) + (should (file-has-changed-p zip tag)))))) + (unwind-protect + (progn + ;; setup: make two zip files with different contents + (mapc make-file (append content-1 content-2)) + (funcall make-zip base-zip-1 content-1) + (funcall make-zip base-zip-2 content-2) + + ;; test 1: with "test-update" and "test-update.zip", update + ;; "test-update": (1) ensure only "test-update" is modified, (2) + ;; ensure the contents of the new member is expected. + (funcall test-modify "test-update" update-fn) + + ;; test 2: with "test-delete" and "test-delete.zip", delete entry + ;; from "test-delete": (1) ensure only "test-delete" is modified, + ;; (2) ensure the file list is reduced as expected. + (funcall test-modify "test-delete" delete-fn)) + + ;; Clean up created files. + (dolist (file created-files) + (ignore-errors (delete-file file)))))) + (provide 'arc-mode-tests) ;;; arc-mode-tests.el ends here diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 6f832725754..ab1a437b303 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -341,13 +341,14 @@ (should (string-equal (plist-get auth-info :user) (user-login-name))) (should (string-equal (plist-get auth-info :host) host)) - (should (string-equal auth-passwd passwd))))) + (should (string-equal auth-passwd passwd)))) - ;; Cleanup. - ;; Should use `auth-source-delete' when implemented for :secrets backend. - (secrets-delete-item - "session" - (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))) + ;; Cleanup. + ;; Should use `auth-source-delete' when implemented for :secrets backend. + (secrets-delete-item + "session" + (format + "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))))) (ert-deftest auth-source-test-netrc-create-secret () (ert-with-temp-file netrc-file @@ -434,5 +435,25 @@ machine c1 port c2 user c3 password c4\n" '((("machine" . "XM") ("login" . "XL") ("password" . "XP")) (("machine" . "YM") ("login" . "YL") ("password" . "YP"))))))) +(ert-deftest test-macos-keychain-search () + "Test if the constructed command line arglist is correct." + (let ((auth-sources '(macos-keychain-internet macos-keychain-generic))) + ;; Redefine `call-process' to check command line arguments. + (cl-letf (((symbol-function 'call-process) + (lambda (_program _infile _destination _display + &rest args) + ;; Arguments must be all strings + (should (cl-every #'stringp args)) + ;; Argument number should be even + (should (cl-evenp (length args))) + (should (cond ((string= (car args) "find-internet-password") + (let ((protocol (cl-member "-r" args :test #'string=))) + (if protocol + (= 4 (length (cadr protocol))) + t))) + ((string= (car args) "find-generic-password") + t)))))) + (auth-source-search :user '("a" "b") :host '("example.org") :port '("irc" "ftp" "https"))))) + (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 8dbb5d2a496..e01ce82858b 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -257,7 +257,7 @@ This expects `auto-revert--messages' to be bound by ;; Repeated unpredictable failures, bug#32645. :tags '(:unstable) ;; Unlikely to be hydra-specific? - ;; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + ;; (skip-when (getenv "EMACS_HYDRA_CI")) (with-auto-revert-test (ert-with-temp-file tmpfile (let (;; Try to catch bug#32645. diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 41c47e5332c..74eaf9093e8 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -698,8 +698,8 @@ An existing calc stack is reused, otherwise a new one is created." (calc-tests--not x w))) (dolist (n '(0 1 4 16 32 -1 -4 -16 -32)) - (equal (calcFunc-clip x n) - (calc-tests--clip x n))) + (should (equal (calcFunc-clip x n) + (calc-tests--clip x n)))) (dolist (y '(0 1 #x1234 #x8000 #xabcd #xffff #x12345678 #xabcdef12 #x80000000 #xffffffff @@ -816,5 +816,43 @@ An existing calc stack is reused, otherwise a new one is created." (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6))))) (should (< (abs (- x (sqrt 2.0))) 1.0e-10)))) +(require 'calc-aent) + +(ert-deftest calc-math-read-preprocess-string () + "Test replacement of allowed special Unicode symbols." + ;; ... doesn't change an empty string + (should (string= "" (math-read-preprocess-string ""))) + ;; ... doesn't change a string without characters from + ;; ‘math-read-replacement-list’ + (let ((str "don't replace here")) + (should (string= str (math-read-preprocess-string str)))) + ;; ... replaces irrespective of position in input string + (should (string= "^(1)" (math-read-preprocess-string "¹"))) + (should (string= "some^(1)" (math-read-preprocess-string "some¹"))) + (should (string= "^(1)time" (math-read-preprocess-string "¹time"))) + (should (string= "some^(1)else" (math-read-preprocess-string "some¹else"))) + ;; ... replaces every element of ‘math-read-replacement-list’ correctly, + ;; in particular combining consecutive super-/subscripts into one + ;; exponent/subscript + (should (string= (concat "+/-*:-/*inf<=>=<=>=μ(1:4)(1:2)(3:4)(1:3)(2:3)" + "(1:5)(2:5)(3:5)(4:5)(1:6)(5:6)" + "(1:8)(3:8)(5:8)(7:8)1:^(0123456789+-()ni)" + "_(0123456789+-())") + (math-read-preprocess-string + (mapconcat #'car math-read-replacement-list)))) + ;; ... replaces strings of more than a single character correctly + (let ((math-read-replacement-list (append + math-read-replacement-list + '(("𝚤𝚥" "ij")) + '(("¼½" "(1:4)(1:2)"))))) + (should (string= "(1:4)(1:2)ij" + (math-read-preprocess-string "¼½𝚤𝚥")))) + ;; ... handles an empty replacement list gracefully + (let ((math-read-replacement-list '())) + (should (string= "¼" (math-read-preprocess-string "¼")))) + ;; ... signals an error if the argument is not a string + (should-error (math-read-preprocess-string nil)) + (should-error (math-read-preprocess-string 42))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calculator-tests.el b/test/lisp/calculator-tests.el index 7ac3b9ba37a..8786d5c6c3b 100644 --- a/test/lisp/calculator-tests.el +++ b/test/lisp/calculator-tests.el @@ -47,5 +47,11 @@ (let ((calculator-input-radix nil)) (should (equal (calculator-string-to-number str) expected))))))) +(ert-deftest calculator-expt () + (should (= (calculator-expt 2 -1) 0.5)) + (should (= (calculator-expt -2 2) 4)) + (should (= (calculator-expt -2 3) -8)) + (should (= (calculator-expt 2 64) 18446744073709551616))) + (provide 'calculator-tests) ;;; calculator-tests.el ends here diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el index baae9282628..e19965d1034 100644 --- a/test/lisp/calendar/lunar-tests.el +++ b/test/lisp/calendar/lunar-tests.el @@ -41,10 +41,10 @@ (should (equal (lunar-phase 1) '((1 8 1900) "05:40" 1 ""))))) -(ert-deftest lunar-test-eclipse-check () +(ert-deftest lunar-test-check-for-eclipse () (with-lunar-test - (should (equal (eclipse-check 10.0 1) "")) - (should (equal (eclipse-check 10.0 2) "** Lunar Eclipse **")))) + (should (equal (lunar-check-for-eclipse 10.0 1) "")) + (should (equal (lunar-check-for-eclipse 10.0 2) "** Lunar Eclipse **")))) (ert-deftest lunar-test-phase-list () (with-lunar-test diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 8d4ea69e9eb..3b49dd56b69 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -934,5 +934,70 @@ since all non-initial item lines must begin with whitespace." (insert (concat "\n" item1)) (should-error (todo-edit-quit) :type 'user-error)))) +(ert-deftest todo-test-item-insertion-with-priority-1 () + "Test inserting new item when point is not on a todo item. +When point is on the empty line at the end of the todo items +section, insertion with priority setting should succeed." + (with-todo-test + (todo-test--show 1) + (goto-char (point-max)) + ;; Now point should not be on a todo item. + (should-not (todo-item-start)) + (let ((item "Point was on empty line at end of todo items section.")) + (todo-test--insert-item item 1) + ;; Move point to item that was just inserted. + (goto-char (point-min)) + (re-search-forward (concat todo-date-string-start todo-date-pattern + (regexp-quote todo-nondiary-end) " ") + (pos-eol) t) + (should (looking-at (regexp-quote item)))))) + +(ert-deftest todo-test-item-insertion-with-priority-2 () + "Test inserting new item when point is not on a todo item. +When point is on the empty line at the end of the done items +section, insertion with priority setting should succeed." + (with-todo-test + (todo-test--show 1) + (goto-char (point-max)) + ;; See comment about recentering in todo-test-raise-lower-priority. + (set-window-buffer nil (current-buffer)) + (todo-toggle-view-done-items) + (todo-next-item) + (goto-char (point-max)) + ;; Now point should be at end of done items section, so not be on a + ;; todo item. + (should (todo-done-item-section-p)) + (should-not (todo-item-start)) + (let ((item "Point was on empty line at end of done items section.")) + (todo-test--insert-item item 1) + ;; Move point to item that was just inserted. + (goto-char (point-min)) + (re-search-forward (concat todo-date-string-start todo-date-pattern + (regexp-quote todo-nondiary-end) " ") + (pos-eol) t) + (should (looking-at (regexp-quote item)))))) + +(ert-deftest todo-test-item-insertion-with-priority-3 () + "Test inserting new item when point is not on a todo item. +When point is on a done item, insertion with priority setting +should succeed." + (with-todo-test + (todo-test--show 1) + (goto-char (point-max)) + ;; See comment about recentering in todo-test-raise-lower-priority. + (set-window-buffer nil (current-buffer)) + (todo-toggle-view-done-items) + (todo-next-item) + ;; Now point should be on first done item. + (should (and (todo-item-start) (todo-done-item-section-p))) + (let ((item "Point was on a done item.")) + (todo-test--insert-item item 1) + ;; Move point to item that was just inserted. + (goto-char (point-min)) + (re-search-forward (concat todo-date-string-start todo-date-pattern + (regexp-quote todo-nondiary-end) " ") + (pos-eol) t) + (should (looking-at (regexp-quote item)))))) + (provide 'todo-mode-tests) ;;; todo-mode-tests.el ends here diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index 5437d65d139..0b703fcaa2f 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -31,62 +31,88 @@ ;;; From bovine-gcc: -;; Example output of "gcc -v" -(defvar semantic-gcc-test-strings - '(;; My old box: - "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs +(defmacro semantic-gcc-test (str) + `(let ((fields (semantic-gcc-fields ,str))) + (let-alist fields + (message "%S" fields) + ;; No longer test for prefixes. + ;; (should .--prefix) + (should .version) + (should (or .target + .--target + .--host))))) + +;; A bunch of sample gcc -v outputs from different machines. + +(ert-deftest semantic-gcc-test/1 () + ;; My old box: + (semantic-gcc-test "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux Thread model: posix -gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)" - ;; Alex Ott: - "Using built-in specs. +gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)")) + +(ert-deftest semantic-gcc-test/2 () + ;; Alex Ott: + (semantic-gcc-test "Using built-in specs. Target: i486-linux-gnu Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu Thread model: posix -gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)" - ;; My debian box: - "Using built-in specs. +gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)")) + +(ert-deftest semantic-gcc-test/3 () + ;; My Debian box: + (semantic-gcc-test "Using built-in specs. Target: x86_64-unknown-linux-gnu Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib Thread model: posix -gcc version 4.2.3" - ;; My mac: - "Using built-in specs. +gcc version 4.2.3")) + +(ert-deftest semantic-gcc-test/4 () + ;; My mac: + (semantic-gcc-test "Using built-in specs. Target: i686-apple-darwin8 Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8 Thread model: posix -gcc version 4.0.1 (Apple Computer, Inc. build 5341)" - ;; Ubuntu Intrepid - "Using built-in specs. +gcc version 4.0.1 (Apple Computer, Inc. build 5341)")) + +(ert-deftest semantic-gcc-test/5 () + ;; Ubuntu Intrepid + (semantic-gcc-test "Using built-in specs. Target: x86_64-linux-gnu Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu Thread model: posix -gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" - ;; Red Hat EL4 - "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs +gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)")) + +(ert-deftest semantic-gcc-test/6 () + ;; Red Hat EL4 + (semantic-gcc-test "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux Thread model: posix -gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)" - ;; Red Hat EL5 - "Using built-in specs. +gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)")) + +(ert-deftest semantic-gcc-test/7 () + ;; Red Hat EL5 + (semantic-gcc-test "Using built-in specs. Target: x86_64-redhat-linux Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux Thread model: posix -gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)" - ;; David Engster's german gcc on ubuntu 4.3 - "Es werden eingebaute Spezifikationen verwendet. +gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)")) + +(ert-deftest semantic-gcc-test/8 () + ;; David Engster's german gcc on ubuntu 4.3 + (semantic-gcc-test "Es werden eingebaute Spezifikationen verwendet. Ziel: i486-linux-gnu Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu Thread-Modell: posix -gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" - ;; Damien Deville bsd - "Using built-in specs. +gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)")) + +(ert-deftest semantic-gcc-test/9 () + ;; Damien Deville bsd + (semantic-gcc-test "Using built-in specs. Target: i386-undermydesk-freebsd Configured with: FreeBSD/i386 system compiler Thread model: posix -gcc version 4.2.1 20070719 [FreeBSD]" - ) - "A bunch of sample gcc -v outputs from different machines.") +gcc version 4.2.1 20070719 [FreeBSD]")) (defvar semantic-gcc-test-strings-fail '(;; A really old solaris box I found @@ -95,19 +121,8 @@ gcc version 2.95.2 19991024 (release)" ) "A bunch of sample gcc -v outputs that fail to provide the info we want.") -(defun semantic-gcc-test-output-parser () +(ert-deftest semantic-gcc-test-output-parser/fail () "Test the output parser against some collected strings." - (dolist (S semantic-gcc-test-strings) - (let* ((fields (semantic-gcc-fields S)) - (v (cdr (assoc 'version fields))) - (h (or (cdr (assoc 'target fields)) - (cdr (assoc '--target fields)) - (cdr (assoc '--host fields)))) - (p (cdr (assoc '--prefix fields)))) - ;; No longer test for prefixes. - (when (not (and v h)) - (let ((strs (split-string S "\n"))) - (error "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p))))) (dolist (S semantic-gcc-test-strings-fail) (let* ((fields (semantic-gcc-fields S)) (v (cdr (assoc 'version fields))) @@ -118,14 +133,10 @@ gcc version 2.95.2 19991024 (release)" (when (and v h p) (error "Negative test failed on %S" S))))) -(ert-deftest semantic-gcc-test-output-parser () - (semantic-gcc-test-output-parser)) - -(ert-deftest semantic-gcc-test-output-parser-this-machine () +(ert-deftest semantic-gcc-test-output-parser/this-machine () "Test the output parser against the machine currently running Emacs." (skip-unless (and (executable-find "gcc") (not (ert-gcc-is-clang-p)))) - (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v")))) - (semantic-gcc-test-output-parser))) + (semantic-gcc-test (semantic-gcc-query "gcc" "-v"))) ;;; gcc-tests.el ends here diff --git a/test/lisp/completion-preview-tests.el b/test/lisp/completion-preview-tests.el new file mode 100644 index 00000000000..b5518e96254 --- /dev/null +++ b/test/lisp/completion-preview-tests.el @@ -0,0 +1,184 @@ +;;; completion-preview-tests.el --- tests for completion-preview.el -*- 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/>. + +;;; Code: + +(require 'ert) +(require 'completion-preview) + +(defun completion-preview-tests--capf (completions &rest props) + (lambda () + (when-let ((bounds (bounds-of-thing-at-point 'symbol))) + (append (list (car bounds) (cdr bounds) completions) props)))) + +(defun completion-preview-tests--check-preview (string &optional exact) + "Check that the completion preview is showing STRING. + +If EXACT is non-nil, check that STRING has the +`completion-preview-exact' face. Otherwise check that STRING has +the `completion-preview' face. + +If STRING is nil, check that there is no completion preview +instead." + (if (not string) + (should (not completion-preview--overlay)) + (should completion-preview--overlay) + (let ((after-string (completion-preview--get 'after-string))) + (should (string= after-string string)) + (should (eq (get-text-property 0 'face after-string) + (if exact + 'completion-preview-exact + 'completion-preview)))))) + +(ert-deftest completion-preview () + "Test Completion Preview mode." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf '("foobarbaz")))) + + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Exact match + (completion-preview-tests--check-preview "barbaz" 'exact) + + (insert "v") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; No match, no preview + (completion-preview-tests--check-preview nil) + + (delete-char -1) + (let ((this-command 'delete-backward-char)) + (completion-preview--post-command)) + + ;; Exact match again + (completion-preview-tests--check-preview "barbaz" 'exact))) + +(ert-deftest completion-preview-multiple-matches () + "Test Completion Preview mode with multiple matching candidates." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf + '("foobar" "foobaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Multiple matches, the preview shows the first one + (completion-preview-tests--check-preview "bar") + + (completion-preview-next-candidate 1) + + ;; Next match + (completion-preview-tests--check-preview "baz"))) + +(ert-deftest completion-preview-exact-match-only () + "Test `completion-preview-exact-match-only'." + (with-temp-buffer + (setq-local completion-at-point-functions + (list (completion-preview-tests--capf + '("spam" "foobar" "foobaz"))) + completion-preview-exact-match-only t) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Multiple matches, so no preview + (completion-preview-tests--check-preview nil) + + (delete-region (point-min) (point-max)) + (insert "spa") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + + ;; Exact match + (completion-preview-tests--check-preview "m" 'exact))) + +(ert-deftest completion-preview-function-capfs () + "Test Completion Preview mode with capfs that return a function." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (lambda () #'ignore) + (completion-preview-tests--capf + '("foobar" "foobaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar"))) + +(ert-deftest completion-preview-non-exclusive-capfs () + "Test Completion Preview mode with non-exclusive capfs." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("spam") :exclusive 'no) + (completion-preview-tests--capf + '("foobar" "foobaz") :exclusive 'no) + (completion-preview-tests--capf + '("foobarbaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "bar") + (setq-local completion-preview-exact-match-only t) + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "barbaz" 'exact))) + +(ert-deftest completion-preview-face-updates () + "Test updating the face in completion preview when match is no longer exact." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (completion-preview-tests--capf + '("foobarbaz" "food")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "d") + (insert "b") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "arbaz" 'exact) + (delete-char -1) + (let ((this-command 'delete-backward-char)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "d"))) + +(ert-deftest completion-preview-capf-errors () + "Test Completion Preview mode with capfs that signal errors. + +`dabbrev-capf' is one example of such a capf." + (with-temp-buffer + (setq-local completion-at-point-functions + (list + (lambda () (user-error "bad")) + (completion-preview-tests--capf + '("foobarbaz")))) + (insert "foo") + (let ((this-command 'self-insert-command)) + (completion-preview--post-command)) + (completion-preview-tests--check-preview "barbaz" 'exact))) + +;;; completion-preview-tests.el ends here diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el index eca35d7c96a..9ceab16e194 100644 --- a/test/lisp/cus-edit-tests.el +++ b/test/lisp/cus-edit-tests.el @@ -92,5 +92,47 @@ (buffer-substring-no-properties (point-min) (point-max))))) (should (string-search "Value `:foo' does not match type number" warn-txt)))) + +(defcustom cus-edit-test-bug63290-option nil + "Choice option for testing Bug#63290." + :type '(choice (alist + :key-type (string :tag "key") + :value-type (string :tag "value")) + (const :tag "auto" auto))) + +(defcustom cus-edit-test-bug63290-option2 'some + "Choice option for testing Bug#63290." + :type '(choice + (const :tag "some" some) + (alist + :key-type (string :tag "key") + :value-type (string :tag "value")))) + +(ert-deftest cus-edit-test-bug63290 () + "Test that changing a choice value back to an alist respects its nil value." + (customize-variable 'cus-edit-test-bug63290-option) + (search-forward "Value") + ;; Simulate changing the value. + (let* ((choice (widget-at)) + (args (widget-get choice :args)) + (list-opt (car (widget-get choice :children))) + (const-opt (nth 1 args))) + (widget-put choice :explicit-choice const-opt) + (widget-value-set choice (widget-default-get const-opt)) + (widget-put choice :explicit-choice list-opt) + (widget-value-set choice (widget-default-get list-opt))) + ;; No empty key/value pairs should show up. + (should-not (search-forward "key" nil t)) + (customize-variable 'cus-edit-test-bug63290-option2) + (search-forward "Value") + ;; Simulate changing the value. + (let* ((choice (widget-at)) + (args (widget-get choice :args)) + (list-opt (nth 1 args))) + (widget-put choice :explicit-choice list-opt) + (widget-value-set choice (widget-default-get list-opt))) + ;; No empty key/value pairs should show up. + (should-not (search-forward "key" nil t))) + (provide 'cus-edit-tests) ;;; cus-edit-tests.el ends here diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 5939f480680..62011d8b0f0 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -55,12 +55,11 @@ (setq to-mv (expand-file-name "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) - (unwind-protect - (if ,yes-or-no - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (_prompt) (eq ,yes-or-no 'yes)))) - ,@body) - ,@body))))))) + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body)))))) (ert-deftest dired-test-bug28834 () "test for https://debbugs.gnu.org/28834 ." diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 347bdfc0d7b..599cfa0ce77 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -241,12 +241,12 @@ (let ((buffers (find-file (concat (file-name-as-directory test-dir) "*") t))) + (setq allbufs (append buffers allbufs)) (dolist (buf buffers) (let ((pt (with-current-buffer buf (point)))) (switch-to-buffer (find-file-noselect test-dir)) (find-file (buffer-name buf)) - (should (equal (point) pt)))) - (append buffers allbufs))) + (should (equal (point) pt)))))) (dolist (buf allbufs) (when (buffer-live-p buf) (kill-buffer buf))))))) @@ -270,8 +270,8 @@ "Test for https://debbugs.gnu.org/27631 ." ;; For dired using 'ls' emulation we test for this bug in ;; ls-lisp-tests.el and em-ls-tests.el. - (skip-unless (and (not (featurep 'ls-lisp)) - (not (featurep 'eshell)))) + (skip-unless (not (or (featurep 'ls-lisp) + (featurep 'eshell)))) (ert-with-temp-directory dir (let* ((dir1 (expand-file-name "dir1" dir)) (dir2 (expand-file-name "dir2" dir)) @@ -477,9 +477,9 @@ ;;(should (= 0 (length (directory-files testdir nil "[0-9]" t -1)))) (should (= 5 (length (directory-files testdir nil "[0-9]" t)))) (should (= 5 (length (directory-files testdir nil "[0-9]" t 50)))) - (should-not (directory-empty-p testdir))) + (should-not (directory-empty-p testdir)))) - (delete-directory testdir t))))) + (delete-directory testdir t)))) (ert-deftest dired-test-directory-files-and-attributes () "Test for `directory-files-and-attributes'." diff --git a/test/lisp/dnd-tests.el b/test/lisp/dnd-tests.el index a603f29eb6d..7a7f54ba0bb 100644 --- a/test/lisp/dnd-tests.el +++ b/test/lisp/dnd-tests.el @@ -33,6 +33,7 @@ (require 'tramp) (require 'select) (require 'ert-x) +(require 'browse-url) (defvar dnd-tests-selection-table nil "Alist of selection names to their values.") @@ -172,7 +173,7 @@ This function only tries to handle strings." (extracted-1 (dnd-tests-extract-selection-data string-data-1 t)) (extracted (dnd-tests-extract-selection-data string-data t))) (should (and (stringp extracted) (stringp extracted-1))) - (should (equal extracted extracted))) + (should (equal extracted extracted-1))) ;; Now check text/plain. (let ((string-data (dnd-tests-verify-selection-data 'text/plain))) @@ -437,5 +438,162 @@ This function only tries to handle strings." (ignore-errors (delete-file normal-temp-file))))) + + +(defvar dnd-tests-list-1 '("file:///usr/openwin/include/pixrect/pr_impl.h" + "file:///usr/openwin/include/pixrect/pr_io.h") + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-2 '("file:///usr/openwin/include/pixrect/pr_impl.h" + "file://remote/usr/openwin/include/pixrect/pr_io.h") + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-3 (append dnd-tests-list-2 '("http://example.com")) + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defvar dnd-tests-list-4 (append dnd-tests-list-3 '("scheme1://foo.bar" + "scheme2://foo.bar")) + "Sample data for tests concerning the treatment of drag-and-drop URLs.") + +(defun dnd-tests-local-file-function (urls _action) + "Signal an error if URLS doesn't match `dnd-tests-list-1'. +ACTION is ignored. Return the symbol `copy' otherwise." + (should (equal urls dnd-tests-list-1)) + 'copy) + +(put 'dnd-tests-local-file-function 'dnd-multiple-handler t) + +(defun dnd-tests-remote-file-function (urls _action) + "Signal an error if URLS doesn't match `dnd-tests-list-2'. +ACTION is ignored. Return the symbol `copy' otherwise." + (should (equal urls dnd-tests-list-2)) + 'copy) + +(put 'dnd-tests-remote-file-function 'dnd-multiple-handler t) + +(defun dnd-tests-http-scheme-function (url _action) + "Signal an error if URLS doesn't match `dnd-tests-list-3''s third element. +ACTION is ignored. Return the symbol `private' otherwise." + (should (equal url (car (last dnd-tests-list-3)))) + 'private) + +(defun dnd-tests-browse-url-handler (url &rest _ignored) + "Verify URL is `dnd-tests-list-4''s fourth element." + (should (equal url (nth 3 dnd-tests-list-4)))) + +(put 'dnd-tests-browse-url-handler 'browse-url-browser-kind 'internal) + +(ert-deftest dnd-tests-receive-multiple-urls () + (let ((dnd-protocol-alist '(("^file:///" . dnd-tests-local-file-function) + ("^file:" . error) + ("^unrelated-scheme:" . error))) + (browse-url-handlers nil)) + ;; Check that the order of the alist is respected when the + ;; precedences of two handlers are equal. + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-1) + 'copy) + 'copy)) + ;; Check that sorting handlers by precedence functions correctly. + (setq dnd-protocol-alist '(("^file:///" . error) + ("^file:" . dnd-tests-remote-file-function) + ("^unrelated-scheme:" . error))) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-2) + 'copy) + 'copy)) + ;; Check that multiple handlers can be called at once, and actions + ;; are properly "downgraded" to private when multiple handlers + ;; return inconsistent values. + (setq dnd-protocol-alist '(("^file:" . dnd-tests-remote-file-function) + ("^file:///" . error) + ("^http://" . dnd-tests-http-scheme-function))) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-3) + 'copy) + 'private)) + ;; Now verify that the function's documented fallback behavior + ;; functions correctly. Set browse-url-handlers to an association + ;; list incorporating a test function, then guarantee that is + ;; called. + (setq browse-url-handlers '(("^scheme1://" . dnd-tests-browse-url-handler))) + ;; Furthermore, guarantee the fifth argument of the test data is + ;; inserted, for no apposite handler exists. + (save-window-excursion + (set-window-buffer nil (get-buffer-create " *dnd-tests*")) + (set-buffer (get-buffer-create " *dnd-tests*")) + (erase-buffer) + (should (equal (dnd-handle-multiple-urls (selected-window) + (copy-sequence + dnd-tests-list-4) + 'copy) + 'private)) + (should (equal (buffer-string) (nth 4 dnd-tests-list-4)))) + ;; Check that a handler enumerated twice in the handler list + ;; receives URIs assigned to it only once. + (let* ((received-p nil) + (lambda (lambda (uri _action) + (should (equal uri "scheme1://test")) + (should (null received-p)) + (setq received-p 'copy)))) + (setq dnd-protocol-alist (list (cons "scheme1://" lambda) + (cons "scheme1://" lambda))) + (should (equal (dnd-handle-multiple-urls (selected-window) + (list "scheme1://test") + 'copy) + 'copy))))) + +(ert-deftest dnd-tests-default-file-name-handlers () + (let* ((local-files-opened nil) + (remote-files-opened nil) + (function-1 (lambda (file _uri) + (push file local-files-opened) + 'copy)) + (function-2 (lambda (file _uri) + (push file remote-files-opened) + 'copy))) + (unwind-protect + (progn + (advice-add #'dnd-open-local-file :override + function-1) + (advice-add #'dnd-open-file :override + function-2) + ;; Guarantee that file names are properly categorized as either + ;; local or remote by the default dnd-protocol-alist. + (dnd-handle-multiple-urls + (selected-window) + (list + ;; These are run-of-the-mill local file URIs. + "file:///usr/include/sys/acct.h" + "file:///usr/include/sys/acctctl.h" + ;; These URIs incorporate a host; they should match + ;; function-2 but never function-1. + "file://remotehost/usr/src/emacs/configure.ac" + "file://remotehost/usr/src/emacs/configure" + ;; These URIs are generated by drag-and-drop event + ;; handlers from local file names alone; they are not + ;; echt URIs in and of themselves, but a product of our + ;; drag and drop code. + "file:/etc/vfstab" + "file:/etc/dfs/sharetab" + ;; These URIs are generated under MS-Windows. + "file:c:/path/to/file/name" + "file:d:/path/to/file/name") + 'copy) + (should (equal (sort local-files-opened #'string<) + '("file:///usr/include/sys/acct.h" + "file:///usr/include/sys/acctctl.h" + "file:/etc/dfs/sharetab" + "file:/etc/vfstab" + "file:c:/path/to/file/name" + "file:d:/path/to/file/name"))) + (should (equal (sort remote-files-opened #'string<) + '("file://remotehost/usr/src/emacs/configure" + "file://remotehost/usr/src/emacs/configure.ac")))) + (advice-remove #'dnd-open-local-file function-2)))) + (provide 'dnd-tests) ;;; dnd-tests.el ends here diff --git a/test/lisp/elide-head-tests.el b/test/lisp/elide-head-tests.el index d751eee06a0..40a9d365f37 100644 --- a/test/lisp/elide-head-tests.el +++ b/test/lisp/elide-head-tests.el @@ -180,6 +180,90 @@ ;; along with Mentor. If not, see <https://www.gnu.org/licenses>. " "Mentor is distributed in the hope that") +;; from GnuTLS [has a line break in snail mail address] +(elide-head--add-test gpl3-6 "\ +# This file is part of GnuTLS. +# +# This program 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. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 +# USA +" "This program is distributed in the hope that") + +;; from GnuTLS [has a different line break in snail mail address] +(elide-head--add-test gpl3-7 "\ +# This file is part of GnuTLS. +# +# The GnuTLS is free software; you can redistribute it and/or +# modify it under the terms of the GNU Lesser General Public License +# as published by the Free Software Foundation; either version 2.1 of +# the License, or (at your option) any later version. +# +# The GnuTLS 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 +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with GnuTLS; if not, write to the Free +# Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, +# MA 02110-1301, USA +" "The GnuTLS is distributed in the hope that") + +;; from GnuTLS [has a typo in the 02111-1301 part] +(elide-head--add-test gpl3-8 "\ +/* nettle, low-level cryptographics library + * + * Copyright (C) 2002 Niels Möller + * Copyright (C) 2014 Red Hat + *\s\s + * The nettle library is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation; either version 2.1 of the License, or (at your + * option) any later version. + *\s + * The nettle library 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 Lesser General Public + * License for more details. + *\s + * You should have received a copy of the GNU Lesser General Public License + * along with the nettle library; see the file COPYING.LIB. If not, write to + * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, + * MA 02111-1301, USA. + */ +" "The nettle library is distributed in the hope that") + +;; from GnuTLS-EXTRA [has a different line break in snail mail address] +(elide-head--add-test gpl3-9 "\ +# This file is part of GnuTLS-EXTRA. +# +# GnuTLS-extra 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. +# +# GnuTLS-extra 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 GnuTLS-EXTRA; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301, USA. +" "GnuTLS-extra is distributed in the hope that") + ;;; GPLv2 @@ -201,6 +285,28 @@ " "This program is distributed in the hope that") +;;; Apache License + +(elide-head--add-test apache1-1 "\ +/* + * Copyright 2011-2016 The Pkcs11Interop Project + * + * Licensed under the Apache License, Version 2.0 (the \"License\"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * https://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an \"AS IS\" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + */ +" "Unless required by applicable law") + + + ;;; Obsolete (with-suppressed-warnings ((obsolete elide-head) diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 794488edae8..e5899446ee4 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -226,6 +226,9 @@ "Forms in backtrace frames can be on a single line or on multiple lines." (ert-with-test-buffer (:name "single-multi-line") (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + ;; Make the form long enough so `number' should not + ;; appear on the first line once pretty-printed. + (interactive (region-beginning)) (let ((number (1+ x))) (+ x number)))) (header-string "Test header: ") @@ -280,7 +283,8 @@ line contains the strings \"lambda\" and \"number\"." ;; Verify that the form is now back on one line, ;; and that point is at the same place. (should (string= (backtrace-tests--get-substring - (- (point) 6) (point)) "number")) + (- (point) 6) (point)) + "number")) (should-not (= (point) (pos-bol))) (should (string= (backtrace-tests--get-substring (pos-bol) (1+ (pos-eol))) diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index 99b5b142c37..7fe3be2157f 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -25,8 +25,8 @@ (ert-deftest benchmark-tests () ;; Avoid fork failures on Cygwin. See bug#62450 and etc/PROBLEMS ;; ("Fork failures in a build with native compilation"). - (skip-unless (not (and (eq system-type 'cygwin) - (featurep 'native-compile)))) + (skip-when (and (eq system-type 'cygwin) + (featurep 'native-compile))) (let (str t-long t-short m) (should (consp (benchmark-run nil (setq m (1+ 0))))) (should (consp (benchmark-run 1 (setq m (1+ 0))))) diff --git a/test/lisp/emacs-lisp/byte-run-tests.el b/test/lisp/emacs-lisp/byte-run-tests.el new file mode 100644 index 00000000000..59ce24ad251 --- /dev/null +++ b/test/lisp/emacs-lisp/byte-run-tests.el @@ -0,0 +1,32 @@ +;;; byte-run-tests.el --- Tests for byte-run.el -*- 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/>. + +;;; Code: + +(require 'ert) + +(ert-deftest make-obsolete () + (should-error (make-obsolete nil 'foo "30.1")) + (should-error (make-obsolete t 'foo "30.1") )) + +(ert-deftest make-obsolete-variable () + (should-error (make-obsolete-variable nil 'foo "30.1")) + (should-error (make-obsolete-variable t 'foo "30.1"))) + +;;; byte-run-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el index 00ad1947507..1de5cf66b66 100644 --- a/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el +++ b/test/lisp/emacs-lisp/bytecomp-resources/no-byte-compile.el @@ -1 +1 @@ -;; -*- no-byte-compile: t; -*- +;; -*- no-byte-compile: t; lexical-binding: t; -*- diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el new file mode 100644 index 00000000000..9369e78ff54 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-arg.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls")) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el new file mode 100644 index 00000000000..4226349afef --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-missing-keyword-value.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el new file mode 100644 index 00000000000..18250f14ee9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-repeated-keyword-arg.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command "ls" :name "ls")) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el new file mode 100644 index 00000000000..4721035780b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-process-unknown-keyword-arg.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (make-process :name "ls" :command "ls" + :coding-system 'binary)) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 7ae10cdea73..8fbe48bbb9a 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -643,6 +643,16 @@ inner loops respectively." (funcall (car f) 3) (list a b)) + (let ((x (list 1))) + (let ((y x) + (z (setq x (vector x)))) + (list x y z))) + + (let ((x (list 1))) + (let* ((y x) + (z (setq x (vector x)))) + (list x y z))) + (cond) (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) @@ -677,16 +687,18 @@ inner loops respectively." (list x (funcall g)))))))) (funcall (funcall f 'b))) (let ((f (lambda (x) - (let ((g (lambda () x)) - (h (lambda () (setq x (list x x))))) - (let ((x 'a)) - (list x (funcall g) (funcall h))))))) + (lambda () + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let ((x 'a)) + (list x (funcall g) (funcall h)))))))) (funcall (funcall f 'b))) (let ((f (lambda (x) - (let ((g (lambda () x)) - (h (lambda () (setq x (list x x))))) - (let* ((x 'a)) - (list x (funcall g) (funcall h))))))) + (lambda () + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let* ((x 'a)) + (list x (funcall g) (funcall h)))))))) (funcall (funcall f 'b))) ;; Test constant-propagation of access to captured variables. @@ -704,6 +716,90 @@ inner loops respectively." (let ((bytecomp-tests--xx 1)) (set (make-local-variable 'bytecomp-tests--xx) 2) bytecomp-tests--xx) + + ;; Check for-effect optimization of `condition-case' body form. + ;; With `condition-case' in for-effect context: + (let ((x (bytecomp-test-identity ?A)) + (r nil)) + (condition-case e + (characterp x) ; value (:success, var) + (error (setq r 'bad)) + (:success (setq r (list 'good e)))) + r) + (let ((x (bytecomp-test-identity ?B)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error (setq r 'bad)) + (:success (setq r 'good))) + r) + (let ((x (bytecomp-test-identity ?C)) + (r nil)) + (condition-case e + (characterp x) ; for-effect (no :success, var) + (error (setq r (list 'bad e)))) + r) + (let ((x (bytecomp-test-identity ?D)) + (r nil)) + (condition-case nil + (characterp x) ; for-effect (no :success, no var) + (error (setq r 'bad))) + r) + ;; With `condition-case' in value context: + (let ((x (bytecomp-test-identity ?E))) + (condition-case e + (characterp x) ; for-effect (:success, var) + (error (list 'bad e)) + (:success (list 'good e)))) + (let ((x (bytecomp-test-identity ?F))) + (condition-case nil + (characterp x) ; for-effect (:success, no var) + (error 'bad) + (:success 'good))) + (let ((x (bytecomp-test-identity ?G))) + (condition-case e + (characterp x) ; value (no :success, var) + (error (list 'bad e)))) + (let ((x (bytecomp-test-identity ?H))) + (condition-case nil + (characterp x) ; value (no :success, no var) + (error 'bad))) + + (condition-case nil + (bytecomp-test-identity 3) + (error 'bad) + (:success)) ; empty handler + + ;; `cond' miscompilation bug + (let ((fn (lambda (x) + (let ((y nil)) + (cond ((progn (setq x (1+ x)) (> x 10)) (setq y 'a)) + ((eq x 1) (setq y 'b)) + ((eq x 2) (setq y 'c))) + (list x y))))) + (mapcar fn (bytecomp-test-identity '(0 1 2 3 10 11)))) + + ;; `nconc' nil arg elimination + (nconc (list 1 2 3 4) nil) + (nconc (list 1 2 3 4) nil nil) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc x nil)) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc x nil nil)) + (let ((x (cons 1 (cons 2 (cons 3 4))))) + (nconc nil x nil (list 5 6) nil)) + + ;; (+ 0 -0.0) etc + (let ((x (bytecomp-test-identity -0.0))) + (list x (+ x) (+ 0 x) (+ x 0) (+ 1 2 -3 x) (+ 0 x 0))) + + ;; Unary comparisons: keep side-effect, return t + (let ((x 0)) + (list (= (setq x 1)) + x)) + ;; Aristotelian identity optimization + (let ((x (bytecomp-test-identity 1))) + (list (eq x x) (eql x x) (equal x x))) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -752,6 +848,11 @@ byte-compiled. Run with dynamic binding." (should (equal (bytecomp-tests--eval-interpreted form) (bytecomp-tests--eval-compiled form))))))) +(defmacro bytecomp-tests--with-fresh-warnings (&rest body) + `(let ((macroexp--warned ; oh dear + (make-hash-table :test #'equal :weakness 'key))) + ,@body)) + (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) (ert-with-temp-file elfile @@ -766,7 +867,8 @@ byte-compiled. Run with dynamic binding." (if compile (let ((byte-compile-dest-file-function (lambda (e) elcfile))) - (byte-compile-file elfile))) + (bytecomp-tests--with-fresh-warnings + (byte-compile-file elfile)))) (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () @@ -833,13 +935,30 @@ byte-compiled. Run with dynamic binding." ;; Should not warn that mt--test2 is not known to be defined. (should-not (re-search-forward "my--test2" nil t)))) -(defmacro bytecomp--with-warning-test (re-warning &rest form) +(defun bytecomp--with-warning-test (re-warning form) (declare (indent 1)) - `(with-current-buffer (get-buffer-create "*Compile-Log*") + (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile ,@form) - (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") - (should (re-search-forward ,(string-replace " " "[ \n]+" re-warning)))))) + (ert-info ((prin1-to-string form) :prefix "form: ") + (let ((text-quoting-style 'grave)) + (bytecomp-tests--with-fresh-warnings + (byte-compile form))) + (ert-info ((prin1-to-string (buffer-string)) :prefix "buffer: ") + (should (re-search-forward + (string-replace " " "[ \n]+" re-warning))))))) + +(defun bytecomp--without-warning-test (form) + (bytecomp--with-warning-test "\\`\\'" form)) + +(ert-deftest bytecomp-warn--ignore () + (bytecomp--with-warning-test "unused" + '(lambda (y) 6)) + (bytecomp--without-warning-test + '(lambda (y) (ignore y) 6)) + (bytecomp--with-warning-test "assq" + '(lambda (x y) (progn (assq x y) 5))) + (bytecomp--without-warning-test + '(lambda (x y) (progn (ignore (assq x y)) 5)))) (ert-deftest bytecomp-warn-wrong-args () (bytecomp--with-warning-test "remq.*3.*2" @@ -863,6 +982,94 @@ byte-compiled. Run with dynamic binding." (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters" `(defvar foo t ,bytecomp-tests--docstring))) +(ert-deftest bytecomp-warn-wide-docstring/cl-defsubst () + (bytecomp--without-warning-test + `(cl-defsubst short-name () + "Do something.")) + (bytecomp--without-warning-test + `(cl-defsubst long-name-with-less-80-characters-but-still-quite-a-bit () + "Do something.")) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defsubst long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!! () + "Do something."))) + +(ert-deftest bytecomp-warn-wide-docstring/cl-defstruct () + (bytecomp--without-warning-test + `(cl-defstruct short-name + field)) + (bytecomp--without-warning-test + `(cl-defstruct short-name + long-name-with-less-80-characters-but-still-quite-a-bit)) + (bytecomp--without-warning-test + `(cl-defstruct long-name-with-less-80-characters-but-still-quite-a-bit + field)) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defstruct short-name + long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!!)) + (bytecomp--with-warning-test "wider than.*characters" + `(cl-defstruct long-name-with-more-than-80-characters-yes-this-is-a-very-long-name-but-why-not!! + field))) + +(ert-deftest bytecomp-warn-quoted-condition () + (bytecomp--with-warning-test + "Warning: `condition-case' condition should not be quoted: 'arith-error" + '(condition-case nil + (abc) + ('arith-error "ugh"))) + (bytecomp--with-warning-test + "Warning: `ignore-error' condition argument should not be quoted: 'error" + '(ignore-error 'error (abc)))) + +(ert-deftest bytecomp-warn-dodgy-args-eq () + (dolist (fn '(eq eql)) + (cl-flet ((msg (type arg) + (format + "`%s' called with literal %s that may never match (arg %d)" + fn type arg))) + (bytecomp--with-warning-test (msg "list" 1) `(,fn '(a) 'x)) + (bytecomp--with-warning-test (msg "string" 2) `(,fn 'x "a")) + (bytecomp--with-warning-test (msg "vector" 2) `(,fn 'x [a])) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x (lambda () 1))) + (bytecomp--with-warning-test (msg "function" 2) `(,fn 'x #'(lambda () 1))) + (unless (eq fn 'eql) + (bytecomp--with-warning-test (msg "integer" 2) `(,fn 'x #x10000000000)) + (bytecomp--with-warning-test (msg "float" 2) `(,fn 'x 1.0)))))) + +(ert-deftest bytecomp-warn-dodgy-args-memq () + (dolist (fn '(memq memql remq delq assq rassq)) + (cl-labels + ((msg1 (type) + (format + "`%s' called with literal %s that may never match (arg 1)" + fn type)) + (msg2 (type) + (format + "`%s' called with literal %s that may never match (element 2 of arg 2)" + fn type)) + (lst (elt) + (cond ((eq fn 'assq) `((a . 1) (,elt . 2) (c . 3))) + ((eq fn 'rassq) `((1 . a) (2 . ,elt) (3 . c))) + (t `(a ,elt c)))) + (form2 (elt) + `(,fn 'x ',(lst elt)))) + + (bytecomp--with-warning-test (msg1 "list") `(,fn '(a) '(x))) + (bytecomp--with-warning-test (msg1 "string") `(,fn "a" '(x))) + (bytecomp--with-warning-test (msg1 "vector") `(,fn [a] '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn (lambda () 1) '(x))) + (bytecomp--with-warning-test (msg1 "function") `(,fn #'(lambda () 1) '(x))) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg1 "integer") `(,fn #x10000000000 '(x))) + (bytecomp--with-warning-test (msg1 "float") `(,fn 1.0 '(x)))) + + (bytecomp--with-warning-test (msg2 "list") (form2 '(b))) + (bytecomp--with-warning-test (msg2 "list") (form2 ''b)) + (bytecomp--with-warning-test (msg2 "string") (form2 "b")) + (bytecomp--with-warning-test (msg2 "vector") (form2 [b])) + (unless (eq fn 'memql) + (bytecomp--with-warning-test (msg2 "integer") (form2 #x10000000000)) + (bytecomp--with-warning-test (msg2 "float") (form2 1.0)))))) + (defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) `(ert-deftest ,(intern (format "bytecomp/%s" file)) () (with-current-buffer (get-buffer-create "*Compile-Log*") @@ -903,7 +1110,7 @@ byte-compiled. Run with dynamic binding." "fails to specify containing group") (bytecomp--define-warning-file-test "warn-defcustom-notype.el" - "fails to specify type") + "missing :type keyword parameter") (bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el" "var.*foo.*lacks a prefix") @@ -1043,6 +1250,22 @@ byte-compiled. Run with dynamic binding." "nowarn-inline-after-defvar.el" "Lexical argument shadows" 'reverse) +(bytecomp--define-warning-file-test + "warn-make-process-missing-keyword-arg.el" + "called without required keyword argument :command") + +(bytecomp--define-warning-file-test + "warn-make-process-unknown-keyword-arg.el" + "called with unknown keyword argument :coding-system") + +(bytecomp--define-warning-file-test + "warn-make-process-repeated-keyword-arg.el" + "called with repeated keyword argument :name") + +(bytecomp--define-warning-file-test + "warn-make-process-missing-keyword-value.el" + "missing value for keyword argument :command") + ;;;; Macro expansion. @@ -1089,14 +1312,41 @@ byte-compiled. Run with dynamic binding." (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) +(defun bytecomp-tests--log-from-compilation (source) + "Compile the string SOURCE and return the compilation log output." + (let ((text-quoting-style 'grave) + (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (with-current-buffer byte-compile-log-buffer + (let ((inhibit-read-only t)) (erase-buffer))) + (bytecomp-tests--with-temp-file el-file + (write-region source nil el-file) + (byte-compile-file el-file)) + (with-current-buffer byte-compile-log-buffer + (buffer-string)))) + +(ert-deftest bytecomp-tests--lexical-binding-cookie () + (cl-flet ((cookie-warning (source) + (string-search + "file has no `lexical-binding' directive on its first line" + (bytecomp-tests--log-from-compilation source)))) + (let ((some-code "(defun my-fun () 12)\n")) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:t-*-\n" some-code))) + (should-not (cookie-warning + (concat ";;; -*-lexical-binding:nil-*-\n" some-code))) + (should (cookie-warning some-code))))) + (ert-deftest bytecomp-tests--unescaped-char-literals () "Check that byte compiling warns about unescaped character literals (Bug#20852)." (should (boundp 'lread--unescaped-character-literals)) (let ((byte-compile-error-on-warn t) - (byte-compile-debug t)) + (byte-compile-debug t) + (text-quoting-style 'grave)) (bytecomp-tests--with-temp-file source - (write-region "(list ?) ?( ?; ?\" ?[ ?])" nil source) + (write-region (concat ";;; -*-lexical-binding:t-*-\n" + "(list ?) ?( ?; ?\" ?[ ?])") + nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) (err (should-error (byte-compile-file source)))) @@ -1108,7 +1358,9 @@ literals (Bug#20852)." "`?\\]' expected!"))))))) ;; But don't warn in subsequent compilations (Bug#36068). (bytecomp-tests--with-temp-file source - (write-region "(list 1 2 3)" nil source) + (write-region (concat ";;; -*-lexical-binding:t-*-\n" + "(list 1 2 3)") + nil source) (bytecomp-tests--with-temp-file destination (let ((byte-compile-dest-file-function (lambda (_) destination))) (should (byte-compile-file source))))))) @@ -1116,6 +1368,7 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." (bytecomp-tests--with-temp-file source + (insert ";;; -*-lexical-binding:t-*-\n") (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) (defmacro bytecomp-tests--foobar () @@ -1213,6 +1466,7 @@ literals (Bug#20852)." (defun test-suppression (form suppress match) (let ((lexical-binding t) + (text-quoting-style 'grave) (byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) ;; Check that we get a warning without suppression. (with-current-buffer byte-compile-log-buffer @@ -1299,8 +1553,8 @@ literals (Bug#20852)." '(defun zot () (mapcar #'list '(1 2 3)) nil) - '((mapcar mapcar)) - "Warning: .mapcar. called for effect") + '((ignored-return-value mapcar)) + "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead") (test-suppression '(defun zot () @@ -1314,7 +1568,101 @@ literals (Bug#20852)." (set-buffer (get-buffer-create "foo")) nil)) '((suspicious set-buffer)) - "Warning: Use .with-current-buffer. rather than")) + "Warning: Use .with-current-buffer. rather than") + + (test-suppression + '(defun zot (x) + (condition-case nil (list x))) + '((suspicious condition-case)) + "Warning: `condition-case' without handlers") + + (test-suppression + '(defun zot (x) + (unwind-protect (print x))) + '((suspicious unwind-protect)) + "Warning: `unwind-protect' without unwind forms") + + (test-suppression + '(defun zot (x) + (cond + ((zerop x) 'zero) + (t 'nonzero) + (happy puppy))) + '((suspicious cond)) + "Warning: Useless clause following default `cond' clause") + + (test-suppression + '(defun zot () + (let ((_ 1)) + )) + '((empty-body let)) + "Warning: `let' with empty body") + + (test-suppression + '(defun zot () + (let* ((_ 1)) + )) + '((empty-body let*)) + "Warning: `let\\*' with empty body") + + (test-suppression + '(defun zot (x) + (when x + )) + '((empty-body when)) + "Warning: `when' with empty body") + + (test-suppression + '(defun zot (x) + (unless x + )) + '((empty-body unless)) + "Warning: `unless' with empty body") + + (test-suppression + '(defun zot (x) + (ignore-error arith-error + )) + '((empty-body ignore-error)) + "Warning: `ignore-error' with empty body") + + (test-suppression + '(defun zot (x) + (with-suppressed-warnings ((suspicious eq)) + )) + '((empty-body with-suppressed-warnings)) + "Warning: `with-suppressed-warnings' with empty body") + + (test-suppression + '(defun zot () + (setcar '(1 2) 3)) + '((mutate-constant setcar)) + "Warning: `setcar' on constant list (arg 1)") + + (test-suppression + '(defun zot () + (aset [1 2] 1 3)) + '((mutate-constant aset)) + "Warning: `aset' on constant vector (arg 1)") + + (test-suppression + '(defun zot () + (aset "abc" 1 ?d)) + '((mutate-constant aset)) + "Warning: `aset' on constant string (arg 1)") + + (test-suppression + '(defun zot (x y) + (nconc x y '(1 2) '(3 4))) + '((mutate-constant nconc)) + "Warning: `nconc' on constant list (arg 3)") + + (test-suppression + '(defun zot () + (put-text-property 0 2 'prop 'val "abc")) + '((mutate-constant put-text-property)) + "Warning: `put-text-property' on constant string (arg 5)") + ) (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't @@ -1327,7 +1675,8 @@ writable (Bug#44631)." (byte-compile-error-on-warn t)) (unwind-protect (progn - (write-region "" nil input-file nil nil nil 'excl) + (write-region ";;; -*-lexical-binding:t-*-\n" + nil input-file nil nil nil 'excl) (write-region "" nil output-file nil nil nil 'excl) (set-file-modes input-file #o400) (set-file-modes output-file #o200) @@ -1358,7 +1707,8 @@ mountpoint (Bug#44631)." (byte-compile-error-on-warn t)) (should-not (file-remote-p input-file)) (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) + (write-region ";;; -*-lexical-binding:t-*-\n" + nil input-file nil nil nil 'excl) (write-region "" nil output-file nil nil nil 'excl) (unwind-protect (progn @@ -1391,7 +1741,8 @@ mountpoint (Bug#44631)." (let* ((default-directory directory) (byte-compile-dest-file-function (lambda (_) "test.elc")) (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) + (write-region ";;; -*-lexical-binding:t-*-\n" + nil "test.el" nil nil nil 'excl) (should (byte-compile-file "test.el")) (should (file-regular-p "test.elc")) (should (cl-plusp (file-attribute-size @@ -1565,12 +1916,53 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \ (FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column))) -(defun test-bytecomp-defgroup-choice () - (should-not (byte-compile--suspicious-defcustom-choice 'integer)) - (should-not (byte-compile--suspicious-defcustom-choice - '(choice (const :tag "foo" bar)))) - (should (byte-compile--suspicious-defcustom-choice - '(choice (const :tag "foo" 'bar))))) +(ert-deftest bytecomp-test-defcustom-type () + (cl-flet ((dc (type) `(defcustom mytest nil "doc" :type ',type :group 'test))) + (bytecomp--with-warning-test + (rx "type should not be quoted") (dc ''integer)) + (bytecomp--with-warning-test + (rx "type should not be quoted") (dc '(choice '(repeat boolean)))) + (bytecomp--with-warning-test + (rx "misplaced :tag keyword") (dc '(choice (const b :tag "a")))) + (bytecomp--with-warning-test + (rx "`choice' without any types inside") (dc '(choice :tag "a"))) + (bytecomp--with-warning-test + (rx "`other' not last in `choice'") + (dc '(choice (const a) (other b) (const c)))) + (bytecomp--with-warning-test + (rx "duplicated value in `choice': `a'") + (dc '(choice (const a) (const b) (const a)))) + (bytecomp--with-warning-test + (rx "duplicated :tag string in `choice': \"X\"") + (dc '(choice (const :tag "X" a) (const :tag "Y" b) (other :tag "X" c)))) + (bytecomp--with-warning-test + (rx "`cons' requires 2 type specs, found 1") + (dc '(cons :tag "a" integer))) + (bytecomp--with-warning-test + (rx "`repeat' without type specs") + (dc '(repeat :tag "a"))) + (bytecomp--with-warning-test + (rx "`const' with too many values") + (dc '(const :tag "a" x y))) + (bytecomp--with-warning-test + (rx "`const' with quoted value") + (dc '(const :tag "a" 'x))) + (bytecomp--with-warning-test + (rx "`bool' is not a valid type") + (dc '(bool :tag "a"))) + (bytecomp--with-warning-test + (rx "irregular type `:tag'") + (dc '(:tag "a"))) + (bytecomp--with-warning-test + (rx "irregular type `\"string\"'") + (dc '(list "string"))) + (bytecomp--with-warning-test + (rx "`list' without arguments") + (dc 'list)) + (bytecomp--with-warning-test + (rx "`integerp' is not a valid type") + (dc 'integerp)) + )) (ert-deftest bytecomp-function-attributes () ;; Check that `byte-compile' keeps the declarations, interactive spec and @@ -1662,6 +2054,135 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ (should (eq (byte-compile-file src-file) 'no-byte-compile)) (should-not (file-exists-p dest-file)))) +(ert-deftest bytecomp--copy-tree () + (should (null (bytecomp--copy-tree nil))) + (let ((print-circle t)) + (let* ((x '(1 2 (3 4))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "((1 2 (3 4)) (1 2 (3 4)))"))) + (let* ((x '#1=(a #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(a #1#) #2=(a #2#))"))) + (let* ((x '#1=(#1# a)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(#1=(#1# a) #2=(#2# a))"))) + (let* ((x '((a . #1=(b)) #1#)) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))"))) + (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))) + (y (bytecomp--copy-tree x))) + (should (equal (prin1-to-string (list x y)) + (concat + "(" + "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))" + " " + "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))" + ")")))))) + +(require 'backtrace) + +(defun bytecomp-tests--error-frame (fun args) + "Call FUN with ARGS. Return result or (ERROR . BACKTRACE-FRAME)." + (let* ((debugger + (lambda (&rest args) + ;; Make sure Emacs doesn't think our debugger is buggy. + (cl-incf num-nonmacro-input-events) + (throw 'bytecomp-tests--backtrace + (cons args (cadr (backtrace-get-frames debugger)))))) + (debug-on-error t) + (backtrace-on-error-noninteractive nil) + (debug-on-quit t) + (debug-ignored-errors nil)) + (catch 'bytecomp-tests--backtrace + (apply fun args)))) + +(defconst bytecomp-tests--byte-op-error-cases + '(((car a) (wrong-type-argument listp a)) + ((cdr 3) (wrong-type-argument listp 3)) + ((setcar 4 b) (wrong-type-argument consp 4)) + ((setcdr c 5) (wrong-type-argument consp c)) + ((nth 2 "abcd") (wrong-type-argument listp "abcd")) + ((elt (x y . z) 2) (wrong-type-argument listp z)) + ((aref [2 3 5] p) (wrong-type-argument fixnump p)) + ((aref #s(a b c) p) (wrong-type-argument fixnump p)) + ((aref "abc" p) (wrong-type-argument fixnump p)) + ((aref [2 3 5] 3) (args-out-of-range [2 3 5] 3)) + ((aref #s(a b c) 3) (args-out-of-range #s(a b c) 3)) + ((aset [2 3 5] q 1) (wrong-type-argument fixnump q)) + ((aset #s(a b c) q 1) (wrong-type-argument fixnump q)) + ((aset [2 3 5] -1 1) (args-out-of-range [2 3 5] -1)) + ((aset #s(a b c) -1 1) (args-out-of-range #s(a b c) -1)) + ;; Many more to add + )) + +(ert-deftest bytecomp--byte-op-error-backtrace () + "Check that signaling byte ops show up in the backtrace." + (dolist (case bytecomp-tests--byte-op-error-cases) + (ert-info ((prin1-to-string case) :prefix "case: ") + (let* ((call (nth 0 case)) + (expected-error (nth 1 case)) + (fun-sym (car call)) + (actuals (cdr call))) + ;; Test both calling the function directly, and calling + ;; a byte-compiled η-expansion (lambda (ARGS...) (FUN ARGS...)) + ;; which should turn the function call into a byte-op. + (dolist (mode '(funcall byte-op)) + (ert-info ((symbol-name mode) :prefix "mode: ") + (let* ((fun (pcase-exhaustive mode + ('funcall fun-sym) + ('byte-op + (let* ((nargs (length (cdr call))) + (formals (mapcar (lambda (i) + (intern (format "x%d" i))) + (number-sequence 1 nargs)))) + (byte-compile + `(lambda ,formals (,fun-sym ,@formals))))))) + (error-frame (bytecomp-tests--error-frame fun actuals))) + (should (consp error-frame)) + (should (equal (car error-frame) (list 'error expected-error))) + (let ((frame (cdr error-frame))) + (should (equal (type-of frame) 'backtrace-frame)) + (should (equal (cons (backtrace-frame-fun frame) + (backtrace-frame-args frame)) + call)))))))))) + +(ert-deftest bytecomp--eq-symbols-with-pos-enabled () + ;; Verify that we don't optimize away a binding of + ;; `symbols-with-pos-enabled' around an application of `eq' (bug#65017). + (let* ((sym-with-pos1 (read-positioning-symbols "sym")) + (sym-with-pos2 (read-positioning-symbols " sym")) ; <- space! + (without-pos-eq (lambda (a b) + (let ((symbols-with-pos-enabled nil)) + (eq a b)))) + (without-pos-eq-compiled (byte-compile without-pos-eq)) + (with-pos-eq (lambda (a b) + (let ((symbols-with-pos-enabled t)) + (eq a b)))) + (with-pos-eq-compiled (byte-compile with-pos-eq))) + (dolist (mode '(interpreted compiled)) + (ert-info ((symbol-name mode) :prefix "mode: ") + (ert-info ("disabled" :prefix "symbol-pos: ") + (let ((eq-fn (pcase-exhaustive mode + ('interpreted without-pos-eq) + ('compiled without-pos-eq-compiled)))) + (should (equal (funcall eq-fn 'sym 'sym) t)) + (should (equal (funcall eq-fn sym-with-pos1 'sym) nil)) + (should (equal (funcall eq-fn 'sym sym-with-pos1) nil)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) nil)))) + (ert-info ("enabled" :prefix "symbol-pos: ") + (let ((eq-fn (pcase-exhaustive mode + ('interpreted with-pos-eq) + ('compiled with-pos-eq-compiled)))) + (should (equal (funcall eq-fn 'sym 'sym) t)) + (should (equal (funcall eq-fn sym-with-pos1 'sym) t)) + (should (equal (funcall eq-fn 'sym sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos1) t)) + (should (equal (funcall eq-fn sym-with-pos1 sym-with-pos2) t)))))))) ;; Local Variables: ;; no-byte-compile: t diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 83013cf46a9..6facd3452ea 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -364,5 +364,30 @@ (call-interactively f)) '((t 51696) (nil 51695) (t 51697))))))) +(ert-deftest cconv-safe-for-space () + (let* ((magic-string "This-is-a-magic-string") + (safe-p (lambda (x) (not (string-match magic-string (format "%S" x)))))) + (should (funcall safe-p (lambda (x) (+ x 1)))) + (should (funcall safe-p (eval '(lambda (x) (+ x 1)) + `((y . ,magic-string))))) + (should (funcall safe-p (eval '(lambda (x) :closure-dont-trim-context) + `((y . ,magic-string))))) + (should-not (funcall safe-p + (eval '(lambda (x) :closure-dont-trim-context (+ x 1)) + `((y . ,magic-string))))))) + +(ert-deftest cconv-tests-interactive-form-modify-bug60974 () + (let* ((f '(function (lambda (&optional arg) + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + 'toggle))) + (ignore arg)))) + (if (cadr (nth 2 (cadr f)))) + (if2)) + (cconv-closure-convert f) + (setq if2 (cadr (nth 2 (cadr f)))) + (should (eq if if2)))) + (provide 'cconv-tests) ;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index 57694bd424b..242e41c7f08 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -37,6 +37,15 @@ (insert "(defun foo())") (should-error (checkdoc-defun) :type 'user-error))) +(ert-deftest checkdoc-docstring-avoid-false-positive-ok () + "Check that Bug#68002 is fixed." + (with-temp-buffer + (emacs-lisp-mode) + (insert "(defvar org-element--cache-interrupt-C-g-count 0 + \"Current number of `org-element--cache-sync' calls. +See `org-element--cache-interrupt-C-g'.\")") + (checkdoc-defun))) + (ert-deftest checkdoc-cl-defmethod-ok () "Checkdoc should be happy with a simple correct cl-defmethod." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index d5886626bf1..0995e71db4e 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -404,7 +404,7 @@ (ert-deftest cl-lib-nth-value-test-multiple-values () "While CL multiple values are an alias to list, these won't work." :expected-result :failed - (should (eq (cl-nth-value 0 '(2 3)) '(2 3))) + (should (equal (cl-nth-value 0 '(2 3)) '(2 3))) (should (= (cl-nth-value 0 1) 1)) (should (null (cl-nth-value 1 1))) (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) @@ -431,7 +431,8 @@ (should (eq nums (cdr (cl-adjoin 3 nums)))) ;; add only when not already there (should (eq nums (cl-adjoin 2 nums))) - (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2))))) + (with-suppressed-warnings ((suspicious memql)) + (should (equal '(2 1 (2)) (cl-adjoin 2 '(1 (2)))))) ;; default test function is eql (should (equal '(1.0 1 2) (cl-adjoin 1.0 nums))) ;; own :test function - returns true if match @@ -529,27 +530,29 @@ (ert-deftest old-struct () (cl-defstruct foo x) - (let ((x [cl-struct-foo]) - (saved cl-old-struct-compat-mode)) - (cl-old-struct-compat-mode -1) - (should (eq (type-of x) 'vector)) + (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) + (let ((x (vector 'cl-struct-foo)) + (saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (should (eq (type-of x) 'vector)) - (cl-old-struct-compat-mode 1) - (defvar cl-struct-foo) - (let ((cl-struct-foo (cl--struct-get-class 'foo))) - (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) - (should (eq (type-of x) 'foo)) - (should (eq (type-of [foo]) 'vector))) + (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) + (let ((cl-struct-foo (cl--struct-get-class 'foo))) + (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) + (should (eq (type-of x) 'foo)) + (should (eq (type-of (vector 'foo)) 'vector))) - (cl-old-struct-compat-mode (if saved 1 -1)))) + (cl-old-struct-compat-mode (if saved 1 -1))))) (ert-deftest cl-lib-old-struct () - (let ((saved cl-old-struct-compat-mode)) - (cl-old-struct-compat-mode -1) - (cl-struct-define 'foo "" 'cl-structure-object nil nil nil - 'cl-struct-foo-tags 'cl-struct-foo t) - (should cl-old-struct-compat-mode) - (cl-old-struct-compat-mode (if saved 1 -1)))) + (with-suppressed-warnings ((obsolete cl-old-struct-compat-mode)) + (let ((saved cl-old-struct-compat-mode)) + (cl-old-struct-compat-mode -1) + (cl-struct-define 'foo "" 'cl-structure-object nil nil nil + 'cl-struct-foo-tags 'cl-struct-foo t) + (should cl-old-struct-compat-mode) + (cl-old-struct-compat-mode (if saved 1 -1))))) (ert-deftest cl-constantly () (should (equal (mapcar (cl-constantly 3) '(a b c d)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index a9ec0b76ae8..56a49fd865a 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -535,7 +535,7 @@ collection clause." (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to ;; see its `gv-expander'. - (should (equal (let ((l '(0))) + (should (equal (let ((l (list 0))) (let ((cl (car l))) (cl-symbol-macrolet ((p (gv-synthetic-place cl (lambda (v) `(setcar l ,v))))) @@ -708,6 +708,23 @@ collection clause." (f lex-var))))) (should (equal (f nil) 'a))))) +(ert-deftest cl-flet/edebug () + "Check that we can instrument `cl-flet' forms (bug#65344)." + (with-temp-buffer + (print '(cl-flet (;; "Obscure" form of binding supported by cl-flet + (x (progn (list 1 2) (lambda ()))) + ;; Destructuring lambda-list + (y ((min max)) (list min max)) + ;; Regular binding plus shadowing. + (z (a) a) + (z (a) a)) + (y '(1 2))) + (current-buffer)) + (let ((edebug-all-forms t) + (edebug-initial-mode 'Go-nonstop)) + ;; Just make sure the forms can be instrumented. + (eval-buffer)))) + (ert-deftest cl-macs--progv () (defvar cl-macs--test) (defvar cl-macs--test1) @@ -803,10 +820,30 @@ See Bug#57915." (macroexpand form) (should (string-empty-p messages)))))))) +(defvar cl--test-a) + (ert-deftest cl-&key-arguments () (cl-flet ((fn (&key x) x)) (should-error (fn :x)) - (should (eq (fn :x :a) :a)))) - + (should (eq (fn :x :a) :a))) + ;; In ELisp function arguments are always statically scoped (bug#47552). + (let ((cl--test-a 'dyn) + ;; FIXME: How do we silence the "Lexical argument shadows" warning? + (f + (with-suppressed-warnings ((lexical cl--test-a)) + (cl-function (lambda (&key cl--test-a b) + (list cl--test-a (symbol-value 'cl--test-a) b)))))) + (should (equal (funcall f :cl--test-a 'lex :b 2) '(lex dyn 2))))) + +(cl-defstruct cl--test-s + cl--test-a b) + +(ert-deftest cl-defstruct-dynbound-label-47552 () + "Check that labels can have the same name as dynbound vars." + (let ((cl--test-a 'dyn)) + (let ((x (make-cl--test-s :cl--test-a 4 :b cl--test-a))) + (should (cl--test-s-p x)) + (should (equal (cl--test-s-cl--test-a x) 4)) + (should (equal (cl--test-s-b x) 'dyn))))) ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 7161035d75a..631dd834a68 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'cl-print) (cl-defstruct (cl-print-tests-struct (:constructor cl-print-tests-con)) @@ -59,18 +60,20 @@ (ert-deftest cl-print-tests-ellipsis-string () "Ellipsis expansion works in strings." - (let ((print-length 4) - (print-level 3)) + (let ((cl-print-string-length 4)) (cl-print-tests-check-ellipsis-expansion "abcdefg" "\"abcd...\"" "efg") (cl-print-tests-check-ellipsis-expansion "abcdefghijk" "\"abcd...\"" "efgh...") - (cl-print-tests-check-ellipsis-expansion - '(1 (2 (3 #("abcde" 0 5 (test t))))) - "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") - (cl-print-tests-check-ellipsis-expansion - #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) - "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))")) + (let ((print-length 4)) + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ...")))) (ert-deftest cl-print-tests-ellipsis-struct () "Ellipsis expansion works in structures." @@ -90,7 +93,7 @@ (ert-deftest cl-print-tests-ellipsis-circular () "Ellipsis expansion works with circular objects." (let ((wide-obj (list 0 1 2 3 4)) - (deep-obj `(0 (1 (2 (3 (4)))))) + (deep-obj (list 0 (list 1 (list 2 (list 3 (list 4)))))) (print-length 4) (print-level 3)) (setf (nth 4 wide-obj) wide-obj) @@ -113,7 +116,7 @@ (should pos) (setq value (get-text-property pos 'cl-print-ellipsis result)) (should (equal expected result)) - (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + (should (equal expanded (with-output-to-string (cl-print--expand-ellipsis value nil)))))) (defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) @@ -122,7 +125,7 @@ (value (get-text-property pos 'cl-print-ellipsis result))) (should (string-match expected result)) (should (string-match expanded (with-output-to-string - (cl-print-expand-ellipsis value nil)))))) + (cl-print--expand-ellipsis value nil)))))) (ert-deftest cl-print-tests-print-to-string-with-limit () (let* ((thing10 (make-list 10 'a)) diff --git a/test/lisp/emacs-lisp/comp-cstr-tests.el b/test/lisp/emacs-lisp/comp-cstr-tests.el index 78d9bb49b98..cbedce0c47d 100644 --- a/test/lisp/emacs-lisp/comp-cstr-tests.el +++ b/test/lisp/emacs-lisp/comp-cstr-tests.el @@ -42,14 +42,14 @@ ',expected-type-spec)))) (defconst comp-cstr-typespec-tests-alist - `(;; 1 + '(;; 1 (symbol . symbol) ;; 2 ((or string array) . array) ;; 3 ((or symbol number) . (or number symbol)) ;; 4 - ((or cons atom) . (or atom cons)) ;; SBCL return T + ((or cons atom) . t) ;; SBCL return T ;; 5 ((or integer number) . number) ;; 6 @@ -191,7 +191,7 @@ ;; 74 ((and boolean (or number marker)) . nil) ;; 75 - ((and atom (or number marker)) . (or marker number)) + ((and atom (or number marker)) . number-or-marker) ;; 76 ((and symbol (or number marker)) . nil) ;; 77 @@ -217,7 +217,20 @@ ;; 87 ((and (or null integer) (not (or null integer))) . nil) ;; 88 - ((and (or (member a b c)) (not (or (member a b)))) . (member c))) + ((and (or (member a b c)) (not (or (member a b)))) . (member c)) + ;; 89 + ((or cons symbol) . (or list symbol)) ;; FIXME: Why `list'? + ;; 90 + ((or string char-table bool-vector vector) . array) + ;; 91 + ((or string char-table bool-vector vector number) . (or array number)) + ;; 92 + ((or string char-table bool-vector vector cons symbol number) . + (or number sequence symbol)) + ;; 93? + ;; FIXME: I get `cons' rather than `list'? + ;;((or null cons) . list) + ) "Alist type specifier -> expected type specifier.")) (defmacro comp-cstr-synthesize-tests () diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index de2fff5ef19..28a7f38c576 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -116,6 +116,7 @@ back to the top level.") (with-current-buffer (find-file edebug-tests-temp-file) (read-only-mode) (setq lexical-binding t) + (syntax-ppss) (eval-buffer) ,@body (when edebug-tests-failure-in-post-command diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index 4feaebed452..4f13881dbd4 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -40,7 +40,7 @@ This is usually a symbol that starts with `:'." (car tuple) nil))) -(defun hash-equal (hash1 hash2) +(defun eieio-test--hash-equal (hash1 hash2) "Compare two hash tables to see whether they are equal." (and (= (hash-table-count hash1) (hash-table-count hash2)) @@ -78,7 +78,7 @@ This is usually a symbol that starts with `:'." (if initarg-p (unless (cond ((and (hash-table-p origvalue) (hash-table-p fromdiskvalue)) - (hash-equal origvalue fromdiskvalue)) + (eieio-test--hash-equal origvalue fromdiskvalue)) (t (equal origvalue fromdiskvalue))) (error "Slot %S Original Val %S != Persistent Val %S" oneslot origvalue fromdiskvalue)) @@ -87,7 +87,7 @@ This is usually a symbol that starts with `:'." (diskval fromdiskvalue)) (unless (cond ((and (hash-table-p origval) (hash-table-p diskval)) - (hash-equal origval diskval)) + (eieio-test--hash-equal origval diskval)) (t (equal origval diskval))) (error "Slot %S Persistent Val %S != Default Value %S" oneslot diskval origvalue)))))))) @@ -329,8 +329,8 @@ persistent class.") "container-" emacs-version ".eieio"))) (john (make-instance 'person :name "John")) (alexie (make-instance 'person :name "Alexie")) - (alst '(("first" (one two three)) - ("second" (four five six))))) + (alst (list (list "first" (list 'one 'two 'three)) + (list "second" (list 'four 'five 'six))))) (setf (slot-value thing 'alist) alst) (puthash "alst" alst (slot-value thing 'htab)) (aset (slot-value thing 'vec) 0 alst) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index c9993341f98..a0507afe833 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1046,6 +1046,27 @@ Subclasses to override slot attributes.")) (should (eq (eieio-test--struct-a x) 1)) (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) +(defclass foo-bug-66938 (eieio-instance-inheritor) + ((x :initarg :x + :accessor ref-x + :reader get-x)) + "A class to test that delegation occurs under certain +circumstances when using an accessor function, as it would when +using the reader function.") + +(ert-deftest eieio-test-use-accessor-function-with-cloned-object () + "The class FOO-BUG-66938 is a subclass of +`eieio-instance-inheritor'. Therefore, given an instance OBJ1 of +FOO-BUG-66938, and a clone (OBJ2), OBJ2 should delegate to OBJ1 +when accessing an unbound slot. + +In particular, its behavior should be identical to that of the +reader function, when reading a slot." + (let* ((obj1 (foo-bug-66938 :x 4)) + (obj2 (clone obj1))) + (should (eql (ref-x obj2) 4)) + (should (eql (get-x obj2) (ref-x obj2))))) + (provide 'eieio-tests) ;;; eieio-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js new file mode 100644 index 00000000000..69c1c5cca88 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/broken.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ wrong-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js new file mode 100644 index 00000000000..5e614c64755 --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-resources/correct.js @@ -0,0 +1,3 @@ +var abc = function(d) { +// ^ font-lock-variable-name-face +}; diff --git a/test/lisp/emacs-lisp/ert-font-lock-tests.el b/test/lisp/emacs-lisp/ert-font-lock-tests.el new file mode 100644 index 00000000000..33ef0c6eede --- /dev/null +++ b/test/lisp/emacs-lisp/ert-font-lock-tests.el @@ -0,0 +1,464 @@ +;;; ert-font-lock-tests.el --- ERT Font Lock tests -*- lexical-binding: t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Vladimir Kazanov + +;; 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 is part of ERT Font Lock, an extension to the Emacs Lisp +;; Regression Test library (ERT) providing a convenient way to check +;; syntax highlighting provided by font-lock. +;; +;; See ert-font-lock.el for details, and below for example usage of +;; ert-font-lock facilities. + +(require 'ert) +(require 'ert-x) +(require 'ert-font-lock) + +;;; Helpers +;; + +(defmacro with-temp-buffer-str-mode (mode str &rest body) + "Create a buffer with STR contents and MODE. " + (declare (indent 1) (debug t)) + `(with-temp-buffer + (insert ,str) + (,mode) + (goto-char (point-min)) + ,@body)) + +;;; Comment parsing tests +;; + +(ert-deftest test-line-comment-p--fundamental () + (with-temp-buffer-str-mode fundamental-mode + "// comment\n" + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--emacs-lisp () + (with-temp-buffer-str-mode emacs-lisp-mode + "not comment +;; comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--shell-script () + (with-temp-buffer-str-mode shell-script-mode + "echo Not a comment +# comment +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(declare-function php-mode "php-mode") +(ert-deftest test-line-comment-p--php () + (skip-unless (featurep 'php-mode)) + + (with-temp-buffer-str-mode php-mode + "echo 'Not a comment' +// comment +/* comment */ +" + (should-not (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)) + (forward-line) + (should (ert-font-lock--line-comment-p)))) + + +(ert-deftest test-line-comment-p--javascript () + (with-temp-buffer-str-mode javascript-mode + "// comment + + // comment, after a blank line + +var abc = function(d) {}; +" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--python () + + (with-temp-buffer-str-mode python-mode + "# comment + + # comment +print(\"Hello, world!\")" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should-not (ert-font-lock--line-comment-p)))) + +(ert-deftest test-line-comment-p--c () + + (with-temp-buffer-str-mode c-mode + "// comment +/* also comment */" + (should (ert-font-lock--line-comment-p)) + + (forward-line) + (should (ert-font-lock--line-comment-p)))) + +(ert-deftest test-parse-comments--single-line-error () + (let* ((str "// ^ face.face1")) + (with-temp-buffer + (insert str) + (javascript-mode) + + (should-error (ert-font-lock--parse-comments))))) + +(ert-deftest test-parse-comments--single-line-single-caret () + (let* ((str " +first +// ^ face.face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 3 :face "face.face1" :negation nil)))))) + +(ert-deftest test-parse-comments--caret-negation () + (let* ((str " +first +// ^ !face +// ^ face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face" :negation t) + (:line-checked 2 :line-assert 4 :column-checked 3 :face "face" :negation nil))))))) + + +(ert-deftest test-parse-comments--single-line-multiple-carets () + (let* ((str " +first +// ^ face1 +// ^ face.face2 +// ^ face-face.face3 + // ^ face_face.face4 +") + asserts) + + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 4)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 7 :face "face.face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 7 :face "face-face.face3" :negation nil) + (:line-checked 2 :line-assert 6 :column-checked 7 :face "face_face.face4" :negation nil))))))) + +(ert-deftest test-parse-comments--multiple-line-multiple-carets () + (let* ((str " +first +// ^ face1 +second +// ^ face2 +// ^ face3 +third +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 3 :face "face1" :negation nil) + (:line-checked 4 :line-assert 5 :column-checked 3 :face "face2" :negation nil) + (:line-checked 4 :line-assert 6 :column-checked 5 :face "face3" :negation nil))))))) + + +(ert-deftest test-parse-comments--arrow-single-line-single () + (let* ((str " +first +// <- face1 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil)))))) + + +(ert-deftest test-parse-comments-arrow-multiple-line-single () + (let* ((str " +first +// <- face1 + // <- face2 + // <- face3 +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 0 :face "face1" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 2 :face "face2" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 4 :face "face3" :negation nil))))))) + +(ert-deftest test-parse-comments--non-assert-comment-single () + (let* ((str " +// first +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--non-assert-comment-multiple () + (let* ((str " +// first second third +// ^ comment-face +// ^ comment-face +// ^ comment-face +") + asserts) + (with-temp-buffer + (insert str) + (javascript-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 3)) + (should (equal asserts + '((:line-checked 2 :line-assert 3 :column-checked 4 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 4 :column-checked 10 :face "comment-face" :negation nil) + (:line-checked 2 :line-assert 5 :column-checked 18 :face "comment-face" :negation nil))))))) + + +(ert-deftest test-parse-comments--multiline-comment-single () + (let* ((str " +/* + this is a comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 1)) + (should (equal (car asserts) + '(:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil)))))) + +(ert-deftest test-parse-comments--multiline-comment-multiple () + (let* ((str " +/* + this is a comment + ^ comment-face + another comment + ^ comment-face + */ +") + asserts) + (with-temp-buffer + (insert str) + (c-mode) + + (setq asserts (ert-font-lock--parse-comments)) + (should (eql (length asserts) 2)) + (should (equal asserts + '((:line-checked 3 :line-assert 4 :column-checked 3 :face "comment-face" :negation nil) + (:line-checked 5 :line-assert 6 :column-checked 4 :face "comment-face" :negation nil))))))) + +;;; Syntax highlighting assertion tests +;; + +(ert-deftest test-syntax-highlight-inline--caret-multiple-faces () + (let ((str " +var abc = function(d) { +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + +(ert-deftest test-syntax-highlight-inline--caret-wrong-face () + (let* ((str " +var abc = function(d) { +// ^ not-a-face +}; +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (should-error (ert-font-lock--check-faces + (ert-font-lock--parse-comments)))))) + + +(ert-deftest test-syntax-highlight-inline--comment-face () + (let* ((str " +// this is a comment +// ^ font-lock-comment-face +// ^ font-lock-comment-face +// ^ font-lock-comment-face +")) + (with-temp-buffer + (insert str) + (javascript-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-syntax-highlight-inline--multiline-comment-face () + (let* ((str " +/* + this is a comment + ^ font-lock-comment-face + another comment + more comments + ^ font-lock-comment-face + */ +")) + (with-temp-buffer + (insert str) + (c-mode) + (font-lock-ensure) + + (ert-font-lock--check-faces + (ert-font-lock--parse-comments))))) + + +(ert-deftest test-font-lock-test-string--correct () + (ert-font-lock-test-string + " +var abc = function(d) { +// <- font-lock-keyword-face +// ^ font-lock-variable-name-face + // ^ font-lock-keyword-face + // ^ font-lock-variable-name-face +}; + +" + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--correct () + (ert-font-lock-test-file + (ert-resource-file "correct.js") + 'javascript-mode)) + +(ert-deftest test-font-lock-test-file--wrong () + :expected-result :failed + (ert-font-lock-test-file + (ert-resource-file "broken.js") + 'javascript-mode)) + +;;; Macro tests +;; + +(ert-font-lock-deftest test-macro-test--correct-highlighting + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face +;; ^ font-lock-function-name-face") + +(ert-font-lock-deftest test-macro-test--docstring + "A test with a docstring." + emacs-lisp-mode + " +(defun fun ()) +;; ^ font-lock-keyword-face" + ) + +(ert-font-lock-deftest test-macro-test--failing + "A failing test." + :expected-result :failed + emacs-lisp-mode + " +(defun fun ()) +;; ^ wrong-face") + +(ert-font-lock-deftest-file test-macro-test--file + "Test reading correct assertions from a file" + javascript-mode + "correct.js") + +(ert-font-lock-deftest-file test-macro-test--file-failing + "Test reading wrong assertions from a file" + :expected-result :failed + javascript-mode + "broken.js") + +;;; ert-font-lock-tests.el ends here diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 3e499fc6f59..bb3de111e3e 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -304,6 +304,20 @@ failed or if there was a problem." (cl-macrolet ((test () (error "Foo"))) (should-error (test)))) +(ert-deftest ert-test-skip-when () + ;; Don't skip. + (let ((test (make-ert-test :body (lambda () (skip-when nil))))) + (let ((result (ert-run-test test))) + (should (ert-test-passed-p result)))) + ;; Skip. + (let ((test (make-ert-test :body (lambda () (skip-when t))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result)))) + ;; Skip in case of error. + (let ((test (make-ert-test :body (lambda () (skip-when (error "Foo")))))) + (let ((result (ert-run-test test))) + (should (ert-test-skipped-p result))))) + (ert-deftest ert-test-skip-unless () ;; Don't skip. (let ((test (make-ert-test :body (lambda () (skip-unless t))))) @@ -577,13 +591,12 @@ This macro is used to test if macroexpansion in `should' works." (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (save-window-excursion - (unwind-protect - (let ((case-fold-search nil) - (ert-batch-backtrace-right-margin nil) - (ert-batch-print-level 10) - (ert-batch-print-length 11)) - (ert-run-tests-batch - `(member ,failing-test-1 ,failing-test-2)))))) + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2))))) (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") found-long @@ -609,14 +622,13 @@ This macro is used to test if macroexpansion in `should' works." (lambda (format-string &rest args) (push (apply #'format format-string args) messages)))) (save-window-excursion - (unwind-protect - (let ((case-fold-search nil) - (ert-batch-backtrace-right-margin nil) - (ert-batch-backtrace-line-length nil) - (ert-batch-print-level 6) - (ert-batch-print-length 11)) - (ert-run-tests-batch - `(member ,failing-test-1)))))) + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1))))) (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") found-frame) (cl-loop for msg in (reverse messages) diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el index 7251b76157b..59ecb5ab187 100644 --- a/test/lisp/emacs-lisp/find-func-tests.el +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -32,7 +32,7 @@ (ert-deftest find-func-tests--library-completion () ;bug#43393 ;; FIXME: How can we make this work in batch (see also ;; `mule-cmds--test-universal-coding-system-argument')? - ;; (skip-unless (not noninteractive)) + ;; (skip-when noninteractive) ;; Check that `partial-completion' works when completing library names. (should (equal "org/org" (ert-simulate-keys diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el index c056761f0f9..1418abf221f 100644 --- a/test/lisp/emacs-lisp/lisp-mnt-tests.el +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -30,6 +30,26 @@ '(("Bob Weiner" . "rsw@gnu.org") ("Mats Lidell" . "matsl@gnu.org"))))) +(ert-deftest lm--tests-lm-package-requires () + (with-temp-buffer + (insert ";; Package-Requires: ((emacs 29.1))") + (should (equal (lm-package-requires) '((emacs 29.1))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\") (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\") (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1"))))) + (with-temp-buffer + (insert ";; Package-Requires: ((emacs \"26.3\") (jsonrpc \"1.0.16\") (flymake \"1.2.1\")\n" + ";; (project \"0.9.8\") (xref \"1.6.2\") (eldoc \"1.14.0\")\n" + ";; (seq \"2.23\") (external-completion \"0.1\"))") + (should (equal (lm-package-requires) + '((emacs "26.3") (jsonrpc "1.0.16") (flymake "1.2.1") + (project "0.9.8") (xref "1.6.2") (eldoc "1.14.0") + (seq "2.23") (external-completion "0.1")))))) + + (ert-deftest lm--tests-lm-website () (with-temp-buffer (insert ";; URL: https://example.org/foo") diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 3e906497020..825e6b6ab80 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -355,5 +355,28 @@ Expected initialization file: `%s'\" ;; (should (equal (lisp-current-defun-name) "defblarg"))) ) +(ert-deftest test-font-lock-keywords () + "Keywords should be fontified in `font-lock-keyword-face`." + (with-temp-buffer + (emacs-lisp-mode) + (mapc (lambda (el-keyword) + (erase-buffer) + (insert (format "(%s some-symbol () \"hello\"" el-keyword)) + (font-lock-ensure) + ;; Verify face property throughout the keyword + (let* ((begin (1+ (point-min))) + (end (1- (+ begin (length el-keyword))))) + (mapc (lambda (pos) + (should (equal (get-text-property pos 'face) + 'font-lock-keyword-face))) + (number-sequence begin end)))) + '("defsubst" "cl-defsubst" "define-inline" + "define-advice" "defadvice" "defalias" + "define-derived-mode" "define-minor-mode" + "define-generic-mode" "define-global-minor-mode" + "define-globalized-minor-mode" "define-skeleton" + "define-widget" "ert-deftest" "defconst" "defcustom" + "defvaralias" "defvar-local" "defface" "define-error")))) + (provide 'lisp-mode-tests) ;;; lisp-mode-tests.el ends here diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index 7bb38fe58f7..d0efbfd28c1 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -124,4 +124,20 @@ (dyn dyn dyn dyn) (dyn dyn dyn lex)))))) +(defmacro macroexp--test-macro1 () + (declare (obsolete "new-replacement" nil)) + 1) + +(defmacro macroexp--test-macro2 () + '(macroexp--test-macro1)) + +(ert-deftest macroexp--test-obsolete-macro () + (should + (let ((res + (cl-letf (((symbol-function 'message) #'user-error)) + (condition-case err + (macroexpand-all '(macroexp--test-macro2)) + (user-error (error-message-string err)))))) + (should (and (stringp res) (string-match "new-replacement" res)))))) + ;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 86c0e9e0503..2204743f794 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -577,6 +577,13 @@ See bug#58531#25 and bug#58563." (should (= b 2)) (should-not c))) +(ert-deftest test-map-let-default () + (map-let (('foo a 3) + ('baz b 4)) + '((foo . 1)) + (should (equal a 1)) + (should (equal b 4)))) + (ert-deftest test-map-merge () "Test `map-merge'." (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) @@ -617,6 +624,58 @@ See bug#58531#25 and bug#58563." (list one two)) '(1 2))))) +(ert-deftest test-map-plist-pcase-default () + (let ((plist '(:two 2))) + (should (equal (pcase-let (((map (:two two 33) + (:three three 44)) + plist)) + (list two three)) + '(2 44))))) + +(ert-deftest test-map-pcase-matches () + (let ((plist '(:two 2))) + (should (equal (pcase plist + ((map (:two two 33) + (:three three)) + (list two three)) + (_ 'fail)) + '(2 nil))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three three 44)) + (list two three)) + (_ 'fail)) + '(2 44))) + + (should (equal (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) '(11 . 22))) + (list two a b)) + (_ 'fail)) + '(2 11 22))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) 44)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b) nil)) + (list two a b)) + (_ 'fail)))) + + (should (equal 'fail + (pcase plist + ((map (:two two 33) + (:three `(,a . ,b))) + (list two a b)) + (_ 'fail)))))) + (ert-deftest test-map-setf-alist-insert-key () (let ((alist)) (should (equal (setf (map-elt alist 'key) 'value) diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el index c55db6491cd..639a8ab5219 100644 --- a/test/lisp/emacs-lisp/multisession-tests.el +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -94,7 +94,7 @@ (dotimes (i 100) (cl-incf (multisession-value multisession--bar)))))))) (while (process-live-p proc) - (ignore-error 'sqlite-locked-error + (ignore-error sqlite-locked-error (message "multisession--bar %s" (multisession-value multisession--bar)) ;;(cl-incf (multisession-value multisession--bar)) ) diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 748d42f2120..7dfa936214a 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -29,6 +29,7 @@ (advice-add 'sm-test1 :around (lambda (f y) (* (funcall f y) 2))) (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 5))) (defun sm-test1 (x) (+ x 4)) + (declare-function sm-test1 nil) (should (equal (sm-test1 6) 20)) (advice-remove 'sm-test1 (lambda (f y) (* (funcall f y) 2))) (should (equal (sm-test1 6) 10)) @@ -62,9 +63,11 @@ (ert-deftest advice-tests-advice () "Test advice code." (defun sm-test2 (x) (+ x 4)) + (declare-function sm-test2 nil) (should (equal (sm-test2 6) 10)) - (defadvice sm-test2 (around sm-test activate) - ad-do-it (setq ad-return-value (* ad-return-value 5))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test2 (around sm-test activate) + ad-do-it (setq ad-return-value (* ad-return-value 5)))) (should (equal (sm-test2 6) 50)) (ad-deactivate 'sm-test2) (should (equal (sm-test2 6) 10)) @@ -79,8 +82,9 @@ (should (equal (sm-test2 6) 20)) (should (equal (null (get 'sm-test2 'defalias-fset-function)) t)) - (defadvice sm-test4 (around wrap-with-toto activate) - ad-do-it (setq ad-return-value `(toto ,ad-return-value))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test4 (around wrap-with-toto activate) + ad-do-it (setq ad-return-value `(toto ,ad-return-value)))) (defmacro sm-test4 (x) `(call-test4 ,x)) (should (equal (macroexpand '(sm-test4 56)) '(toto (call-test4 56)))) (defmacro sm-test4 (x) `(call-testq ,x)) @@ -88,17 +92,20 @@ ;; This used to signal an error (bug#12858). (autoload 'sm-test6 "foo") - (defadvice sm-test6 (around test activate) - ad-do-it)) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test6 (around test activate) + ad-do-it))) (ert-deftest advice-tests-combination () "Combining old style and new style advices." (defun sm-test5 (x) (+ x 4)) + (declare-function sm-test5 nil) (should (equal (sm-test5 6) 10)) (advice-add 'sm-test5 :around (lambda (f y) (* (funcall f y) 5))) (should (equal (sm-test5 6) 50)) - (defadvice sm-test5 (around test activate) - ad-do-it (setq ad-return-value (+ ad-return-value 0.1))) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test5 (around test activate) + ad-do-it (setq ad-return-value (+ ad-return-value 0.1)))) (should (equal (sm-test5 5) 45.1)) (ad-deactivate 'sm-test5) (should (equal (sm-test5 6) 50)) @@ -112,22 +119,23 @@ (ert-deftest advice-test-called-interactively-p () "Check interaction between advice and called-interactively-p." (defun sm-test7 (&optional x) (interactive) (+ (or x 7) 4)) + (declare-function sm-test7 nil) (advice-add 'sm-test7 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7) '((1 . nil) 11))) (should (equal (call-interactively 'sm-test7) '((1 . t) 11))) (let ((smi 7)) (advice-add 'sm-test7 :before - (lambda (&rest args) - (setq smi (called-interactively-p)))) + (lambda (&rest _args) + (setq smi (called-interactively-p 'any)))) (should (equal (list (sm-test7) smi) '(((1 . nil) 11) nil))) (should (equal (list (call-interactively 'sm-test7) smi) '(((1 . t) 11) t)))) (advice-add 'sm-test7 :around (lambda (f &rest args) - (cons (cons 2 (called-interactively-p)) (apply f args)))) + (cons (cons 2 (called-interactively-p 'any)) (apply f args)))) (should (equal (call-interactively 'sm-test7) '((2 . t) (1 . t) 11)))) (ert-deftest advice-test-called-interactively-p-around () @@ -136,24 +144,28 @@ This tests the currently broken case of the innermost advice to a function being an around advice." :expected-result :failed - (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.2 () (interactive) (cons 1 (called-interactively-p 'any))) + (declare-function sm-test7.2 nil) (advice-add 'sm-test7.2 :around (lambda (f &rest args) - (list (cons 1 (called-interactively-p)) (apply f args)))) + (list (cons 1 (called-interactively-p 'any)) (apply f args)))) (should (equal (sm-test7.2) '((1 . nil) (1 . nil)))) (should (equal (call-interactively 'sm-test7.2) '((1 . t) (1 . t))))) (ert-deftest advice-test-called-interactively-p-filter-args () "Check interaction between filter-args advice and called-interactively-p." :expected-result :failed - (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p))) + (defun sm-test7.3 () (interactive) (cons 1 (called-interactively-p 'any))) + (declare-function sm-test7.3 nil) (advice-add 'sm-test7.3 :filter-args #'list) (should (equal (sm-test7.3) '(1 . nil))) (should (equal (call-interactively 'sm-test7.3) '(1 . t)))) (ert-deftest advice-test-call-interactively () "Check interaction between advice on call-interactively and called-interactively-p." - (let ((sm-test7.4 (lambda () (interactive) (cons 1 (called-interactively-p)))) + (let ((sm-test7.4 (lambda () + (interactive) + (cons 1 (called-interactively-p 'any)))) (old (symbol-function 'call-interactively))) (unwind-protect (progn @@ -166,18 +178,20 @@ function being an around advice." (ert-deftest advice-test-interactive () "Check handling of interactive spec." (defun sm-test8 (a) (interactive "p") a) - (defadvice sm-test8 (before adv1 activate) nil) - (defadvice sm-test8 (before adv2 activate) (interactive "P") nil) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test8 (before adv1 activate) nil) + (defadvice sm-test8 (before adv2 activate) (interactive "P") nil)) (should (equal (interactive-form 'sm-test8) '(interactive "P")))) (ert-deftest advice-test-preactivate () (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) (defun sm-test9 (a) (interactive "p") a) (should (equal (null (get 'sm-test9 'defalias-fset-function)) t)) - (defadvice sm-test9 (before adv1 pre act protect compile) nil) - (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) - (defadvice sm-test9 (before adv2 pre act protect compile) - (interactive "P") nil) + (with-suppressed-warnings ((obsolete defadvice)) + (defadvice sm-test9 (before adv1 pre act protect compile) nil) + (should (equal (null (get 'sm-test9 'defalias-fset-function)) nil)) + (defadvice sm-test9 (before adv2 pre act protect compile) + (interactive "P") nil)) (should (equal (interactive-form 'sm-test9) '(interactive "P")))) (ert-deftest advice-test-multiples () @@ -213,8 +227,16 @@ function being an around advice." (should (equal (cl-prin1-to-string (car x)) "#f(advice first :before #f(advice car :after cdr))")))) -;; Local Variables: -;; no-byte-compile: t -;; End: +(ert-deftest advice-test-bug61179 () + (let* ((magic 42) + (ad (lambda (&rest _) + (interactive (lambda (is) + (cons magic (advice-eval-interactive-spec is)))) + nil)) + (sym (make-symbol "adtest"))) + (defalias sym (lambda (&rest args) (interactive (list 'main)) args)) + (should (equal (call-interactively sym) '(main))) + (advice-add sym :before ad) + (should (equal (call-interactively sym) '(42 main))))) ;;; nadvice-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 0016fb586b7..e44ad3677d1 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -125,6 +125,7 @@ abbreviated-home-dir package--initialized package-alist + package-selected-packages ,@(if update-news '(package-update-news-on-upload t) (list (cl-gensym))) @@ -219,9 +220,14 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-desc-from-buffer () "Parse an elisp buffer to get a `package-desc' object." - (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") - (should (package-test--compatible-p - (package-buffer-info) simple-single-desc 'kind))) + (with-package-test (:basedir (ert-resource-directory) + :file "simple-single-1.3.el") + (let ((pi (package-buffer-info))) + (should (package-test--compatible-p pi simple-single-desc 'kind)) + ;; The terminating line is not mandatory any more. + (re-search-forward "^;;; .* ends here") + (delete-region (match-beginning 0) (point-max)) + (should (equal (package-buffer-info) pi)))) (with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el") (should (package-test--compatible-p (package-buffer-info) simple-depend-desc 'kind))) @@ -302,6 +308,21 @@ Must called from within a `tar-mode' buffer." (package-delete (cadr (assq 'v7-withsub package-alist)))) )) +(ert-deftest package-test-bug65475 () + "Deleting the last package clears `package-selected-packages'." + (with-package-test (:basedir (ert-resource-directory)) + (package-initialize) + (let* ((pkg-el "simple-single-1.3.el") + (source-file (expand-file-name pkg-el (ert-resource-directory)))) + (package-install-file source-file) + (should package-alist) + (should package-selected-packages) + (let ((desc (cadr (assq 'simple-single package-alist)))) + (should desc) + (package-delete desc)) + (should-not package-alist) + (should-not package-selected-packages)))) + (ert-deftest package-test-install-file-EOLs () "Install same file multiple time with `package-install-file' but with a different end of line convention (bug#48137)." diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index 72c7cb880d2..1b248e19a31 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -23,8 +23,8 @@ (require 'ert-x) (ert-deftest pp-print-quote () - (should (string= (pp-to-string 'quote) "quote")) - (should (string= (pp-to-string ''quote) "'quote")) + (should (string= (pp-to-string 'quote) "quote\n")) + (should (string= (pp-to-string ''quote) "'quote\n")) (should (string= (pp-to-string '('a 'b)) "('a 'b)\n")) (should (string= (pp-to-string '(''quote 'quote)) "(''quote 'quote)\n")) (should (string= (pp-to-string '(quote)) "(quote)\n")) diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 9c8628a8f26..e773ddf158e 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -41,19 +41,31 @@ (should (equal (rx "" (or "ab" nonl) "") "ab\\|."))) +;; FIXME: Extend tests for `or', `not' etc to cover char pattern combination, +;; including (syntax whitespace) and (syntax word). + (ert-deftest rx-or () - (should (equal (rx (or "ab" (| "c" nonl) "de")) - "ab\\|c\\|.\\|de")) + (should (equal (rx (or "ab" (| "cd" nonl) "de")) + "ab\\|cd\\|.\\|de")) (should (equal (rx (or "ab" "abc" ?a)) "\\(?:a\\(?:bc?\\)?\\)")) (should (equal (rx (or "ab" (| (or "abcd" "abcde")) (or "a" "abc"))) "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) (should (equal (rx (or "a" (eval (string ?a ?b)))) "\\(?:ab?\\)")) + (should (equal (rx (| nonl "ac") (| "bd" blank)) + "\\(?:.\\|ac\\)\\(?:bd\\|[[:blank:]]\\)")) (should (equal (rx (| nonl "a") (| "b" blank)) - "\\(?:.\\|a\\)\\(?:b\\|[[:blank:]]\\)")) + ".[b[:blank:]]")) (should (equal (rx (|)) - "\\`a\\`"))) + "\\`a\\`")) + (should (equal (rx (or "a" (not anychar) punct ?c "b" (not (not ?d)))) + "[a-d[:punct:]]")) + (should (equal (rx (or nonl ?\n)) + "[^z-a]")) + (should (equal (rx (or "ab" "a" "b" blank (syntax whitespace) word "z")) + "ab\\|[ab[:blank:]]\\|\\s-\\|[z[:word:]]")) + ) (ert-deftest rx-def-in-or () (rx-let ((a b) @@ -98,7 +110,21 @@ "[\177Å\211\326-\377]")) ;; Split range; \177-\377ÿ should not be optimized to \177-\377. (should (equal (rx (any "\177-\377" ?ÿ)) - "[\177ÿ\200-\377]"))) + "[\177ÿ\200-\377]")) + ;; Range between normal chars and raw bytes: must be split to be parsed + ;; correctly by the Emacs regexp engine. + (should (equal (rx (any (0 . #x3fffff) word) (any (?G . #x3fff9a) word) + (any (?Ü . #x3ffff2) word)) + (concat "[\0-\x3fff7f\x80-\xff[:word:]]" + "[G-\x3fff7f\x80-\x9a[:word:]]" + "[Ü-\x3fff7f\x80-\xf2[:word:]]"))) + ;; As above but with ranges in string form. For historical reasons, + ;; we special-case ASCII-to-raw ranges to exclude non-ASCII unicode. + (should (equal (rx (any "\x00-\xff" alpha) (any "G-\x9a" alpha) + (any "Ü-\xf2" alpha)) + (concat "[\0-\x7f\x80-\xff[:alpha:]]" + "[G-\x7f\x80-\x9a[:alpha:]]" + "[Ü-\x3fff7f\x80-\xf2[:alpha:]]")))) (ert-deftest rx-any () (should (equal (rx (any ?A (?C . ?D) "F-H" "J-L" "M" "N-P" "Q" "RS")) @@ -138,7 +164,7 @@ (should (equal (rx (any "-]^" ascii) (not (any "-]^" ascii))) "[]^[:ascii:]-][^]^[:ascii:]-]")) (should (equal (rx (any "^" lower upper) (not (any "^" lower upper))) - "[[:lower:]^[:upper:]][^^[:lower:][:upper:]]")) + "[[:lower:][:upper:]^][^^[:lower:][:upper:]]")) (should (equal (rx (any "-" lower upper) (not (any "-" lower upper))) "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) @@ -165,7 +191,10 @@ "[a[:space:][:digit:]]")) (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) (| (not (in "a\n")) (not (char ?\n (?b . ?b))))) - "....."))) + ".....")) + (should (equal (rx (or (in "g-k") (in "a-f") (or ?r (in "i-m" "n-q")))) + "[a-r]")) + ) (ert-deftest rx-pcase () (should (equal (pcase "i18n" ((rx (let x (+ digit))) (list 'ok x))) @@ -274,7 +303,7 @@ "^\\`\\'\\`\\'\\`\\'\\`\\'$")) (should (equal (rx point word-start word-end bow eow symbol-start symbol-end word-boundary not-word-boundary not-wordchar) - "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B\\W")) + "\\=\\<\\>\\<\\>\\_<\\_>\\b\\B[^[:word:]]")) (should (equal (rx digit numeric num control cntrl) "[[:digit:]][[:digit:]][[:digit:]][[:cntrl:]][[:cntrl:]]")) (should (equal (rx hex-digit hex xdigit blank) @@ -296,7 +325,7 @@ (should (equal (rx (syntax whitespace) (syntax punctuation) (syntax word) (syntax symbol) (syntax open-parenthesis) (syntax close-parenthesis)) - "\\s-\\s.\\sw\\s_\\s(\\s)")) + "\\s-\\s.\\w\\s_\\s(\\s)")) (should (equal (rx (syntax string-quote) (syntax paired-delimiter) (syntax escape) (syntax character-quote) (syntax comment-start) (syntax comment-end) @@ -344,8 +373,9 @@ "\\B")) (should (equal (rx (not ascii) (not lower-case) (not wordchar)) "[^[:ascii:]][^[:lower:]][^[:word:]]")) - (should (equal (rx (not (syntax punctuation)) (not (syntax escape))) - "\\S.\\S\\")) + (should (equal (rx (not (syntax punctuation)) (not (syntax escape)) + (not (syntax word))) + "\\S.\\S\\\\W")) (should (equal (rx (not (category tone-mark)) (not (category lao))) "\\C4\\Co")) (should (equal (rx (not (not ascii)) (not (not (not (any "a-z"))))) @@ -381,7 +411,16 @@ (should (equal (rx (or (not (in "abc")) (not (char "bcd")))) "[^bc]")) (should (equal (rx (or "x" (? "yz"))) - "x\\|\\(?:yz\\)?"))) + "x\\|\\(?:yz\\)?")) + (should (equal (rx (or anychar (not anychar))) + "[^z-a]")) + (should (equal (rx (or (not (in "a-p")) (not (in "k-u")))) + "[^k-p]")) + (should (equal (rx (or (not (in "a-p")) word (not (in "k-u")))) + "[\0-jq-\x3fff7f\x80-\xff[:word:]]")) + (should (equal (rx (or (in "a-f" blank) (in "c-z") blank)) + "[a-z[:blank:]]")) + ) (ert-deftest rx-def-in-charset-or () (rx-let ((a (any "badc")) @@ -600,6 +639,57 @@ (rx-submatch-n '(group-n 3 (+ nonl) eol))) "\\(?3:.+$\\)"))) +;;; unit tests for internal functions + +(ert-deftest rx--interval-set-complement () + (should (equal (rx--interval-set-complement '()) + '((0 . #x3fffff)))) + (should (equal (rx--interval-set-complement '((10 . 20) (30 . 40))) + '((0 . 9) (21 . 29) (41 . #x3fffff)))) + (should (equal (rx--interval-set-complement '((0 . #x3fffff))) + '())) + (should (equal (rx--interval-set-complement + '((0 . 10) (20 . 20) (30 . #x3fffff))) + '((11 . 19) (21 . 29))))) + +(ert-deftest rx--interval-set-union () + (should (equal (rx--interval-set-union '() '()) '())) + (should (equal (rx--interval-set-union '() '((10 . 20) (30 . 40))) + '((10 . 20) (30 . 40)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) '()) + '((10 . 20) (30 . 40)))) + (should (equal (rx--interval-set-union '((5 . 15) (18 . 24) (32 . 40)) + '((10 . 20) (30 . 40) (50 . 60))) + '((5 . 24) (30 . 40) (50 . 60)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40) (50 . 60)) + '((0 . 9) (21 . 29) (41 . 50))) + '((0 . 60)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) + '((12 . 18) (28 . 42))) + '((10 . 20) (28 . 42)))) + (should (equal (rx--interval-set-union '((10 . 20) (30 . 40)) + '((0 . #x3fffff))) + '((0 . #x3fffff))))) + +(ert-deftest rx--interval-set-intersection () + (should (equal (rx--interval-set-intersection '() '()) '())) + (should (equal (rx--interval-set-intersection '() '((10 . 20) (30 . 40))) + '())) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) '()) + '())) + (should (equal (rx--interval-set-intersection '((5 . 15) (18 . 24) (32 . 40)) + '((10 . 20) (30 . 40) (50 . 60))) + '((10 . 15) (18 . 20) (32 . 40)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40) (50 . 60)) + '((0 . 9) (21 . 29) (41 . 50))) + '((50 . 50)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) + '((12 . 18) (28 . 42))) + '((12 . 18) (30 . 40)))) + (should (equal (rx--interval-set-intersection '((10 . 20) (30 . 40)) + '((0 . #x3fffff))) + '((10 . 20) (30 . 40))))) + (provide 'rx-tests) ;;; rx-tests.el ends here diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 516d095767f..596b47d2543 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -65,6 +65,49 @@ (when buf (kill-buffer buf)))))) +(defun shortdoc-tests--to-ascii (x) + "Translate Unicode arrows to ASCII for making the test work everywhere." + (cond ((consp x) + (cons (shortdoc-tests--to-ascii (car x)) + (shortdoc-tests--to-ascii (cdr x)))) + ((stringp x) + (thread-last x + (string-replace "⇒" "=>") + (string-replace "→" "->"))) + (t x))) + +(ert-deftest shortdoc-function-examples-test () + "Test the extraction of usage examples of some Elisp functions." + (should (equal '((list . "(delete 2 (list 1 2 3 4))\n => (1 3 4)\n (delete \"a\" (list \"a\" \"b\" \"c\" \"d\"))\n => (\"b\" \"c\" \"d\")")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'delete)))) + (should (equal '((alist . "(assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)") + (list . "(assq 'b '((a . 1) (b . 2)))\n => (b . 2)")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'assq)))) + (should (equal '((regexp . "(string-match-p \"^[fo]+\" \"foobar\")\n => 0")) + (shortdoc-tests--to-ascii + (shortdoc-function-examples 'string-match-p))))) + +(ert-deftest shortdoc-help-fns-examples-function-test () + "Test that `shortdoc-help-fns-examples-function' correctly prints ELisp function examples." + (with-temp-buffer + (shortdoc-help-fns-examples-function 'string-fill) + (should (equal "\n Examples:\n\n (string-fill \"Three short words\" 12)\n => \"Three short\\nwords\"\n (string-fill \"Long-word\" 3)\n => \"Long-word\"\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) (point-max))))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'assq) + (should (equal "\n Examples:\n\n (assq 'foo '((foo . bar) (zot . baz)))\n => (foo . bar)\n\n (assq 'b '((a . 1) (b . 2)))\n => (b . 2)\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) (point-max))))) + (erase-buffer) + (shortdoc-help-fns-examples-function 'string-trim) + (should (equal "\n Example:\n\n (string-trim \" foo \")\n => \"foo\"\n\n" + (shortdoc-tests--to-ascii + (buffer-substring-no-properties (point-min) + (point-max))))))) + (provide 'shortdoc-tests) ;;; shortdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index e4c270a114f..63d8fcd080c 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -709,14 +709,15 @@ [(raise 0.5) (height 2.0)])) (should (equal (get-text-property 9 'display) '(raise 0.5)))) (with-temp-buffer - (should (equal (let ((str "some useless string")) - (add-display-text-property 4 8 'height 2.0 str) - (add-display-text-property 2 12 'raise 0.5 str) - str) - #("some useless string" - 2 4 (display (raise 0.5)) - 4 8 (display ((raise 0.5) (height 2.0))) - 8 12 (display (raise 0.5))))))) + (should (equal-including-properties + (let ((str (copy-sequence "some useless string"))) + (add-display-text-property 4 8 'height 2.0 str) + (add-display-text-property 2 12 'raise 0.5 str) + str) + #("some useless string" + 2 4 (display (raise 0.5)) + 4 8 (display ((raise 0.5) (height 2.0))) + 8 12 (display (raise 0.5))))))) (ert-deftest subr-x-named-let () (let ((funs ())) diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 3659a922fe3..ed9da90c029 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -111,14 +111,23 @@ jA0ECQMCdW8+qtS9Tin/0jUBO1/9Oz69BWPmtFKEeBM62WpFP4o1+bNzdxogdyeg -----END PGP MESSAGE----- "))))) +(defun epg--gnupg-version-is-not-buggy () + ;; We need to skip some versions of GnuPG, as they make tests hang. + ;; See Bug#63256 and https://dev.gnupg.org/T6481 as well as PROBLEMS. + ;; Known bad versions for now are 2.4.1--2.4.3. + (not (string-match (rx bos "gpg (GnuPG) 2.4." (+ digit)) + (shell-command-to-string "gpg --version")))) + (ert-deftest epg-roundtrip-1 () - :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme + :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme + (skip-unless (epg--gnupg-version-is-not-buggy)) (with-epg-tests (:require-passphrase t) (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) (should (equal "symmetric" (epg-decrypt-string epg-tests-context cipher)))))) (ert-deftest epg-roundtrip-2 () + (skip-unless (epg--gnupg-version-is-not-buggy)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) diff --git a/test/lisp/erc/erc-button-tests.el b/test/lisp/erc/erc-button-tests.el new file mode 100644 index 00000000000..be11b76bd2e --- /dev/null +++ b/test/lisp/erc/erc-button-tests.el @@ -0,0 +1,308 @@ +;;; erc-button-tests.el --- Tests for erc-button -*- 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: + +;;; Code: + +(require 'ert-x) ; cl-lib +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(require 'erc-button) + +(ert-deftest erc-button-alist--url () + (erc-tests-common-init-server-proc "sleep" "1") + (with-current-buffer (erc--open-target "#chan") + (let ((verify + (lambda (p url) + (should (equal (get-text-property p 'erc-data) (list url))) + (should (equal (get-text-property p 'mouse-face) 'highlight)) + (should (eq (get-text-property p 'font-lock-face) 'erc-button)) + (should (eq (get-text-property p 'erc-callback) + 'browse-url-button-open-url))))) + (goto-char (point-min)) + + ;; Most common (unbracketed) + (erc-display-message nil nil (current-buffer) + "Foo https://example.com bar.") + (search-forward "https") + (funcall verify (point) "https://example.com") + + ;; The <URL: form> still works despite being removed in ERC 5.6. + (erc-display-message nil nil (current-buffer) + "Foo <URL: https://gnu.org> bar.") + (search-forward "https") + (funcall verify (point) "https://gnu.org") + + ;; Bracketed + (erc-display-message nil nil (current-buffer) "Foo <ftp://gnu.org> bar.") + (search-forward "ftp") + (funcall verify (point) "ftp://gnu.org")) + + (when noninteractive + (kill-buffer)))) + +(defvar erc-button-tests--form nil) +(defvar erc-button-tests--some-var nil) + +(defun erc-button-tests--form (&rest rest) + (push rest erc-button-tests--form) + (apply #'erc-button-add-button rest)) + +(defun erc-button-tests--erc-button-alist--function-as-form (func) + (erc-tests-common-init-server-proc "sleep" "1") + + (with-current-buffer (erc--open-target "#chan") + (let* ((erc-button-tests--form nil) + (entry (list (rx "+1") 0 func #'ignore 0)) + (erc-button-alist (cons entry erc-button-alist))) + + (erc-display-message nil 'notice (current-buffer) "Foo bar baz") + (erc-display-message nil nil (current-buffer) "+1") + (erc-display-message nil 'notice (current-buffer) "Spam") + (should (equal (pop erc-button-tests--form) + '(53 55 ignore nil ("+1") "\\+1"))) + (should-not erc-button-tests--form) + (goto-char (point-min)) + (search-forward "+") + (should (equal (get-text-property (point) 'erc-data) '("+1"))) + (should (equal (get-text-property (point) 'mouse-face) 'highlight)) + (should (eq (get-text-property (point) 'font-lock-face) 'erc-button)) + (should (eq (get-text-property (point) 'erc-callback) 'ignore))) + + (when noninteractive + (kill-buffer)))) + +(ert-deftest erc-button-alist--function-as-form () + (erc-button-tests--erc-button-alist--function-as-form + #'erc-button-tests--form) + + (erc-button-tests--erc-button-alist--function-as-form + (symbol-function #'erc-button-tests--form)) + + (erc-button-tests--erc-button-alist--function-as-form + (lambda (&rest r) (push r erc-button-tests--form) + (apply #'erc-button-add-button r)))) + +(defun erc-button-tests--erc-button-alist--nil-form (form) + (erc-tests-common-init-server-proc "sleep" "1") + + (with-current-buffer (erc--open-target "#chan") + (let* ((erc-button-tests--form nil) + (entry (list (rx "+1") 0 form #'ignore 0)) + (erc-button-alist (cons entry erc-button-alist))) + + (erc-display-message nil 'notice (current-buffer) "Foo bar baz") + (erc-display-message nil nil (current-buffer) "+1") + (erc-display-message nil 'notice (current-buffer) "Spam") + (should-not erc-button-tests--form) + (goto-char (point-min)) + (search-forward "+") + (should-not (get-text-property (point) 'erc-data)) + (should-not (get-text-property (point) 'mouse-face)) + (should-not (get-text-property (point) 'font-lock-face)) + (should-not (get-text-property (point) 'erc-callback))) + + (when noninteractive + (kill-buffer)))) + +(ert-deftest erc-button-alist--nil-form () + (erc-button-tests--erc-button-alist--nil-form nil) + (erc-button-tests--erc-button-alist--nil-form 'erc-button-tests--some-var)) + +(defun erc-button-tests--insert-privmsg (speaker &rest msg-parts) + (declare (indent 1)) + (let ((msg (erc-format-privmessage speaker + (apply #'concat msg-parts) nil t))) + (erc-display-message nil nil (current-buffer) msg))) + +(defun erc-button-tests--populate (test) + (let ((inhibit-message noninteractive) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer + (cl-letf + (((symbol-function 'erc-server-connect) + (lambda (&rest _) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil)))) + + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" 'foonet)) + + (with-current-buffer (erc--open-target "#chan") + (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. " + "Blah alice (1) bob (2) blah.")) + + (funcall test)) + + (when noninteractive + (kill-buffer "#chan") + (kill-buffer))))) + +(ert-deftest erc-button-next () + (erc-button-tests--populate + (lambda () + (erc-button-tests--insert-privmsg "alice" + "(3) bob (4) come, you are a tedious fool: to the purpose.") + + (erc-button-tests--insert-privmsg "bob" + "(5) alice (6) Come me to what was done to her.") + + (should (= erc-input-marker (point))) + + ;; Break out of input area + (erc-button-previous 1) + (should (looking-at (rx "alice (6)"))) + + ;; No next button + (should-error (erc-button-next 1) :type 'user-error) + (should (looking-at (rx "alice (6)"))) + + ;; Next with negative arg is equivalent to previous + (erc-button-next -1) + (should (looking-at (rx "bob> (5)"))) + + ;; One past end of button + (forward-char 3) + (should (looking-at (rx "> (5)"))) + (should-not (get-text-property (point) 'erc-callback)) + (erc-button-previous 1) + (should (looking-at (rx "bob> (5)"))) + + ;; At end of button + (forward-char 2) + (should (looking-at (rx "b> (5)"))) + (erc-button-previous 1) + (should (looking-at (rx "bob (4)"))) + + ;; Skip multiple buttons back + (erc-button-previous 2) + (should (looking-at (rx "bob (2)"))) + + ;; Skip multiple buttons forward + (erc-button-next 2) + (should (looking-at (rx "bob (4)"))) + + ;; No error as long as some progress made + (erc-button-previous 100) + (should (looking-at (rx "alice (1)"))) + + ;; Error when no progress made + (should-error (erc-button-previous 1) :type 'user-error) + (should (looking-at (rx "alice (1)")))))) + +;; See also `erc-scenarios-networks-announced-missing' in +;; erc-scenarios-misc.el for a more realistic example. +(ert-deftest erc-button--display-error-notice-with-keys () + (with-current-buffer (get-buffer-create "*fake*") + (let ((mode erc-button-mode) + (inhibit-message noninteractive) + erc-modules + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (erc-tests-common-prep-for-insertion) + (erc-tests-common-init-server-proc "sleep" "1") + + (erc-button-mode +1) + (should (equal (erc-button--display-error-notice-with-keys + "If \\[erc-bol] fails, " + "see \\[erc-bug] or `erc-mode-map'.") + "*** If C-a fails, see M-x erc-bug or `erc-mode-map'.")) + (goto-char (point-min)) + + (ert-info ("Keymap substitution succeeds") + (erc-button-next 1) + (should (looking-at "C-a")) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (erc-button-press-button) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bol" nil t))) + (erc-button-next 1) + ;; End of interval correct + (erc-button-previous 1) + (should (looking-at "C-a fails"))) + + (ert-info ("Extended command mapping succeeds") + (erc-button-next 1) + (should (looking-at "M-x erc-bug")) + (erc-button-press-button) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bug" nil t)))) + + (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k + (erc-button-next 1) + (should (equal (get-text-property (point) 'font-lock-face) + '(erc-button erc-error-face erc-notice-face))) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (should (eq erc-button-face 'erc-button))) ; extent evaporates + + (ert-info ("Format when trailing args include non-strings") + (should (equal (erc-button--display-error-notice-with-keys + "abc" " %d def" " 45%s" 123 '\6) + "*** abc 123 def 456"))) + + (ert-info ("Respects buffer as first argument when given") + (should (equal (erc-button--display-error-notice-with-keys + (make-erc-response) "abc") ; compat + "*** abc")) + (should (equal (erc-button--display-error-notice-with-keys + (current-buffer) "abc") + "*** abc"))) + + (ert-info ("Accounts for nil members when concatenating") + (should (equal (erc-button--display-error-notice-with-keys + "a" nil) + "*** a")) + (should (equal (erc-button--display-error-notice-with-keys + "a" nil " b") + "*** a b")) + (should (equal (erc-button--display-error-notice-with-keys + "a: %d" nil 1) + "*** a: 1")) + (should (equal (erc-button--display-error-notice-with-keys + "a: %d %s" 1 nil) + "*** a: 1 nil")) + (should (equal (erc-button--display-error-notice-with-keys + "a: " "%d %s" 1 nil) + "*** a: 1 nil")) + (should (equal (erc-button--display-error-notice-with-keys + "a: " nil "%d %s" 1 nil) + "*** a: 1 nil"))) + + (when noninteractive + (unless mode + (erc-button-mode -1)) + (kill-buffer "*Help*") + (kill-buffer))))) + +;;; erc-button-tests.el ends here diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index bd8a9fc7951..a750c96c80f 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -57,9 +57,8 @@ (erc-mode) (setq erc-server-process (start-process "fake" (current-buffer) "sleep" "10") - erc-input-marker (make-marker) - erc-insert-marker (make-marker) erc-server-current-nick "dummy") + (erc--initialize-markers (point) nil) (set-process-query-on-exit-flag erc-server-process nil) (should-not erc-dcc-list) (erc-ctcp-query-DCC erc-server-process @@ -100,17 +99,19 @@ (ert-deftest erc-dcc-handle-ctcp-send--turbo () (erc-dcc-tests--dcc-handle-ctcp-send t)) -(ert-deftest erc-dcc-do-GET-command () +(defun erc-dcc-tests--erc-dcc-do-GET-command (file &optional sep nuh) + (unless nuh (setq nuh "tester!~tester@fake.irc")) (with-temp-buffer (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) - (elt (list :nick "tester!~tester@fake.irc" + (elt (list :nick nuh :type 'GET :peer nil :parent proc :ip "127.0.0.1" :port "9899" - :file "foo.bin" + :file file :size 1405135128)) + (nic (erc-extract-nick nuh)) (erc-dcc-list (list elt)) ;; erc-accidental-paste-threshold-seconds @@ -119,53 +120,63 @@ calls) (erc-mode) (setq erc-server-process proc - erc-input-marker (make-marker) - erc-insert-marker (make-marker) erc-server-current-nick "dummy") + (erc--initialize-markers (point) nil) (set-process-query-on-exit-flag proc nil) (cl-letf (((symbol-function 'read-file-name) - (lambda (&rest _) "foo.bin")) + (lambda (&rest _) file)) ((symbol-function 'erc-dcc-get-file) (lambda (&rest r) (push r calls)))) (goto-char (point-max)) - (set-marker erc-insert-marker (point-max)) - (erc-display-prompt) (ert-info ("No turbo") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET tester foo.bin") + (insert "/dcc GET " nic " " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should-not (plist-member (car erc-dcc-list) :turbo)) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 2") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET -t tester foo.bin") + (insert "/dcc GET -t " nic " " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 4") (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester -t foo.bin") + (insert "/dcc GET " nic " -t " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 6") (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester foo.bin -t") + (insert "/dcc GET " nic " " (prin1-to-string file) " -t" (or sep "")) (erc-send-current-line) - (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))))))) + (should (eq (if sep nil t) (plist-get (car erc-dcc-list) :turbo))) + (should (equal (pop calls) (if sep nil (list elt file proc))))))))) + +(ert-deftest erc-dcc-do-GET-command () + (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- ") -(defun erc-dcc-tests--pcomplete-common (test-fn) + ;; Regression involving pipe character in nickname. + (let ((nuh "test|r!~test|r@fake.irc")) + (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin" nil nuh) + (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- " nuh))) + +(defun erc-dcc-tests--pcomplete-common (test-fn &optional file) (with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*") (let* ((inhibit-message noninteractive) (proc (start-process "fake" (current-buffer) "sleep" "10")) @@ -175,7 +186,7 @@ :parent proc :ip "127.0.0.1" :port "9899" - :file "foo.bin" + :file (or file "foo.bin") :size 1405135128)) ;; erc-accidental-paste-threshold-seconds @@ -211,6 +222,20 @@ (beginning-of-line) (should (search-forward "/dcc get tester foo.bin" nil t)))))) +(ert-deftest pcomplete/erc-mode/DCC--get-quoted () + (erc-dcc-tests--pcomplete-common + (lambda () + (insert "/dcc get ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester \"foo bar.bin\"" nil t)))) + "foo bar.bin")) + (ert-deftest pcomplete/erc-mode/DCC--get-1flag () (erc-dcc-tests--pcomplete-common (lambda () @@ -282,4 +307,23 @@ (beginning-of-line) (should (search-forward "/dcc get -t -s tester foo.bin" nil t)))))) +(ert-deftest pcomplete/erc-mode/DCC--get-sep () + (erc-dcc-tests--pcomplete-common + (lambda () + (insert "/dcc get ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester" nil t))) + (insert "-") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester -- " nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester -- -t" nil t)))) + "-t")) + ;;; erc-dcc-tests.el ends here 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 diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el new file mode 100644 index 00000000000..bdd197fa5cb --- /dev/null +++ b/test/lisp/erc/erc-goodies-tests.el @@ -0,0 +1,444 @@ +;;; erc-goodies-tests.el --- Tests for erc-goodies -*- 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: +;;; Code: +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(require 'erc-goodies) + +(defun erc-goodies-tests--assert-face (beg end-str present &optional absent) + (setq beg (+ beg (point-min))) + (let ((end (+ beg (1- (length end-str))))) + (while (and beg (< beg end)) + (let* ((val (get-text-property beg 'font-lock-face)) + (ft (flatten-tree (ensure-list val)))) + (dolist (p (ensure-list present)) + (if (consp p) + (should (member p val)) + (should (memq p ft)))) + (dolist (a (ensure-list absent)) + (if (consp a) + (should-not (member a val)) + (should-not (memq a ft)))) + (setq beg (text-property-not-all beg (point-max) + 'font-lock-face val)))))) + +;; These are from the "Examples" section of +;; https://modern.ircdocs.horse/formatting.html + +(ert-deftest erc-controls-highlight--examples () + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (let* ((m "I love \C-c3IRC!\C-c It is the \C-c7best protocol ever!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward "<bob> " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "I love" 'erc-default-face 'fg:erc-color-face3) + (erc-goodies-tests--assert-face + 7 " IRC!" 'fg:erc-color-face3) + (erc-goodies-tests--assert-face + 11 " It is the " 'erc-default-face 'fg:erc-color-face7) + (erc-goodies-tests--assert-face + 22 "best protocol ever!" 'fg:erc-color-face7)) + + (let* ((m "This is a \C-]\C-c13,9cool \C-cmessage") + (msg (erc-format-privmessage "alice" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward "<alice> " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "this is a " 'erc-default-face 'erc-italic-face) + (erc-goodies-tests--assert-face + 10 "cool " '(erc-italic-face fg:erc-color-face13 bg:erc-color-face9)) + (erc-goodies-tests--assert-face + 15 "message" 'erc-italic-face + '(fg:erc-color-face13 bg:erc-color-face9))) + + (let* ((m "IRC \C-bis \C-c4,12so \C-cgreat\C-o!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward "<bob> " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "IRC " 'erc-default-face 'erc-bold-face) + (erc-goodies-tests--assert-face + 4 "is " 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 7 "so " '(erc-bold-face fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 10 "great" 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 15 "!" 'erc-default-face 'erc-bold-face)) + + (let* ((m (concat "Rules: Don't spam 5\C-c13,8,6\C-c,7,8, " + "and especially not \C-b9\C-b\C-]!")) + (msg (erc-format-privmessage "alice" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward "<alice> " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "Rules: Don't spam 5" 'erc-default-face + '(fg:erc-color-face13 bg:erc-color-face8)) + (erc-goodies-tests--assert-face + 19 ",6" '(fg:erc-color-face13 bg:erc-color-face8)) + (erc-goodies-tests--assert-face + 21 ",7,8, and especially not " 'erc-default-face + '(fg:erc-color-face13 bg:erc-color-face8 erc-bold-face)) + (erc-goodies-tests--assert-face + 44 "9" 'erc-bold-face 'erc-italic-face) + (erc-goodies-tests--assert-face + 45 "!" 'erc-italic-face 'erc-bold-face)) + + (when noninteractive + (kill-buffer))))) + +;; Like the test above, this is most intuitive when run interactively. +;; Hovering over the redacted area should reveal its underlying text +;; in a high-contrast face. + +(ert-deftest erc-controls-highlight--inverse () + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (let* ((m "Spoiler: \C-c0,0Hello\C-c1,1World!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward "<bob> " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (should (eq (get-text-property (+ 9 (point)) 'mouse-face) + 'erc-inverse-face)) + (should (eq (get-text-property (1- (pos-eol)) 'mouse-face) + 'erc-inverse-face)) + (erc-goodies-tests--assert-face + 0 "Spoiler: " 'erc-default-face + '(fg:erc-color-face0 bg:erc-color-face0)) + (erc-goodies-tests--assert-face + 9 "Hello" '(erc-spoiler-face) + '( fg:erc-color-face0 bg:erc-color-face0 + fg:erc-color-face1 bg:erc-color-face1)) + (erc-goodies-tests--assert-face + 18 " World" '(erc-spoiler-face) + '( fg:erc-color-face0 bg:erc-color-face0 + fg:erc-color-face1 bg:erc-color-face1 ))) + (when noninteractive + (kill-buffer))))) + +(defvar erc-goodies-tests--motd + ;; This is from ergo's MOTD + '((":- - this is \2bold text\17.") + (":- - this is \35italics text\17.") + (":- - this is \0034red\3 and \0032blue\3 text.") + (":- - this is \0034,12red text with a light blue background\3.") + (":- - this is a normal escaped dollarsign: $") + (":- ") + (":- " + "\0031,0 00 \0030,1 01 \0030,2 02 \0030,3 03 " + "\0031,4 04 \0030,5 05 \0030,6 06 \0031,7 07 ") + (":- " + "\0031,8 08 \0031,9 09 \0030,10 10 \0031,11 11 " + "\0030,12 12 \0031,13 13 \0031,14 14 \0031,15 15 ") + (":- ") + (":- " + "\0030,16 16 \0030,17 17 \0030,18 18 \0030,19 19 " + "\0030,20 20 \0030,21 21 \0030,22 22 \0030,23 23 " + "\0030,24 24 \0030,25 25 \0030,26 26 \0030,27 27 ") + (":- " + "\0030,28 28 \0030,29 29 \0030,30 30 \0030,31 31 " + "\0030,32 32 \0030,33 33 \0030,34 34 \0030,35 35 " + "\0030,36 36 \0030,37 37 \0030,38 38 \0030,39 39 ") + (":- " + "\0030,40 40 \0030,41 41 \0030,42 42 \0030,43 43 " + "\0030,44 44 \0030,45 45 \0030,46 46 \0030,47 47 " + "\0030,48 48 \0030,49 49 \0030,50 50 \0030,51 51 ") + (":- " + "\0030,52 52 \0030,53 53 \0031,54 54 \0031,55 55 " + "\0031,56 56 \0031,57 57 \0031,58 58 \0030,59 59 " + "\0030,60 60 \0030,61 61 \0030,62 62 \0030,63 63 ") + (":- " + "\0030,64 64 \0031,65 65 \0031,66 66 \0031,67 67 " + "\0031,68 68 \0031,69 69 \0031,70 70 \0031,71 71 " + "\0030,72 72 \0030,73 73 \0030,74 74 \0030,75 75 ") + (":- " + "\0031,76 76 \0031,77 77 \0031,78 78 \0031,79 79 " + "\0031,80 80 \0031,81 81 \0031,82 82 \0031,83 83 " + "\0031,84 84 \0031,85 85 \0031,86 86 \0031,87 87 ") + (":- " + "\0030,88 88 \0030,89 89 \0030,90 90 \0030,91 91 " + "\0030,92 92 \0030,93 93 \0030,94 94 \0030,95 95 " + "\0031,96 96 \0031,97 97 \0031,98 98 \399,99 99 ") + (":- "))) + +(ert-deftest erc-controls-highlight--motd () + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (dolist (parts erc-goodies-tests--motd) + (erc-display-message nil 'notice (current-buffer) (string-join parts))) + + ;; Spot check + (goto-char (point-min)) + (should (search-forward " 16 " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 " 17 " '(fg:erc-color-face0 (:background "#472100"))) + (erc-goodies-tests--assert-face + 4 " 18 " '(fg:erc-color-face0 (:background "#474700")) + '((:background "#472100")))) + + (should (search-forward " 71 " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 " 72 " '(fg:erc-color-face0 (:background "#5959ff"))) + (erc-goodies-tests--assert-face + 4 " 73 " '(fg:erc-color-face0 (:background "#c459ff")) + '((:background "#5959ff")))) + + (goto-char (point-min)) + (when noninteractive + (kill-buffer))))) + + +;; Among other things, this test also asserts that a local module's +;; minor-mode toggle is allowed to disable its mode variable as +;; needed. + +(defun erc-goodies-tests--assert-kp-indicator-on () + (should erc--keep-place-indicator-overlay) + (should (local-variable-p 'window-buffer-change-functions)) + (should window-configuration-change-hook) + (should (memq 'erc-keep-place erc-insert-pre-hook)) + (should (eq erc-keep-place-mode + (not (local-variable-p 'erc-insert-pre-hook))))) + +(defun erc-goodies-tests--assert-kp-indicator-off () + (should-not (local-variable-p 'erc-insert-pre-hook)) + (should-not (local-variable-p 'window-buffer-change-functions)) + (should-not erc--keep-place-indicator-overlay)) + +(defun erc-goodies-tests--kp-indicator-populate () + (erc-display-message nil 'notice (current-buffer) + "This buffer is for text that is not saved") + (erc-display-message nil 'notice (current-buffer) + "and for lisp evaluation") + (should (search-forward "saved" nil t)) + (erc-keep-place-move nil) + (goto-char erc-input-marker)) + +(defun erc-goodies-tests--keep-place-indicator (test) + (with-current-buffer (get-buffer-create "*erc-keep-place-indicator-mode*") + (erc-mode) + (erc--initialize-markers (point) nil) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil) + (let (erc-connect-pre-hook + erc-modules) + + (ert-info ("Clean slate") + (erc-goodies-tests--assert-kp-indicator-off) + (should-not erc-keep-place-mode) + (should-not (memq 'keep-place erc-modules))) + + (funcall test)) + + (when noninteractive + (erc-keep-place-indicator-mode -1) + (erc-keep-place-mode -1) + (should-not (member 'erc-keep-place + (default-value 'erc-insert-pre-hook))) + (should-not (local-variable-p 'erc-insert-pre-hook)) + (kill-buffer)))) + +(ert-deftest erc-keep-place-indicator-mode--no-global () + (erc-goodies-tests--keep-place-indicator + (lambda () + + (ert-info ("Value t") + (should (eq erc-keep-place-indicator-buffer-type t)) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on) + (goto-char (point-min))) + + (erc-keep-place-indicator-mode -1) + (erc-goodies-tests--assert-kp-indicator-off) + + (ert-info ("Value `target'") + (let ((erc-keep-place-indicator-buffer-type 'target)) + ;; No-op because server buffer. + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-off) + ;; Spoof target buffer (no longer no-op). + (setq erc--target (erc--target-from-string "#chan")) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on))) + + (erc-keep-place-indicator-mode -1) + (erc-goodies-tests--assert-kp-indicator-off) + + (ert-info ("Value `server'") + (let ((erc-keep-place-indicator-buffer-type 'server)) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-off) + (setq erc--target nil) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on))) + + ;; Populate buffer + (erc-goodies-tests--kp-indicator-populate) + + (ert-info ("Indicator survives reconnect") + (let ((erc--server-reconnecting (buffer-local-variables))) + (cl-letf (((symbol-function 'erc-server-connect) #'ignore)) + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" nil))) + (erc-goodies-tests--assert-kp-indicator-on) + (should (= (point) erc-input-marker)) + (goto-char (overlay-start erc--keep-place-indicator-overlay)) + (should (looking-at (rx "*** This buffer is for text"))))))) + +(ert-deftest erc-keep-place-indicator-mode--global () + (erc-goodies-tests--keep-place-indicator + (lambda () + + (push 'keep-place erc-modules) + + (ert-info ("Value t") + (should (eq erc-keep-place-indicator-buffer-type t)) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on) + ;; Local module activates global `keep-place'. + (should erc-keep-place-mode) + ;; Does not register local version of hook (otherwise would run + ;; twice). + (should-not (local-variable-p 'erc-insert-pre-hook)) + (goto-char (point-min))) + + (erc-keep-place-indicator-mode -1) + (erc-goodies-tests--assert-kp-indicator-off) + (should erc-keep-place-mode) + (should (member 'erc-keep-place erc-insert-pre-hook)) + + (ert-info ("Value `target'") + (let ((erc-keep-place-indicator-buffer-type 'target)) + ;; No-op because server buffer. + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-off) + ;; Does not interfere with global activation state. + (should erc-keep-place-mode) + (should (member 'erc-keep-place erc-insert-pre-hook)) + ;; Morph into a target buffer (no longer no-op). + (setq erc--target (erc--target-from-string "#chan")) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on) + ;; Does not register local version of hook. + (should-not (local-variable-p 'erc-insert-pre-hook)))) + + (erc-keep-place-indicator-mode -1) + (erc-goodies-tests--assert-kp-indicator-off) + (should erc-keep-place-mode) + (should (member 'erc-keep-place erc-insert-pre-hook)) + + (ert-info ("Value `server'") + (let ((erc-keep-place-indicator-buffer-type 'server)) + ;; No-op because we're now a target buffer. + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-off) + (should erc-keep-place-mode) + (should (member 'erc-keep-place erc-insert-pre-hook)) + ;; Back to server. + (setq erc--target nil) + (erc-keep-place-indicator-mode +1) + (erc-goodies-tests--assert-kp-indicator-on) + (should-not (local-variable-p 'erc-insert-pre-hook)))) + + (ert-info ("Local adapts to global toggle") + (erc-keep-place-mode -1) + (should-not (member 'erc-keep-place + (default-value 'erc-insert-pre-hook))) + (should (member 'erc-keep-place erc-insert-pre-hook)) + (erc-goodies-tests--assert-kp-indicator-on) + (erc-keep-place-mode +1) + (should (member 'erc-keep-place (default-value 'erc-insert-pre-hook))) + (should-not (local-variable-p 'erc-insert-pre-hook)) + (erc-goodies-tests--assert-kp-indicator-on)) + + ;; Populate buffer + (erc-goodies-tests--kp-indicator-populate) + + (ert-info ("Indicator survives reconnect") + (let ((erc--server-reconnecting (buffer-local-variables))) + (cl-letf (((symbol-function 'erc-server-connect) #'ignore)) + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" nil))) + (erc-goodies-tests--assert-kp-indicator-on) + (should erc-keep-place-mode) + (should (member 'erc-keep-place erc-insert-pre-hook)) + (should (= (point) erc-input-marker)) + (goto-char (overlay-start erc--keep-place-indicator-overlay)) + (should (looking-at (rx "*** This buffer is for text"))))))) + +(ert-deftest erc--get-inserted-msg-beg/readonly () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg)))))) + +(ert-deftest erc--get-inserted-msg-end/readonly () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) (should (= 11 (erc--get-inserted-msg-end arg)))))) + +(ert-deftest erc--get-inserted-msg-bounds/readonly () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) + (should (equal '(3 . 11) (erc--get-inserted-msg-bounds arg)))))) + + +;;; erc-goodies-tests.el ends here diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index 96836c29aed..7d9424d7430 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -20,25 +20,21 @@ ;;; Code: (require 'ert-x) ; cl-lib -(require 'erc) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) (defun erc-networks-tests--create-dead-proc (&optional buf) (let ((p (start-process "true" (or buf (current-buffer)) "true"))) (while (process-live-p p) (sit-for 0.1)) p)) -(defun erc-networks-tests--create-live-proc (&optional buf) - (let ((proc (start-process "sleep" (or buf (current-buffer)) "sleep" "1"))) - (set-process-query-on-exit-flag proc nil) - proc)) +(defun erc-networks-tests--create-live-proc () + (erc-tests-common-init-server-proc "sleep" "1")) ;; When we drop 27, call `get-buffer-create with INHIBIT-BUFFER-HOOKS. (defun erc-networks-tests--clean-bufs () - (let (erc-kill-channel-hook - erc-kill-server-hook - erc-kill-buffer-hook) - (dolist (buf (erc-buffer-list)) - (kill-buffer buf)))) + (erc-tests-common-kill-buffers)) (defun erc-networks-tests--bufnames (prefix) (let* ((case-fold-search) @@ -623,11 +619,6 @@ :symbol 'foonet/dummy :parts [foonet "dummy"] :len 2) - ;; `erc-kill-buffer-function' uses legacy target detection - ;; but falls back on buffer name, so no need for: - ;; - ;; erc-default-recipients '("#a") - ;; erc--target (erc--target-from-string "#a") erc-server-process (with-temp-buffer (erc-networks-tests--create-dead-proc))) @@ -1206,7 +1197,7 @@ calls) (erc-mode) - (cl-letf (((symbol-function 'erc-display-line) + (cl-letf (((symbol-function 'erc--route-insertion) (lambda (&rest r) (push r calls)))) (ert-info ("Signals when `erc-server-announced-name' unset") @@ -1233,10 +1224,7 @@ :contents "MOTD File is missing"))) (erc-mode) ; boilerplate displayable start (needs `erc-server-process') - (insert "\n\n") - (setq erc-input-marker (make-marker) erc-insert-marker (make-marker)) - (set-marker erc-insert-marker (point-max)) - (erc-display-prompt) ; boilerplate displayable end + (erc--initialize-markers (point) nil) (erc-networks--ensure-announced erc-server-process parsed) (goto-char (point-min)) @@ -1277,9 +1265,9 @@ (with-current-buffer old-buf (erc-mode) (insert "*** Old buf") + (erc--initialize-markers (point) nil) (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc-networks--id (erc-networks--id-create nil))) @@ -1328,10 +1316,10 @@ erc-reuse-buffers) (with-current-buffer old-buf (erc-mode) + (erc--initialize-markers (point) nil) (insert "*** Old buf") (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc-networks--id (erc-networks--id-create nil))) (with-current-buffer (get-buffer-create "#chan") @@ -1377,10 +1365,10 @@ (with-current-buffer old-buf (erc-mode) + (erc--initialize-markers (point) nil) (insert "*** Old buf") (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc-networks--id (erc-networks--id-create nil))) @@ -1415,10 +1403,10 @@ (with-current-buffer old-buf (erc-mode) + (erc--initialize-markers (point) nil) (insert "*** Old buf") (setq erc-network 'FooNet erc-networks--id (erc-networks--id-create 'MySession) - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc)) (with-current-buffer (get-buffer-create "#chan") @@ -1450,14 +1438,16 @@ (let* (erc-kill-server-hook erc-insert-modify-hook (old-buf (get-buffer-create "FooNet")) - (old-proc (erc-networks-tests--create-live-proc old-buf))) ; live + ;; + old-proc) ; live (with-current-buffer old-buf (erc-mode) + (setq old-proc (erc-networks-tests--create-live-proc)) + (erc--initialize-markers (point) nil) (insert "*** Old buf") (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc-networks--id (erc-networks--id-create nil)) (should (erc-server-process-alive))) @@ -1473,12 +1463,15 @@ (ert-info ("New buffer rejected, abandoned, not killed") (with-current-buffer (get-buffer-create "irc.foonet.org") (erc-mode) + (erc--initialize-markers (point) nil) (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process (erc-networks-tests--create-live-proc) erc-networks--id (erc-networks--id-create nil)) - (should-not (erc-networks--rename-server-buffer erc-server-process)) + (set-process-sentinel erc-server-process #'ignore) + (erc-display-message nil 'notice (current-buffer) "notice") + (with-silent-modifications + (should-not (erc-networks--rename-server-buffer erc-server-process))) (should (eq erc-active-buffer old-buf)) (should-not (erc-server-process-alive)) (should (string= (buffer-name) "irc.foonet.org")) @@ -1508,10 +1501,10 @@ (with-current-buffer old-buf (erc-mode) (insert "*** Old buf") + (erc--initialize-markers (point) nil) (setq erc-network 'FooNet erc-server-current-nick "tester" erc-server-announced-name "us-east.foonet.org" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc--isupport-params (make-hash-table) erc-networks--id (erc-networks--id-create nil)) @@ -1560,10 +1553,10 @@ (with-current-buffer old-buf (erc-mode) (insert "*** Old buf") + (erc--initialize-markers (point) nil) (setq erc-network 'FooNet erc-server-current-nick "tester" erc-server-announced-name "us-west.foonet.org" - erc-insert-marker (set-marker (make-marker) (point-max)) erc-server-process old-proc erc--isupport-params (make-hash-table) erc-networks--id (erc-networks--id-create nil)) @@ -1750,4 +1743,22 @@ (should (eq (erc-networks--determine) erc-networks--name-missing-sentinel)))) +(ert-deftest erc-ports-list () + (with-suppressed-warnings ((obsolete erc-server-alist)) + (let* ((srv (assoc "Libera.Chat: Random server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) + '(6665 6666 6667 8000 8001 8002))) + (should (equal (erc-ports-list (nth 4 srv)) + '(6697 7000 7070)))) + + (let* ((srv (assoc "Libera.Chat: Random Europe server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) '(6667))) + (should (equal (erc-ports-list (nth 4 srv)) '(6697)))) + + (let* ((srv (assoc "OFTC: Random server" erc-server-alist))) + (should (equal (erc-ports-list (nth 3 srv)) + '(6667 6668 6669 6670 7000))) + (should (equal (erc-ports-list (nth 4 srv)) + '(6697 9999)))))) + ;;; erc-networks-tests.el ends here diff --git a/test/lisp/erc/erc-nicks-tests.el b/test/lisp/erc/erc-nicks-tests.el new file mode 100644 index 00000000000..54882278139 --- /dev/null +++ b/test/lisp/erc/erc-nicks-tests.el @@ -0,0 +1,571 @@ +;;; erc-nicks-tests.el --- Tests for erc-nicks -*- 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: + +;; Unlike most of ERC's tests, the ones in this file can be run +;; interactively in the same session. + +;; TODO: +;; +;; * Add mock session (or scenario) with buffer snapshots, like those +;; in erc-fill-tests.el. (Should probably move helpers to a common +;; library under ./resources.) + +;;; Code: + +(require 'ert-x) +(require 'erc-nicks) + +;; This function replicates the behavior of older "invert" strategy +;; implementations from EmacsWiki, etc. The values for the lower and +;; upper bounds (0.33 and 0.66) are likewise inherited. See +;; `erc-nicks--invert-classic--dark' below for one reason its results +;; may not be plainly obvious. +(defun erc-nicks-tests--invert-classic (color) + (if (pcase (erc-nicks--bg-mode) + ('dark (< (erc-nicks--get-luminance color) (/ 1 3.0))) + ('light (> (erc-nicks--get-luminance color) (/ 2 3.0)))) + (list (- 1.0 (nth 0 color)) (- 1.0 (nth 1 color)) (- 1.0 (nth 2 color))) + color)) + + +(ert-deftest erc-nicks--get-luminance () + (should (eql 0.0 (erc-nicks--get-luminance "black"))) + (should (eql 1.0 (erc-nicks--get-luminance "white"))) + (should (eql 21.0 (/ (+ 0.05 1.0) (+ 0.05 0.0)))) + + ;; RGB floats from a `display-graphic-p' session. + (let ((a (erc-nicks--get-luminance ; #9439ad + '(0.5803921568627451 0.2235294117647059 0.6784313725490196))) + (b (erc-nicks--get-luminance ; #ae54c7 + '(0.6823529411764706 0.32941176470588235 0.7803921568627451))) + (c (erc-nicks--get-luminance ; #d19ddf + '(0.8196078431372549 0.615686274509804 0.8745098039215686))) + (d (erc-nicks--get-luminance ; #f5e8f8 + '(0.9607843137254902 0.9098039215686274 0.9725490196078431)))) + ;; Low, med, high contrast comparisons against known values from + ;; an external source. + (should (eql 1.42 (/ (round (* 100 (/ (+ 0.05 b) (+ 0.05 a)))) 100.0))) + (should (eql 2.78 (/ (round (* 100 (/ (+ 0.05 c) (+ 0.05 a)))) 100.0))) + (should (eql 5.16 (/ (round (* 100 (/ (+ 0.05 d) (+ 0.05 a)))) 100.0))))) + +(ert-deftest erc-nicks-invert--classic () + (let ((convert (lambda (n) (apply #'color-rgb-to-hex + (erc-nicks-tests--invert-classic + (color-name-to-rgb n)))))) + (let ((erc-nicks--bg-mode-value 'dark)) + (should (equal (funcall convert "white") "#ffffffffffff")) + (should (equal (funcall convert "black") "#ffffffffffff")) + (should (equal (funcall convert "green") "#0000ffff0000"))) + (let ((erc-nicks--bg-mode-value 'light)) + (should (equal (funcall convert "white") "#000000000000")) + (should (equal (funcall convert "black") "#000000000000")) + (should (equal (funcall convert "green") "#ffff0000ffff"))))) + +(ert-deftest erc-nicks--get-contrast () + (should (= 21.0 (erc-nicks--get-contrast "white" "black"))) + (should (= 21.0 (erc-nicks--get-contrast "black" "white"))) + (should (= 1.0 (erc-nicks--get-contrast "black" "black"))) + (should (= 1.0 (erc-nicks--get-contrast "white" "white")))) + +(defun erc-nicks-tests--print-contrast (fn color) + (let* ((erc-nicks-color-adjustments (list fn)) + (result (erc-nicks--reduce color)) + (start (point))) + (insert (format "%16s%-16s%16s%-16s\n" + (concat color "-") + (concat ">" result) + (concat color " ") + (concat " " result))) + (put-text-property (+ start 32) (+ start 48) 'face + (list :background color :foreground result)) + (put-text-property (+ start 48) (+ start 64) 'face + (list :background result :foreground color)) + result)) + +(ert-deftest erc-nicks--invert-classic--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +;; This shows that the output can be darker (have less contrast) than +;; the input. +(ert-deftest erc-nicks--invert-classic--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-tests--invert-classic c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#777777777777" (funcall show "#888888888888"))) + (should (equal "#666666666666" (funcall show "#999999999999"))) + (should (equal "#aaaaaaaaaaaa" (funcall show "#aaaaaaaaaaaa")))) + + (when noninteractive + (kill-buffer))))) + +;; These are the same as the legacy version but work in terms of +;; contrast ratios. Converting the original bounds to contrast ratios +;; (assuming pure white and black backgrounds) gives: +;; +;; min-lum of 0.33 ~~> 1.465 +;; max-lum of 0.66 ~~> 7.666 +;; +(ert-deftest erc-nicks-invert--light () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks-contrast-range '(1.465)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create + "*erc-nicks--invert-classic--light*") + (should (equal "#000000000000" (funcall show "white"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#ffff0000ffff" (funcall show "green"))) ; magenta + (should (equal "#00000000ffff" (funcall show "blue"))) + + (unless noninteractive + (should (equal "#bbbbbbbbbbbb" (funcall show "#bbbbbbbbbbbb"))) + (should (equal "#cccccccccccc" (funcall show "#cccccccccccc"))) + (should (equal "#222122212221" (funcall show "#dddddddddddd"))) + (should (equal "#111011101110" (funcall show "#eeeeeeeeeeee")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-invert--dark () + (let ((erc-nicks--bg-luminance 0.0) + (erc-nicks--bg-mode-value 'dark) + (erc-nicks-contrast-range '(7.666)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-invert c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-invert--dark*") + (should (equal "#ffffffffffff" (funcall show "white"))) + (should (equal "#ffffffffffff" (funcall show "black"))) + (should (equal "#0000ffffffff" (funcall show "red"))) ; cyan + (should (equal "#0000ffff0000" (funcall show "green"))) + (should (equal "#ffffffff0000" (funcall show "blue"))) ; yellow + + (unless noninteractive + (should (equal "#aaaaaaaaaaaa" (funcall show "#555555555555"))) + (should (equal "#999999999999" (funcall show "#666666666666"))) + (should (equal "#888888888888" (funcall show "#777777777777"))) + (should (equal "#888888888888" (funcall show "#888888888888"))) + (should (equal "#999999999999" (funcall show "#999999999999")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-add-contrast () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (erc-nicks-contrast-range '(3.5)) + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-add-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-add-contrast*") + (should (equal "#893a893a893a" (funcall show "white"))) + (should (equal "#893a893a893a" (funcall show "#893a893a893a"))) + (should (equal "#000000000000" (funcall show "black"))) + (should (equal "#ffff00000000" (funcall show "red"))) + (should (equal "#0000a12e0000" (funcall show "green"))) + (should (equal "#00000000ffff" (funcall show "blue"))) + + ;; When the input is already near the desired ratio, the result + ;; may not be in bounds, only close. But the difference is + ;; usually imperceptible. + (unless noninteractive + ;; Well inside (light slate gray) + (should (equal "#777788889999" (funcall show "#777788889999"))) + ;; Slightly outside -> just outside + (should (equal "#7c498bd39b5c" (funcall show "#88889999aaaa"))) + ;; Just outside -> just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7c498bd39b5c"))) + ;; Just inside + (should (equal "#7bcc8b479ac0" (funcall show "#7bcc8b479ac0")))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks-cap-contrast () + (should (= 12.5 (cdr erc-nicks-contrast-range))) + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (show (lambda (c) (erc-nicks-tests--print-contrast + #'erc-nicks-cap-contrast c)))) + + (with-current-buffer (get-buffer-create "*erc-nicks-remove-contrast*") + (should (equal (funcall show "black") "#34e534e534e5" )) ; 21.0 -> 12.14 + (should ; 12.32 -> 12.32 (same) + (equal (funcall show "#34e534e534e5") "#34e534e534e5")) + (should (equal (funcall show "white") "#ffffffffffff")) + + (unless noninteractive + (should (equal (funcall show "DarkRed") "#8b8b00000000")) + (should (equal (funcall show "DarkGreen") "#000064640000")) + ;; 15.29 -> 12.38 + (should (equal (funcall show "DarkBlue") "#1cf11cf198b5")) + + ;; 12.50 -> 12.22 + (should (equal (funcall show "#33e033e033e0") "#34ab34ab34ab")) + ;; 12.57 -> 12.28 + (should (equal (funcall show "#338033803380") "#344c344c344c")) + ;; 12.67 -> 12.37 + (should (equal (funcall show "#330033003300") "#33cc33cc33cc"))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-nicks--skip-p () + ;; Baseline + (should-not (erc-nicks--skip-p 'bold nil 10000000)) + (should-not (erc-nicks--skip-p '(bold) nil 10000000)) + (should-not (erc-nicks--skip-p nil '(bold) 10000000)) + (should-not (erc-nicks--skip-p 'bold '(bold) 0)) + (should-not (erc-nicks--skip-p '(bold) '(bold) 0)) + (should-not (erc-nicks--skip-p 'bold '(foo bold) 0)) + (should-not (erc-nicks--skip-p '((:inherit bold)) '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(bold) 1)) + (should (erc-nicks--skip-p 'bold '(fake bold) 1)) + (should (erc-nicks--skip-p 'bold '(foo bar bold) 1)) + (should (erc-nicks--skip-p '(bold) '(bold) 1)) + (should (erc-nicks--skip-p '((bold)) '(bold) 1)) + (should (erc-nicks--skip-p '((((bold)))) '(bold) 1)) + (should (erc-nicks--skip-p '(bold) '(foo bold) 1)) + (should (erc-nicks--skip-p '(:inherit bold) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '((:inherit bold)) '((:inherit bold)) 1)) + (should (erc-nicks--skip-p '(((:inherit bold))) '((:inherit bold)) 1)) + + ;; Composed + (should-not (erc-nicks--skip-p '(italic bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '((italic) bold) '(bold) 1)) + (should-not (erc-nicks--skip-p '(italic (bold)) '(bold) 1)) + (should (erc-nicks--skip-p '(italic bold) '(bold) 2)) + (should (erc-nicks--skip-p '((italic) bold) '(bold) 2)) + (should (erc-nicks--skip-p '(italic (bold)) '(bold) 2)) + + (should-not (erc-nicks--skip-p '(italic default bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) bold) '(bold) 2)) + (should-not (erc-nicks--skip-p '(italic (default bold)) '(bold) 2)) + (should-not (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 2)) + (should (erc-nicks--skip-p '((default italic) bold) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default bold)) '(bold) 3)) + (should (erc-nicks--skip-p '((default italic) (bold shadow)) '(bold) 3)) + (should (erc-nicks--skip-p '(italic (default (bold shadow))) '(bold) 3))) + +(ert-deftest erc-nicks--trim () + (should (equal (erc-nicks--trim "Bob`") "bob")) + (should (equal (erc-nicks--trim "Bob``") "bob")) + + ;; `erc--casemapping-rfc1459' + (let ((erc-nicks-ignore-chars "^")) + (should (equal (erc-nicks--trim "Bob~") "bob^")) + (should (equal (erc-nicks--trim "Bob^") "bob")))) + +(defvar erc-nicks-tests--fake-face-list nil) + +;; Since we can't delete faces, mock `face-list' to only return those +;; in `erc-nicks--face-table' created by the current test. +(defun erc-nicks-tests--face-list () + (let ((table (buffer-local-value 'erc-nicks--face-table + (get-buffer "foonet"))) + out) + (maphash (lambda (k v) + (when (member k erc-nicks-tests--fake-face-list) + (push v out))) + table) + (nreverse out))) + +(defun erc-nicks-tests--create-session (test alice bob) + (should-not (memq 'nicks erc-modules)) + (advice-add 'face-list :override #'erc-nicks-tests--face-list) + (let ((erc-modules (cons 'nicks erc-modules)) + (inhibit-message noninteractive) + (erc-nicks-tests--fake-face-list + (list (downcase alice) (downcase bob))) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer + (cl-letf + (((symbol-function 'erc-server-connect) + (lambda (&rest _) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil)))) + + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester")) + + (let ((inhibit-message noninteractive)) + (dolist (line (split-string "\ +:irc.foonet.org 004 tester irc.foonet.org irc.d abc 123 456 +:irc.foonet.org 005 tester NETWORK=foonet :are supported +:irc.foonet.org 376 tester :End of /MOTD command." + "\n")) + (erc-parse-server-response erc-server-process line))) + + (with-current-buffer (erc--open-target "#chan") + (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. " + "Blah " alice " (1) " bob " (2) blah.")) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage bob "Hi Alice" nil t)) + + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage alice "Hi Bob" nil t))) + + (funcall test) + + (when noninteractive + (kill-buffer "#chan") + (when (get-buffer " *Custom-Work*") + (kill-buffer " *Custom-Work*")) + (kill-buffer)))) + (advice-remove 'face-list #'erc-nicks-tests--face-list)) + +(ert-deftest erc-nicks-list-faces () + (erc-nicks-tests--create-session + (lambda () + (erc-nicks-list-faces) + (let ((table (buffer-local-value 'erc-nicks--face-table + (get-buffer "foonet"))) + calls) + (cl-letf (((symbol-function 'erc-nicks--list-faces-help-button-action) + (lambda (&rest r) (push r calls)))) + (with-current-buffer "*Faces*" + (set-window-buffer (selected-window) (current-buffer)) + (goto-char (point-min)) + + (ert-info ("Clicking on face link runs action function") + (forward-button 1) + (should (looking-at "erc-nicks-alice1-face")) + (push-button) + (should (eq (car (car calls)) (gethash "alice1" table)))) + + (ert-info ("Clicking on sample text describes face") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (push-button) + (should (search-forward-regexp + (rx "Foreground: #" (group (+ xdigit)) eol))) + (forward-button 2) ; skip Inherit:... + (push-button)) + + (ert-info ("First entry's sample is rendered correctly") + (let ((hex (match-string 1))) + (should (looking-at (concat "#" hex))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls))) + + (ert-info ("Clicking on another entry's face link runs action") + (forward-button 1) + (should (looking-at "erc-nicks-bob1-face")) + (push-button) + (should (eq (car (car calls)) (gethash "bob1" table)))) + + (ert-info ("Second entry's sample is rendered correctly") + (forward-button 1) + (should (looking-at (rx "#" (+ xdigit)))) + (goto-char (button-end (point))) + (should (looking-back " foonet")) + (should (eq (button-get (1- (point)) 'face) (car (pop calls)))) + (should-not calls)) + + (when noninteractive + (kill-buffer)))))) + "Alice1" "Bob1")) + +(ert-deftest erc-nicks-customize-face () + (unless (>= emacs-major-version 28) + (ert-skip "Face link required in customize-face buffers")) + (erc-nicks-tests--create-session + (lambda () + (erc-nicks-list-faces) + (with-current-buffer "*Faces*" + (set-window-buffer (selected-window) (current-buffer)) + (goto-char (point-min)) + + (ert-info ("Clicking on face link runs action function") + (forward-button 1) + (should (looking-at "erc-nicks-alice2")) + (ert-simulate-keys "y\r" + (call-interactively #'push-button nil))) + + (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*" + (should (search-forward "Erc Nicks Alice2@Foonet Face" nil t)) + (widget-button-press (1- (point)))) + + (with-current-buffer "*New face erc-nicks-alice2@foonet-face*" + (goto-char (point-min)) + (should (search-forward "(use-package erc-nicks" nil t)) + (should (search-forward ":foreground \"#" nil t)) + (when noninteractive + (kill-buffer))) + + (with-current-buffer "*Customize Face: Erc Nicks Alice2@Foonet Face*" + (should (search-forward "Foreground: #" nil t)) + (when noninteractive + (kill-buffer))) + + (when noninteractive + (kill-buffer)))) + "Alice2" "Bob2")) + +(ert-deftest erc-nicks--gen-key-from-format-spec () + (let ((erc-network 'OFTC) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@OFTC00000000"))) + + (let ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%-012n") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat0"))) + + (let* ((erc-network 'Libera.Chat) + (erc-nicks-key-suffix-format "@%n/%m") + (erc-server-current-nick "tester")) + (should (equal (erc-nicks--gen-key-from-format-spec "bob") + "bob@Libera.Chat/tester")))) + +(ert-deftest erc-nicks--create-culled-pool () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + ;; + (erc-nicks--colors-rejects '(t))) + + ;; Reject + (should-not (erc-nicks--create-culled-pool '(erc-nicks-invert) '("white"))) + (should (equal (pop erc-nicks--colors-rejects) "white")) ; too close + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) '("black"))) + (should (equal (pop erc-nicks--colors-rejects) "black")) ; too far + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("white"))) + (should (equal (pop erc-nicks--colors-rejects) "white")) ; lacks color + (should-not + (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) '("red"))) + (should (equal (pop erc-nicks--colors-rejects) "red")) ; too much color + + ;; Safe + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-invert) + '("black")) + '("black"))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-add-contrast) + '("black")) + '("black"))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-cap-contrast) + '("white")) + '("white"))) + (let ((erc-nicks-saturation-range '(0.5 . 1.0))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("green")) + '("green")))) + (let ((erc-nicks-saturation-range '(0.0 . 0.5))) + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("gray")) + '("gray")))) + (unless noninteractive + (should (equal (erc-nicks--create-culled-pool '(erc-nicks-ensaturate) + '("firebrick")) + '("firebrick")))) + (should (equal erc-nicks--colors-rejects '(t))))) + +(ert-deftest erc-nicks--create-coerced-pool () + (let ((erc-nicks--bg-luminance 1.0) + (erc-nicks--bg-mode-value 'light) + (erc-nicks--fg-rgb '(0.0 0.0 0.0)) + (erc-nicks-bg-color "white") + (num-colors (length (defined-colors))) + ;; + (erc-nicks--colors-rejects '(t))) + + ;; Deduplication. + (when (= 8 num-colors) + (should (equal (erc-nicks--create-coerced-pool '(erc-nicks-ensaturate) + '("#ee0000" "#f80000")) + '("red"))) + (should (equal (pop erc-nicks--colors-rejects) "#f80000"))) + + ;; "Coercion" in Xterm. + (unless noninteractive + (when (= 665 num-colors) + (pcase-dolist (`(,adjustments ,candidates ,result) + '(((erc-nicks-invert) ("white") ("gray10")) + ((erc-nicks-cap-contrast) ("black") ("gray20")) + ((erc-nicks-ensaturate) ("white") ("lavenderblush2")) + ((erc-nicks-ensaturate) ("red") ("firebrick")))) + (should (equal (erc-nicks--create-coerced-pool adjustments + candidates) + result))))) + + (should (equal erc-nicks--colors-rejects '(t))))) + +;;; erc-nicks-tests.el ends here diff --git a/test/lisp/erc/erc-scenarios-auth-source.el b/test/lisp/erc/erc-scenarios-auth-source.el index 641b881666e..7eaf90e1e41 100644 --- a/test/lisp/erc/erc-scenarios-auth-source.el +++ b/test/lisp/erc/erc-scenarios-auth-source.el @@ -56,7 +56,7 @@ (should (string= (buffer-name) (if id (symbol-name id) (format "127.0.0.1:%d" port)))) - (erc-d-t-wait-for 5 (eq erc-network 'FooNet)))))) + (erc-d-t-wait-for 10 (eq erc-network 'FooNet)))))) (ert-deftest erc-scenarios-base-auth-source-server--dialed () :tags '(:expensive-test) diff --git a/test/lisp/erc/erc-scenarios-base-association.el b/test/lisp/erc/erc-scenarios-base-association.el index a40a4cb7550..10abe14c43b 100644 --- a/test/lisp/erc/erc-scenarios-base-association.el +++ b/test/lisp/erc/erc-scenarios-base-association.el @@ -78,7 +78,7 @@ (with-current-buffer "#chan@foonet" (funcall expect 3 "bob") (funcall expect 3 "was created on") - (funcall expect 3 "prosperous"))) + (funcall expect 10 "prosperous"))) (ert-info ("All #chan@barnet output consumed") (with-current-buffer "#chan@barnet" diff --git a/test/lisp/erc/erc-scenarios-base-attach.el b/test/lisp/erc/erc-scenarios-base-attach.el new file mode 100644 index 00000000000..29f5bd2ddd8 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-attach.el @@ -0,0 +1,191 @@ +;;; erc-scenarios-base-attach.el --- Reattach scenarios -*- 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: + +;; See also: `erc-scenarios-base-channel-buffer-revival'. +;; +;; ERC 5.5 silently dropped support for the ancient option +;; `erc-query-on-unjoined-chan-privmsg' because the tangled logic in +;; and around the function `erc-auto-query' made it difficult to +;; divine its purpose. +;; +;; Based on the name, it was thought this option likely involved +;; controlling the creation of query buffers for unsolicited messages +;; from users with whom you don't share a common channel. However, +;; additional spelunking has recently revealed that it was instead +;; meant to service a feature offered by most bouncers that sends +;; PRIVMSGs directed at a channel you're no longer in and that you +;; haven't received a(nother) JOIN message for. IOW, this is meant to +;; support the following sequence of events: +;; +;; 1. /detach #chan +;; 2. kill buffer #chan or reconnect in new Emacs session +;; 3. /playbuffer #chan +;; +;; Note that the above slash commands are bouncer-specific aliases. +;; +;; Interested users can find more info by looking at this change set +;; from the ancient CVS repo: +;; +;; Author: Mario Lang <mlang@delysid.org> +;; AuthorDate: Mon Nov 26 18:33:19 2001 +0000 +;; +;; * new function erc-BBDB-NICK to handle nickname annotation ... +;; * Applied antifuchs/mhp patches, the latest on erc-help, unmodified +;; * New variable: erc-reuse-buffers default to t. +;; * Modified erc-generate-new-buffer-name to use it. it checks if +;; server and port are the same, then one can assume that's the same +;; channel/query target again. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--enabled () + :tags '(:expensive-test) + (should erc-ensure-target-buffer-on-privmsg) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/channel-buffer-revival") + (dumb-server (erc-d-run "localhost" t 'reattach)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "tester@vanilla/foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (erc-cmd-MSG "*status playbuffer #chan")) + + (ert-info ("Playback appears in buffer #chan") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "Buffer Playback...") + (funcall expect 10 "Was I a child") + (funcall expect 10 "Thou counterfeit'st most lively") + (funcall expect 10 "Playback Complete"))) + + (with-current-buffer "foonet" + (erc-cmd-MSG "*status attach #chan")) + + (ert-info ("Live output from #chan after more playback") + (with-current-buffer "#chan" + (funcall expect 10 "Buffer Playback...") + (funcall expect 10 "With what it loathes") + (funcall expect 10 "Not by his breath") + (funcall expect 10 "Playback Complete") + (funcall expect 10 "Ay, and the captain") + (erc-scenarios-common-say "bob: hi") + (funcall expect 10 "Pawn me to this"))))) + +(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--disabled () + :tags '(:expensive-test) + (should erc-ensure-target-buffer-on-privmsg) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/channel-buffer-revival") + (dumb-server (erc-d-run "localhost" t 'reattach)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (erc-ensure-target-buffer-on-privmsg nil) ; off + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "tester@vanilla/foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (erc-cmd-MSG "*status playbuffer #chan") + (ert-info ("Playback appears in buffer server buffer") + (erc-d-t-ensure-for -1 (not (get-buffer "#chan"))) + (funcall expect 10 "Buffer Playback...") + (funcall expect 10 "Was I a child") + (funcall expect 10 "Thou counterfeit'st most lively") + (funcall expect 10 "Playback Complete")) + (should-not (get-buffer "#chan")) + (erc-cmd-MSG "*status attach #chan")) + + (ert-info ("Buffer #chan joined") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "Buffer Playback...") + (funcall expect 10 "With what it loathes") + (funcall expect 10 "Not by his breath") + (funcall expect 10 "Playback Complete") + (funcall expect 10 "Ay, and the captain") + (erc-scenarios-common-say "bob: hi") + (funcall expect 10 "Pawn me to this"))))) + + +;; We omit the `enabled' case for queries because it's the default for +;; this option and already covered many times over by other tests in +;; this directory. + +(ert-deftest erc-scenarios-base-attach--ensure-target-buffer--disabled-query () + :tags '(:expensive-test) + (should erc-ensure-target-buffer-on-privmsg) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/queries") + (dumb-server (erc-d-run "localhost" t 'non-erc)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter)) + (erc-ensure-target-buffer-on-privmsg nil) + (erc-server-flood-penalty 0.1)) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester") + (erc-scenarios-common-assert-initial-buf-name nil port) + (erc-d-t-wait-for 5 (eq erc-network 'foonet)) + (funcall expect 15 "debug mode"))) + + (ert-info ("User dummy's greeting appears in server buffer") + (erc-d-t-wait-for -1 (get-buffer "dummy")) + (with-current-buffer "foonet" + (funcall expect 5 "hi") + + (ert-info ("Option being nil doesn't queries we create") + (with-current-buffer (erc-cmd-QUERY "nitwit") + (should (equal (buffer-name) "nitwit")) + (erc-scenarios-common-say "hola") + (funcall expect 5 "ciao"))) + + (erc-scenarios-common-say "howdy") + (funcall expect 5 "no target") + (erc-cmd-MSG "dummy howdy") + (funcall expect 5 "bye") + (erc-cmd-QUIT ""))))) + +;;; erc-scenarios-base-attach.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-auto-recon.el b/test/lisp/erc/erc-scenarios-base-auto-recon.el new file mode 100644 index 00000000000..40e2c23408b --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-auto-recon.el @@ -0,0 +1,141 @@ +;;; erc-scenarios-base-auto-recon.el --- auto-recon scenarios -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(defun erc-scenarios-base-auto-recon--get-unused-port () + (let ((server (make-network-process :name "*erc-scenarios-base-auto-recon*" + :host "localhost" + :service t + :server t))) + (delete-process server) + (process-contact server :service))) + +;; This demos one possible flavor of intermittent service. +;; It may end up needing to be marked :unstable. + +(ert-deftest erc-scenarios-base-auto-recon-unavailable () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (port (erc-scenarios-base-auto-recon--get-unused-port)) + (erc--server-reconnect-timeout-scale-function (lambda (_) 1)) + (erc-server-auto-reconnect t) + (erc-server-reconnect-function #'erc-server-delayed-check-reconnect) + (expect (erc-d-t-make-expecter)) + (erc-scenarios-common-dialog "base/reconnect") + (dumb-server nil)) + + (ert-info ("Dialing fails: nobody home") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (erc-d-t-wait-for 10 (not (erc-server-process-alive))) + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (funcall expect 10 "Opening connection") + (funcall expect 10 "failed") + + (ert-info ("Reconnect function freezes attempts at 1") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home")))) + + (ert-info ("Service appears") + (setq dumb-server (erc-d-run "localhost" port + 'just-eof 'unexpected-disconnect)) + (with-current-buffer (format "127.0.0.1:%d" port) + (funcall expect 10 "server is in debug mode") + (should (equal (buffer-name) "FooNet")))) + + (ert-info ("Service interrupted, reconnect starts again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")))) + + (ert-info ("Service restored") + (delete-process dumb-server) + (setq dumb-server (erc-d-run "localhost" port + 'just-eof 'unexpected-disconnect)) + (with-current-buffer "FooNet" + (funcall expect 10 "server is in debug mode"))) + + (ert-info ("Service interrupted a third time, reconnect starts yet again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (erc-cmd-RECONNECT "cancel") + (funcall expect 10 "canceled"))))) + +;; In this test, a listener accepts but doesn't respond to any messages. + +(ert-deftest erc-scenarios-base-auto-recon-no-proto () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "base/reconnect") + (erc-d-auto-pong nil) + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc--server-reconnect-timeout-scale-function (lambda (_) 1)) + (erc--server-reconnect-timeout-check 0.5) + (erc-server-auto-reconnect t) + (erc-server-reconnect-function #'erc-server-delayed-check-reconnect) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Session succeeds but cut short") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "server is in debug mode") + (should (equal (buffer-name) "FooNet")) + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (delete-process dumb-server) + (funcall expect 10 "failed") + + (ert-info ("Reconnect function freezes attempts at 1") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home") + (funcall expect 10 "timed out while dialing") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home")))) + + (ert-info ("Service restored") + (setq dumb-server (erc-d-run "localhost" port + 'just-ping + 'ping-pong + 'unexpected-disconnect)) + (with-current-buffer "FooNet" + (funcall expect 30 "server is in debug mode"))) + + (ert-info ("Service interrupted again, reconnect starts again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (erc-cmd-RECONNECT "cancel") + (funcall expect 10 "canceled"))))) + +;;; erc-scenarios-base-auto-recon.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-buffer-display.el b/test/lisp/erc/erc-scenarios-base-buffer-display.el new file mode 100644 index 00000000000..889f274b8b1 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-buffer-display.el @@ -0,0 +1,249 @@ +;;; erc-scenarios-base-buffer-display.el --- Buffer display scenarios -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(eval-when-compile (require 'erc-join)) + +;; These first couple `erc-auto-reconnect-display' tests used to live +;; in erc-scenarios-base-reconnect but have since been renamed. Note +;; that these are somewhat difficult to reason about because the user +;; joins a second channel after reconnecting, and the first is +;; controlled by `autojoin'. + +(defun erc-scenarios-base-buffer-display--reconnect-common + (assert-server assert-chan assert-rest) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (dumb-server (erc-d-run "localhost" t 'options 'options-again)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter)) + (erc-server-flood-penalty 0.1) + (erc-server-auto-reconnect t) + erc-autojoin-channels-alist) + + (should (memq 'autojoin erc-modules)) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "changeme" + :full-name "tester") + (funcall assert-server expect) + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (funcall expect 10 "debug mode"))) + + (ert-info ("Wait for some output in channels") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall assert-chan expect) + (funcall expect 10 "welcome") + (funcall expect 10 "welcome"))) + + (ert-info ("Server buffer shows connection failed") + (with-current-buffer "FooNet" + (funcall expect 10 "Connection failed! Re-establishing"))) + + (should (equal erc-autojoin-channels-alist '((FooNet "#chan")))) + (delete-other-windows) + (pop-to-buffer-same-window "*Messages*") + + (ert-info ("Wait for auto reconnect") + (with-current-buffer "FooNet" (funcall expect 10 "still in debug mode"))) + + (ert-info ("Lone window still shows messages buffer") + (should (eq (window-buffer) (messages-buffer))) + (should (frame-root-window-p (selected-window)))) + + (funcall assert-rest expect) + + (ert-info ("Wait for activity to recommence in both channels") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "forest of Arden")) + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) + (funcall expect 10 "her elves come here anon"))))) + +;; Interactively issuing a slash command resets the auto-reconnect +;; count, making ERC ignore the option `erc-auto-reconnect-display' +;; when next displaying a newly set up buffer. In the case of a +;; /JOIN, the option `erc-interactive-display' takes precedence. +(ert-deftest erc-scenarios-base-buffer-display--defwin-recbury-intbuf () + :tags '(:expensive-test) + (should (eq erc-buffer-display 'bury)) + (should (eq erc-interactive-display 'window)) + (should-not erc-auto-reconnect-display) + + (let ((erc-buffer-display 'window) ; defwin + (erc-interactive-display 'buffer) ; intbuf + (erc-auto-reconnect-display 'bury)) ; recbury + + (erc-scenarios-base-buffer-display--reconnect-common + + (lambda (_) + (ert-info ("New server buffer appears in a selected split") + (should (eq (window-buffer) (current-buffer))) + (should-not (frame-root-window-p (selected-window))))) + + (lambda (_) + (ert-info ("New channel buffer appears in other window") + (should (eq (window-buffer) (current-buffer))) ; selected + (should (equal (get-buffer "FooNet") (window-buffer (next-window)))))) + + (lambda (expect) + ;; If we /JOIN #spam now, we'll cancel the auto-reconnect + ;; timer, and "#chan" may well pop up in a split before we can + ;; verify that the lone window displays #spam (a race, IOW). + (ert-info ("Autojoined channel #chan buried on JOIN") + (with-current-buffer "#chan" + (funcall expect 10 "You have joined channel #chan")) + (should (frame-root-window-p (selected-window))) + (should (eq (window-buffer) (messages-buffer)))) + + (with-current-buffer "FooNet" (erc-scenarios-common-say "/JOIN #spam")) + + (ert-info ("A /JOIN ignores `erc-auto-reconnect-display'") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) + (should (eq (window-buffer) (get-buffer "#spam"))) + ;; Option `erc-interactive-display' being `buffer' means + ;; Emacs reuses the selected window (no split). + (should (frame-root-window-p (selected-window))))))))) + +(ert-deftest erc-scenarios-base-buffer-display--defwino-recbury-intbuf () + :tags '(:expensive-test) + (should (eq erc-buffer-display 'bury)) + (should (eq erc-interactive-display 'window)) + (should-not erc-auto-reconnect-display) + + (let ((erc-buffer-display 'window-noselect) ; defwino + (erc-auto-reconnect-display 'bury) + (erc-interactive-display 'buffer)) + (erc-scenarios-base-buffer-display--reconnect-common + + (lambda (_) + ;; Selected window shows some non-ERC buffer. New server + ;; buffer appears in another window (other side of split). + (should-not (frame-root-window-p (selected-window))) + (should-not (eq (window-buffer) (current-buffer))) + (with-current-buffer (window-buffer) + (should-not (derived-mode-p 'erc-mode))) + (should (eq (current-buffer) (window-buffer (next-window))))) + + (lambda (_) + (should-not (frame-root-window-p (selected-window))) + ;; Current split likely shows scratch. + (with-current-buffer (window-buffer) + (should-not (derived-mode-p 'erc-mode))) + (should (eq (current-buffer) (window-buffer (next-window))))) + + (lambda (_) + ;; A JOIN command sent from lisp code is "non-interactive" and + ;; doesn't reset the auto-reconnect count, so ERC treats the + ;; response as possibly server-initiated or otherwise the + ;; result of an autojoin and continues to favor + ;; `erc-auto-reconnect-display'. + (ert-info ("Join chan non-interactively and open a /QUERY") + (with-current-buffer "FooNet" + (erc-cmd-JOIN "#spam") ; "non-interactive" according to ERC + (erc-scenarios-common-say "/QUERY bob") ; resets count + (should (eq (window-buffer) (get-buffer "bob"))) + (should (frame-root-window-p (selected-window))))) + + ;; The /QUERY above resets the count, and `erc-buffer-display' + ;; again decides how #spam is displayed. + (ert-info ("Newly joined chan ignores `erc-auto-reconnect-display'") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) + (should (eq (window-buffer) (get-buffer "bob"))) + (should-not (frame-root-window-p (selected-window))) ; noselect + (should (eq (current-buffer) (window-buffer (next-window)))))))))) + +(ert-deftest erc-scenarios-base-buffer-display--count-reset-timeout () + :tags '(:expensive-test) + (should (eq erc-buffer-display 'bury)) + (should (eq erc-interactive-display 'window)) + (should (eq erc-auto-reconnect-display-timeout 10)) + (should-not erc-auto-reconnect-display) + + (let ((erc-buffer-display 'window-noselect) + (erc-auto-reconnect-display 'bury) + (erc-interactive-display 'buffer) + (erc-auto-reconnect-display-timeout 0.5)) + (erc-scenarios-base-buffer-display--reconnect-common + #'ignore #'ignore ; These two are identical to the previous test. + + (lambda (_) + (with-current-buffer "FooNet" + (erc-d-t-wait-for 1 erc--server-reconnect-display-timer)) + + ;; A non-interactive JOIN command doesn't signal that we're + ;; done auto-reconnecting. + (ert-info ("Join channel #spam non-interactively") + (with-current-buffer "FooNet" + (erc-d-t-wait-for 1 (null erc--server-reconnect-display-timer)) + (erc-cmd-JOIN "#spam"))) ; not processed as a /JOIN + + (ert-info ("Option `erc-auto-reconnect-display' ignored w/o timer") + (should (eq (window-buffer) (messages-buffer))) + (erc-d-t-wait-for 10 (get-buffer "#spam")) + ;; If `erc-auto-reconnect-display-timeout' were left alone, + ;; this would be (frame-root-window-p #<window 1 on scratch*>). + (should-not (frame-root-window-p (selected-window))) + (should (eq (get-buffer "#spam") (window-buffer (next-window))))))))) + +;; This shows that the option `erc-interactive-display' overrides +;; `erc-join-buffer' during cold opens and interactive /JOINs. + +(ert-deftest erc-scenarios-base-buffer-display--interactive-default () + :tags '(:expensive-test) + (should (eq erc-join-buffer 'bury)) + (should (eq erc-interactive-display 'window)) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "join/legacy") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (port (process-contact dumb-server :service)) + (url (format "tester:changeme@127.0.0.1:%d\r\r" port)) + (expect (erc-d-t-make-expecter)) + (erc-server-flood-penalty 0.1) + (erc-server-auto-reconnect t) + (erc-user-full-name "tester")) + + (ert-info ("Connect to foonet") + (with-current-buffer (let (inhibit-interaction) + (ert-simulate-keys url + (call-interactively #'erc))) + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + + (erc-d-t-wait-for 10 "Server buffer shown" + (eq (window-buffer) (current-buffer))) + (funcall expect 10 "debug mode") + (erc-scenarios-common-say "/JOIN #chan"))) + + (ert-info ("Wait for output in #chan") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 10 "welcome") + (erc-d-t-ensure-for 3 "Channel #chan shown" + (eq (window-buffer) (current-buffer))) + (funcall expect 10 "be prosperous"))))) + +;;; erc-scenarios-base-buffer-display.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-chan-modes.el b/test/lisp/erc/erc-scenarios-base-chan-modes.el new file mode 100644 index 00000000000..9c63d8aff8e --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-chan-modes.el @@ -0,0 +1,84 @@ +;;; erc-scenarios-base-chan-modes.el --- Channel mode scenarios -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +;; This asserts that a bug present in ERC 5.4+ is now absent. +;; Previously, ERC would attempt to parse a nullary channel mode as if +;; it were a status prefix update, which led to a wrong-type error. +;; This test does not address similar collisions with unary modes, +;; such as "MODE +q foo!*@*", but it should. +(ert-deftest erc-scenarios-base-chan-modes--plus-q () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/modes") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'chan-changed)) + (erc-modules (cons 'fill-wrap erc-modules)) + (erc-autojoin-channels-alist '((Libera.Chat "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to Libera.Chat") + (with-current-buffer (erc :server "127.0.0.1" + :port (process-contact dumb-server :service) + :nick "tester" + :full-name "tester") + (funcall expect 5 "changed mode"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (should-not erc-channel-key) + (should-not erc-channel-user-limit) + + (ert-info ("Receive notice that mode has changed") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t"))) + (erc-scenarios-common-say "ready before") + (funcall expect 10 "<Chad> before") + (funcall expect 10 " has changed mode for #chan to +Qu") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("Q" "n" "t" "u")))) + + (ert-info ("Key stored locally") + (erc-scenarios-common-say "ready key") + (funcall expect 10 "<Chad> doing key") + (funcall expect 10 " has changed mode for #chan to +k hunter2") + (should (equal erc-channel-key "hunter2"))) + + (ert-info ("Limit stored locally") + (erc-scenarios-common-say "ready limit") + (funcall expect 10 "<Chad> doing limit") + (funcall expect 10 " has changed mode for #chan to +l 3") + (erc-d-t-wait-for 10 (eql erc-channel-user-limit 3)) + (should (equal erc-channel-modes '("Q" "n" "t" "u")))) + + (ert-info ("Modes removed and local state deletion succeeds") + (erc-scenarios-common-say "ready drop") + (funcall expect 10 "<Chad> dropping") + (funcall expect 10 " has changed mode for #chan to -lu") + (funcall expect 10 " has changed mode for #chan to -Qk *") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t")))) + + (should-not erc-channel-key) + (should-not erc-channel-user-limit) + (funcall expect 10 "<Chad> after")))) + +;;; erc-scenarios-base-chan-modes.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-local-module-modes.el b/test/lisp/erc/erc-scenarios-base-local-module-modes.el new file mode 100644 index 00000000000..7b91e28dc83 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-local-module-modes.el @@ -0,0 +1,211 @@ +;;; erc-scenarios-base-local-module-modes.el --- More local-mod ERC tests -*- 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: + +;; A local module doubles as a minor mode whose mode variable and +;; associated local data can withstand service disruptions. +;; Unfortunately, the current implementation is too unwieldy to be +;; made public because it doesn't perform any of the boiler plate +;; needed to save and restore buffer-local and "network-local" copies +;; of user options. Ultimately, a user-friendly framework must fill +;; this void if third-party local modules are ever to become +;; practical. +;; +;; The following tests all use `sasl' because, as of ERC 5.5, it's the +;; only local module. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-sasl) + +;; After quitting a session for which `sasl' is enabled, you +;; disconnect and toggle `erc-sasl-mode' off. You then reconnect +;; using an alternate nickname. You again disconnect and reconnect, +;; this time immediately, and the mode stays disabled. Finally, you +;; once again disconnect, toggle the mode back on, and reconnect. You +;; are authenticated successfully, just like in the initial session. +;; +;; This is meant to show that a user's local mode settings persist +;; between sessions. It also happens to show (in round four, below) +;; that a server renicking a user on 001 after a 903 is handled just +;; like a user-initiated renick, although this is not the main thrust. + +(ert-deftest erc-scenarios-base-local-module-modes--reconnect () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/local-modules") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'first 'second 'third 'fourth)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (expect (erc-d-t-make-expecter)) + (server-buffer-name (format "127.0.0.1:%d" port))) + + (ert-info ("Round one, initial authentication succeeds as expected") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) server-buffer-name)) + (funcall expect 10 "You are now logged in as tester")) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (funcall expect 10 "This server is in debug mode") + (erc-cmd-JOIN "#chan") + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round two, nick rejected, alternate granted") + (with-current-buffer "foonet" + + (ert-info ("Toggle mode off, reconnect") + (erc-sasl-mode -1) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester`") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Some enigma, some riddle")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round three, send alternate nick initially") + (with-current-buffer "foonet" + + (ert-info ("Keep mode off, reconnect") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester`") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Let our reciprocal vows be remembered.")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round four, authenticated successfully again") + (with-current-buffer "foonet" + + (ert-info ("Toggle mode on, reconnect") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-sasl-mode +1) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Well met; good morrow, Titus and Hortensius.")) + + (erc-cmd-QUIT ""))))) + +;; In contrast to the mode-persistence test above, this one +;; demonstrates that a user reinvoking an entry point declares their +;; intention to reset local-module state for the server buffer. +;; Whether a local-module's state variable is also reset in target +;; buffers up to the module. That is, by default, they're left alone. + +(ert-deftest erc-scenarios-base-local-module-modes--entrypoint () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/local-modules") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'first 'first)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (expect (erc-d-t-make-expecter)) + (server-buffer-name (format "127.0.0.1:%d" port))) + + (ert-info ("Round one, initial authentication succeeds as expected") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) server-buffer-name)) + (funcall expect 10 "You are now logged in as tester")) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (funcall expect 10 "This server is in debug mode") + (erc-cmd-JOIN "#chan") + + (ert-info ("Toggle local-module off in target buffer") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must") + (erc-sasl-mode -1))) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished") + + (ert-info ("Toggle mode off") + (erc-sasl-mode -1) + (should (local-variable-p 'erc-sasl-mode))))) + + (ert-info ("Reconnecting via entry point discards `erc-sasl-mode' value.") + ;; If you were to /RECONNECT here, no PASS changeme would be + ;; sent instead of CAP SASL, resulting in a failure. + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) server-buffer-name)) + (funcall expect 10 "You are now logged in as tester") + + (erc-d-t-wait-for 10 (equal (buffer-name) "foonet")) + (funcall expect 10 "User modes for tester") + (should erc-sasl-mode)) ; obviously + + ;; No other foonet buffer exists, e.g., foonet<2> + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + + (ert-info ("Target buffer retains local-module state") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-cmd-QUIT "")))))) + +;;; erc-scenarios-base-local-module-modes.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-local-modules.el b/test/lisp/erc/erc-scenarios-base-local-modules.el index 1318207a3bf..d6dbd87c8cc 100644 --- a/test/lisp/erc/erc-scenarios-base-local-modules.el +++ b/test/lisp/erc/erc-scenarios-base-local-modules.el @@ -82,105 +82,6 @@ (erc-cmd-QUIT "") (funcall expect 10 "finished"))))) -;; After quitting a session for which `sasl' is enabled, you -;; disconnect and toggle `erc-sasl-mode' off. You then reconnect -;; using an alternate nickname. You again disconnect and reconnect, -;; this time immediately, and the mode stays disabled. Finally, you -;; once again disconnect, toggle the mode back on, and reconnect. You -;; are authenticated successfully, just like in the initial session. -;; -;; This is meant to show that a user's local mode settings persist -;; between sessions. It also happens to show (in round four, below) -;; that a server renicking a user on 001 after a 903 is handled just -;; like a user-initiated renick, although this is not the main thrust. - -(ert-deftest erc-scenarios-base-local-modules--mode-persistence () - :tags '(:expensive-test) - (erc-scenarios-common-with-cleanup - ((erc-scenarios-common-dialog "base/local-modules") - (erc-server-flood-penalty 0.1) - (dumb-server (erc-d-run "localhost" t 'first 'second 'third 'fourth)) - (port (process-contact dumb-server :service)) - (erc-modules (cons 'sasl erc-modules)) - (expect (erc-d-t-make-expecter)) - (server-buffer-name (format "127.0.0.1:%d" port))) - - (ert-info ("Round one, initial authentication succeeds as expected") - (with-current-buffer (erc :server "127.0.0.1" - :port port - :nick "tester" - :user "tester" - :password "changeme" - :full-name "tester") - (should (string= (buffer-name) server-buffer-name)) - (funcall expect 10 "You are now logged in as tester")) - - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) - (funcall expect 10 "This server is in debug mode") - (erc-cmd-JOIN "#chan") - - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) - (funcall expect 20 "She is Lavinia, therefore must")) - - (erc-cmd-QUIT "") - (funcall expect 10 "finished"))) - - (ert-info ("Round two, nick rejected, alternate granted") - (with-current-buffer "foonet" - - (ert-info ("Toggle mode off, reconnect") - (erc-sasl-mode -1) - (erc-cmd-RECONNECT)) - - (funcall expect 10 "User modes for tester`") - (should-not (cdr (erc-scenarios-common-buflist "foonet"))) - (should (equal (buffer-name) "foonet")) - (should-not (cdr (erc-scenarios-common-buflist "#chan"))) - - (with-current-buffer "#chan" - (funcall expect 10 "Some enigma, some riddle")) - - (erc-cmd-QUIT "") - (funcall expect 10 "finished"))) - - (ert-info ("Round three, send alternate nick initially") - (with-current-buffer "foonet" - - (ert-info ("Keep mode off, reconnect") - (should-not erc-sasl-mode) - (should (local-variable-p 'erc-sasl-mode)) - (erc-cmd-RECONNECT)) - - (funcall expect 10 "User modes for tester`") - (should-not (cdr (erc-scenarios-common-buflist "foonet"))) - (should (equal (buffer-name) "foonet")) - (should-not (cdr (erc-scenarios-common-buflist "#chan"))) - - (with-current-buffer "#chan" - (funcall expect 10 "Let our reciprocal vows be remembered.")) - - (erc-cmd-QUIT "") - (funcall expect 10 "finished"))) - - (ert-info ("Round four, authenticated successfully again") - (with-current-buffer "foonet" - - (ert-info ("Toggle mode on, reconnect") - (should-not erc-sasl-mode) - (should (local-variable-p 'erc-sasl-mode)) - (erc-sasl-mode +1) - (erc-cmd-RECONNECT)) - - (funcall expect 10 "User modes for tester") - (should-not (cdr (erc-scenarios-common-buflist "foonet"))) - (should (equal (buffer-name) "foonet")) - (should-not (cdr (erc-scenarios-common-buflist "#chan"))) - - (with-current-buffer "#chan" - (funcall expect 10 "Well met; good morrow, Titus and Hortensius.")) - - (erc-cmd-QUIT ""))))) - ;; For local modules, the twin toggle commands `erc-FOO-enable' and ;; `erc-FOO-disable' affect all buffers of a connection, whereas ;; `erc-FOO-mode' continues to operate only on the current buffer. diff --git a/test/lisp/erc/erc-scenarios-base-misc-regressions.el b/test/lisp/erc/erc-scenarios-base-misc-regressions.el index 16b2cb355d1..85b2c03b6a4 100644 --- a/test/lisp/erc/erc-scenarios-base-misc-regressions.el +++ b/test/lisp/erc/erc-scenarios-base-misc-regressions.el @@ -77,7 +77,7 @@ Originally from scenario rebuffed/gapless as explained in Bug#48598: (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar")) (funcall expect 10 "was created on") - (funcall expect 2 "his second fit")) + (funcall expect 10 "his second fit")) (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo")) (funcall expect 10 "was created on") @@ -108,7 +108,7 @@ Originally from scenario rebuffed/gapless as explained in Bug#48598: (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) (ert-info ("Server buffer is unique and temp name is absent") - (erc-d-t-wait-for 1 (get-buffer "FooNet")) + (erc-d-t-wait-for 10 (get-buffer "FooNet")) (should-not (erc-scenarios-common-buflist "127.0.0.1")) (with-current-buffer erc-server-buffer-foo (erc-cmd-JOIN "#chan"))) diff --git a/test/lisp/erc/erc-scenarios-base-reconnect.el b/test/lisp/erc/erc-scenarios-base-reconnect.el index 5b4dc549042..163521f4a7b 100644 --- a/test/lisp/erc/erc-scenarios-base-reconnect.el +++ b/test/lisp/erc/erc-scenarios-base-reconnect.el @@ -65,95 +65,6 @@ (should (equal (list (get-buffer (format "127.0.0.1:%d" port))) (erc-scenarios-common-buflist "127.0.0.1")))))) -(defun erc-scenarios-common--base-reconnect-options (test) - (erc-scenarios-common-with-cleanup - ((erc-scenarios-common-dialog "base/reconnect") - (dumb-server (erc-d-run "localhost" t 'options 'options-again)) - (port (process-contact dumb-server :service)) - (expect (erc-d-t-make-expecter)) - (erc-server-flood-penalty 0.1) - (erc-server-auto-reconnect t) - erc-autojoin-channels-alist - erc-server-buffer) - - (should (memq 'autojoin erc-modules)) - - (ert-info ("Connect to foonet") - (setq erc-server-buffer (erc :server "127.0.0.1" - :port port - :nick "tester" - :password "changeme" - :full-name "tester")) - (with-current-buffer erc-server-buffer - (should (string= (buffer-name) (format "127.0.0.1:%d" port))) - (funcall expect 10 "debug mode"))) - - (ert-info ("Wait for some output in channels") - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) - (funcall expect 10 "welcome"))) - - (ert-info ("Server buffer shows connection failed") - (with-current-buffer erc-server-buffer - (funcall expect 10 "Connection failed! Re-establishing"))) - - (should (equal erc-autojoin-channels-alist '((FooNet "#chan")))) - - (funcall test) - - ;; A manual /JOIN command tells ERC we're done auto-reconnecting - (with-current-buffer "FooNet" (erc-cmd-JOIN "#spam")) - - (erc-d-t-ensure-for 1 "Newly joined chan ignores `erc-reconnect-display'" - (not (eq (window-buffer) (get-buffer "#spam")))) - - (ert-info ("Wait for auto reconnect") - (with-current-buffer erc-server-buffer - (funcall expect 10 "still in debug mode"))) - - (ert-info ("Wait for activity to recommence in channels") - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) - (funcall expect 10 "forest of Arden")) - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#spam")) - (funcall expect 10 "her elves come here anon"))))) - -(ert-deftest erc-scenarios-base-reconnect-options--buffer () - :tags '(:expensive-test) - (should (eq erc-join-buffer 'bury)) - (should-not erc-reconnect-display) - - ;; FooNet (the server buffer) is not switched to because it's - ;; already current (but not shown) when `erc-open' is called. See - ;; related conditional guard towards the end of that function. - - (let ((erc-reconnect-display 'buffer)) - (erc-scenarios-common--base-reconnect-options - (lambda () - (pop-to-buffer-same-window "*Messages*") - - (erc-d-t-ensure-for 1 "Server buffer not shown" - (not (eq (window-buffer) (get-buffer "FooNet")))) - - (erc-d-t-wait-for 5 "Channel #chan shown when autojoined" - (eq (window-buffer) (get-buffer "#chan"))))))) - -(ert-deftest erc-scenarios-base-reconnect-options--default () - :tags '(:expensive-test) - (should (eq erc-join-buffer 'bury)) - (should-not erc-reconnect-display) - - (erc-scenarios-common--base-reconnect-options - - (lambda () - (pop-to-buffer-same-window "*Messages*") - - (erc-d-t-ensure-for 1 "Server buffer not shown" - (not (eq (window-buffer) (get-buffer "FooNet")))) - - (erc-d-t-ensure-for 3 "Channel #chan not shown" - (not (eq (window-buffer) (get-buffer "#chan")))) - - (eq (window-buffer) (messages-buffer))))) - ;; Upon reconnecting, playback for channel and target buffers is ;; routed correctly. Autojoin is irrelevant here, but for the ;; skeptical, see `erc-scenarios-common--join-network-id', which @@ -260,7 +171,7 @@ (funcall expect 2 "Canceled") (funcall expect 3 "Opening connection") (funcall expect 2 "Password incorrect") - (funcall expect 2 "Connection failed!") + (funcall expect 10 "Connection failed!") (funcall expect 2 "Re-establishing connection")) (ert-info ("Explicitly cancel timer") (erc-cmd-RECONNECT "cancel") diff --git a/test/lisp/erc/erc-scenarios-base-renick.el b/test/lisp/erc/erc-scenarios-base-renick.el index f1723200533..689f962812a 100644 --- a/test/lisp/erc/erc-scenarios-base-renick.el +++ b/test/lisp/erc/erc-scenarios-base-renick.el @@ -173,7 +173,7 @@ (with-current-buffer erc-server-buffer-foo (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) - (erc-d-t-wait-for 1 (get-buffer "foonet")) + (erc-d-t-wait-for 10 (get-buffer "foonet")) (ert-info ("Joined by bouncer to #foo, pal persent") (with-current-buffer (erc-d-t-wait-for 1 (get-buffer "#foo")) @@ -267,7 +267,7 @@ (ert-info ("Sync convo for rando@foonet") (with-current-buffer "rando@foonet" - (funcall expect 1 "u are dumb") + (funcall expect 10 "u are dumb") (erc-scenarios-common-say "not so"))) (ert-info ("Sync convo for rando@barnet") @@ -275,8 +275,8 @@ (funcall expect 3 "I never saw her before") (erc-scenarios-common-say "You aren't with Wage?"))) - (erc-d-t-wait-for 3 (get-buffer "frenemy@foonet")) - (erc-d-t-wait-for 3 (get-buffer "frenemy@barnet")) + (erc-d-t-wait-for 10 (get-buffer "frenemy@foonet")) + (erc-d-t-wait-for 10 (get-buffer "frenemy@barnet")) (should-not (get-buffer "rando@foonet")) (should-not (get-buffer "rando@barnet")) diff --git a/test/lisp/erc/erc-scenarios-base-reuse-buffers.el b/test/lisp/erc/erc-scenarios-base-reuse-buffers.el index 71027a0c138..af483bb1a52 100644 --- a/test/lisp/erc/erc-scenarios-base-reuse-buffers.el +++ b/test/lisp/erc/erc-scenarios-base-reuse-buffers.el @@ -124,6 +124,7 @@ Adapted from scenario clash-of-chans/uniquify described in Bug#48598: (erc-d-t-search-for 1 "shake my sword") (erc-cmd-PART "#chan") (funcall expect 3 "You have left channel #chan") + (should-not (erc-get-channel-user (erc-current-nick))) (erc-cmd-JOIN "#chan"))) (ert-info ("Part #chan@barnet") @@ -139,6 +140,7 @@ Adapted from scenario clash-of-chans/uniquify described in Bug#48598: (get-buffer "#chan/127.0.0.1<3>")) (ert-info ("Activity continues in new, <n>-suffixed #chan@foonet buffer") + ;; The first /JOIN did not cause the same buffer to be reused. (with-current-buffer "#chan/127.0.0.1" (should-not (erc-get-channel-user (erc-current-nick)))) (with-current-buffer "#chan/127.0.0.1<3>" diff --git a/test/lisp/erc/erc-scenarios-base-send-message.el b/test/lisp/erc/erc-scenarios-base-send-message.el new file mode 100644 index 00000000000..bf9e0f5ae3a --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-send-message.el @@ -0,0 +1,126 @@ +;;; erc-scenarios-base-send-message.el --- `send-message' scenarios -*- lexical-binding: t -*- + +;; Copyright (C) 2022-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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +;; So-called "noncommands" are those that massage input submitted at +;; the prompt and send it on behalf of the user. + +(ert-deftest erc-scenarios-base-send-message--noncommands () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/send-message") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'noncommands)) + (erc-modules (cons 'fill-wrap erc-modules)) + (erc-autojoin-channels-alist '((foonet "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port (process-contact dumb-server :service) + :nick "tester" + :full-name "tester") + (funcall expect 5 "debug mode"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (ert-info ("Send CTCP ACTION") + (funcall expect 10 "<bob> alice: For hands, to do Rome") + (erc-scenarios-common-say "/me sad") + (funcall expect 10 "* tester sad")) + + (ert-info ("Send literal command") + (funcall expect 10 "<alice> bob: Spotted, detested") + (erc-scenarios-common-say "/say /me sad") + (funcall expect 10 "<tester> /me sad")) + + (ert-info ("\"Nested\" `noncommands'") + + (ert-info ("Send version via /SV") + (funcall expect 10 "<bob> Marcus, my brother!") + (erc-scenarios-common-say "/sv") + (funcall expect 10 "<tester> I'm using ERC")) + + (ert-info ("Send module list via /SM") + (funcall expect 10 "<bob> alice: You still wrangle") + (erc-scenarios-common-say "/sm") + (funcall expect 10 "<tester> I'm using the following modules: ") + (funcall expect 10 "<alice> No, not till Thursday;")))))) + + +;; This asserts that the `command-indicator' module only inserts +;; prompt-like prefixes for normal slash commands, like /JOIN. + +(ert-deftest erc-scenarios-base-send-message--command-indicator () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/send-message") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'noncommands)) + (erc-modules `(command-indicator fill-wrap ,@erc-modules)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port (process-contact dumb-server :service) + :nick "tester" + :full-name "tester") + (funcall expect 5 "debug mode") + (erc-scenarios-common-say "/join #chan") + (funcall expect 10 "ERC> /join #chan"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (ert-info ("Prompt absent for CTCP ACTION") + (funcall expect 10 "<bob> alice: For hands, to do Rome") + (erc-scenarios-common-say "/me sad") + (funcall expect -0.1 "ERC> /me sad") + (funcall expect 10 "* tester sad")) + + (ert-info ("Prompt absent for literal command") + (funcall expect 10 "<alice> bob: Spotted, detested") + (erc-scenarios-common-say "/say /me sad") + (funcall expect -0.1 "ERC> /say /me sad") + (funcall expect 10 "<tester> /me sad")) + + (ert-info ("Prompt absent for /SV") + (funcall expect 10 "<bob> Marcus, my brother!") + (erc-scenarios-common-say "/sv") + (funcall expect -0.1 "ERC> /sv") + (funcall expect 10 "<tester> I'm using ERC")) + + (ert-info ("Prompt absent module list via /SM") + (funcall expect 10 "<bob> alice: You still wrangle") + (erc-scenarios-common-say "/sm") + (funcall expect -0.1 "ERC> /sm") + (funcall expect 10 "<tester> I'm using the following modules: ") + (funcall expect 10 "<alice> No, not till Thursday;")) + + (ert-info ("Prompt present for /QUIT in issuing buffer") + (erc-scenarios-common-say "/quit") + (funcall expect 10 "ERC> /quit")) + + (with-current-buffer "foonet" + (funcall expect 10 "ERC finished"))))) + +;;; erc-scenarios-base-send-message.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-split-line.el b/test/lisp/erc/erc-scenarios-base-split-line.el new file mode 100644 index 00000000000..f6d888c1f28 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-split-line.el @@ -0,0 +1,202 @@ +;;; erc-scenarios-base-split-line.el --- ERC line splitting -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-base-split-line--koi8-r () + :tags '(:expensive-test) + (should (equal erc-split-line-length 440)) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/flood") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'koi8-r)) + (erc-encoding-coding-alist '(("#koi8" . cyrillic-koi8))) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "debug mode") + (erc-cmd-JOIN "#koi8"))) + + (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#koi8")) + (funcall expect 10 "короче теперь") + (ert-info ("Message well within `erc-split-line-length'") + (erc-scenarios-common-say + (concat + "короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно")) + (funcall expect 1 "<tester>") + (funcall expect -0.1 "<tester>")) + + (ert-info ("Message over `erc-split-line-length'") + (erc-scenarios-common-say + (concat + "короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " будет разрыв строки непонятно где")) + (funcall expect 1 "<tester>") + (funcall expect 1 "<tester> разрыв"))) + + (with-current-buffer "foonet" + (erc-cmd-QUIT "") + (funcall expect 10 "finished")))) + +(ert-deftest erc-scenarios-base-split-line--ascii () + :tags '(:expensive-test) + (should (equal erc-split-line-length 440)) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/flood") + (msg-432 (string-join (make-list 18 "twenty-three characters") " ")) + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'ascii)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "debug mode") + (erc-cmd-JOIN "#ascii"))) + + (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#ascii")) + (ert-info ("Message with spaces fits exactly") + (funcall expect 10 "Welcome") + (should (= (length (concat msg-432 " 12345678")) 440)) + (erc-scenarios-common-say (concat msg-432 " 12345678")) + (funcall expect 1 "<tester>") + ;; Sent in a single go, hence no second <speaker>. + (funcall expect -0.1 "<tester>") + (funcall expect 0.1 "12345678")) + + (ert-info ("Message with spaces too long.") + (erc-scenarios-common-say (concat msg-432 " 123456789")) + (funcall expect 1 "<tester>") + ;; Sent in two passes, split at last word. + (funcall expect 0.1 "<tester> 123456789")) + + (ert-info ("Message sans spaces fits exactly") + (erc-scenarios-common-say (make-string 440 ?x)) + (funcall expect 1 "<tester>") + ;; Sent in a single go, hence no second <speaker>. + (funcall expect -0.1 "<tester>")) + + (ert-info ("Message sans spaces too long.") + (erc-scenarios-common-say (concat (make-string 440 ?y) "z")) + (funcall expect 1 "<tester>") + ;; Sent in two passes, split at last word. + (funcall expect 0.1 "<tester> z")) + + (ert-info ("Rejected when escape-hatch set") + (let ((erc--reject-unbreakable-lines t)) + (should-error + (erc-scenarios-common-say + (concat + "https://mail.example.org/verify?token=" + (string-join (make-list 18 "twenty-three_characters") "_"))))))) + + (with-current-buffer "foonet" + (erc-cmd-QUIT "") + (funcall expect 10 "finished")))) + +(ert-deftest erc-scenarios-base-split-line--utf-8 () + :tags '(:expensive-test) + (unless (> emacs-major-version 27) + (ert-skip "No emojis in Emacs 27")) + + (should (equal erc-split-line-length 440)) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/flood") + (msg-432 (string-join (make-list 18 "twenty-three characters") " ")) + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'utf-8)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "debug mode") + (erc-cmd-JOIN "#utf-8"))) + + (with-current-buffer (erc-d-t-wait-for 8 (get-buffer "#utf-8")) + (funcall expect 10 "Welcome") + + (ert-info ("Message with spaces over `erc-split-line-length'") + (erc-scenarios-common-say + (concat + "короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " короче теперь если по русски написать все четко или все равно" + " будет разрыв строки непонятно где" + " будет разрыв строки непонятно где")) + (funcall expect 1 "<tester> короче") + (funcall expect 1 "<tester> все") + (funcall expect 1 "<tester> разрыв") + (funcall expect 1 "Entirely honour")) + + (ert-info ("Message sans spaces over `erc-split-line-length'") + (erc-scenarios-common-say + (concat "話說天下大勢，分久必合，合久必分：周末七國分爭，并入於秦。" + "及秦滅之後，楚、漢分爭，又并入於漢。漢朝自高祖斬白蛇而起義，" + "一統天下。後來光武中興，傳至獻帝，遂分為三國。推其致亂之由，" + "殆始於桓、靈二帝。桓帝禁錮善類，崇信宦官。及桓帝崩，靈帝即位，" + "大將軍竇武、太傅陳蕃，共相輔佐。時有宦官曹節等弄權，竇武、陳蕃謀誅之，" + "作事不密，反為所害。中涓自此愈橫")) + (funcall expect 1 "<tester>") + ;; Sent in two passes, split at last word. + (funcall expect 0.1 "<tester> 竇武") + (funcall expect 1 "this prey out")) + + ;; Combining emojis are respected. + (ert-info ("Message sans spaces over small `erc-split-line-length'") + (let ((erc-split-line-length 100)) + (erc-scenarios-common-say + "будет разрыв строки непонятно где🏁🚩🎌🏴🏳️🏳️🌈🏳️⚧️🏴☠️")) + (funcall expect 1 "<tester>") + (funcall expect 1 "<tester> 🏳️🌈"))) + + (with-current-buffer "foonet" + (erc-cmd-QUIT "") + (funcall expect 10 "finished")))) + +;;; erc-scenarios-base-split-line.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-statusmsg.el b/test/lisp/erc/erc-scenarios-base-statusmsg.el new file mode 100644 index 00000000000..80582e0cf80 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-statusmsg.el @@ -0,0 +1,103 @@ +;;; erc-scenarios-base-statusmsg.el --- statusmsg tests -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-base-statusmsg () + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/display-message") + (dumb-server (erc-d-run "localhost" t 'statusmsg)) + (erc-autojoin-channels-alist '((foonet "#mine"))) + (erc-modules (cons 'fill-wrap erc-modules)) + (port (process-contact dumb-server :service)) + (erc-show-speaker-membership-status nil) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester") + (funcall expect 5 "This server is in debug mode"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#mine")) + + (ert-info ("Receive status messages unprefixed") + (funcall expect 5 "+dummy") + (funcall expect 5 "(dummy+) hello") + (should (eq 'statusmsg (erc--get-inserted-msg-prop 'erc--msg))) + (should (equal "dummy" (erc--get-inserted-msg-prop 'erc--spkr))) + (should (eq (get-text-property (1- (point)) 'font-lock-face) + 'erc-default-face)) + (funcall expect 5 "(dummy+) there") + (should (equal "" (get-text-property (pos-bol) 'display))) + + ;; CTCP ACTION + (funcall expect 5 "* (dummy+) sad") + (should (eq 'ctcp-action-statusmsg + (erc--get-inserted-msg-prop 'erc--msg))) + (should (eq (get-text-property (1- (point)) 'font-lock-face) + 'erc-action-face)) + (funcall expect 5 "* (dummy+) glad") + (should (equal "" (get-text-property (pos-bol) 'display)))) + + (ert-info ("Send status messages") + ;; We don't have `echo-message' yet, so ERC doesn't currently + ;; insert commands like "/msg +#mine foo". + (let ((erc-default-recipients '("+#mine"))) + (erc-send-message "howdy")) + (funcall expect 5 "(@tester+) howdy") + (should (eq 'statusmsg-input (erc--get-inserted-msg-prop 'erc--msg))) + (should (equal "tester" (erc--get-inserted-msg-prop 'erc--spkr))) + (should (eq (get-text-property (1- (point)) 'font-lock-face) + 'erc-input-face)) + (let ((erc-default-recipients '("+#mine"))) + (erc-send-message "tenderfoot")) + (funcall expect 5 "(@tester+) tenderfoot") + (should (equal "" (get-text-property (pos-bol) 'display))) + + ;; Simulate some "echoed" CTCP ACTION messages since we don't + ;; actually support that yet. + (funcall expect 5 "* (@tester+) mad") + (should (eq 'ctcp-action-statusmsg-input + (erc--get-inserted-msg-prop 'erc--msg))) + (should (equal (get-text-property (1- (point)) 'font-lock-face) + '(erc-input-face erc-action-face))) + (funcall expect 5 "* (@tester+) chad") + (should (equal "" (get-text-property (pos-bol) 'display)))) + + (ert-info ("Receive status messages prefixed") + (setq erc-show-speaker-membership-status t) + (erc-scenarios-common-say "/me ready") ; sync + (funcall expect 5 "* @tester ready") + (funcall expect 5 "(+dummy+) okie") + + ;; CTCP ACTION + (funcall expect 5 "* (+dummy+) dokie") + (funcall expect 5 "* +dummy out"))))) + +;;; erc-scenarios-base-statusmsg.el ends here diff --git a/test/lisp/erc/erc-scenarios-display-message.el b/test/lisp/erc/erc-scenarios-display-message.el new file mode 100644 index 00000000000..91b82889f3e --- /dev/null +++ b/test/lisp/erc/erc-scenarios-display-message.el @@ -0,0 +1,63 @@ +;;; erc-scenarios-display-message.el --- erc-display-message -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-display-message--multibuf () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/display-message") + (dumb-server (erc-d-run "localhost" t 'multibuf)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (erc-modules (cons 'fill-wrap erc-modules)) + (erc-autojoin-channels-alist '((foonet "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "debug mode"))) + + (ert-info ("User dummy is a member of #chan") + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "dummy"))) + + (ert-info ("Dummy's QUIT notice in query contains metadata props") + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "dummy")) + (funcall expect 10 "<dummy> hi") + (funcall expect 10 "*** dummy (~u@rdjcgiwfuwqmc.irc) has quit") + (should (eq 'QUIT (get-text-property (match-beginning 0) 'erc--msg))))) + + (ert-info ("Dummy's QUIT notice in #chan contains metadata props") + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "*** dummy (~u@rdjcgiwfuwqmc.irc) has quit") + (should (eq 'QUIT (get-text-property (match-beginning 0) 'erc--msg))))) + + (with-current-buffer "foonet" + (erc-cmd-QUIT "")))) + +;;; erc-scenarios-display-message.el ends here diff --git a/test/lisp/erc/erc-scenarios-internal.el b/test/lisp/erc/erc-scenarios-internal.el index 18eb94e24b0..b6c4d1ba27f 100644 --- a/test/lisp/erc/erc-scenarios-internal.el +++ b/test/lisp/erc/erc-scenarios-internal.el @@ -24,8 +24,37 @@ (when (and (getenv "EMACS_TEST_DIRECTORY") (getenv "EMACS_TEST_JUNIT_REPORT")) (setq ert-load-file-name (or (macroexp-file-name) buffer-file-name))) - (let ((load-path (cons (expand-file-name "erc-d" (ert-resource-directory)) - load-path))) - (load "erc-d-tests" nil 'silent))) + (let ((load-path `(,(expand-file-name "erc-d" (ert-resource-directory)) + ,(ert-resource-directory) + ,@load-path))) + ;; Run all tests in ./resources/erc-d/erc-d-tests.el. + (load "erc-d-tests" nil 'silent) + (require 'erc-tests-common))) + +;; Run all tests tagged `:erc--graphical' in an "interactive" +;; subprocess. Time out after 90 seconds. +(ert-deftest erc-scenarios-internal--run-graphical-all () + :tags '(:expensive-test :unstable) + (unless (and (getenv "ERC_TESTS_GRAPHICAL_ALL") + (not (getenv "ERC_TESTS_GRAPHICAL")) + (not (getenv "CI"))) + (ert-skip "Environmental conditions unmet")) + + (let* ((default-directory (expand-file-name "../" (ert-resource-directory))) + (libs (directory-files default-directory 'full (rx ".el" eot))) + (process-environment (cons "ERC_TESTS_GRAPHICAL=1" + process-environment)) + (program '(progn (ert (quote (tag :erc--graphical))) + (with-current-buffer ert--output-buffer-name + (kill-emacs (ert--stats-failed-unexpected + ert--results-stats))))) + (proc (erc-tests-common-create-subprocess program + '( "-L" "." "-l" "ert") + libs))) + + (erc-d-t-wait-for 90 "interactive tests to complete" + (not (process-live-p proc))) + + (should (zerop (process-exit-status proc))))) ;;; erc-scenarios-internal.el ends here diff --git a/test/lisp/erc/erc-scenarios-join-display-context.el b/test/lisp/erc/erc-scenarios-join-display-context.el new file mode 100644 index 00000000000..32b782d2af1 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-join-display-context.el @@ -0,0 +1,66 @@ +;;; erc-scenarios-join-display-context.el --- buffer-display autojoin ctx -*- 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: + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(ert-deftest erc-scenarios-join-display-context--errors () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "join/buffer-display") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'mode-context)) + (port (process-contact dumb-server :service)) + (erc-buffer-display (lambda (buf action) + (when (equal + (alist-get 'erc-autojoin-mode action) + "#chan") + (pop-to-buffer buf)))) + (erc-autojoin-channels-alist '((foonet "#chan" "#spam" "#foo"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect without password") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + ;; FIXME test for effect rather than inspecting interval variables. + (erc-d-t-wait-for 10 (equal erc-join--requested-channels + '("#foo" "#spam" "#chan"))) + (funcall expect 10 "Max occupancy for channel #spam exceeded") + (funcall expect 10 "Channel #foo is invitation only"))) + + (ert-info ("New #chan buffer displayed in new window") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (should (eq (window-buffer) (current-buffer))) + (funcall expect 10 "#chan was created on"))) + + ;; FIXME find a less dishonest way to do this than inspecting + ;; interval variables. + (ert-info ("Ensure channels no longer tracked") + (should-not erc-join--requested-channels)))) + +;;; erc-scenarios-join-display-context.el ends here diff --git a/test/lisp/erc/erc-scenarios-keep-place-indicator.el b/test/lisp/erc/erc-scenarios-keep-place-indicator.el new file mode 100644 index 00000000000..8ebef5404c1 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-keep-place-indicator.el @@ -0,0 +1,141 @@ +;;; erc-scenarios-keep-place-indicator.el --- erc-keep-place-indicator-mode -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-goodies) + +;; This test shows that the indicator does not update when at least +;; one window remains. When the last window showing a buffer switches +;; away, the indicator is updated if it's earlier in the buffer. +(ert-deftest erc-scenarios-keep-place-indicator--follow () + :tags `(:expensive-test + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (when (version< emacs-version "29") (ert-skip "Times out")) + ;; XXX verify that this continues to be the case ^. + + (should-not erc-scrolltobottom-all) + (should-not erc-scrolltobottom-mode) + (should-not erc-keep-place-mode) + + (erc-scenarios-common-with-noninteractive-in-term + ((erc-scenarios-common-dialog "keep-place") + (dumb-server (erc-d-run "localhost" t 'follow)) + (port (process-contact dumb-server :service)) + (erc-modules `( keep-place-indicator scrolltobottom fill-wrap + ,@erc-modules)) + (erc-keep-place-indicator-follow t) + (erc-scrolltobottom-all t) + (erc-server-flood-penalty 0.1) + (erc-autojoin-channels-alist '((foonet "#chan" "#spam"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester" + :user "tester") + (funcall expect 10 "debug mode"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (set-window-buffer nil (current-buffer)) + (delete-other-windows) + (split-window-below) + (funcall expect 10 "<bob> tester, welcome!") + (recenter 0) + (other-window 1) + (funcall expect 10 "<alice> tester, welcome!") + (recenter 0) + (should (= 2 (length (window-list)))) + + (ert-info ("Last window to switch away has point earlier in buffer") + ;; Lower window, with point later in buffer, switches away first. + (switch-to-buffer (erc-d-t-wait-for 10 (get-buffer "#spam"))) ; lower + (other-window 1) + (switch-to-buffer "#spam") ; upper + (erc-scenarios-common-say "one") + (funcall expect 10 "Ay, the heads") + + ;; Overlay has moved to upper window start. + (switch-to-buffer "#chan") + (redisplay) ; force overlay to update + (save-excursion + (goto-char (window-point)) + (should (looking-back (rx "<bob> tester, welcome!"))) + (should (= (pos-bol) (window-start))) + (should (= (overlay-start erc--keep-place-indicator-overlay) + (pos-bol)))) + ;; Lower window is still centered at start. + (other-window 1) + (switch-to-buffer "#chan") + (save-excursion + (goto-char (window-point)) + (should (looking-back (rx "<alice> tester, welcome!"))) + (should (= (pos-bol) (window-start))))) + + (ert-info ("Last window to switch away has point later in buffer") + ;; Lower window advances. + (funcall expect 10 "<bob> alice: Since you can cog") + (recenter 0) + (redisplay) ; force ^ to appear on first line + + (other-window 1) ; upper still at indicator, swtiches first + (switch-to-buffer "#spam") + (other-window 1) + (switch-to-buffer "#spam") ; lower follows, speaks to sync + (erc-scenarios-common-say "two") + (funcall expect 10 "<bob> Cause they take") + (goto-char (point-max)) + + ;; Upper switches back first, finds indicator gone. + (other-window 1) + (switch-to-buffer "#chan") + (save-excursion + (goto-char (window-point)) + (should (looking-back (rx "<bob> tester, welcome!"))) + (should (= (pos-bol) (window-start))) + (should (> (overlay-start erc--keep-place-indicator-overlay) + (pos-eol)))) + + ;; Lower window follows, window-start preserved. + (other-window 1) + (switch-to-buffer "#chan") + (save-excursion + (goto-char (window-point)) + (should (looking-back (rx "you can cog"))) + (should (= (pos-bol) (window-start))) + (should (= (overlay-start erc--keep-place-indicator-overlay) + (pos-bol))))) + + (ert-info ("description") + (erc-send-input-line "#spam" "three") + (save-excursion (erc-d-t-search-for 10 "Ready")) + (switch-to-buffer "#spam") + (should (< (point) erc-input-marker)))) + + (erc-keep-place-mode -1) + (erc-scrolltobottom-mode -1))) + +;;; erc-scenarios-keep-place-indicator.el ends here diff --git a/test/lisp/erc/erc-scenarios-log.el b/test/lisp/erc/erc-scenarios-log.el new file mode 100644 index 00000000000..cff88d59c85 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-log.el @@ -0,0 +1,264 @@ +;;; erc-scenarios-log.el --- erc-log scenarios -*- 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: + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-log) +(require 'erc-truncate) + +(defvar erc-timestamp-format-left) + +(ert-deftest erc-scenarios-log--kill-hook () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/bouncer-history") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (tempdir (make-temp-file "erc-tests-log." t nil nil)) + (erc-log-channels-directory tempdir) + (erc-modules (cons 'log erc-modules)) + (port (process-contact dumb-server :service)) + (logfile (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port) + tempdir)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (funcall expect 5 "foonet"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "was created on") + (funcall expect 10 "please your lordship") + (with-current-buffer "foonet" + (delete-process erc-server-process) + (funcall expect 5 "failed")) + (should-not (file-exists-p logfile)) + (kill-buffer) + (should (file-exists-p logfile))) + + (with-temp-buffer + (insert-file-contents logfile) + (funcall expect 1 "You have joined") + (funcall expect 1 "Playback Complete.") + (funcall expect 1 "please your lordship")) + + (erc-log-mode -1) + (if noninteractive + (delete-directory tempdir :recursive) + (add-hook 'kill-emacs-hook + (lambda () (delete-directory tempdir :recursive)))))) + +;; This shows that, in addition to truncating the buffer, /clear also +;; syncs the log. + +(ert-deftest erc-scenarios-log--clear-stamp () + :tags '(:expensive-test) + (require 'erc-stamp) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/bouncer-history") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (tempdir (make-temp-file "erc-tests-log." t nil nil)) + (erc-log-channels-directory tempdir) + (erc-modules (cons 'log erc-modules)) + (erc-timestamp-format-left "\n[%a %b %e %Y @@STAMP@@]\n") + (port (process-contact dumb-server :service)) + (logfile (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port) + tempdir)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (unless noninteractive + (add-hook 'kill-emacs-hook + (lambda () (delete-directory tempdir :recursive)))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (funcall expect 5 "foonet"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "@@STAMP@@") + (funcall expect 10 "Grows, lives") + (should-not (file-exists-p logfile)) + (goto-char (point-max)) + (erc-cmd-CLEAR) + (should (file-exists-p logfile)) + (funcall expect 10 "please your lordship") + (ert-info ("Buffer truncated") + (goto-char (point-min)) + (funcall expect 10 "@@STAMP@@" (point)) ; reset + (funcall expect -0.1 "Grows, lives") + (funcall expect 1 "For these two"))) + + (ert-info ("Current contents saved") + (with-temp-buffer + (insert-file-contents logfile) + (funcall expect 1 "@@STAMP@@") + (funcall expect 1 "You have joined") + (funcall expect 1 "Playback Complete.") + (funcall expect 1 "Grows, lives") + (funcall expect -0.01 "please your lordship"))) + + (ert-info ("Remainder saved, timestamp printed when option non-nil") + (with-current-buffer "foonet" + (delete-process erc-server-process) + (funcall expect 5 "failed")) + (kill-buffer "#chan") + (with-temp-buffer + (insert-file-contents logfile) + (funcall expect 1 "@@STAMP@@") + (funcall expect 1 "Grows, lives") + (funcall expect -0.01 "@@STAMP@@") + (forward-line 1) ; no blank, no timestamp + (should (looking-at (rx "<bob> alice: For these two hours,"))) + (funcall expect 1 "please your lordship"))) + + (erc-log-mode -1) + (when noninteractive (delete-directory tempdir :recursive)))) + +(ert-deftest erc-scenarios-log--truncate () + :tags '(:expensive-test :unstable) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/bouncer-history") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (tempdir (make-temp-file "erc-tests-log." t nil nil)) + (erc-log-channels-directory tempdir) + (erc-modules (cons 'truncate (cons 'log erc-modules))) + (erc-max-buffer-size 512) + (port (process-contact dumb-server :service)) + (logchan (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port) + tempdir)) + (logserv (expand-file-name + (format "127.0.0.1:%d!tester@127.0.0.1:%d.txt" port port) + tempdir)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (unless noninteractive + (add-hook 'kill-emacs-hook + (lambda () (delete-directory tempdir :recursive)))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (should-not (file-exists-p logserv)) + (should-not (file-exists-p logchan)) + (funcall expect 10 "*** MAXLIST=beI:60") + (should (= (pos-bol) (point-min))) + (should (file-exists-p logserv)))) + + (ert-info ("Log file ahead of truncation point") + ;; Log contains lines still present in buffer. + (with-temp-buffer + (insert-file-contents logserv) + (funcall expect 10 "*** MAXLIST=beI:60"))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "please your lordship") + (should (file-exists-p logchan)) + (funcall expect -0.1 "[07:04:37] alice: Here," (point-min))) + + (ert-info ("Log ahead of truncation point") + (with-temp-buffer + (insert-file-contents logchan) + (funcall expect 1 "You have joined") + (funcall expect 1 "[07:04:37] alice: Here,") + (funcall expect 1 "loathed enemy") + (funcall expect -0.1 "please your lordship"))) + + (erc-log-mode -1) + (erc-truncate-mode -1) + (when noninteractive (delete-directory tempdir :recursive)))) + +(defvar erc-insert-timestamp-function) +(declare-function erc-insert-timestamp-left "erc-stamp" (string)) + +(ert-deftest erc-scenarios-log--save-buffer-in-logs/truncate-on-save () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/assoc/bouncer-history") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (tempdir (make-temp-file "erc-tests-log." t nil nil)) + (erc-log-channels-directory tempdir) + (erc-modules (cons 'log erc-modules)) + (port (process-contact dumb-server :service)) + (erc-truncate-buffer-on-save t) + (logchan (expand-file-name (format "#chan!tester@127.0.0.1:%d.txt" port) + tempdir)) + (erc-server-flood-penalty 0.1) + (erc-insert-timestamp-function #'erc-insert-timestamp-left) + (expect (erc-d-t-make-expecter))) + + (unless noninteractive + (add-hook 'kill-emacs-hook + (lambda () (delete-directory tempdir :recursive)))) + + (ert-info ("Connect to foonet") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (funcall expect 10 "<someone> [07:04:10] hi everyone") + (should-not (file-exists-p logchan)) + ;; Simulate an M-x erc-save-buffer-in-logs RET + (cl-letf (((symbol-function 'called-interactively-p) #'always)) + (call-interactively #'erc-save-buffer-in-logs)) + (should (file-exists-p logchan)) + (funcall expect 10 "<alice> bob: As't please your lordship") + (erc-save-buffer-in-logs) + ;; Not truncated when called by lisp code. + (should (> (buffer-size) 400))) + + (ert-info ("No double entries") + (with-temp-buffer + (insert-file-contents logchan) + (funcall expect 0.1 "hi everyone") + (funcall expect -0.1 "hi everyone") + (funcall expect 0.1 "Playback Complete") + (funcall expect -0.1 "Playback Complete") + (funcall expect 10 "<alice> bob: As't"))) + + (erc-log-mode -1) + (when noninteractive (delete-directory tempdir :recursive)))) + +;;; erc-scenarios-log.el ends here diff --git a/test/lisp/erc/erc-scenarios-match.el b/test/lisp/erc/erc-scenarios-match.el new file mode 100644 index 00000000000..b18c0a4bd17 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-match.el @@ -0,0 +1,555 @@ +;;; erc-scenarios-match.el --- Misc `erc-match' scenarios -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(eval-when-compile + (require 'erc-join) + (require 'erc-match)) + +(require 'erc-stamp) +(require 'erc-fill) + +;; This defends against a regression in which all matching by the +;; `erc-match-message' fails when `erc-add-timestamp' precedes it in +;; `erc-insert-modify-hook'. Basically, `erc-match-message' used to +;; expect an `erc-parsed' text property on the first character in a +;; message, which doesn't exist, when the message content is prefixed +;; by a leading timestamp. + +(ert-deftest erc-scenarios-match--stamp-left-current-nick () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (erc-insert-timestamp-function 'erc-insert-timestamp-left) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + ;; Module `timestamp' follows `match' in insertion hooks. + (should (memq 'erc-add-timestamp + (memq 'erc-match-message + (default-value 'erc-insert-modify-hook)))) + ;; The "match type" is `current-nick'. + (funcall expect 5 "tester") + (should (eq (get-text-property (1- (point)) 'font-lock-face) + 'erc-current-nick-face)))))) + +;; When hacking on tests that use this fixture, it's best to run it +;; interactively, and visually inspect the output with various +;; combinations of: +;; +;; M-x erc-match-toggle-hidden-fools RET +;; M-x erc-toggle-timestamps RET +;; +(defun erc-scenarios-match--invisible-stamp (hiddenp visiblep) + (unless noninteractive + (kill-new "erc-match-toggle-hidden-fools")) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "join/legacy") + (dumb-server (erc-d-run "localhost" t 'foonet)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (erc-timestamp-only-if-changed-flag nil) + (erc-fools '("bob")) + (erc-text-matched-hook '(erc-hide-fools)) + (erc-autojoin-channels-alist '((FooNet "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :password "changeme" + :nick "tester") + ;; Module `timestamp' follows `match' in insertion hooks. + (should (memq 'erc-add-timestamp + (memq 'erc-match-message + (default-value 'erc-insert-modify-hook)))) + (funcall expect 5 "This server is in debug mode"))) + + (ert-info ("Ensure lines featuring \"bob\" are invisible") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (should (funcall expect 10 "<bob> tester, welcome!")) + (ert-info ("<bob> tester, welcome!") (funcall hiddenp)) + + ;; Alice's is the only one visible. + (should (funcall expect 10 "<alice> tester, welcome!")) + (ert-info ("<alice> tester, welcome!") (funcall visiblep)) + + (should (funcall expect 10 "<bob> alice: But, as it seems")) + (ert-info ("<bob> alice: But, as it seems") (funcall hiddenp)) + + (should (funcall expect 10 "<alice> bob: Well, this is the forest")) + (ert-info ("<alice> bob: Well, this is the forest") (funcall hiddenp)) + + (should (funcall expect 10 "<alice> bob: And will you")) + (ert-info ("<alice> bob: And will you") (funcall hiddenp)) + + (should (funcall expect 10 "<bob> alice: Live, and be prosperous")) + (ert-info ("<bob> alice: Live, and be prosperous") (funcall hiddenp)) + + (should (funcall expect 10 "ERC>")) + (should-not (get-text-property (pos-bol) 'invisible)) + (should-not (get-text-property (point) 'invisible)))))) + +;; This asserts that when stamps appear before a message, registered +;; invisibility properties owned by modules span the entire message. +(ert-deftest erc-scenarios-match--stamp-left-fools-invisible () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-left)) + (erc-scenarios-match--invisible-stamp + + (lambda () + ;; This is a time-stamped message. + (should (eq (field-at-pos (pos-bol)) 'erc-timestamp)) + + ;; Leading stamp has combined `invisible' property value. + (should (equal (get-text-property (pos-bol) 'invisible) + '(match-fools timestamp))) + + ;; Message proper has the `invisible' property `match-fools'. + (let ((msg-beg (next-single-property-change (pos-bol) 'invisible))) + (should (eq (get-text-property msg-beg 'invisible) 'match-fools)) + (should (>= (next-single-property-change msg-beg 'invisible nil) + (pos-eol))))) + + (lambda () + ;; This is a time-stamped message. + (should (eq (field-at-pos (pos-bol)) 'erc-timestamp)) + (should (get-text-property (pos-bol) 'invisible)) + + ;; The entire message proper is visible. + (let ((msg-beg (next-single-property-change (pos-bol) 'invisible))) + (should + (= (next-single-property-change msg-beg 'invisible nil (pos-eol)) + (pos-eol)))))))) + +;; In most cases, `erc-hide-fools' makes line endings invisible. +(defun erc-scenarios-match--stamp-right-fools-invisible () + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right)) + (erc-scenarios-match--invisible-stamp + + (lambda () + (pcase-let ((`(,beg . ,end) (erc--get-inserted-msg-bounds))) + ;; The end of the message is a newline. + (should (= ?\n (char-after end))) + + ;; Every message has a trailing time stamp. + (should (eq (field-at-pos (1- end)) 'erc-timestamp)) + + ;; Stamps have a combined `invisible' property value. + (should (equal (get-text-property (1- end) 'invisible) + '(match-fools timestamp))) + + ;; The final newline is hidden by `match', not `stamps' + (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) + (if erc-legacy-invisible-bounds-p + (should (eq (get-text-property end 'invisible) 'match-fools)) + (should (eq (get-text-property beg 'invisible) 'match-fools)) + (should-not (get-text-property end 'invisible)))) + + ;; The message proper has the `invisible' property `match-fools', + ;; and it starts after the preceding newline. + (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools)) + + ;; It ends just before the timestamp. + (let ((msg-end (next-single-property-change (pos-bol) 'invisible))) + (should (equal (get-text-property msg-end 'invisible) + '(match-fools timestamp))) + + ;; Stamp's `invisible' property extends throughout the stamp + ;; and ends before the trailing newline. + (should (= (next-single-property-change msg-end 'invisible) end))))) + + (lambda () + (let ((end (erc--get-inserted-msg-end (point)))) + ;; This message has a time stamp like all the others. + (should (eq (field-at-pos (1- end)) 'erc-timestamp)) + + ;; The entire message proper is visible. + (should-not (get-text-property (pos-bol) 'invisible)) + (let ((inv-beg (next-single-property-change (pos-bol) 'invisible))) + (should (eq (get-text-property inv-beg 'invisible) + 'timestamp)))))))) + +(ert-deftest erc-scenarios-match--stamp-right-fools-invisible () + :tags '(:expensive-test) + (erc-scenarios-match--stamp-right-fools-invisible)) + +(ert-deftest erc-scenarios-match--stamp-right-fools-invisible--nooffset () + :tags '(:expensive-test) + (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) + (should-not erc-legacy-invisible-bounds-p) + (let ((erc-legacy-invisible-bounds-p t)) + (erc-scenarios-match--stamp-right-fools-invisible)))) + +;; This asserts that when `erc-fill-wrap-mode' is enabled, ERC hides +;; the preceding message's line ending. +(ert-deftest erc-scenarios-match--stamp-right-invisible-fill-wrap () + :tags '(:expensive-test) + (let ((erc-insert-timestamp-function #'erc-insert-timestamp-right) + (erc-fill-function #'erc-fill-wrap)) + (erc-scenarios-match--invisible-stamp + + (lambda () + ;; Every message has a trailing time stamp. + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + + ;; Stamps appear in the right margin. + (should (equal (car (get-text-property (1- (pos-eol)) 'display)) + '(margin right-margin))) + + ;; Stamps have a combined `invisible' property value. + (should (equal (get-text-property (1- (pos-eol)) 'invisible) + '(match-fools timestamp))) + + ;; The message proper has the `invisible' property `match-fools', + ;; which starts at the preceding newline... + (should (eq (get-text-property (1- (pos-bol)) 'invisible) 'match-fools)) + + ;; ... and ends just before the timestamp. + (let ((msgend (next-single-property-change (1- (pos-bol)) 'invisible))) + (should (equal (get-text-property msgend 'invisible) + '(match-fools timestamp))) + + ;; The newline before `erc-insert-marker' is still visible. + (should-not (get-text-property (pos-eol) 'invisible)) + (should (= (next-single-property-change msgend 'invisible) + (pos-eol))))) + + (lambda () + ;; This message has a time stamp like all the others. + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + + ;; Unlike hidden messages, the preceding newline is visible. + (should-not (get-text-property (1- (pos-bol)) 'invisible)) + + ;; The entire message proper is visible. + (let ((inv-beg (next-single-property-change (1- (pos-bol)) 'invisible))) + (should (eq (get-text-property inv-beg 'invisible) 'timestamp))))))) + +(defun erc-scenarios-match--fill-wrap-stamp-dedented-p (point) + (pcase (get-text-property point 'line-prefix) + (`(space :width (- erc-fill--wrap-value (,n))) + (if (display-graphic-p) (< 100 n 200) (< 10 n 30))) + (`(space :width (- erc-fill--wrap-value ,n)) + (< 10 n 30)))) + +(ert-deftest erc-scenarios-match--hide-fools/stamp-both/fill-wrap () + + ;; Rewind the clock to known date artificially. We should probably + ;; use a ticks/hz cons on 29+. + (let ((erc-stamp--current-time 704591940) + (erc-stamp--tz t) + (erc-fill-function #'erc-fill-wrap) + (bob-utterance-counter 0)) + + (erc-scenarios-match--invisible-stamp + + (lambda () + (ert-info ("Baseline check") + ;; False date printed initially before anyone speaks. + (when (zerop bob-utterance-counter) + (save-excursion + (goto-char (point-min)) + (search-forward "[Wed Apr 29 1992]") + ;; First stamp in a buffer is not invisible from previous + ;; newline (before stamp's own leading newline). + (should (= 4 (match-beginning 0))) + (should (get-text-property 3 'invisible)) + (should-not (get-text-property 2 'invisible)) + (should (erc-scenarios-match--fill-wrap-stamp-dedented-p 4)) + (search-forward "[23:59]")))) + + (ert-info ("Line endings in Bob's messages are invisible") + ;; The message proper has the `invisible' property `match-fools'. + (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools)) + (pcase-let ((`(,mbeg . ,mend) (erc--get-inserted-msg-bounds))) + (should (= (char-after mend) ?\n)) + (should-not (field-at-pos mend)) + (should-not (field-at-pos mbeg)) + + (when (= bob-utterance-counter 1) + (let ((right-stamp (field-end mbeg))) + (should (eq 'erc-timestamp (field-at-pos right-stamp))) + (should (= mend (field-end right-stamp))) + (should (eq (field-at-pos (1- mend)) 'erc-timestamp)))) + + ;; The `erc--ts' property is present in prop stack. + (should (get-text-property (pos-bol) 'erc--ts)) + (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts)) + + ;; Line ending has the `invisible' property `match-fools'. + (should (eq (get-text-property mbeg 'invisible) 'match-fools)) + (should-not (get-text-property mend 'invisible)))) + + ;; Only the message right after Alice speaks contains stamps. + (when (= 1 bob-utterance-counter) + + (ert-info ("Date stamp occupying previous line is invisible") + (should (eq 'match-fools (get-text-property (point) 'invisible))) + (save-excursion + (forward-line -1) + (goto-char (pos-bol)) + (should (looking-at (rx "[Mon May 4 1992]"))) + (ert-info ("Stamp's NL `invisible' as fool, not timestamp") + (let ((end (match-end 0))) + (should (eq (char-after end) ?\n)) + (should (eq 'timestamp + (get-text-property (1- end) 'invisible))) + (should (eq 'match-fools + (get-text-property end 'invisible))))) + (should (erc-scenarios-match--fill-wrap-stamp-dedented-p (point))) + ;; Date stamp has a combined `invisible' property value + ;; that starts at the previous message's trailing newline + ;; and extends until the start of the message proper. + (should (equal ?\n (char-before (point)))) + (should (equal ?\n (char-before (1- (point))))) + (let ((val (get-text-property (- (point) 2) 'invisible))) + (should (equal val 'timestamp)) + (should (= (text-property-not-all (- (point) 2) (point-max) + 'invisible val) + (pos-eol)))))) + + (ert-info ("Current message's RHS stamp is hidden") + ;; Right stamp has `match-fools' property. + (save-excursion + (should-not (field-at-pos (point))) + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))) + + ;; Stamp invisibility starts where message's ends. + (let ((msgend (next-single-property-change (pos-bol) 'invisible))) + ;; Stamp has a combined `invisible' property value. + (should (equal (get-text-property msgend 'invisible) + '(match-fools timestamp))) + + ;; Combined `invisible' property spans entire timestamp. + (should (= (next-single-property-change msgend 'invisible) + (pos-eol)))))) + + (cl-incf bob-utterance-counter)) + + ;; Alice. + (lambda () + ;; Set clock ahead a week or so. + (setq erc-stamp--current-time 704962800) + + ;; This message has no time stamp and is completely visible. + (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + (should-not (next-single-property-change (pos-bol) 'invisible)))))) + +;; This asserts that speaker hiding by `erc-fill-wrap-merge' doesn't +;; take place after a series of hidden fool messages with an +;; intervening outgoing message followed immediately by a non-fool +;; message from the last non-hidden speaker (other than the user). +(ert-deftest erc-scenarios-match--hide-fools/stamp-both/fill-wrap/speak () + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "match/fools") + (erc-stamp--current-time 704591940) + (dumb-server (erc-d-run "localhost" t 'fill-wrap)) + (erc-stamp--tz t) + (erc-fill-function #'erc-fill-wrap) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (erc-timestamp-only-if-changed-flag nil) + (erc-fools '("bob")) + (erc-text-matched-hook '(erc-hide-fools)) + (erc-autojoin-channels-alist '((FooNet "#chan"))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :password "changeme" + :nick "tester") + ;; Module `timestamp' follows `match' in insertion hooks. + (should (memq 'erc-add-timestamp + (memq 'erc-match-message + (default-value 'erc-insert-modify-hook)))) + (funcall expect 5 "This server is in debug mode"))) + + (ert-info ("Ensure lines featuring \"bob\" are invisible") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (should (funcall expect 10 "<alice> None better than")) + (should (funcall expect 10 "<alice> bob: Still we went")) + (should (funcall expect 10 "<bob> alice: Give me your hand")) + (erc-scenarios-common-say "hey") + (should (funcall expect 10 "<bob> You have paid the heavens")) + (should (funcall expect 10 "<alice> bob: In the sick air")) + (should (funcall expect 10 "<alice> The web of our life")) + + ;; Regression (see leading comment). + (should-not (equal "" (get-text-property (pos-bol) 'display))) + + ;; No remaining meta-data positions, no more timestamps. + (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts)) + ;; No remaining invisible messages. + (should-not (text-property-not-all (pos-bol) erc-insert-marker + 'invisible nil)) + + (should (funcall expect 10 "ERC>")) + (should-not (get-text-property (pos-bol) 'invisible)) + (should-not (get-text-property (point) 'invisible)))))) + +(defun erc-scenarios-match--stamp-both-invisible-fill-static (assert-ds) + (should (eq erc-insert-timestamp-function + #'erc-insert-timestamp-left-and-right)) + + ;; Rewind the clock to known date artificially. + (let ((erc-stamp--current-time 704591940) + (erc-stamp--tz t) + (erc-fill-function #'erc-fill-static) + (bob-utterance-counter 0)) + + (erc-scenarios-match--invisible-stamp + + (lambda () + (ert-info ("Baseline check") + ;; False date printed initially before anyone speaks. + (when (zerop bob-utterance-counter) + (save-excursion + (goto-char (point-min)) + (search-forward "[Wed Apr 29 1992]") + (search-forward "[23:59]")))) + + (ert-info ("Line endings in Bob's messages are invisible") + ;; The message proper has the `invisible' property `match-fools'. + (should (eq (get-text-property (pos-bol) 'invisible) 'match-fools)) + (pcase-let ((`(,mbeg . ,mend) (erc--get-inserted-msg-bounds))) + + (should (= (char-after mend) ?\n)) + (should-not (field-at-pos mbeg)) + (should-not (field-at-pos mend)) + (when (= 1 bob-utterance-counter) + ;; For Bob's stamped message, check newline after stamp. + (should (eq (field-at-pos (field-end mbeg)) 'erc-timestamp)) + (should (eq (field-at-pos (1- mend)) 'erc-timestamp))) + + ;; The `erc--ts' property is present in the message's + ;; width 1 prop collection at its first char. + (should (get-text-property (pos-bol) 'erc--ts)) + (should-not (next-single-property-change (1+ (pos-bol)) 'erc--ts)) + + ;; Line ending has the `invisible' property `match-fools'. + (should (= (char-after mend) ?\n)) + (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) + (if erc-legacy-invisible-bounds-p + (should (eq (get-text-property mend 'invisible) 'match-fools)) + (should (eq (get-text-property mbeg 'invisible) 'match-fools)) + (should-not (get-text-property mend 'invisible)))))) + + ;; Only the message right after Alice speaks contains stamps. + (when (= 1 bob-utterance-counter) + + (ert-info ("Date stamp occupying previous line is invisible") + (save-excursion + (forward-line -1) + (goto-char (pos-bol)) + (should (looking-at (rx "[Mon May 4 1992]"))) + (should (= ?\n (char-after (- (point) 2)))) ; welcome!\n + (funcall assert-ds))) ; "assert date stamp" + + (ert-info ("Folding preserved despite invisibility") + ;; Message has a trailing time stamp, but it's been folded + ;; over to the next line. + (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + (save-excursion + (forward-line) + (should (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp))) + + ;; Stamp invisibility starts where message's ends. + (let ((msgend (next-single-property-change (pos-bol) 'invisible))) + ;; Stamp has a combined `invisible' property value. + (should (equal (get-text-property msgend 'invisible) + '(match-fools timestamp))) + + ;; Combined `invisible' property spans entire timestamp. + (should (= (next-single-property-change msgend 'invisible) + (save-excursion (forward-line) (pos-eol))))))) + + (cl-incf bob-utterance-counter)) + + ;; Alice. + (lambda () + ;; Set clock ahead a week or so. + (setq erc-stamp--current-time 704962800) + + ;; This message has no time stamp and is completely visible. + (should-not (eq (field-at-pos (1- (pos-eol))) 'erc-timestamp)) + (should-not (next-single-property-change (pos-bol) 'invisible)))))) + +(ert-deftest erc-scenarios-match--stamp-both-invisible-fill-static () + :tags '(:expensive-test) + (erc-scenarios-match--stamp-both-invisible-fill-static + + (lambda () + ;; Date stamp has an `invisible' property that starts from the + ;; newline delimiting the current and previous messages and + ;; extends until the stamp's final newline. It is not combined + ;; with the old value, `match-fools'. + (let ((delim-pos (- (point) 2))) + (should (equal 'timestamp (get-text-property delim-pos 'invisible))) + ;; Stamp-only invisibility ends before its last newline. + (should (= (text-property-not-all delim-pos (point-max) + 'invisible 'timestamp) + (match-end 0))))))) ; pos-eol + +(ert-deftest erc-scenarios-match--stamp-both-invisible-fill-static--nooffset () + :tags '(:expensive-test) + (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) + (should-not erc-legacy-invisible-bounds-p) + + (let ((erc-legacy-invisible-bounds-p t)) + (erc-scenarios-match--stamp-both-invisible-fill-static + + (lambda () + ;; Date stamp has an `invisible' property that covers its + ;; format string exactly. It is not combined with the old + ;; value, `match-fools'. + (let ((delim-prev (- (point) 2))) + (should-not (get-text-property delim-prev 'invisible)) + (should (eq 'erc-timestamp (field-at-pos (point)))) + (should (= (next-single-property-change delim-prev 'invisible) + (field-beginning (point)))) + (should (equal 'timestamp + (get-text-property (1- (point)) 'invisible))) + ;; Field stops before final newline because the date stamp + ;; is (now, as of ERC 5.6) its own standalone message. + (should (= ?\n (char-after (field-end (point))))) + ;; Stamp-only invisibility includes last newline. + (should (= (text-property-not-all (1- (point)) (point-max) + 'invisible 'timestamp) + (1+ (field-end (point))))))))))) + +;;; erc-scenarios-match.el ends here diff --git a/test/lisp/erc/erc-scenarios-misc-commands.el b/test/lisp/erc/erc-scenarios-misc-commands.el new file mode 100644 index 00000000000..b96782cf29c --- /dev/null +++ b/test/lisp/erc/erc-scenarios-misc-commands.el @@ -0,0 +1,126 @@ +;;; erc-scenarios-misc-commands.el --- Misc commands for ERC -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +;; This defends against a partial regression in which an /MOTD caused +;; 376 and 422 handlers in erc-networks to run. + +(ert-deftest erc-scenarios-misc-commands--MOTD () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "commands") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'motd)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "This is the default Ergo MOTD") + (funcall expect 10 "debug mode"))) + + (ert-info ("Send plain MOTD") + (with-current-buffer "foonet" + (erc-cmd-MOTD) + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "This is the default Ergo MOTD"))) + + (ert-info ("Send MOTD with known target") + (with-current-buffer "foonet" + (erc-scenarios-common-say "/MOTD irc1.foonet.org") + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "This is the default Ergo MOTD"))) + + (ert-info ("Send MOTD with erroneous target") + (with-current-buffer "foonet" + (erc-scenarios-common-say "/MOTD fake.foonet.org") + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "No such server") + ;; Message may show up before the handler runs. + (erc-d-t-wait-for 10 + (not (local-variable-p 'erc-server-402-functions))) + (should-not (local-variable-p 'erc-server-376-functions)) + (should-not (local-variable-p 'erc-server-422-functions)) + (erc-cmd-QUIT ""))))) + + +(ert-deftest erc-scenarios-misc-commands--SQUERY () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "commands") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'squery)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "Your connection is secure"))) + + (ert-info ("Send SQUERY") + (with-current-buffer "IRCnet" + (erc-scenarios-common-say "/SQUERY alis help list") + (funcall expect -0.1 "Incorrect arguments") + (funcall expect 10 "See also: HELP EXAMPLES"))))) + +;; Note that as of ERC 5.6, there is no actual slash-command function +;; named `erc-cmd-vhost'. At the moment, this test merely exists to +;; assert that the `erc-server-396' response handler updates the rolls +;; correctly. +(ert-deftest erc-scenarios-misc-commands--VHOST () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "commands") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'vhost)) + ;; As of ERC 5.6, we must join a channel before ERC adds itself + ;; to `erc-server-users'. Without such an entry, there's + ;; nothing to update when the 396 arrives. + (erc-autojoin-channels-alist '((foonet "#chan"))) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "changeme" + :full-name "tester") + (funcall expect 10 "debug mode"))) + + (ert-info ("Send VHOST") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (erc-scenarios-common-say "/VHOST tester changeme") + (funcall expect 10 "visible host") + (should (string= (erc-server-user-host (erc-get-server-user "tester")) + "some.host.test.cc")))))) + +;;; erc-scenarios-misc-commands.el ends here diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index 5927eee48fd..2efcd7ec7fb 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -75,7 +75,7 @@ (ert-info ("All output sent") (with-current-buffer "#chan/foonet" - (funcall expect 8 "Some man or other")) + (funcall expect 16 "Some man or other")) (with-current-buffer "#chan/barnet" (funcall expect 10 "That's he that was Othello"))))) @@ -205,4 +205,38 @@ (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) (funcall expect 10 "welcome"))))) +;; Ensure that ERC does not attempt to switch to a killed server +;; buffer via `erc-track-switch-buffer'. + +(declare-function erc-track-switch-buffer "erc-track" (arg)) +(defvar erc-track-mode) + +(ert-deftest erc-scenarios-base-kill-server-track () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "networks/merge-server") + (dumb-server (erc-d-run "localhost" t 'track)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (should erc-track-mode) + (funcall expect 5 "changed mode for tester") + (erc-cmd-JOIN "#chan"))) + + (ert-info ("Join channel and kill server buffer") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 5 "The hour that fools should ask")) + (with-current-buffer "FooNet" + (set-process-query-on-exit-flag erc-server-process nil) + (kill-buffer)) + (should-not (eq (current-buffer) (get-buffer "#chan"))) ; *temp* + (ert-simulate-command '(erc-track-switch-buffer 1)) ; No longer signals + (should (eq (current-buffer) (get-buffer "#chan")))))) + ;;; erc-scenarios-misc.el ends here diff --git a/test/lisp/erc/erc-scenarios-prompt-format.el b/test/lisp/erc/erc-scenarios-prompt-format.el new file mode 100644 index 00000000000..7eccb859dbc --- /dev/null +++ b/test/lisp/erc/erc-scenarios-prompt-format.el @@ -0,0 +1,117 @@ +;;; erc-scenarios-prompt-format.el --- erc-prompt-format-mode -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(defvar erc-fill-wrap-align-prompt) +(defvar erc-fill-wrap-use-pixels) + +(defun erc-scenarios-prompt-format--assert (needle &rest props) + (save-excursion + (goto-char erc-insert-marker) + (should (search-forward needle nil t)) + (pcase-dolist (`(,k . ,v) props) + (should (equal (get-text-property (point) k) v))))) + +;; This makes assertions about the option `erc-fill-wrap-align-prompt' +;; as well as the standard value of `erc-prompt-format'. One minor +;; omission is that this doesn't check behavior in query buffers. +(ert-deftest erc-scenarios-prompt-format () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/modes") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'chan-changed)) + (erc-modules (cons 'fill-wrap erc-modules)) + (erc-fill-wrap-align-prompt t) + (erc-fill-wrap-use-pixels nil) + (erc-prompt #'erc-prompt-format) + (erc-autojoin-channels-alist '((Libera.Chat "#chan"))) + (expect (erc-d-t-make-expecter)) + ;; Collect samples of `line-prefix' to verify deltas as the + ;; prompt grows and shrinks. + (line-prefixes nil) + (stash-pfx (lambda () + (pcase (get-text-property erc-insert-marker 'line-prefix) + (`(space :width (- erc-fill--wrap-value ,n)) + (car (push n line-prefixes))))))) + + (ert-info ("Connect to Libera.Chat") + (with-current-buffer (erc :server "127.0.0.1" + :port (process-contact dumb-server :service) + :nick "tester" + :full-name "tester") + (funcall expect 5 "Welcome to the Libera.Chat") + (funcall stash-pfx) + (funcall expect 5 "changed mode") + ;; New prompt is shorter than default with placeholders, like + ;; "(foo?)(bar?)" (assuming we win the inherent race). + (should (>= (car line-prefixes) (funcall stash-pfx))) + (erc-scenarios-prompt-format--assert "user-" '(display . ("Ziw"))))) + + (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) + (should-not erc-channel-key) + (should-not erc-channel-user-limit) + + (ert-info ("Receive notice that mode has changed") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t"))) + (funcall stash-pfx) + (erc-scenarios-common-say "ready before") + (funcall expect 10 " has changed mode for #chan to +Qu") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("Q" "n" "t" "u"))) + ;; Prompt is longer now, so too is the `line-prefix' subtrahend. + (should (< (car line-prefixes) (funcall stash-pfx))) + (erc-scenarios-prompt-format--assert "Qntu") + (erc-scenarios-prompt-format--assert "#chan>")) + + (ert-info ("Key stored locally") + (erc-scenarios-common-say "ready key") + (funcall expect 10 " has changed mode for #chan to +k hunter2") + ;; Prompt has grown by 1. + (should (< (car line-prefixes) (funcall stash-pfx))) + (erc-scenarios-prompt-format--assert "Qkntu")) + + (ert-info ("Limit stored locally") + (erc-scenarios-common-say "ready limit") + (funcall expect 10 " has changed mode for #chan to +l 3") + (erc-d-t-wait-for 10 (eql erc-channel-user-limit 3)) + (should (equal erc-channel-modes '("Q" "n" "t" "u"))) + ;; Prompt has grown by 1 again. + (should (< (car line-prefixes) (funcall stash-pfx))) + (erc-scenarios-prompt-format--assert "Qklntu")) + + (ert-info ("Modes removed and local state deletion succeeds") + (erc-scenarios-common-say "ready drop") + (funcall expect 10 " has changed mode for #chan to -lu") + (funcall expect 10 " has changed mode for #chan to -Qk *") + (erc-d-t-wait-for 10 (equal erc-channel-modes '("n" "t"))) + ;; Prompt has shrunk. + (should (> (car line-prefixes) (funcall stash-pfx))) + (erc-scenarios-prompt-format--assert "nt")) + + (should-not erc-channel-key) + (should-not erc-channel-user-limit) + (funcall expect 10 "<Chad> after")))) + +;;; erc-scenarios-prompt-format.el ends here diff --git a/test/lisp/erc/erc-scenarios-sasl.el b/test/lisp/erc/erc-scenarios-sasl.el index 3878237c7d2..ecabc365adb 100644 --- a/test/lisp/erc/erc-scenarios-sasl.el +++ b/test/lisp/erc/erc-scenarios-sasl.el @@ -51,6 +51,70 @@ ;; Regression "\0\0\0\0 ..." caused by (fillarray passphrase 0) (should (string= erc-sasl-password "password123")))))) +;; The user's unreasonably long password is apportioned into chunks on +;; the way out the door. + +(ert-deftest erc-scenarios-sasl--plain-overlong-split () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'plain-overlong-split)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password + (concat + "Est ut beatae omnis ipsam. " + "Quis fugiat deleniti totam qui. " + "Ipsum quam a dolorum tempora velit laborum odit. " + "Et saepe voluptate sed cumque vel. " + "Voluptas sint ab pariatur libero veritatis corrupti. " + "Vero iure omnis ullam. " + "Vero beatae dolores facere fugiat ipsam. " + "Ea est pariatur minima nobis sunt aut ut. " + "Dolores ut laudantium maiores temporibus voluptates. " + "Reiciendis impedit omnis et unde delectus quas ab. " + "Quae eligendi necessitatibus doloribus " + "molestias tempora magnam assumenda.")) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "emersion" + :user "emersion" + :full-name "emersion") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT ""))))) + +(ert-deftest erc-scenarios-sasl--plain-overlong-aligned () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'plain-overlong-aligned)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password + (concat + "Est ut beatae omnis ipsam. " + "Quis fugiat deleniti totam qui. " + "Ipsum quam a dolorum tempora velit laborum odit. " + "Et saepe voluptate sed cumque vel. " + "Voluptas sint ab pariatur libero veritatis corrupti. " + "Vero iure omnis ullam. Vero beatae dolores facere fugiat ipsam. " + "Ea est pariatur minima nobis")) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "emersion" + :user "emersion" + :full-name "emersion") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT ""))))) + (ert-deftest erc-scenarios-sasl--external () :tags '(:expensive-test) (erc-scenarios-common-with-cleanup @@ -85,23 +149,26 @@ (erc-modules (cons 'sasl erc-modules)) (erc-sasl-password "wrong") (erc-sasl-mechanism 'plain) - (expect (erc-d-t-make-expecter)) - (buf nil)) + (erc--warnings-buffer-name "*ERC test warnings*") + (warnings-buffer (get-buffer-create erc--warnings-buffer-name)) + (inhibit-message noninteractive) + (expect (erc-d-t-make-expecter))) - (ert-info ("Connect") - (setq buf (erc :server "127.0.0.1" - :port port - :nick "tester" - :user "tester" - :full-name "tester")) - (let ((err (should-error - (with-current-buffer buf - (funcall expect 20 "Connection failed!"))))) - (should (string-search "please review" (cadr err))) - (with-current-buffer buf - (funcall expect 10 "Opening connection") - (funcall expect 20 "SASL authentication failed") - (should-not (erc-server-process-alive))))))) + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester") + (funcall expect 10 "Opening connection") + (funcall expect 20 "SASL authentication failed") + (funcall expect 20 "Connection failed!") + (should-not (erc-server-process-alive))) + + (with-current-buffer warnings-buffer + (funcall expect 10 "please review SASL settings"))) + + (when noninteractive + (should-not (get-buffer "*ERC test warnings*")))) (defun erc-scenarios--common--sasl (mech) (erc-scenarios-common-with-cleanup diff --git a/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el b/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el new file mode 100644 index 00000000000..e99a05526f3 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-scrolltobottom-relaxed.el @@ -0,0 +1,140 @@ +;;; erc-scenarios-scrolltobottom-relaxed.el --- erc-scrolltobottom-all relaxed -*- 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/>. + +;; TODO assert behavior of prompt input spanning multiple lines, with +;; and without line endings. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-goodies) + +(ert-deftest erc-scenarios-scrolltobottom--relaxed () + :tags `(:expensive-test + ,@(and (getenv "ERC_TESTS_GRAPHICAL") '(:erc--graphical))) + (when (version< emacs-version "29") (ert-skip "Times out")) + + (should-not erc-scrolltobottom-all) + + (erc-scenarios-common-with-noninteractive-in-term + ((erc-scenarios-common-dialog "scrolltobottom") + (dumb-server (erc-d-run "localhost" t 'help)) + (port (process-contact dumb-server :service)) + (erc-modules `(scrolltobottom fill-wrap ,@erc-modules)) + (erc-scrolltobottom-all 'relaxed) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter)) + lower upper) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + (funcall expect 10 "debug mode"))) + + (with-current-buffer "foonet" + (should (looking-at " and")) + (set-window-buffer nil (current-buffer)) + (delete-other-windows) + (split-window-below 15) + (recenter 0) + + (ert-info ("Moving into prompt does not trigger scroll") + (with-selected-window (next-window) + (should-not (erc-scenarios-common--at-win-end-p)) + (recenter 0) + (goto-char (1- erc-insert-marker)) + (execute-kbd-macro "\C-n") + (should-not (erc-scenarios-common--at-win-end-p)) + (should (= (point) (point-max))) + (setq lower (count-screen-lines (window-start) (window-point))))) + + (ert-info ("Module `move-to-prompt' still works") + ;; Prompt is somewhere in the middle of the window. + (should (erc-scenarios-common--above-win-end-p)) + (should-not (= (point-max) (point))) + ;; Hitting a self-insert key triggers `move-to-prompt' but not + ;; a scroll (to bottom). + (execute-kbd-macro "hi") + ;; Prompt and input appear on same line. + (should (= (point-max) (point))) + (setq upper (count-screen-lines (window-start) (window-point))) + (should-not (= upper (window-body-height)))) + + (ert-info ("Command `recenter-top-bottom' allowed at prompt") + ;; Hitting C-l recenters the window. + (should (= upper (count-screen-lines (window-start) (window-point)))) + (let ((lines (list upper))) + (erc-scenarios-common--recenter-top-bottom) + (push (count-screen-lines (window-start) (window-point)) lines) + (erc-scenarios-common--recenter-top-bottom) + (push (count-screen-lines (window-start) (window-point)) lines) + (erc-scenarios-common--recenter-top-bottom) + (push (count-screen-lines (window-start) (window-point)) lines) + (setq lines (delete-dups lines)) + (should (= (length lines) 4)))) + + (ert-info ("Command `beginning-of-buffer' allowed at prompt") + ;; Hitting C-< goes to beginning of buffer. + (execute-kbd-macro "\M-<") + (should (= 1 (point))) + (redisplay) + (should (zerop (count-screen-lines (window-start) (window-point)))) + (should (erc-scenarios-common--prompt-past-win-end-p))) + + (ert-info ("New message doesn't trigger scroll when away from prompt") + ;; Arriving insertions don't trigger a scroll when away from the + ;; prompt. New output not seen. + (erc-cmd-MSG "NickServ help register") + (save-excursion (erc-d-t-search-for 10 "End of NickServ")) + (should (= 1 (point))) + (should (zerop (count-screen-lines (window-start) (window-point)))) + (should (erc-scenarios-common--prompt-past-win-end-p))) + + (ert-info ("New insertion keeps prompt stationary in other window") + (let ((w (next-window))) + ;; We're at prompt and completely stationary. + (should (>= (window-point w) erc-input-marker)) + (erc-d-t-wait-for 10 + (= lower (count-screen-lines (window-start w) (window-point w)))) + (erc-d-t-ensure-for 0.5 + (= lower (count-screen-lines (window-start w) + (window-point w)))))) + + (should (= 2 (length (window-list)))) + (ert-info ("New message does not trigger a scroll when at prompt") + ;; Recenter so prompt is above rather than at window's end. + (funcall expect 10 "End of NickServ HELP") + (recenter 0) + (set-window-point nil (point-max)) + (setq upper (count-screen-lines (window-start) (window-point))) + ;; Prompt is somewhere in the middle of the window. + (erc-d-t-wait-for 10 (erc-scenarios-common--above-win-end-p)) + (erc-scenarios-common-say "/msg NickServ help identify") + ;; New arriving messages don't move prompt. + (erc-d-t-ensure-for 1 + (= upper (count-screen-lines (window-start) (window-point)))) + (funcall expect 10 "IDENTIFY lets you login"))))) + +;;; erc-scenarios-scrolltobottom-relaxed.el ends here diff --git a/test/lisp/erc/erc-scenarios-scrolltobottom.el b/test/lisp/erc/erc-scenarios-scrolltobottom.el new file mode 100644 index 00000000000..25b5c09577f --- /dev/null +++ b/test/lisp/erc/erc-scenarios-scrolltobottom.el @@ -0,0 +1,68 @@ +;;; erc-scenarios-scrolltobottom.el --- erc-scrolltobottom-mode -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-goodies) + +;; These two actually seem to run fine on Emacs 28, but skip them for +;; now to stay in sync with `erc-scenarios-scrolltobottom--relaxed'. + +(ert-deftest erc-scenarios-scrolltobottom--normal () + :tags `(:expensive-test ,@(and (getenv "ERC_TESTS_GRAPHICAL") + '(:erc--graphical))) + (when (version< emacs-version "29") (ert-skip "Times out")) + + (should-not erc-scrolltobottom-all) + + (erc-scenarios-common-scrolltobottom--normal + (lambda () + (ert-info ("New insertion doesn't anchor prompt in other window") + (let ((w (next-window))) + ;; We're at prompt but not aligned to bottom. + (should (>= (window-point w) erc-input-marker)) + (erc-d-t-wait-for 10 + (not (erc-scenarios-common--at-win-end-p w)))))))) + +(ert-deftest erc-scenarios-scrolltobottom--all () + :tags `(:expensive-test ,@(and (getenv "ERC_TESTS_GRAPHICAL") + '(:erc--graphical))) + (when (version< emacs-version "29") (ert-skip "Times out")) + + (should-not erc-scrolltobottom-all) + + (let ((erc-scrolltobottom-all t)) + + (erc-scenarios-common-scrolltobottom--normal + (lambda () + (ert-info ("New insertion anchors prompt in other window") + (let ((w (next-window))) + ;; We're at prompt and aligned to bottom. + (should (>= (window-point w) erc-input-marker)) + (erc-d-t-wait-for 10 + (erc-scenarios-common--at-win-end-p w)) + (erc-d-t-ensure-for 0.5 + (erc-scenarios-common--at-win-end-p w)))))))) + +;;; erc-scenarios-scrolltobottom.el ends here diff --git a/test/lisp/erc/erc-scenarios-services-misc.el b/test/lisp/erc/erc-scenarios-services-misc.el index a1679d302f4..1113849578f 100644 --- a/test/lisp/erc/erc-scenarios-services-misc.el +++ b/test/lisp/erc/erc-scenarios-services-misc.el @@ -143,4 +143,109 @@ (erc-services-mode -1))) +;; The server rejects your nick during registration, so ERC acquires a +;; placeholder and successfully renicks once the connection is up. +;; See also `erc-scenarios-base-renick-self-auto'. + +(ert-deftest erc-scenarios-services-misc--reconnect-retry-nick () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "services/regain") + (dumb-server (erc-d-run "localhost" t 'reconnect-retry + 'reconnect-retry-again)) + (port (process-contact dumb-server :service)) + (erc-server-auto-reconnect t) + (erc-modules `(services-regain sasl ,@erc-modules)) + (erc-services-regain-alist + '((Libera.Chat . erc-services-retry-nick-on-connect))) + (expect (erc-d-t-make-expecter))) + + ;; FIXME figure out and explain why this is so. + (should (featurep 'erc-services)) + + (ert-info ("Session succeeds but cut short") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (funcall expect 10 "Last login from") + (erc-cmd-JOIN "#test"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#test")) + (funcall expect 10 "was created on")) + + (ert-info ("Service restored") + (with-current-buffer "Libera.Chat" + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (funcall expect 10 "Connection failed!") + (funcall expect 10 "already in use") + (funcall expect 10 "changed mode for tester`") + (funcall expect 10 "Last login from") + (funcall expect 10 "Your new nickname is tester"))) + + (with-current-buffer (get-buffer "#test") + (funcall expect 10 "tester ") + (funcall expect 10 "was created on")))) + +;; This only asserts that the handler fires and issues the right +;; NickServ command, but it doesn't accurately recreate a +;; disconnection, but it probably should. +(ert-deftest erc-scenarios-services-misc--regain-command () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "services/regain") + (dumb-server (erc-d-run "localhost" t 'taken-regain)) + (port (process-contact dumb-server :service)) + (erc-server-auto-reconnect t) + (erc-modules `(services-regain sasl ,@erc-modules)) + (erc-services-regain-alist + '((ExampleNet . erc-services-issue-regain))) + (expect (erc-d-t-make-expecter))) + + (should (featurep 'erc-services)) ; see note in prior test + + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "dummy" + :user "tester" + :password "changeme" + :full-name "tester" + :id 'ExampleNet) + (funcall expect 10 "dummy is already in use, trying dummy`") + (funcall expect 10 "You are now logged in as tester") + (funcall expect 10 "-NickServ- dummy has been regained.") + (funcall expect 10 "*** Your new nickname is dummy") + ;; Works with "given" `:id'. + (should (and (erc-network) (not (eq (erc-network) 'ExampleNet))))))) + +(ert-deftest erc-scenarios-services-misc--ghost-and-retry-nick () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "services/regain") + (dumb-server (erc-d-run "localhost" t 'taken-ghost)) + (port (process-contact dumb-server :service)) + (erc-server-auto-reconnect t) + (erc-modules `(services-regain sasl ,@erc-modules)) + (erc-services-regain-alist + '((FooNet . erc-services-issue-ghost-and-retry-nick))) + (expect (erc-d-t-make-expecter))) + + (should (featurep 'erc-services)) ; see note in prior test + + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "dummy" + :user "tester" + :password "changeme" + :full-name "tester") + (funcall expect 10 "dummy is already in use, trying dummy`") + (funcall expect 10 "You are now logged in as tester") + (funcall expect 10 "-NickServ- dummy has been ghosted.") + (funcall expect 10 "*** Your new nickname is dummy")))) + ;;; erc-scenarios-services-misc.el ends here diff --git a/test/lisp/erc/erc-scenarios-stamp.el b/test/lisp/erc/erc-scenarios-stamp.el new file mode 100644 index 00000000000..e4788f78654 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-stamp.el @@ -0,0 +1,181 @@ +;;; erc-scenarios-stamp.el --- Misc `erc-stamp' scenarios -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-stamp) + +(defvar erc-scenarios-stamp--user-marker nil) + +(defun erc-scenarios-stamp--on-post-modify () + (when-let (((erc--check-msg-prop 'erc--cmd 4))) + (set-marker erc-scenarios-stamp--user-marker (point-max)) + (ert-info ("User marker correctly placed at `erc-insert-marker'") + (should (= ?\n (char-before erc-scenarios-stamp--user-marker))) + (should (= erc-scenarios-stamp--user-marker erc-insert-marker)) + (save-excursion + (goto-char erc-scenarios-stamp--user-marker) + ;; The raw message ends in " Iabefhkloqv". However, + ;; `erc-server-004' only prints up to the 5th parameter. + (should (looking-back "CEIMRUabefhiklmnoqstuv\n")))))) + +(ert-deftest erc-scenarios-stamp--left/display-margin-mode () + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc-scenarios-stamp--user-marker (make-marker)) + (erc-stamp--current-time 704591940) + (erc-stamp--tz t) + (erc-server-flood-penalty 0.1) + (erc-insert-timestamp-function #'erc-insert-timestamp-left) + (erc-modules (cons 'fill-wrap erc-modules)) + (erc-timestamp-only-if-changed-flag nil) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + + (add-hook 'erc-insert-post-hook #'erc-scenarios-stamp--on-post-modify + nil t) + (funcall expect 5 "This server is in debug mode") + + (ert-info ("Stamps appear in left margin and are invisible") + (should (eq 'erc-timestamp (field-at-pos (pos-bol)))) + (should (= (pos-bol) (field-beginning (pos-bol)))) + (should (eq 'query-notice (get-text-property (pos-bol) 'erc--msg))) + (should (eq 'NOTICE (get-text-property (pos-bol) 'erc--cmd))) + (should (= ?- (char-after (field-end (pos-bol))))) + (should (equal (get-text-property (1+ (field-end (pos-bol))) + 'erc--speaker) + "irc.foonet.org")) + (should (pcase (get-text-property (pos-bol) 'display) + (`((margin left-margin) ,s) + (eq 'timestamp (get-text-property 0 'invisible s)))))) + + ;; We set a third-party marker at the end of 004's message (on + ;; then "\n"), post-insertion. + (ert-info ("User markers untouched by subsequent message left stamp") + (save-excursion + (goto-char erc-scenarios-stamp--user-marker) + (should (looking-back "CEIMRUabefhiklmnoqstuv\n")) + (should (looking-at (rx "["))))))))) + +(ert-deftest erc-scenarios-stamp--legacy-date-stamps () + (with-suppressed-warnings ((obsolete erc-stamp-prepend-date-stamps-p)) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (erc-stamp-prepend-date-stamps-p t) + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + (funcall expect 5 "Opening connection") + (goto-char (1- (match-beginning 0))) + (should (eq 'erc-timestamp (field-at-pos (point)))) + (should (eq 'unknown (erc--get-inserted-msg-prop 'erc--msg))) + ;; Force redraw of date stamp. + (setq erc-timestamp-last-inserted-left nil) + + (funcall expect 5 "This server is in debug mode") + (while (and (zerop (forward-line -1)) + (not (eq 'erc-timestamp (field-at-pos (point)))))) + (should (erc--get-inserted-msg-prop 'erc--cmd))))))) + +;; This user-owned hook member places a marker on the first message in +;; a buffer. Inserting a date stamp in front of it shouldn't move the +;; marker. +(defun erc-scenarios-stamp--on-insert-modify () + (unless (marker-position erc-scenarios-stamp--user-marker) + (set-marker erc-scenarios-stamp--user-marker (point-min)) + (save-excursion + (goto-char erc-scenarios-stamp--user-marker) + (should (looking-at "Opening")))) + + ;; Sometime after the first message ("Opening connection.."), assert + ;; that the marker we just placed hasn't moved. + (when (erc--check-msg-prop 'erc--cmd 2) + (save-restriction + (widen) + (ert-info ("Date stamp preserves opening user marker") + (goto-char erc-scenarios-stamp--user-marker) + (should-not (eq 'erc-timestamp (field-at-pos (point)))) + (should (looking-at "Opening")) + (should (eq 'unknown (get-text-property (point) 'erc--msg)))))) + + ;; On 003 ("*** This server was created on"), clear state to force a + ;; new date stamp on the next message. + (when (erc--check-msg-prop 'erc--cmd 3) + (setq erc-timestamp-last-inserted-left nil) + (set-marker erc-scenarios-stamp--user-marker erc-insert-marker))) + +(ert-deftest erc-scenarios-stamp--date-mode/left-and-right () + + (should (eq erc-insert-timestamp-function + #'erc-insert-timestamp-left-and-right)) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/reconnect") + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc-scenarios-stamp--user-marker (make-marker)) + (erc-server-flood-penalty 0.1) + (erc-modules (if (zerop (random 2)) + (cons 'fill-wrap erc-modules) + erc-modules)) + (expect (erc-d-t-make-expecter)) + (erc-mode-hook + (cons (lambda () + (add-hook 'erc-insert-modify-hook + #'erc-scenarios-stamp--on-insert-modify -99 t)) + erc-mode-hook))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + + (funcall expect 5 "Welcome to the foonet") + (funcall expect 5 "*** AWAYLEN=390") + + (ert-info ("Date stamp preserves other user marker") + (goto-char erc-scenarios-stamp--user-marker) + (should-not (eq 'erc-timestamp (field-at-pos (point)))) + (should (looking-at (rx "*** irc.foonet.org oragono"))) + (should (eq 's004 (get-text-property (point) 'erc--msg)))) + + (funcall expect 5 "This server is in debug mode"))))) + +;;; erc-scenarios-stamp.el ends here diff --git a/test/lisp/erc/erc-scenarios-status-sidebar.el b/test/lisp/erc/erc-scenarios-status-sidebar.el new file mode 100644 index 00000000000..d447817e307 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-status-sidebar.el @@ -0,0 +1,174 @@ +;;; erc-scenarios-status-sidebar.el --- erc-sidebar/speedbar tests -*- 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/>. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-status-sidebar) + + +(ert-deftest erc-scenarios-status-sidebar--bufbar () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/gapless-connect") + (erc-server-flood-penalty 0.1) + (erc-server-flood-penalty erc-server-flood-penalty) + (erc-modules `(bufbar ,@erc-modules)) + (dumb-server (erc-d-run "localhost" t 'foonet 'barnet)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to two different endpoints") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (funcall expect 10 "MOTD File is missing")) + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "barnet:changeme" + :full-name "tester") + (funcall expect 10 "marked as being away"))) + + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#bar")) + (funcall expect 10 "was created on") + (funcall expect 2 "his second fit")) + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "#foo")) + (funcall expect 10 "was created on") + (funcall expect 2 "no use of him") + (ert-info ("Activity marker is in the right spot") + (let ((obuf (window-buffer))) ; *scratch* + (set-window-buffer (selected-window) "#foo") + (erc-d-t-wait-for 5 + (erc-status-sidebar-refresh) + (with-current-buffer "*ERC Status*" + (and (marker-position erc-status-sidebar--active-marker) + (goto-char erc-status-sidebar--active-marker) + ;; The " [N]" suffix disappears because it's selected + (search-forward "#foo" (pos-eol) t)))) + (set-window-buffer (selected-window) obuf)))) + + (with-current-buffer (erc-d-t-wait-for 20 (get-buffer "*ERC Status*")) + (ert-info ("Hierarchy printed correctly") + (funcall expect 10 "barnet [") + (funcall expect 10 "#bar [") + (funcall expect 10 "foonet [") + (funcall expect 10 "#foo"))) + + (with-current-buffer "#foo" + (ert-info ("Core toggle and kill commands work") + ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p', + ;; etc. for testing commands that call those same functions. + (should (get-buffer-window "*ERC Status*")) + (erc-bufbar-mode -1) + (should-not (get-buffer-window "*ERC Status*")) + (erc-status-sidebar-kill) + (should-not (get-buffer "*ERC Status*")))))) + +;; We can't currently run this on EMBA because it needs a usable +;; terminal, and we lack a fixture for that. Please try running this +;; test interactively with both graphical Emacs and non. +(declare-function erc-nickbar-mode "erc-speedbar" (arg)) +(declare-function erc-speedbar--get-timers "erc-speedbar" nil) +(declare-function speedbar-timer-fn "speedbar" nil) +(defvar erc-nickbar-mode) +(defvar speedbar-buffer) + +(ert-deftest erc-scenarios-status-sidebar--nickbar () + :tags `(:expensive-test :unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL") + '(:erc--graphical))) + (when noninteractive (ert-skip "Interactive only")) + + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/gapless-connect") + (erc-server-flood-penalty 0.1) + (erc-server-flood-penalty erc-server-flood-penalty) + (erc-modules `(nickbar ,@erc-modules)) + (dumb-server (erc-d-run "localhost" t 'foonet 'barnet)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to two different endpoints") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "foonet:changeme" + :full-name "tester") + (funcall expect 10 "MOTD File is missing")) + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :password "barnet:changeme" + :full-name "tester") + (funcall expect 10 "marked as being away"))) + + (erc-d-t-wait-for 20 (get-buffer "#bar")) + (with-current-buffer (pop-to-buffer "#bar") + (funcall expect 10 "was created on") + (funcall expect 2 "his second fit") + (erc-d-t-wait-for 10 (and speedbar-buffer (get-buffer speedbar-buffer))) + (speedbar-timer-fn) + (with-current-buffer speedbar-buffer + (funcall expect 10 "#bar (3)") + (funcall expect 10 '(| "@mike" "joe")) + (funcall expect 10 '(| "@mike" "joe")) + (funcall expect 10 "tester"))) + + (erc-d-t-wait-for 20 (get-buffer "#foo")) + (with-current-buffer (pop-to-buffer "#foo") + (delete-other-windows) + (funcall expect 10 "was created on") + (funcall expect 2 "no use of him") + (speedbar-timer-fn) + (with-current-buffer speedbar-buffer + (funcall expect 10 "#foo (3)") + (funcall expect 10 '(| "alice" "@bob")) + (funcall expect 10 '(| "alice" "@bob")) + (funcall expect 10 "tester"))) + + (with-current-buffer "#foo" + (ert-info ("Core toggle and kill commands work") + ;; Avoid using API, e.g., `erc-status-sidebar-buffer-exists-p', + ;; etc. for testing commands that call those same functions. + (call-interactively #'erc-nickbar-mode) + (should-not erc-nickbar-mode) + (should-not (and speedbar-buffer + (get-buffer-window speedbar-buffer))) + (should speedbar-buffer) + + (erc-nickbar-mode +1) + (should (and speedbar-buffer + (get-buffer-window speedbar-buffer))) + (should (get-buffer " SPEEDBAR")) + (erc-nickbar-mode -1) + (should-not (get-buffer " SPEEDBAR")) + (should-not erc-nickbar-mode) + (should-not (cdr (frame-list))))) + + (should-not (erc-speedbar--get-timers)))) + +;;; erc-scenarios-status-sidebar.el ends here diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index 9181a47ee3b..6cbba02a37e 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -212,39 +212,32 @@ (advice-remove 'epg-decrypt-string 'erc--auth-source-plstore) (advice-remove 'epg-find-configuration 'erc--auth-source-plstore))) -(defvar erc-services-tests--auth-source-plstore-standard-entries - '(("ba950d38118a76d71f9f0591bb373d6cb366a512" - :secret-secret t - :host "irc.gnu.org" - :user "#chan" - :port "irc") - ("7f17ca445d11158065e911a6d0f4cbf52ca250e3" - :secret-secret t - :host "my.gnu.org" - :user "#chan" - :port "irc") - ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377" - :secret-secret t - :host "GNU.chat" - :user "#chan" - :port "irc"))) - -(defvar erc-services-tests--auth-source-plstore-standard-secrets - '(("ba950d38118a76d71f9f0591bb373d6cb366a512" :secret "bar") - ("7f17ca445d11158065e911a6d0f4cbf52ca250e3" :secret "baz") - ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377" :secret "foo"))) +(defvar erc-services-tests--auth-source-plstore-standard-announced "\ +;;; public entries -*- mode: plstore -*- +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" + :secret-secret t + :host \"irc.gnu.org\" + :user \"#chan\" + :port \"irc\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" + :secret-secret t + :host \"my.gnu.org\" + :user \"#chan\" + :port \"irc\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" + :secret-secret t + :host \"GNU.chat\" + :user \"#chan\" + :port \"irc\")) +;;; secret entries +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\"))") (ert-deftest erc--auth-source-search--plstore-standard () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-entries) - "\n;;; secret entries\n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-secrets) - "\n") - + :text erc-services-tests--auth-source-plstore-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-standard @@ -254,14 +247,7 @@ (ert-deftest erc--auth-source-search--plstore-announced () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-entries) - "\n;;; secret entries\n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-secrets) - "\n") - + :text erc-services-tests--auth-source-plstore-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-announced @@ -271,29 +257,33 @@ (ert-deftest erc--auth-source-search--plstore-overrides () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat - ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - `(,@erc-services-tests--auth-source-plstore-standard-entries - ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a" - :secret-secret t :host "GNU.chat" :user "#chan" :port "6697") - ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc" - :secret-secret t :host "my.gnu.org" :user "#fsf" :port "irc") - ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d" - :secret-secret t :host "irc.gnu.org" :port "6667") - ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537" - :secret-secret t :host "MyHost" :port "irc") - ("61a6bd552059494f479ff720e8de33e22574650a" - :secret-secret t :host "MyHost" :port "6667"))) - "\n;;; secret entries\n" - (prin1-to-string - `(,@erc-services-tests--auth-source-plstore-standard-secrets - ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a" :secret "spam") - ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc" :secret "42") - ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d" :secret "sesame") - ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537" :secret "456") - ("61a6bd552059494f479ff720e8de33e22574650a" :secret "123"))) - "\n") + :text "\ +;;; public entries -*- mode: plstore -*- +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" + :secret-secret t :host \"irc.gnu.org\" :user \"#chan\" :port \"irc\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" + :secret-secret t :host \"my.gnu.org\" :user \"#chan\" :port \"irc\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" + :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"irc\") + (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\" + :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"6697\") + (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\" + :secret-secret t :host \"my.gnu.org\" :user \"#fsf\" :port \"irc\") + (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\" + :secret-secret t :host \"irc.gnu.org\" :port \"6667\") + (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\" + :secret-secret t :host \"MyHost\" :port \"irc\") + (\"61a6bd552059494f479ff720e8de33e22574650a\" + :secret-secret t :host \"MyHost\" :port \"6667\")) +;;; secret entries +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\") + (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\" :secret \"spam\") + (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\" :secret \"42\") + (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\" :secret \"sesame\") + (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\" :secret \"456\") + (\"61a6bd552059494f479ff720e8de33e22574650a\" :secret \"123\"))" (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) @@ -303,17 +293,24 @@ ;; auth-source JSON backend -(defvar erc-services-tests--auth-source-json-standard-entries - [(:host "irc.gnu.org" :port "irc" :user "#chan" :secret "bar") - (:host "my.gnu.org" :port "irc" :user "#chan" :secret "baz") - (:host "GNU.chat" :port "irc" :user "#chan" :secret "foo")]) +(defvar erc-services-tests--auth-source-json-standard-announced "\ +[{\"host\": \"irc.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"bar\"}, + {\"host\": \"my.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"baz\"}, + {\"host\": \"GNU.chat\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"foo\"}]") (ert-deftest erc--auth-source-search--json-standard () (ert-with-temp-file json-store + :text erc-services-tests--auth-source-json-standard-announced :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - erc-services-tests--auth-source-json-standard-entries)) (let ((auth-sources (list json-store)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-standard #'erc-auth-source-search)))) @@ -321,10 +318,7 @@ (ert-deftest erc--auth-source-search--json-announced () (ert-with-temp-file plstore-file :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - erc-services-tests--auth-source-json-standard-entries)) - + :text erc-services-tests--auth-source-json-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-announced #'erc-auth-source-search)))) @@ -332,16 +326,36 @@ (ert-deftest erc--auth-source-search--json-overrides () (ert-with-temp-file json-file :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - (vconcat - erc-services-tests--auth-source-json-standard-entries - [(:secret "spam" :host "GNU.chat" :user "#chan" :port "6697") - (:secret "42" :host "my.gnu.org" :user "#fsf" :port "irc") - (:secret "sesame" :host "irc.gnu.org" :port "6667") - (:secret "456" :host "MyHost" :port "irc") - (:secret "123" :host "MyHost" :port "6667")]))) - + :text "\ +[{\"host\": \"irc.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"bar\"}, + {\"host\": \"my.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"baz\"}, + {\"host\": \"GNU.chat\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"foo\"}, + {\"host\": \"GNU.chat\", + \"user\": \"#chan\", + \"port\": \"6697\", + \"secret\": \"spam\"}, + {\"host\": \"my.gnu.org\", + \"user\": \"#fsf\", + \"port\": \"irc\", + \"secret\": \"42\"}, + {\"host\": \"irc.gnu.org\", + \"port\": \"6667\", + \"secret\": \"sesame\"}, + {\"host\": \"MyHost\", + \"port\": \"irc\", + \"secret\": \"456\"}, + {\"host\": \"MyHost\", + \"port\": \"6667\", + \"secret\": \"123\"}]" (let ((auth-sources (list json-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-overrides #'erc-auth-source-search)))) @@ -370,6 +384,14 @@ ("#chan@my.gnu.org:irc" . "baz") ("#chan@GNU.chat:irc" . "foo"))) +(defun erc-services-tests--secrets-search-items (entries _ &rest r) + (mapcan (lambda (s) + (and (seq-every-p (pcase-lambda (`(,k . ,v)) + (equal v (alist-get k (cdr s)))) + (map-pairs r)) + (list (car s)))) + entries)) + (ert-deftest erc--auth-source-search--secrets-standard () (skip-unless (bound-and-true-p secrets-enabled)) (let ((auth-sources '("secrets:Test")) @@ -378,18 +400,12 @@ (secrets erc-services-tests--auth-source-secrets-standard-secrets)) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest r) - (should (equal col "Test")) - (should (plist-get r :user)) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-standard #'erc-auth-source-search)))) @@ -401,18 +417,12 @@ (secrets erc-services-tests--auth-source-secrets-standard-secrets)) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest r) - (should (equal col "Test")) - (should (plist-get r :user)) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-announced #'erc-auth-source-search)))) @@ -444,17 +454,12 @@ ("MyHost:6667" . "123")))) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest _) - (should (equal col "Test")) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-overrides #'erc-auth-source-search)))) diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el new file mode 100644 index 00000000000..3f17e36e002 --- /dev/null +++ b/test/lisp/erc/erc-stamp-tests.el @@ -0,0 +1,352 @@ +;;; erc-stamp-tests.el --- Tests for erc-stamp. -*- 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: + +;;; Code: +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + +(require 'erc-stamp) +(require 'erc-goodies) ; for `erc-make-read-only' + +;; These display-oriented tests are brittle because many factors +;; influence how text properties are applied. We should just +;; rework these into full scenarios. + +(defun erc-stamp-tests--insert-right (test) + (let ((val (list 0 0)) + (erc-insert-modify-hook '(erc-add-timestamp)) + (erc-insert-post-hook '(erc-make-read-only)) ; see comment above + (erc-timestamp-only-if-changed-flag nil) + ;; + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (advice-add 'erc-format-timestamp :filter-args + (lambda (args) (cons (cl-incf (cadr val) 60) (cdr args))) + '((name . ert-deftest--erc-timestamp-use-align-to))) + + (with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*") + (erc-mode) + (erc-munge-invisibility-spec) + (erc--initialize-markers (point) nil) + (erc-tests-common-init-server-proc "sleep" "1") + + (funcall test) + + (when noninteractive + (kill-buffer))) + + (advice-remove 'erc-format-timestamp + 'ert-deftest--erc-timestamp-use-align-to))) + +(defun erc-stamp-tests--use-align-to--nil (compat) + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("nil, normal") + (let ((erc-timestamp-use-align-to nil)) + (erc-display-message nil 'notice (current-buffer) "begin")) + (goto-char (point-min)) + (should (search-forward-regexp + (rx "begin" (+ "\t") (* " ") "[") nil t)) + ;; Field includes intervening spaces + (should (eql ?n (char-before (field-beginning (point))))) + ;; Timestamp extends to the end of the line + (should (eql ?\n (char-after (field-end (point)))))) + + ;; The option `erc-timestamp-right-column' is normally nil by + ;; default, but it's a convenient stand in for a sufficiently + ;; small `erc-fill-column' (we can force a line break without + ;; involving that module). + (should-not erc-timestamp-right-column) + + (ert-info ("nil, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to nil) + (erc-timestamp-right-column 20)) + (erc-display-message nil 'notice (current-buffer) + "twenty characters")) + (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t)) + ;; Field includes leading whitespace. + (should (eql (if compat ?\[ ?\n) + (char-after (field-beginning (point))))) + ;; Timestamp extends to the end of the line. + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-timestamp-use-align-to--nil () + (ert-info ("Field starts on stamp text (compat)") + (let ((erc-stamp--omit-properties-on-folded-lines t)) + (erc-stamp-tests--use-align-to--nil 'compat))) + (ert-info ("Field includes leaidng white space") + (erc-stamp-tests--use-align-to--nil nil))) + +(defun erc-stamp-tests--use-align-to--t (compat) + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("t, normal") + (let ((erc-timestamp-use-align-to t)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Exactly two spaces, one from format, one added by erc-stamp. + (should (search-forward "msg one [" nil t)) + ;; Field covers space between. + (should (eql ?e (char-before (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("t, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to t) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; Indented to pos (this is arguably a bug). + (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t)) + ;; Field includes leading space. + (should (eql (if compat ?\[ ?\n) (char-after (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-timestamp-use-align-to--t () + (ert-info ("Field starts on stamp text (compat)") + (let ((erc-stamp--omit-properties-on-folded-lines t)) + (erc-stamp-tests--use-align-to--t 'compat))) + (ert-info ("Field includes leaidng white space") + (erc-stamp-tests--use-align-to--t nil))) + +(ert-deftest erc-timestamp-use-align-to--integer () + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("integer, normal") + (let ((erc-timestamp-use-align-to 1)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Space not added because included in format string. + (should (search-forward "msg one [" nil t)) + ;; Field covers space between. + (should (eql ?e (char-before (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("integer, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to 1) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; No hard wrap + (should (search-forward "oooo [" nil t)) + ;; Field starts at leading space. + (should (eql ?\s (char-after (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-stamp--display-margin-mode--right () + (erc-stamp-tests--insert-right + (lambda () + (erc-stamp--display-margin-mode +1) + + (ert-info ("margin, normal") + (let ((erc-timestamp-use-align-to 'margin)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (put-text-property 0 (length msg) 'wrap-prefix 10 msg) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Space not added (treated as opaque string). + (should (search-forward "msg one[" nil t)) + ;; Field covers stamp alone + (should (eql ?e (char-before (field-beginning (point))))) + ;; Vanity props extended + (should (get-text-property (field-beginning (point)) 'wrap-prefix)) + (should (get-text-property (1+ (field-beginning (point))) 'wrap-prefix)) + (should (get-text-property (1- (field-end (point))) 'wrap-prefix)) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("margin, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to 'margin) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; No hard wrap + (should (search-forward "oooo[" nil t)) + ;; Field starts at format string (right bracket) + (should (eql ?\[ (char-after (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +;; This concerns a proposed partial reversal of the changes resulting +;; from: +;; +;; 24.1.50; Wrong behavior of move-end-of-line in ERC (Bug#11706) +;; +;; Perhaps core behavior has changed since this bug was reported, but +;; C-e stopping one char short of EOL no longer seems a problem. +;; However, invoking C-n (`next-line') exhibits a similar effect. +;; When point is in a stamp or near the beginning of a line, issuing a +;; C-n puts point one past the start of the message (i.e., two chars +;; beyond the timestamp's closing "]". Dropping the invisible +;; property when timestamps are hidden does indeed prevent this, but +;; it's also a lasting commitment. The docs mention that it's +;; pointless to pair the old `intangible' property with `invisible' +;; and suggest users look at `cursor-intangible-mode'. Turning off +;; the latter does indeed do the trick as does decrementing the end of +;; the `cursor-intangible' interval so that, in addition to C-n +;; working, a C-f from before the timestamp doesn't overshoot. This +;; appears to be the case whether `erc-hide-timestamps' is enabled or +;; not, but it may be inadvisable for some reason (a hack) and +;; therefore warrants further investigation. +;; +;; Note some striking omissions here: +;; +;; 1. a lack of `fill' module integration (we simulate it by +;; making lines short enough to not wrap) +;; 2. functions like `line-move' behave differently when +;; `noninteractive' +;; 3. no actual test assertions involving `cursor-sensor' movement +;; even though that's a huge ingredient + +(ert-deftest erc-timestamp-intangible--left () + (let ((erc-timestamp-only-if-changed-flag nil) + (erc-timestamp-intangible t) ; default changed to nil in 2014 + (erc-hide-timestamps t) + (erc-insert-timestamp-function 'erc-insert-timestamp-left) + (erc-insert-modify-hook '(erc-make-read-only erc-add-timestamp)) + msg + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (should (not cursor-sensor-inhibit)) + + (erc-mode) + (erc-tests-common-init-server-proc "true") + (with-current-buffer (get-buffer-create "*erc-timestamp-intangible*") + (erc-mode) + (erc--initialize-markers (point) nil) + (erc-munge-invisibility-spec) + (erc-display-message nil 'notice (current-buffer) "Welcome") + ;; + ;; Pretend `fill' is active and that these lines are + ;; folded. Otherwise, there's an annoying issue on wrapped lines + ;; (when visual-line-mode is off and stamps are visible) where + ;; C-e sends you to the end of the previous line. + (setq msg "Lorem ipsum dolor sit amet") + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "alyssa" msg nil t)) + (erc-display-message nil 'notice (current-buffer) "Home") + (goto-char (point-min)) + + ;; EOL is actually EOL (Bug#11706) + + (ert-info ("Notice before stamp, C-e") ; first line/stamp + (should (search-forward "Welcome" nil t)) + (ert-simulate-command '(erc-bol)) + (should (looking-at (rx "["))) + (let ((end (pos-eol))) ; `line-end-position' fails because fields + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (ert-info ("Privmsg before stamp, C-e") + (should (search-forward "Lorem" nil t)) + (goto-char (pos-bol)) + (should (looking-at (rx "["))) + (let ((end (pos-eol))) + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (ert-info ("Privmsg first line, C-e") + (goto-char (pos-bol)) + (should (search-forward "ipsum" nil t)) + (let ((end (pos-eol))) + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (when noninteractive + (kill-buffer))))) + +(ert-deftest erc-echo-timestamp () + :tags (and (null (getenv "CI")) '(:unstable)) + + (should-not erc-echo-timestamps) + (should-not erc-stamp--last-stamp) + (insert (propertize "a" 'erc--ts 433483200 'erc--msg 'msg) "bc") + (goto-char (point-min)) + (let ((inhibit-message t) + (erc-echo-timestamp-format "%Y-%m-%d %H:%M:%S %Z") + (erc-echo-timestamp-zone (list (* 60 60 -4) "EDT"))) + + ;; No-op when non-interactive and option is nil + (should-not (erc--echo-ts-csf nil nil 'entered)) + (should-not erc-stamp--last-stamp) + + ;; Non-interactive (cursor sensor function) + (let ((erc-echo-timestamps t)) + (should (equal (erc--echo-ts-csf nil nil 'entered) + "1983-09-27 00:00:00 EDT"))) + (should (= 433483200 erc-stamp--last-stamp)) + + ;; Interactive + (should (equal (call-interactively #'erc-echo-timestamp) + "1983-09-27 00:00:00 EDT")) + ;; Interactive with zone + (let ((current-prefix-arg '(4))) + (should (member (call-interactively #'erc-echo-timestamp) + '("1983-09-27 04:00:00 GMT" + "1983-09-27 04:00:00 UTC")))) + (let ((current-prefix-arg -7)) + (should (equal (call-interactively #'erc-echo-timestamp) + "1983-09-26 21:00:00 -07"))))) + +(defun erc-stamp-tests--assert-get-inserted-msg/stamp (test-fn) + (let ((erc-insert-modify-hook erc-insert-modify-hook) + (erc-insert-timestamp-function 'erc-insert-timestamp-right) + (erc-timestamp-use-align-to 0) + (erc-timestamp-format "[00:00]")) + (cl-pushnew 'erc-add-timestamp erc-insert-modify-hook) + (erc-tests-common-get-inserted-msg-setup)) + (goto-char 19) + (should (looking-back (rx "<bob> hi [00:00]"))) + (erc-tests-common-assert-get-inserted-msg 3 19 test-fn)) + +(ert-deftest erc--get-inserted-msg-beg/stamp () + (erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg)))))) + +(ert-deftest erc--get-inserted-msg-beg/readonly/stamp () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg)))))) + +(ert-deftest erc--get-inserted-msg-end/stamp () + (erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) (should (= 19 (erc--get-inserted-msg-end arg)))))) + +(ert-deftest erc--get-inserted-msg-end/readonly/stamp () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) (should (= 19 (erc--get-inserted-msg-end arg)))))) + +(ert-deftest erc--get-inserted-msg-bounds/stamp () + (erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) + (should (equal '(3 . 19) (erc--get-inserted-msg-bounds arg)))))) + +(ert-deftest erc--get-inserted-msg-bounds/readonly/stamp () + (erc-tests-common-assert-get-inserted-msg-readonly-with + #'erc-stamp-tests--assert-get-inserted-msg/stamp + (lambda (arg) + (should (equal '(3 . 19) (erc--get-inserted-msg-bounds arg)))))) + +;;; erc-stamp-tests.el ends here diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index d6c63934163..bf93379b117 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -22,7 +22,10 @@ ;;; Code: (require 'ert-x) -(require 'erc) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-tests-common))) + (require 'erc-ring) (ert-deftest erc--read-time-period () @@ -69,26 +72,25 @@ (with-current-buffer (get-buffer-create "#foo") (erc-mode) (setq erc-server-process proc-exnet) - (setq erc-default-recipients '("#foo"))) + (setq erc--target (erc--target-from-string "#foo"))) (with-current-buffer (get-buffer-create "#spam") (erc-mode) (setq erc-server-process proc-onet) - (setq erc-default-recipients '("#spam"))) + (setq erc--target (erc--target-from-string "#spam"))) (with-current-buffer (get-buffer-create "#bar") (erc-mode) (setq erc-server-process proc-onet) - (setq erc-default-recipients '("#bar"))) + (setq erc--target (erc--target-from-string "#bar"))) (with-current-buffer (get-buffer-create "#baz") (erc-mode) (setq erc-server-process proc-exnet) - (setq erc-default-recipients '("#baz"))) + (setq erc--target (erc--target-from-string "#baz"))) (should (eq (get-buffer-process "ExampleNet") proc-exnet)) - (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet") - nil + (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet") nil (kill-buffer)) (should-not (get-buffer "ExampleNet")) @@ -102,8 +104,7 @@ (calls 0) (get-test (lambda () (cl-incf calls) test))) - (erc-with-all-buffers-of-server proc-onet - (funcall get-test) + (erc-with-all-buffers-of-server proc-onet (funcall get-test) (kill-buffer)) (should (= calls 1))) @@ -113,36 +114,66 @@ (should (get-buffer "#spam")) (kill-buffer "#spam"))) -(defun erc-tests--send-prep () - ;; Caller should probably shadow `erc-insert-modify-hook' or - ;; populate user tables for erc-button. - (erc-mode) - (insert "\n\n") - (setq erc-input-marker (make-marker) - erc-insert-marker (make-marker)) - (set-marker erc-insert-marker (point-max)) - (erc-display-prompt) - (should (= (point) erc-input-marker))) - -(defun erc-tests--set-fake-server-process (&rest args) - (setq erc-server-process - (apply #'start-process (car args) (current-buffer) args)) - (set-process-query-on-exit-flag erc-server-process nil)) +(ert-deftest erc-with-server-buffer () + (setq erc-away 1) + (erc-tests-common-init-server-proc "sleep" "1") + + (let (mockingp calls) + (advice-add 'buffer-local-value :after + (lambda (&rest r) (when mockingp (push r calls))) + '((name . erc-with-server-buffer))) + + (should (= 1 (prog2 (setq mockingp t) + (erc-with-server-buffer erc-away) + (setq mockingp nil)))) + + (should (equal (pop calls) (list 'erc-away (current-buffer)))) + + (should (= 1 (prog2 (setq mockingp t) + (erc-with-server-buffer (ignore 'me) erc-away) + (setq mockingp nil)))) + (should-not calls) + + (advice-remove 'buffer-local-value 'erc-with-server-buffer))) + +(ert-deftest erc--with-dependent-type-match () + (should (equal (macroexpand-1 + '(erc--with-dependent-type-match (repeat face) erc-match)) + '(backquote-list* + 'repeat :match (lambda (w v) + (require 'erc-match) + (widget-editable-list-match w v)) + '(face))))) + +(ert-deftest erc--doarray () + (let ((array "abcdefg") + out) + ;; No return form. + (should-not (erc--doarray (c array) (push c out))) + (should (equal out '(?g ?f ?e ?d ?c ?b ?a))) + + ;; Return form evaluated upon completion. + (setq out nil) + (should (= 42 (erc--doarray (c array (+ 39 (length out))) + (when (cl-evenp c) (push c out))))) + (should (equal out '(?f ?d ?b))))) (ert-deftest erc-hide-prompt () - (let (erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (let ((erc-hide-prompt erc-hide-prompt) + ;; + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) (with-current-buffer (get-buffer-create "ServNet") - (erc-tests--send-prep) + (erc-tests-common-prep-for-insertion) (goto-char erc-insert-marker) (should (looking-at-p (regexp-quote erc-prompt))) - (erc-tests--set-fake-server-process "sleep" "1") + (erc-tests-common-init-server-proc "sleep" "1") (set-process-sentinel erc-server-process #'ignore) (setq erc-network 'ServNet) (set-process-query-on-exit-flag erc-server-process nil)) (with-current-buffer (get-buffer-create "#chan") - (erc-tests--send-prep) + (erc-tests-common-prep-for-insertion) (goto-char erc-insert-marker) (should (looking-at-p (regexp-quote erc-prompt))) (setq erc-server-process (buffer-local-value 'erc-server-process @@ -150,7 +181,7 @@ erc--target (erc--target-from-string "#chan"))) (with-current-buffer (get-buffer-create "bob") - (erc-tests--send-prep) + (erc-tests-common-prep-for-insertion) (goto-char erc-insert-marker) (should (looking-at-p (regexp-quote erc-prompt))) (setq erc-server-process (buffer-local-value 'erc-server-process @@ -162,101 +193,291 @@ (with-current-buffer "ServNet" (should (= (point) erc-insert-marker)) (erc--hide-prompt erc-server-process) - (should (string= ">" (get-text-property (point) 'display)))) + (should (string= ">" (get-char-property (point) 'display)))) (with-current-buffer "#chan" (goto-char erc-insert-marker) - (should (string= ">" (get-text-property (point) 'display))) + (should (string= ">" (get-char-property (point) 'display))) (should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook)) (goto-char erc-input-marker) (ert-simulate-command '(self-insert-command 1 ?/)) (goto-char erc-insert-marker) - (should-not (get-text-property (point) 'display)) + (should-not (get-char-property (point) 'display)) (should-not (memq #'erc--unhide-prompt-on-self-insert pre-command-hook))) (with-current-buffer "bob" (goto-char erc-insert-marker) - (should (string= ">" (get-text-property (point) 'display))) + (should (string= ">" (get-char-property (point) 'display))) (should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook)) (goto-char erc-input-marker) (ert-simulate-command '(self-insert-command 1 ?/)) (goto-char erc-insert-marker) - (should-not (get-text-property (point) 'display)) + (should-not (get-char-property (point) 'display)) (should-not (memq #'erc--unhide-prompt-on-self-insert pre-command-hook))) (with-current-buffer "ServNet" - (should (get-text-property erc-insert-marker 'display)) + (should (get-char-property erc-insert-marker 'display)) (should (memq #'erc--unhide-prompt-on-self-insert pre-command-hook)) (erc--unhide-prompt) (should-not (memq #'erc--unhide-prompt-on-self-insert pre-command-hook)) - (should-not (get-text-property erc-insert-marker 'display)))) + (should-not (get-char-property erc-insert-marker 'display)))) (ert-info ("Value: server") (setq erc-hide-prompt '(server)) (with-current-buffer "ServNet" (erc--hide-prompt erc-server-process) - (should (string= ">" (get-text-property erc-insert-marker 'display)))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden)) + (should (string= ">" (get-char-property erc-insert-marker 'display)))) (with-current-buffer "#chan" - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "bob" - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "ServNet" (erc--unhide-prompt) - (should-not (get-text-property erc-insert-marker 'display)))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) t)) + (should-not (get-char-property erc-insert-marker 'display)))) (ert-info ("Value: channel") (setq erc-hide-prompt '(channel)) (with-current-buffer "ServNet" (erc--hide-prompt erc-server-process) - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "bob" - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "#chan" - (should (string= ">" (get-text-property erc-insert-marker 'display))) + (should (string= ">" (get-char-property erc-insert-marker 'display))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden)) (erc--unhide-prompt) - (should-not (get-text-property erc-insert-marker 'display)))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) t)) + (should-not (get-char-property erc-insert-marker 'display)))) (ert-info ("Value: query") (setq erc-hide-prompt '(query)) (with-current-buffer "ServNet" (erc--hide-prompt erc-server-process) - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "bob" - (should (string= ">" (get-text-property erc-insert-marker 'display))) + (should (string= ">" (get-char-property erc-insert-marker 'display))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) 'hidden)) (erc--unhide-prompt) - (should-not (get-text-property erc-insert-marker 'display))) + (should (eq (get-text-property erc-insert-marker 'erc-prompt) t)) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "#chan" - (should-not (get-text-property erc-insert-marker 'display)))) + (should-not (get-char-property erc-insert-marker 'display)))) (ert-info ("Value: nil") (setq erc-hide-prompt nil) (with-current-buffer "ServNet" (erc--hide-prompt erc-server-process) - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "bob" - (should-not (get-text-property erc-insert-marker 'display))) + (should-not (get-char-property erc-insert-marker 'display))) (with-current-buffer "#chan" - (should-not (get-text-property erc-insert-marker 'display)) + (should-not (get-char-property erc-insert-marker 'display)) (erc--unhide-prompt) ; won't blow up when prompt already showing - (should-not (get-text-property erc-insert-marker 'display)))) + (should-not (get-char-property erc-insert-marker 'display)))) (when noninteractive (kill-buffer "#chan") (kill-buffer "bob") (kill-buffer "ServNet")))) +(ert-deftest erc--refresh-prompt () + (let* ((counter 0) + (erc-prompt (lambda () + (format "%s %d>" + (erc-format-target-and/or-network) + (cl-incf counter)))) + erc-accidental-paste-threshold-seconds + erc-insert-modify-hook + (erc-modules (remq 'stamp erc-modules)) + (erc-send-input-line-function #'ignore) + (erc--input-review-functions erc--input-review-functions) + erc-send-completed-hook) + + (ert-info ("Server buffer") + (with-current-buffer (get-buffer-create "ServNet") + (erc-tests-common-prep-for-insertion) + (goto-char erc-insert-marker) + (should (looking-at-p "ServNet 3>")) + (erc-tests-common-init-server-proc "sleep" "1") + (set-process-sentinel erc-server-process #'ignore) + (setq erc-network 'ServNet + erc-server-current-nick "tester" + erc-networks--id (erc-networks--id-create nil) + erc-server-users (make-hash-table :test 'equal)) + (set-process-query-on-exit-flag erc-server-process nil) + ;; Incoming message redraws prompt + (erc-display-message nil 'notice nil "Welcome") + (should (looking-at-p (rx "*** Welcome"))) + (forward-line) + (should (looking-at-p "ServNet 4>")) + ;; Say something + (goto-char erc-input-marker) + (insert "Howdy") + (erc-send-current-line) + (save-excursion (forward-line -1) + (should (looking-at (rx "*** No target"))) + (forward-line -1) + (should (looking-at "<tester> Howdy"))) + (should (looking-back "ServNet 6> ")) + (should (= erc-input-marker (point))) + ;; Space after prompt is unpropertized + (should (get-text-property (1- erc-input-marker) 'erc-prompt)) + (should-not (get-text-property erc-input-marker 'erc-prompt)) + ;; No sign of old prompts + (save-excursion + (goto-char (point-min)) + (should-not (search-forward (rx (any "3-5") ">") nil t))))) + + (ert-info ("Channel buffer") + (with-current-buffer (get-buffer-create "#chan") + (erc-tests-common-prep-for-insertion) + (goto-char erc-insert-marker) + (should (looking-at-p "#chan 9>")) + (goto-char erc-input-marker) + (setq erc-server-process (buffer-local-value 'erc-server-process + (get-buffer "ServNet")) + erc-networks--id (erc-with-server-buffer erc-networks--id) + erc--target (erc--target-from-string "#chan") + erc-default-recipients (list "#chan") + erc-channel-users (make-hash-table :test 'equal)) + (erc-update-current-channel-member "alice" "alice") + (erc-update-current-channel-member "bob" "bob") + (erc-update-current-channel-member "tester" "tester") + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "alice" "Hi" nil t)) + (should (looking-back "#chan@ServNet 10> ")) + (goto-char erc-input-marker) + (insert "Howdy") + (erc-send-current-line) + (save-excursion (forward-line -1) + (should (looking-at "<tester> Howdy"))) + (should (looking-back "#chan@ServNet 11> ")) + (should (= (point) erc-input-marker)) + (insert "/query bob") + (let (erc-modules) + (erc-send-current-line)) + ;; Last command not inserted + (save-excursion (forward-line -1) + (should (looking-at "<tester> Howdy"))) + ;; Query does not redraw (nor /help, only message input) + (should (looking-back "#chan@ServNet 11> ")) + ;; No sign of old prompts + (save-excursion + (goto-char (point-min)) + (should-not (search-forward (rx (or "9" "10") ">") nil t))))) + + (ert-info ("Query buffer") + (with-current-buffer (get-buffer "bob") + (goto-char erc-insert-marker) + (should (looking-at-p "bob@ServNet 14>")) + (goto-char erc-input-marker) + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "bob" "Hi" nil t)) + (should (looking-back "bob@ServNet 15> ")) + (goto-char erc-input-marker) + (insert "Howdy") + (erc-send-current-line) + (save-excursion (forward-line -1) + (should (looking-at "<tester> Howdy"))) + (should (looking-back "bob@ServNet 16> ")) + ;; No sign of old prompts + (save-excursion + (goto-char (point-min)) + (should-not (search-forward (rx (or "14" "15") ">") nil t))))) + + (when noninteractive + (kill-buffer "#chan") + (kill-buffer "bob") + (kill-buffer "ServNet")))) + +(ert-deftest erc--initialize-markers () + (let ((proc (start-process "true" (current-buffer) "true")) + erc-modules + erc-connect-pre-hook + erc-insert-modify-hook + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (set-process-query-on-exit-flag proc nil) + (erc-mode) + (setq erc-server-process proc + erc-networks--id (erc-networks--id-create 'foonet)) + (erc-open "localhost" 6667 "tester" "Tester" nil + "fake" nil "#chan" proc nil "user" nil) + (with-current-buffer (should (get-buffer "#chan")) + (should (= ?\n (char-after 1))) + (should (= ?E (char-after erc-insert-marker))) + (should (= 3 (marker-position erc-insert-marker))) + (should (= 8 (marker-position erc-input-marker))) + (should (= 8 (point-max))) + (should (= 8 (point))) + ;; These prompt properties are a continual source of confusion. + ;; Including the literal defaults here can hopefully serve as a + ;; quick reference for anyone operating in that area. + (should (equal (buffer-string) + #("\n\nERC> " + 2 6 ( font-lock-face erc-prompt-face + rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t) + 6 7 ( rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t)))) + + ;; Simulate some activity by inserting some text before and + ;; after the prompt (multiline). + (erc-display-error-notice nil "Welcome") + (goto-char (point-max)) + (insert "Hello\nWorld") + (goto-char 3) + (should (looking-at-p (regexp-quote "*** Welcome")))) + + (ert-info ("Reconnect") + (with-current-buffer (erc-server-buffer) + (erc-open "localhost" 6667 "tester" "Tester" nil + "fake" nil "#chan" proc nil "user" nil)) + (should-not (get-buffer "#chan<2>"))) + + (ert-info ("Existing prompt respected") + (with-current-buffer (should (get-buffer "#chan")) + (should (= ?\n (char-after 1))) + (should (= ?E (char-after erc-insert-marker))) + (should (= 15 (marker-position erc-insert-marker))) + (should (= 20 (marker-position erc-input-marker))) + (should (= 3 (point))) ; point restored + (should (equal (buffer-string) + #("\n\n*** Welcome\nERC> Hello\nWorld" + 2 13 (font-lock-face erc-error-face) + 14 18 ( font-lock-face erc-prompt-face + rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t) + 18 19 ( rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t)))) + (when noninteractive + (kill-buffer)))))) + (ert-deftest erc--switch-to-buffer () (defvar erc-modified-channels-alist) ; lisp/erc/erc-track.el @@ -314,6 +535,80 @@ (dolist (b '("server" "other" "#chan" "#foo" "#fake")) (kill-buffer b)))) +(ert-deftest erc-setup-buffer--custom-action () + (erc-mode) + (erc-tests-common-init-server-proc "sleep" "1") + (setq erc--server-last-reconnect-count 0) + (let ((owin (selected-window)) + (obuf (window-buffer)) + (mbuf (messages-buffer)) + calls) + (cl-letf (((symbol-function 'switch-to-buffer) ; regression + (lambda (&rest r) (push (cons 'switch-to-buffer r) calls))) + ((symbol-function 'erc--test-fun) + (lambda (&rest r) (push (cons 'erc--test-fun r) calls))) + ((symbol-function 'display-buffer) + (lambda (&rest r) (push (cons 'display-buffer r) calls)))) + + ;; Baseline + (let ((erc-join-buffer 'bury)) + (erc-setup-buffer mbuf) + (should-not calls)) + + (should-not erc--display-context) + + ;; `display-buffer' + (let ((erc--display-context '((erc-buffer-display . 1))) + (erc-join-buffer 'erc--test-fun)) + (erc-setup-buffer mbuf) + (should (equal `(erc--test-fun ,mbuf (nil (erc-buffer-display . 1))) + (pop calls))) + (should-not calls)) + + ;; `pop-to-buffer' with `erc-auto-reconnect-display' + (let* ((erc--server-last-reconnect-count 1) + (erc--display-context '((erc-buffer-display . 1))) + (erc-auto-reconnect-display 'erc--test-fun)) + (erc-setup-buffer mbuf) + (should (equal `(erc--test-fun ,mbuf + (nil (erc-auto-reconnect-display . t) + (erc-buffer-display . 1))) + (pop calls))) + (should-not calls))) + + ;; Mimic simplistic version of example in "(erc) display-buffer". + (when (>= emacs-major-version 29) + (let ((proc erc-server-process)) + (with-temp-buffer + (should-not (eq (window-buffer) (current-buffer))) + (erc-mode) + (setq erc-server-process proc) + + (cl-letf (((symbol-function 'erc--test-fun-p) + (lambda (buf action) + (should (eql 1 (alist-get 'erc-buffer-display action))) + (push (cons 'erc--test-fun-p buf) calls))) + ((symbol-function 'action-fn) + (lambda (buf action) + (should (eql 1 (alist-get 'erc-buffer-display action))) + (should (eql 42 (alist-get 'foo action))) + (push (cons 'action-fn buf) calls) + (selected-window)))) + + (let ((erc--display-context '((erc-buffer-display . 1))) + (display-buffer-alist + `(((and (major-mode . erc-mode) erc--test-fun-p) + action-fn (foo . 42)))) + (erc-buffer-display 'display-buffer)) + + (erc-setup-buffer (current-buffer)) + (should (equal 'action-fn (car (pop calls)))) + (should (equal 'erc--test-fun-p (car (pop calls)))) + (should-not calls)))))) + + (should (eq owin (selected-window))) + (should (eq obuf (window-buffer))))) + (ert-deftest erc-lurker-maybe-trim () (let (erc-lurker-trim-nicks (erc-lurker-ignore-chars "_`")) @@ -327,6 +622,339 @@ (setq erc-lurker-ignore-chars "_-`") ; set of chars, not character alts (should (string= "nick" (erc-lurker-maybe-trim "nick-_`"))))) +(ert-deftest erc-parse-user () + (should (equal '("" "" "") (erc-parse-user "!@"))) + (should (equal '("" "!" "") (erc-parse-user "!!@"))) + (should (equal '("" "" "@") (erc-parse-user "!@@"))) + (should (equal '("" "!" "@") (erc-parse-user "!!@@"))) + + (should (equal '("abc" "" "") (erc-parse-user "abc"))) + (should (equal '("" "123" "fake") (erc-parse-user "!123@fake"))) + (should (equal '("abc" "" "123") (erc-parse-user "abc!123"))) + + (should (equal '("abc" "123" "fake") (erc-parse-user "abc!123@fake"))) + (should (equal '("abc" "!123" "@xy") (erc-parse-user "abc!!123@@xy"))) + + (should (equal '("de" "fg" "xy") (erc-parse-user "abc\nde!fg@xy")))) + +(ert-deftest erc--parse-nuh () + (should (equal '(nil nil nil) (erc--parse-nuh "!@"))) + (should (equal '(nil nil nil) (erc--parse-nuh "@"))) + (should (equal '(nil nil nil) (erc--parse-nuh "!"))) + (should (equal '(nil "!" nil) (erc--parse-nuh "!!@"))) + (should (equal '(nil "@" nil) (erc--parse-nuh "!@@"))) + (should (equal '(nil "!@" nil) (erc--parse-nuh "!!@@"))) + + (should (equal '("abc" nil nil) (erc--parse-nuh "abc!"))) + (should (equal '(nil "abc" nil) (erc--parse-nuh "abc@"))) + (should (equal '(nil "abc" nil) (erc--parse-nuh "!abc@"))) + + (should (equal '("abc" "123" "fake") (erc--parse-nuh "abc!123@fake"))) + (should (equal '("abc" "!123@" "xy") (erc--parse-nuh "abc!!123@@xy"))) + + ;; Missing leading components. + (should (equal '(nil "abc" "123") (erc--parse-nuh "abc@123"))) + (should (equal '(nil "123" "fake") (erc--parse-nuh "!123@fake"))) + (should (equal '(nil nil "gnu.org") (erc--parse-nuh "@gnu.org"))) + + ;; Host "wins" over nick and user (sans "@"). + (should (equal '(nil nil "abc") (erc--parse-nuh "abc"))) + (should (equal '(nil nil "gnu.org") (erc--parse-nuh "gnu.org"))) + (should (equal '(nil nil "gnu.org") (erc--parse-nuh "!gnu.org"))) + (should (equal '("abc" nil "123") (erc--parse-nuh "abc!123"))) + + ;; No fallback behavior. + (should-not (erc--parse-nuh "abc\nde!fg@xy"))) + +(ert-deftest erc--parsed-prefix () + (erc-tests-common-make-server-buf (buffer-name)) + + ;; Uses fallback values when no PREFIX parameter yet received, thus + ;; ensuring caller can use slot accessors immediately instead of + ;; checking if null beforehand. + (should-not erc--parsed-prefix) + (should (equal (erc--parsed-prefix) + #s(erc--parsed-prefix nil "qaohv" "~&@%+" + ((?q . ?~) (?a . ?&) + (?o . ?@) (?h . ?%) (?v . ?+))))) + (let ((cached (should erc--parsed-prefix))) + (should (eq (erc--parsed-prefix) cached))) + + ;; Cache broken. (Notice not setting `erc--parsed-prefix' to nil). + (setq erc-server-parameters '(("PREFIX" . "(ov)@+"))) + + (let ((proc erc-server-process) + (expected '((?o . ?@) (?v . ?+))) + cached) + + (with-temp-buffer + (erc-mode) + (setq erc-server-process proc) + (should (equal expected + (erc--parsed-prefix-alist (erc--parsed-prefix))))) + + (should (equal expected (erc--parsed-prefix-alist erc--parsed-prefix))) + (setq cached erc--parsed-prefix) + (should (equal cached + #s(erc--parsed-prefix ("(ov)@+") "ov" "@+" + ((?o . ?@) (?v . ?+))))) + ;; Second target buffer reuses cached value. + (with-temp-buffer + (erc-mode) + (setq erc-server-process proc) + (should (eq cached (erc--parsed-prefix)))) + + ;; New value computed when cache broken. + (puthash 'PREFIX (list "(qh)~%") erc--isupport-params) + (with-temp-buffer + (erc-mode) + (setq erc-server-process proc) + (should-not (eq cached (erc--parsed-prefix))) + (should (equal (erc--parsed-prefix-alist + (erc-with-server-buffer erc--parsed-prefix)) + '((?q . ?~) (?h . ?%))))))) + +;; This exists as a reference to assert legacy behavior in order to +;; preserve and incorporate it as a fallback in the 5.6+ replacement. +(ert-deftest erc-parse-modes () + (with-suppressed-warnings ((obsolete erc-parse-modes)) + (should (equal (erc-parse-modes "+u") '(("u") nil nil))) + (should (equal (erc-parse-modes "-u") '(nil ("u") nil))) + (should (equal (erc-parse-modes "+o bob") '(nil nil (("o" on "bob"))))) + (should (equal (erc-parse-modes "-o bob") '(nil nil (("o" off "bob"))))) + (should (equal (erc-parse-modes "+uo bob") '(("u") nil (("o" on "bob"))))) + (should (equal (erc-parse-modes "+o-u bob") '(nil ("u") (("o" on "bob"))))) + (should (equal (erc-parse-modes "+uo-tv bob alice") + '(("u") ("t") (("o" on "bob") ("v" off "alice"))))) + + (ert-info ("Modes of type B are always grouped as unary") + (should (equal (erc-parse-modes "+k h2") '(nil nil (("k" on "h2"))))) + ;; Channel key args are thrown away. + (should (equal (erc-parse-modes "-k *") '(nil nil (("k" off nil)))))) + + (ert-info ("Modes of type C are grouped as unary even when disabling") + (should (equal (erc-parse-modes "+l 3") '(nil nil (("l" on "3"))))) + (should (equal (erc-parse-modes "-l") '(nil nil (("l" off nil)))))))) + +(ert-deftest erc--update-channel-modes () + (erc-mode) + (setq erc-channel-users (make-hash-table :test #'equal) + erc-server-users (make-hash-table :test #'equal) + erc--isupport-params (make-hash-table) + erc--target (erc--target-from-string "#test")) + (erc-tests-common-init-server-proc "sleep" "1") + + (let ((orig-handle-fn (symbol-function 'erc--handle-channel-mode)) + calls) + (cl-letf (((symbol-function 'erc--handle-channel-mode) + (lambda (&rest r) (push r calls) (apply orig-handle-fn r))) + ((symbol-function 'erc-update-mode-line) #'ignore)) + + (ert-info ("Unknown user not created") + (erc--update-channel-modes "+o" "bob") + (should-not (erc-get-channel-user "bob"))) + + (ert-info ("Status updated when user known") + (puthash "bob" (cons (erc-add-server-user + "bob" (make-erc-server-user + :nickname "bob" + :buffers (list (current-buffer)))) + (make-erc-channel-user)) + erc-channel-users) + ;; Also asserts fallback behavior for traditional prefixes. + (should-not (erc-channel-user-op-p "bob")) + (erc--update-channel-modes "+o" "bob") + (should (erc-channel-user-op-p "bob")) + (erc--update-channel-modes "-o" "bob") ; status revoked + (should-not (erc-channel-user-op-p "bob"))) + + (ert-info ("Unknown nullary added and removed") + (should-not erc--channel-modes) + (should-not erc-channel-modes) + (erc--update-channel-modes "+u") + (should (equal erc-channel-modes '("u"))) + (should (eq t (gethash ?u erc--channel-modes))) + (should (equal (pop calls) '(?d ?u t nil))) + (erc--update-channel-modes "-u") + (should (equal (pop calls) '(?d ?u nil nil))) + (should-not (gethash ?u erc--channel-modes)) + (should-not erc-channel-modes) + (should-not calls)) + + (ert-info ("Fallback for Type B includes mode letter k") + (erc--update-channel-modes "+k" "h2") + (should (equal (pop calls) '(?b ?k t "h2"))) + (should-not erc-channel-modes) + (should (equal "h2" (gethash ?k erc--channel-modes))) + (erc--update-channel-modes "-k" "*") + (should (equal (pop calls) '(?b ?k nil "*"))) + (should-not calls) + (should-not (gethash ?k erc--channel-modes)) + (should-not erc-channel-modes)) + + (ert-info ("Fallback for Type C includes mode letter l") + (erc--update-channel-modes "+l" "3") + (should (equal (pop calls) '(?c ?l t "3"))) + (should-not erc-channel-modes) + (should (equal "3" (gethash ?l erc--channel-modes))) + (erc--update-channel-modes "-l" nil) + (should (equal (pop calls) '(?c ?l nil nil))) + (should-not (gethash ?l erc--channel-modes)) + (should-not erc-channel-modes)) + + (ert-info ("Advertised supersedes heuristics") + (setq erc-server-parameters + '(("PREFIX" . "(ov)@+") + ;; Add phony 5th type for this CHANMODES value for + ;; robustness in case some server gets creative. + ("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz,FAKE"))) + (erc--update-channel-modes "+qu" "fool!*@*") + (should (equal (pop calls) '(?d ?u t nil))) + (should (equal (pop calls) '(?a ?q t "fool!*@*"))) + (should (equal 1 (gethash ?q erc--channel-modes))) + (should (eq t (gethash ?u erc--channel-modes))) + (should (equal erc-channel-modes '("u"))) + (should-not (erc-channel-user-owner-p "bob")) + + ;; Remove fool!*@* from list mode "q". + (erc--update-channel-modes "-uq" "fool!*@*") + (should (equal (pop calls) '(?a ?q nil "fool!*@*"))) + (should (equal (pop calls) '(?d ?u nil nil))) + (should-not (gethash ?u erc--channel-modes)) + (should-not erc-channel-modes) + (should (equal 0 (gethash ?q erc--channel-modes)))) + + (should-not calls)))) + +(ert-deftest erc--channel-modes () + :tags (and (null (getenv "CI")) '(:unstable)) + + (setq erc--isupport-params (make-hash-table) + erc--target (erc--target-from-string "#test") + erc-server-parameters + '(("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz"))) + + (erc-tests-common-init-server-proc "sleep" "1") + + (cl-letf (((symbol-function 'erc-update-mode-line) #'ignore)) + (erc--update-channel-modes "+bltk" "fool!*@*" "3" "h2")) + + (should (equal (erc--channel-modes 'string) "klt")) + (should (equal (erc--channel-modes 'strings) '("k" "l" "t"))) + (should (equal (erc--channel-modes) '((?k . "h2") (?l . "3") (?t)))) + (should (equal (erc--channel-modes 3 ",") "klt h2,3")) + + ;; The function this tests behaves differently in different + ;; environments. For example, on one GNU Linux system, it returns + ;; truncation ellipsis when run interactively. Rather than have + ;; hard-to-read "nondeterministic" comparisons against sets of + ;; acceptable values, we use separate tests. + (when (display-graphic-p) (ert-pass)) + + ;; Truncation cache populated and used. + (let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types)) + first-run) + (should (zerop (hash-table-count cache))) + (should (equal (erc--channel-modes 1 ",") "klt h,3")) + (should (equal (setq first-run (map-pairs cache)) '(((1 ?k "h2") . "h")))) + + ;; Second call uses cache. + (cl-letf (((symbol-function 'truncate-string-to-width) + (lambda (&rest _) (ert-fail "Shouldn't run")))) + (should (equal (erc--channel-modes 1 ",") "klt h,3"))) + + ;; Same key for only entry matches that of first result. + (should (pcase (map-pairs cache) + ((and '(((1 ?k "h2") . "h")) second-run) + (eq (pcase first-run (`((,k . ,_)) k)) + (pcase second-run (`((,k . ,_)) k))))))) + + (should (equal (erc--channel-modes 0 ",") "klt ,")) + (should (equal (erc--channel-modes 2) "klt h2 3")) + (should (equal (erc--channel-modes 1) "klt h 3")) + (should (equal (erc--channel-modes 0) "klt "))) ; 2 spaces + +(ert-deftest erc--channel-modes/graphic-p () + :tags `(:unstable ,@(and (getenv "ERC_TESTS_GRAPHICAL") + '(:erc--graphical))) + (unless (display-graphic-p) (ert-skip "See non-/graphic-p variant")) + + (erc-tests-common-init-server-proc "sleep" "1") + (setq erc--isupport-params (make-hash-table) + erc--target (erc--target-from-string "#test") + erc-server-parameters + '(("CHANMODES" . "eIbq,k,flj,CFLMPQRSTcgimnprstuz"))) + + (cl-letf (((symbol-function 'erc-update-mode-line) #'ignore)) + (erc--update-channel-modes "+bltk" "fool!*@*" "3" "hun2")) + + ;; Truncation cache populated and used. + (let ((cache (erc--channel-mode-types-shortargs erc--channel-mode-types)) + first-run) + (should (zerop (hash-table-count cache))) + (should (equal (erc--channel-modes 2 ",") "klt h…,3" )) + (should (equal (setq first-run (map-pairs cache)) + '(((2 ?k "hun2") . "h…")))) + + ;; Second call uses cache. + (cl-letf (((symbol-function 'truncate-string-to-width) + (lambda (&rest _) (ert-fail "Shouldn't run")))) + (should (equal (erc--channel-modes 2 ",") "klt h…,3" ))) + + ;; Same key for only entry matches that of first result. + (should (pcase (map-pairs cache) + ((and `(((2 ?k "hun2") . "h…")) second-run) + (eq (pcase first-run (`((,k . ,_)) k)) + (pcase second-run (`((,k . ,_)) k))))))) + + ;; A max length of 0 is nonsensical anyway, so skip those. + (should (equal (erc--channel-modes 3) "klt hu… 3")) + (should (equal (erc--channel-modes 2) "klt h… 3")) + (should (equal (erc--channel-modes 1) "klt … 3"))) + +(ert-deftest erc--update-user-modes () + (let ((erc--user-modes (list ?a))) + (should (equal (erc--update-user-modes "+a") '(?a))) + (should (equal (erc--update-user-modes "-b") '(?a))) + (should (equal erc--user-modes '(?a)))) + + (let ((erc--user-modes (list ?b))) + (should (equal (erc--update-user-modes "+ac") '(?a ?b ?c))) + (should (equal (erc--update-user-modes "+a-bc") '(?a))) + (should (equal erc--user-modes '(?a))))) + +(ert-deftest erc--user-modes () + (let ((erc--user-modes '(?a ?b))) + (should (equal (erc--user-modes) '(?a ?b))) + (should (equal (erc--user-modes 'string) "ab")) + (should (equal (erc--user-modes 'strings) '("a" "b"))))) + +(ert-deftest erc--parse-user-modes () + (should (equal (erc--parse-user-modes "a" '(?a)) '(() ()))) + (should (equal (erc--parse-user-modes "+a" '(?a)) '(() ()))) + (should (equal (erc--parse-user-modes "a" '()) '((?a) ()))) + (should (equal (erc--parse-user-modes "+a" '()) '((?a) ()))) + (should (equal (erc--parse-user-modes "-a" '()) '(() ()))) + (should (equal (erc--parse-user-modes "-a" '(?a)) '(() (?a)))) + + (should (equal (erc--parse-user-modes "+a-b" '(?a)) '(() ()))) + (should (equal (erc--parse-user-modes "+a-b" '(?b)) '((?a) (?b)))) + (should (equal (erc--parse-user-modes "+ab-c" '(?b)) '((?a) ()))) + (should (equal (erc--parse-user-modes "+ab-c" '(?b ?c)) '((?a) (?c)))) + (should (equal (erc--parse-user-modes "+a-c+b" '(?b ?c)) '((?a) (?c)))) + (should (equal (erc--parse-user-modes "-c+ab" '(?b ?c)) '((?a) (?c)))) + + ;; Param `extrap' returns groups of redundant chars. + (should (equal (erc--parse-user-modes "+a" '() t) '((?a) () () ()))) + (should (equal (erc--parse-user-modes "+a" '(?a) t) '(() () (?a) ()))) + (should (equal (erc--parse-user-modes "-a" '() t) '(() () () (?a)))) + (should (equal (erc--parse-user-modes "-a" '(?a) t) '(() (?a) () ()))) + + (should (equal (erc--parse-user-modes "+a-b" '(?a) t) '(() () (?a) (?b)))) + (should (equal (erc--parse-user-modes "-b+a" '(?a) t) '(() () (?a) (?b)))) + (should (equal (erc--parse-user-modes "+a-b" '(?b) t) '((?a) (?b) () ()))) + (should (equal (erc--parse-user-modes "-b+a" '(?b) t) '((?a) (?b) () ())))) + (ert-deftest erc--parse-isupport-value () (should (equal (erc--parse-isupport-value "a,b") '("a" "b"))) (should (equal (erc--parse-isupport-value "a,b,c") '("a" "b" "c"))) @@ -447,6 +1075,27 @@ (should (equal (erc-downcase "Tilde~") "tilde~" )) (should (equal (erc-downcase "\\O/") "|o/" ))))) +(ert-deftest erc-channel-p () + (let ((erc--isupport-params (make-hash-table)) + erc-server-parameters) + + (should (erc-channel-p "#chan")) + (should (erc-channel-p "##chan")) + (should (erc-channel-p "&chan")) + (should (erc-channel-p "+chan")) + (should (erc-channel-p "!chan")) + (should-not (erc-channel-p "@chan")) + + (push '("CHANTYPES" . "#&@+!") erc-server-parameters) + + (should (erc-channel-p "!chan")) + (should (erc-channel-p "#chan")) + + (with-current-buffer (get-buffer-create "#chan") + (setq erc--target (erc--target-from-string "#chan"))) + (should (erc-channel-p (get-buffer "#chan")))) + (kill-buffer "#chan")) + (ert-deftest erc--valid-local-channel-p () (ert-info ("Local channels not supported") (let ((erc--isupport-params (make-hash-table))) @@ -459,9 +1108,21 @@ (should-not (erc--valid-local-channel-p "#chan")) (should (erc--valid-local-channel-p "&local"))))) +(ert-deftest erc--restore-initialize-priors () + (should (pcase (macroexpand-1 '(erc--restore-initialize-priors erc-my-mode + foo (ignore 1 2 3) + bar #'spam + baz nil)) + (`(let* ((,p (or erc--server-reconnecting erc--target-priors)) + (,q (and ,p (alist-get 'erc-my-mode ,p)))) + (setq foo (if ,q (alist-get 'foo ,p) (ignore 1 2 3)) + bar (if ,q (alist-get 'bar ,p) #'spam) + baz (if ,q (alist-get 'baz ,p) nil))) + t)))) + (ert-deftest erc--target-from-string () (should (equal (erc--target-from-string "#chan") - #s(erc--target-channel "#chan" \#chan))) + #s(erc--target-channel "#chan" \#chan nil))) (should (equal (erc--target-from-string "Bob") #s(erc--target "Bob" bob))) @@ -469,7 +1130,51 @@ (let ((erc--isupport-params (make-hash-table))) (puthash 'CHANTYPES '("&#") erc--isupport-params) (should (equal (erc--target-from-string "&Bitlbee") - #s(erc--target-channel-local "&Bitlbee" &bitlbee))))) + #s(erc--target-channel-local "&Bitlbee" &bitlbee nil))))) + +(ert-deftest erc--modify-local-map () + (when (and (bound-and-true-p erc-irccontrols-mode) + (fboundp 'erc-irccontrols-mode)) + (erc-irccontrols-mode -1)) + (when (and (bound-and-true-p erc-match-mode) + (fboundp 'erc-match-mode)) + (erc-match-mode -1)) + (let* (calls + (inhibit-message noninteractive) + (cmd-foo (lambda () (interactive) (push 'foo calls))) + (cmd-bar (lambda () (interactive) (push 'bar calls)))) + + (ert-info ("Add non-existing") + (erc--modify-local-map t "C-c C-c" cmd-foo "C-c C-k" cmd-bar) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (equal calls '(bar foo)))) + (setq calls nil) + + (ert-info ("Add existing") ; Attempt to swap definitions fails + (erc--modify-local-map t "C-c C-c" cmd-bar "C-c C-k" cmd-foo) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (equal calls '(bar foo)))) + (setq calls nil) + + (ert-info ("Remove existing") + (ert-with-message-capture messages + (erc--modify-local-map nil "C-c C-c" cmd-foo "C-c C-k" cmd-bar) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (string-search "C-c C-c is undefined" messages)) + (should (string-search "C-c C-k is undefined" messages)) + (should-not calls))))) (ert-deftest erc-ring-previous-command-base-case () (ert-info ("Create ring when nonexistent and do nothing") @@ -484,18 +1189,19 @@ (ert-deftest erc-ring-previous-command () (with-current-buffer (get-buffer-create "*#fake*") (erc-mode) - (erc-tests--send-prep) + (erc-tests-common-prep-for-insertion) + (setq erc-server-current-nick "tester") (setq-local erc-last-input-time 0) (should-not (local-variable-if-set-p 'erc-send-completed-hook)) (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals) ;; Just in case erc-ring-mode is already on - (setq-local erc-pre-send-functions nil) - (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring) + (setq-local erc--input-review-functions erc--input-review-functions) + (add-hook 'erc--input-review-functions #'erc-add-to-input-ring) ;; (cl-letf (((symbol-function 'erc-process-input-line) (lambda (&rest _) - (insert-before-markers - (erc-display-message-highlight 'notice "echo: one\n")))) + (erc-display-message + nil 'notice (current-buffer) "echo: one\n"))) ((symbol-function 'erc-command-no-process-p) (lambda (&rest _) t))) (ert-info ("Create ring, populate, recall") @@ -591,6 +1297,48 @@ (kill-buffer "*erc-protocol*") (should-not erc-debug-irc-protocol))) +(ert-deftest erc--split-line () + (let ((erc-default-recipients '("#chan")) + (erc-split-line-length 10)) + (should (equal (erc--split-line "") '(""))) + (should (equal (erc--split-line "0123456789") '("0123456789"))) + (should (equal (erc--split-line "0123456789a") '("0123456789" "a"))) + + (should (equal (erc--split-line "0123456789 ") '("0123456789" " "))) + (should (equal (erc--split-line "01234567 89") '("01234567 " "89"))) + (should (equal (erc--split-line "0123456 789") '("0123456 " "789"))) + (should (equal (erc--split-line "0 123456789") '("0 " "123456789"))) + (should (equal (erc--split-line " 0123456789") '(" " "0123456789"))) + (should (equal (erc--split-line "012345678 9a") '("012345678 " "9a"))) + (should (equal (erc--split-line "0123456789 a") '("0123456789" " a"))) + + ;; UTF-8 vs. KOI-8 + (should (= 10 (string-bytes "Русск"))) ; utf-8 + (should (equal (erc--split-line "Русск") '("Русск"))) + (should (equal (erc--split-line "РусскийТекст") '("Русск" "ийТек" "ст"))) + (should (equal (erc--split-line "Русский Текст") '("Русск" "ий " "Текст"))) + (let ((erc-encoding-coding-alist '(("#chan" . cyrillic-koi8)))) + (should (equal (erc--split-line "Русск") '("Русск"))) + (should (equal (erc--split-line "РусскийТекст") '("РусскийТек" "ст"))) + (should (equal (erc--split-line "Русский Текст") '("Русский " "Текст")))) + + ;; UTF-8 vs. Latin 1 + (should (= 17 (string-bytes "Hyvää päivää"))) + (should (equal (erc--split-line "Hyvää päivää") '("Hyvää " "päivää"))) + (should (equal (erc--split-line "HyvääPäivää") '("HyvääPä" "ivää"))) + (let ((erc-encoding-coding-alist '(("#chan" . latin-1)))) + (should (equal (erc--split-line "Hyvää päivää") '("Hyvää " "päivää"))) + (should (equal (erc--split-line "HyvääPäivää") '("HyvääPäivä" "ä")))) + + ;; Combining characters + (should (= 10 (string-bytes "Åström"))) + (should (equal (erc--split-line "_Åström") '("_Åströ" "m"))) + (should (equal (erc--split-line "__Åström") '("__Åstr" "öm"))) + (should (equal (erc--split-line "___Åström") '("___Åstr" "öm"))) + (when (> emacs-major-version 27) + (should (equal (erc--split-line "🏁🚩🎌🏴🏳️🏳️🌈🏳️⚧️🏴☠️") + '("🏁🚩" "🎌🏴" "🏳️" "🏳️🌈" "🏳️⚧️" "🏴☠️")))))) + (ert-deftest erc--input-line-delim-regexp () (let ((p erc--input-line-delim-regexp)) ;; none @@ -622,64 +1370,8 @@ (should (equal '("" "" "") (split-string "\n\n" p))) (should (equal '("" "" "") (split-string "\n\r" p))))) -(ert-deftest erc--blank-in-multiline-input-p () - (let ((check (lambda (s) - (erc--blank-in-multiline-input-p - (split-string s erc--input-line-delim-regexp))))) - - (ert-info ("With `erc-send-whitespace-lines'") - (let ((erc-send-whitespace-lines t)) - (should (funcall check "")) - (should-not (funcall check "\na")) - (should-not (funcall check "/msg a\n")) ; real /cmd - (should-not (funcall check "a\n\nb")) ; "" allowed - (should-not (funcall check "/msg a\n\nb")) ; non-/cmd - (should-not (funcall check " ")) - (should-not (funcall check "\t")) - (should-not (funcall check "a\nb")) - (should-not (funcall check "a\n ")) - (should-not (funcall check "a\n \t")) - (should-not (funcall check "a\n \f")) - (should-not (funcall check "a\n \nb")) - (should-not (funcall check "a\n \t\nb")) - (should-not (funcall check "a\n \f\nb")))) - - (should (funcall check "")) - (should (funcall check " ")) - (should (funcall check "\t")) - (should (funcall check "a\n\nb")) - (should (funcall check "a\n\nb")) - (should (funcall check "a\n ")) - (should (funcall check "a\n \t")) - (should (funcall check "a\n \f")) - (should (funcall check "a\n \nb")) - (should (funcall check "a\n \t\nb")) - - (should-not (funcall check "a\rb")) - (should-not (funcall check "a\nb")) - (should-not (funcall check "a\r\nb")))) - -(defun erc-tests--with-process-input-spy (test) - (with-current-buffer (get-buffer-create "FakeNet") - (let* ((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)))) - (erc-tests--send-prep) - (funcall test (lambda () (pop calls))))) - (when noninteractive (kill-buffer)))) - (ert-deftest erc--check-prompt-input-functions () - (erc-tests--with-process-input-spy + (erc-tests-common-with-process-input-spy (lambda (next) (ert-info ("Errors when point not in prompt area") ; actually just dings @@ -691,9 +1383,9 @@ (ert-info ("Input remains untouched") (should (save-excursion (erc-bol) (looking-at "/msg #chan hi"))))) - (ert-info ("Errors when no process running") + (ert-info ("Errors when server buffer absent") (let ((e (should-error (erc-send-current-line)))) - (should (equal "ERC: No process running" (cadr e)))) + (should (equal "Server buffer missing" (cadr e)))) (ert-info ("Input remains untouched") (should (save-excursion (erc-bol) (looking-at "/msg #chan hi"))))) @@ -702,7 +1394,7 @@ (delete-region (point) (point-max)) (insert "one\n") (let ((e (should-error (erc-send-current-line)))) - (should (equal "Blank line - ignoring..." (cadr e)))) + (should (string-prefix-p "Trailing line detected" (cadr e)))) (goto-char (point-max)) (ert-info ("Input remains untouched") (should (save-excursion (goto-char erc-input-marker) @@ -714,9 +1406,9 @@ ;; These also indirectly tests `erc-send-input' (ert-deftest erc-send-current-line () - (erc-tests--with-process-input-spy + (erc-tests-common-with-process-input-spy (lambda (next) - (erc-tests--set-fake-server-process "sleep" "1") + (erc-tests-common-init-server-proc "sleep" "1") (should (= 0 erc-last-input-time)) (ert-info ("Simple command") @@ -728,8 +1420,9 @@ (ert-info ("Input cleared") (erc-bol) (should (eq (point) (point-max)))) - ;; Commands are forced (no flood protection) - (should (equal (funcall next) '("/msg #chan hi\n" t nil)))) + ;; The `force' argument is irrelevant here because it can't + ;; influence dispatched handlers, such as `erc-cmd-MSG'. + (should (pcase (funcall next) (`("/msg #chan hi\n" ,_ nil) t)))) (ert-info ("Simple non-command") (insert "hi") @@ -737,15 +1430,147 @@ (should (eq (point) (point-max))) (should (save-excursion (forward-line -1) (search-forward "<tester> hi"))) - ;; Non-ommands are forced only when `erc-flood-protect' is nil + ;; Non-commands are forced only when `erc-flood-protect' is + ;; nil, which conflates two orthogonal concerns. (should (equal (funcall next) '("hi\n" nil t)))) (should (consp erc-last-input-time))))) +(ert-deftest erc--discard-trailing-multiline-nulls () + (pcase-dolist (`(,input ,want) '((("") ("")) + (("" "") ("")) + (("a") ("a")) + (("a" "") ("a")) + (("" "a") ("" "a")) + (("" "a" "") ("" "a")))) + (ert-info ((format "Input: %S, want: %S" input want)) + (let ((s (make-erc--input-split :lines input))) + (erc--discard-trailing-multiline-nulls s) + (should (equal (erc--input-split-lines s) want)))))) + +(ert-deftest erc--count-blank-lines () + (pcase-dolist (`(,input ,want) '((() (0 0 0)) + (("") (1 1 0)) + (("" "") (2 1 1)) + (("" "" "") (3 1 2)) + ((" " "") (2 0 1)) + ((" " "" "") (3 0 2)) + (("" " " "") (3 1 1)) + (("" "" " ") (3 2 0)) + (("a") (0 0 0)) + (("a" "") (1 0 1)) + (("a" " " "") (2 0 1)) + (("a" "" "") (2 0 2)) + (("a" "b") (0 0 0)) + (("a" "" "b") (1 1 0)) + (("a" " " "b") (1 0 0)) + (("" "a") (1 1 0)) + ((" " "a") (1 0 0)) + (("" "a" "") (2 1 1)) + (("" " " "a" "" " ") (4 2 0)) + (("" " " "a" "" " " "") (5 2 1)))) + (ert-info ((format "Input: %S, want: %S" input want)) + (should (equal (erc--count-blank-lines input) want))))) + +;; Opt `wb': `erc-warn-about-blank-lines' +;; Opt `sw': `erc-send-whitespace-lines' +;; `s': " \n",`a': "a\n",`b': "b\n" +(defvar erc-tests--check-prompt-input--expect + ;; opts "" " " "\n" "\n " " \n" "\n\n" "a\n" "a\n " "a\n \nb" + '(((+wb -sw) err err err err err err err err err) + ((-wb -sw) nop nop nop nop nop nop nop nop nop) + ((+wb +sw) err (s) (0 s) (1 s s) (s) (0 s) (0 a) (a s) (a s b)) + ((-wb +sw) nop (s) (s) (s s) (s) (s) (a) (a s) (a s b)))) + +;; Help messages echoed (not IRC message) was emitted +(defvar erc-tests--check-prompt-input-messages + '("Stripping" "Padding")) + +(ert-deftest erc--check-prompt-input-for-multiline-blanks () + (erc-tests-common-with-process-input-spy + (lambda (next) + (erc-tests-common-init-server-proc "sleep" "10") + (should-not erc-send-whitespace-lines) + (should erc-warn-about-blank-lines) + + (pcase-dolist (`((,wb ,sw) . ,ex) erc-tests--check-prompt-input--expect) + (let ((print-escape-newlines t) + (erc-warn-about-blank-lines (eq wb '+wb)) + (erc-send-whitespace-lines (eq sw '+sw)) + (samples '("" " " "\n" "\n " " \n" "\n\n" + "a\n" "a\n " "a\n \nb"))) + (setq ex `(,@ex (a) (a b)) ; baseline, same for all combos + samples `(,@samples "a" "a\nb")) + (dolist (input samples) + (insert input) + (ert-info ((format "Opts: %S, Input: %S, want: %S" + (list wb sw) input (car ex))) + (ert-with-message-capture messages + (pcase-exhaustive (pop ex) + ('err (let ((e (should-error (erc-send-current-line)))) + (should (string-match (rx (| "trailing" "blank")) + (cadr e)))) + (should (equal (erc-user-input) input)) + (should-not (funcall next))) + ('nop (erc-send-current-line) + (should (equal (erc-user-input) input)) + (should-not (funcall next))) + ('clr (erc-send-current-line) + (should (string-empty-p (erc-user-input))) + (should-not (funcall next))) + ((and (pred consp) v) + (erc-send-current-line) + (should (string-empty-p (erc-user-input))) + (setq v (reverse v)) ; don't use `nreverse' here + (while v + (pcase (pop v) + ((and (pred integerp) n) + (should (string-search + (nth n erc-tests--check-prompt-input-messages) + messages))) + ('s (should (equal " \n" (car (funcall next))))) + ('a (should (equal "a\n" (car (funcall next))))) + ('b (should (equal "b\n" (car (funcall next))))))) + (should-not (funcall next)))))) + (delete-region erc-input-marker (point-max)))))))) + +(ert-deftest erc--check-prompt-input-for-multiline-blanks/explanations () + (should erc-warn-about-blank-lines) + (should-not erc-send-whitespace-lines) + + (let ((erc-send-whitespace-lines t)) + (pcase-dolist (`(,input ,msg) + '((("") "Padding (1) blank line") + (("" " ") "Padding (1) blank line") + ((" " "") "Stripping (1) blank line") + (("a" "") "Stripping (1) blank line") + (("" "") "Stripping (1) and padding (1) blank lines") + (("" "" "") "Stripping (2) and padding (1) blank lines") + (("" "a" "" "b" "" "c" "" "") + "Stripping (2) and padding (3) blank lines"))) + (ert-info ((format "Input: %S, Msg: %S" input msg)) + (let (erc--check-prompt-explanation) + (should-not (erc--check-prompt-input-for-multiline-blanks nil input)) + (should (equal (list msg) erc--check-prompt-explanation)))))) + + (pcase-dolist (`(,input ,msg) + '((("") "Blank line detected") + (("" " ") "2 blank lines detected") + ((" " "") "2 blank (1 trailing) lines detected") + (("a" "") "Trailing line detected") + (("" "") "2 blank (1 trailing) lines detected") + (("a" "" "") "2 trailing lines detected") + (("" "a" "" "b" "" "c" "" "") + "5 blank (2 trailing) lines detected"))) + (ert-info ((format "Input: %S, Msg: %S" input msg)) + (let ((rv (erc--check-prompt-input-for-multiline-blanks nil input))) + (should (equal (concat msg " (see `erc-send-whitespace-lines')") + rv )))))) + (ert-deftest erc-send-whitespace-lines () - (erc-tests--with-process-input-spy + (erc-tests-common-with-process-input-spy (lambda (next) - (erc-tests--set-fake-server-process "sleep" "1") + (erc-tests-common-init-server-proc "sleep" "1") (setq-local erc-send-whitespace-lines t) (ert-info ("Multiline hunk with blank line correctly split") @@ -758,7 +1583,7 @@ (erc-bol) (should (eq (point) (point-max)))) (should (equal (funcall next) '("two\n" nil t))) - (should (equal (funcall next) '("\n" nil t))) + (should (equal (funcall next) '(" \n" nil t))) (should (equal (funcall next) '("one\n" nil t)))) (ert-info ("Multiline hunk with trailing newline filtered") @@ -780,18 +1605,21 @@ (should-not (funcall next))) (ert-info ("Multiline command with trailing blank filtered") - (pcase-dolist (`(,p . ,q) - '(("/a b\r" "/a b\n") ("/a b\n" "/a b\n") - ("/a b\n\n" "/a b\n") ("/a b\r\n" "/a b\n") - ("a b\nc\n\n" "c\n" "a b\n") - ("/a b\nc\n\n" "c\n" "/a b\n") - ("/a b\n\nc\n\n" "c\n" "\n" "/a b\n"))) + (dolist (p '("/a b" "/a b\n" "/a b\n\n" "/a b\n\n\n")) (insert p) (erc-send-current-line) (erc-bol) (should (eq (point) (point-max))) - (while q - (should (equal (funcall next) (list (pop q) nil t)))) + (should (pcase (funcall next) (`(,cmd ,_ nil) (equal cmd "/a b\n")))) + (should-not (funcall next)))) + + (ert-info ("Multiline command with non-blanks errors") + (dolist (p '("/a b\nc\n\n" "/a b\n/c\n\n" "/a b\n\nc\n\n" + "/a\n c\n" "/a\nb\n" "/a\n/b\n" "/a \n \n")) + (insert p) + (should-error (erc-send-current-line)) + (goto-char erc-input-marker) + (delete-region (point) (point-max)) (should-not (funcall next)))) (ert-info ("Multiline hunk with trailing whitespace not filtered") @@ -809,13 +1637,14 @@ (ert-info ("With `erc-inhibit-multiline-input' as t (2)") (let ((erc-inhibit-multiline-input t)) (should-not (erc--check-prompt-input-for-excess-lines "" '("a"))) - (should-not (erc--check-prompt-input-for-excess-lines "" '("a" ""))) + ;; Does not trim trailing blanks. + (should (erc--check-prompt-input-for-excess-lines "" '("a" ""))) (should (erc--check-prompt-input-for-excess-lines "" '("a" "b"))))) (ert-info ("With `erc-inhibit-multiline-input' as 3") (let ((erc-inhibit-multiline-input 3)) (should-not (erc--check-prompt-input-for-excess-lines "" '("a" "b"))) - (should-not (erc--check-prompt-input-for-excess-lines "" '("a" "b" ""))) + (should (erc--check-prompt-input-for-excess-lines "" '("a" "b" ""))) (should (erc--check-prompt-input-for-excess-lines "" '("a" "b" "c"))))) (ert-info ("With `erc-ask-about-multiline-input'") @@ -836,14 +1665,12 @@ (erc-default-recipients '("#chan")) calls) (with-temp-buffer + (erc-tests-common-init-server-proc "sleep" "1") (cl-letf (((symbol-function 'erc-cmd-MSG) (lambda (line) (push line calls) + (should erc--called-as-input-p) (funcall orig-erc-cmd-MSG line))) - ((symbol-function 'erc-server-buffer) - (lambda () (current-buffer))) - ((symbol-function 'erc-server-process-alive) - (lambda () t)) ((symbol-function 'erc-server-send-queue) #'ignore)) @@ -896,6 +1723,487 @@ (should-not calls)))))) +(ert-deftest erc--get-inserted-msg-beg/basic () + (erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) (should (= 3 (erc--get-inserted-msg-beg arg)))))) + +(ert-deftest erc--get-inserted-msg-end/basic () + (erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) (should (= 11 (erc--get-inserted-msg-end arg)))))) + +(ert-deftest erc--get-inserted-msg-bounds/basic () + (erc-tests-common-assert-get-inserted-msg/basic + (lambda (arg) + (should (equal '(3 . 11) (erc--get-inserted-msg-bounds arg)))))) + +(ert-deftest erc--delete-inserted-message () + (erc-mode) + (erc--initialize-markers (point) nil) + ;; Put unique invisible properties on the line endings. + (erc-display-message nil 'notice nil "one") + (put-text-property (1- erc-insert-marker) erc-insert-marker 'invisible 'a) + (let ((erc--msg-prop-overrides '((erc--msg . datestamp) (erc--ts . 0)))) + (erc-display-message nil nil nil + (propertize "\n[date]" 'field 'erc-timestamp))) + (put-text-property (1- erc-insert-marker) erc-insert-marker 'invisible 'b) + (erc-display-message nil 'notice nil "two") + + (ert-info ("Date stamp deleted cleanly") + (goto-char 11) + (should (looking-at (rx "\n[date]"))) + (should (eq 'datestamp (get-text-property (point) 'erc--msg))) + (should (eq (point) (field-beginning (1+ (point))))) + + (erc--delete-inserted-message (point)) + + ;; Preceding line ending clobbered, replaced by trailing. + (should (looking-back (rx "*** one\n"))) + (should (looking-at (rx "*** two"))) + (should (eq 'b (get-text-property (1- (point)) 'invisible)))) + + (ert-info ("Markers at pos-bol preserved") + (erc-display-message nil 'notice nil "three") + (should (looking-at (rx "*** two"))) + + (let ((m (point-marker)) + (n (point-marker)) + (p (point))) + (set-marker-insertion-type m t) + (goto-char (point-max)) + (erc--delete-inserted-message p) + (should (= (marker-position n) p)) + (should (= (marker-position m) p)) + (goto-char p) + (set-marker m nil) + (set-marker n nil) + (should (looking-back (rx "*** one\n"))) + (should (looking-at (rx "*** three"))))) + + (ert-info ("Compat") + (erc-display-message nil 'notice nil "four") + (should (looking-at (rx "*** three\n"))) + (with-suppressed-warnings ((obsolete erc-legacy-invisible-bounds-p)) + (let ((erc-legacy-invisible-bounds-p t)) + (erc--delete-inserted-message (point)))) + (should (looking-at (rx "*** four\n")))) + + (ert-info ("Deleting most recent message preserves markers") + (let ((m (point-marker)) + (n (point-marker)) + (p (point))) + (should (equal "*** four\n" (buffer-substring p erc-insert-marker))) + (set-marker-insertion-type m t) + (goto-char (point-max)) + (erc--delete-inserted-message p) + (should (= (marker-position m) p)) + (should (= (marker-position n) p)) + (goto-char p) + (should (looking-back (rx "*** one\n"))) + (should (looking-at erc-prompt)) + (erc--assert-input-bounds) + + ;; However, `m' is now forever "trapped" at `erc-insert-marker'. + (erc-display-message nil 'notice nil "two") + (should (= m erc-insert-marker)) + (goto-char n) + (should (looking-at (rx "*** two\n"))) + (set-marker m nil) + (set-marker n nil)))) + +(ert-deftest erc--order-text-properties-from-hash () + (let ((table (map-into '((a . 1) + (erc--ts . 0) + (erc--msg . s005) + (b . 2) + (erc--cmd . 5) + (erc--spkr . "X") + (c . 3)) + 'hash-table))) + (with-temp-buffer + (erc-mode) + (insert "abc\n") + (add-text-properties 1 2 (erc--order-text-properties-from-hash table)) + (should (equal '( erc--msg s005 + erc--spkr "X" + erc--ts 0 + erc--cmd 5 + a 1 + b 2 + c 3) + (text-properties-at (point-min))))))) + +(ert-deftest erc--check-msg-prop () + (let ((erc--msg-props (map-into '((a . 1) (b . x)) 'hash-table))) + (should (eq 1 (erc--check-msg-prop 'a))) + (should (erc--check-msg-prop 'a 1)) + (should-not (erc--check-msg-prop 'a 2)) + + (should (eq 'x (erc--check-msg-prop 'b))) + (should (erc--check-msg-prop 'b 'x)) + (should-not (erc--check-msg-prop 'b 1)) + + (should (erc--check-msg-prop 'a '(1 42))) + (should-not (erc--check-msg-prop 'a '(2 42))) + + (let ((props '(42 x))) + (should (erc--check-msg-prop 'b props))) + (let ((v '(42 y))) + (should-not (erc--check-msg-prop 'b v))))) + +(ert-deftest erc--merge-prop () + (with-current-buffer (get-buffer-create "*erc-test*") + ;; Baseline. + (insert "abc\n") + (erc--merge-prop 1 3 'erc-test 'x) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" 0 2 (erc-test x)))) + (erc--merge-prop 1 3 'erc-test 'y) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" 0 2 (erc-test (y x))))) + + ;; Multiple intervals. + (goto-char (point-min)) + (insert "def\n") + (erc--merge-prop 1 2 'erc-test 'x) + (erc--merge-prop 2 3 'erc-test 'y) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) + #("def" 0 1 (erc-test x) 1 2 (erc-test y)))) + (erc--merge-prop 1 3 'erc-test 'z) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) + #("def" 0 1 (erc-test (z x)) 1 2 (erc-test (z y))))) + + ;; New val as list. + (goto-char (point-min)) + (insert "ghi\n") + (erc--merge-prop 2 3 'erc-test '(y z)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" 1 2 (erc-test (y z))))) + (erc--merge-prop 1 3 'erc-test '(w x)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) + #("ghi" 0 1 (erc-test (w x)) 1 2 (erc-test (w x y z))))) + + ;; Flag `erc--merge-prop-behind-p'. + (goto-char (point-min)) + (insert "jkl\n") + (erc--merge-prop 2 3 'erc-test '(y z)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("jkl" 1 2 (erc-test (y z))))) + (let ((erc--merge-prop-behind-p t)) + (erc--merge-prop 1 3 'erc-test '(w x))) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) + #("jkl" 0 1 (erc-test (w x)) 1 2 (erc-test (y z w x))))) + + (when noninteractive + (kill-buffer)))) + +(ert-deftest erc--remove-from-prop-value-list () + (with-current-buffer (get-buffer-create "*erc-test*") + ;; Non-list match. + (insert "abc\n") + (put-text-property 1 2 'erc-test 'a) + (put-text-property 2 3 'erc-test 'b) + (put-text-property 3 4 'erc-test 'c) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" + 0 1 (erc-test a) + 1 2 (erc-test b) + 2 3 (erc-test c)))) + + (erc--remove-from-prop-value-list 1 4 'erc-test 'b) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" + 0 1 (erc-test a) + 2 3 (erc-test c)))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'a) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" 2 3 (erc-test c)))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'c) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) "abc")) + + ;; List match. + (goto-char (point-min)) + (insert "def\n") + (put-text-property 1 2 'erc-test '(d x)) + (put-text-property 2 3 'erc-test '(e y)) + (put-text-property 3 4 'erc-test '(f z)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("def" + 0 1 (erc-test (d x)) + 1 2 (erc-test (e y)) + 2 3 (erc-test (f z))))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'y) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("def" + 0 1 (erc-test (d x)) + 1 2 (erc-test e) + 2 3 (erc-test (f z))))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'd) + (erc--remove-from-prop-value-list 1 4 'erc-test 'f) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("def" + 0 1 (erc-test x) + 1 2 (erc-test e) + 2 3 (erc-test z)))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'e) + (erc--remove-from-prop-value-list 1 4 'erc-test 'z) + (erc--remove-from-prop-value-list 1 4 'erc-test 'x) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) "def")) + + ;; List match. + (goto-char (point-min)) + (insert "ghi\n") + (put-text-property 1 2 'erc-test '(g x)) + (put-text-property 2 3 'erc-test '(h x)) + (put-text-property 3 4 'erc-test '(i y)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" + 0 1 (erc-test (g x)) + 1 2 (erc-test (h x)) + 2 3 (erc-test (i y))))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'x) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" + 0 1 (erc-test g) + 1 2 (erc-test h) + 2 3 (erc-test (i y))))) + (erc--remove-from-prop-value-list 1 2 'erc-test 'g) ; narrowed + (erc--remove-from-prop-value-list 3 4 'erc-test 'i) ; narrowed + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" + 1 2 (erc-test h) + 2 3 (erc-test y)))) + + ;; Pathological (,c) case (hopefully not created by ERC) + (goto-char (point-min)) + (insert "jkl\n") + (put-text-property 1 2 'erc-test '(j x)) + (put-text-property 2 3 'erc-test '(k)) + (put-text-property 3 4 'erc-test '(k)) + (erc--remove-from-prop-value-list 1 4 'erc-test 'k) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("jkl" 0 1 (erc-test (j x))))) + + (when noninteractive + (kill-buffer)))) + +(ert-deftest erc--remove-from-prop-value-list/many () + (with-current-buffer (get-buffer-create "*erc-test*") + ;; Non-list match. + (insert "abc\n") + (put-text-property 1 2 'erc-test 'a) + (put-text-property 2 3 'erc-test 'b) + (put-text-property 3 4 'erc-test 'c) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" + 0 1 (erc-test a) + 1 2 (erc-test b) + 2 3 (erc-test c)))) + + (erc--remove-from-prop-value-list 1 4 'erc-test '(a b)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" 2 3 (erc-test c)))) + (erc--remove-from-prop-value-list 1 4 'erc-test 'a) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("abc" 2 3 (erc-test c)))) + (erc--remove-from-prop-value-list 1 4 'erc-test '(c)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) "abc")) + + ;; List match. + (goto-char (point-min)) + (insert "def\n") + (put-text-property 1 2 'erc-test '(d x y)) + (put-text-property 2 3 'erc-test '(e y)) + (put-text-property 3 4 'erc-test '(f z)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("def" + 0 1 (erc-test (d x y)) + 1 2 (erc-test (e y)) + 2 3 (erc-test (f z))))) + (erc--remove-from-prop-value-list 1 4 'erc-test '(d y f)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("def" + 0 1 (erc-test x) + 1 2 (erc-test e) + 2 3 (erc-test z)))) + (erc--remove-from-prop-value-list 1 4 'erc-test '(e z x)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) "def")) + + ;; Narrowed beg. + (goto-char (point-min)) + (insert "ghi\n") + (put-text-property 1 2 'erc-test '(g x)) + (put-text-property 2 3 'erc-test '(h x)) + (put-text-property 3 4 'erc-test '(i x)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" + 0 1 (erc-test (g x)) + 1 2 (erc-test (h x)) + 2 3 (erc-test (i x))))) + (erc--remove-from-prop-value-list 1 3 'erc-test '(x g i)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("ghi" + 1 2 (erc-test h) + 2 3 (erc-test (i x))))) + + ;; Narrowed middle. + (goto-char (point-min)) + (insert "jkl\n") + (put-text-property 1 2 'erc-test '(j x)) + (put-text-property 2 3 'erc-test '(k)) + (put-text-property 3 4 'erc-test '(l y z)) + (erc--remove-from-prop-value-list 3 4 'erc-test '(k x y z)) + (should (erc-tests-common-equal-with-props + (buffer-substring 1 4) #("jkl" + 0 1 (erc-test (j x)) + 1 2 (erc-test (k)) + 2 3 (erc-test l)))) + + (when noninteractive + (kill-buffer)))) + +(ert-deftest erc--split-string-shell-cmd () + + ;; Leading and trailing space + (should (equal (erc--split-string-shell-cmd "1 2 3") '("1" "2" "3"))) + (should (equal (erc--split-string-shell-cmd " 1 2 3 ") '("1" "2" "3"))) + + ;; Empty string + (should (equal (erc--split-string-shell-cmd "\"\"") '(""))) + (should (equal (erc--split-string-shell-cmd " \"\" ") '(""))) + (should (equal (erc--split-string-shell-cmd "1 \"\"") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "1 \"\" ") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "\"\" 1") '("" "1"))) + (should (equal (erc--split-string-shell-cmd " \"\" 1") '("" "1"))) + + (should (equal (erc--split-string-shell-cmd "''") '(""))) + (should (equal (erc--split-string-shell-cmd " '' ") '(""))) + (should (equal (erc--split-string-shell-cmd "1 ''") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "1 '' ") '("1" ""))) + (should (equal (erc--split-string-shell-cmd "'' 1") '("" "1"))) + (should (equal (erc--split-string-shell-cmd " '' 1") '("" "1"))) + + ;; Backslash + (should (equal (erc--split-string-shell-cmd "\\ ") '(" "))) + (should (equal (erc--split-string-shell-cmd " \\ ") '(" "))) + (should (equal (erc--split-string-shell-cmd "1\\ ") '("1 "))) + (should (equal (erc--split-string-shell-cmd "1\\ 2") '("1 2"))) + + ;; Embedded + (should (equal (erc--split-string-shell-cmd "\"\\\"\"") '("\""))) + (should (equal (erc--split-string-shell-cmd "1 \"2 \\\" \\\" 3\"") + '("1" "2 \" \" 3"))) + (should (equal (erc--split-string-shell-cmd "1 \"2 ' ' 3\"") + '("1" "2 ' ' 3"))) + (should (equal (erc--split-string-shell-cmd "1 '2 \" \" 3'") + '("1" "2 \" \" 3"))) + (should (equal (erc--split-string-shell-cmd "1 '2 \\ 3'") + '("1" "2 \\ 3"))) + (should (equal (erc--split-string-shell-cmd "1 \"2 \\\\ 3\"") + '("1" "2 \\ 3"))) ; see comment re ^ + + ;; Realistic + (should (equal (erc--split-string-shell-cmd "GET bob \"my file.txt\"") + '("GET" "bob" "my file.txt"))) + (should (equal (erc--split-string-shell-cmd "GET EXAMPLE|bob \"my file.txt\"") + '("GET" "EXAMPLE|bob" "my file.txt")))) ; regression + + +;; The behavior of `erc-pre-send-functions' differs between versions +;; in how hook members see and influence a trailing newline that's +;; part of the original prompt submission: +;; +;; 5.4: both seen and sent +;; 5.5: seen but not sent* +;; 5.6: neither seen nor sent* +;; +;; * requires `erc-send-whitespace-lines' for hook to run +;; +;; Two aspects that have remained consistent are +;; +;; - a final nonempty line in any submission is always sent +;; - a trailing newline appended by a hook member is always sent +;; +;; The last bullet would seem to contradict the "not sent" behavior of +;; 5.5 and 5.6, but what's actually happening is that exactly one +;; trailing newline is culled, so anything added always goes through. +;; Also, in ERC 5.6, all empty lines are actually padded, but this is +;; merely incidental WRT the above. +;; +;; Note that this test doesn't run any input-prep hooks and thus can't +;; account for the "seen" dimension noted above. + +(ert-deftest erc--run-send-hooks () + (with-suppressed-warnings ((obsolete erc-send-this) + (obsolete erc-send-pre-hook)) + (should erc-insert-this) + (should erc-send-this) ; populates `erc--input-split-sendp' + + (let (erc-pre-send-functions erc-send-pre-hook) + + (ert-info ("String preserved, lines rewritten, empties padded") + (setq erc-pre-send-functions + (lambda (o) (setf (erc-input-string o) "bar\n\nbaz\n"))) + (should (pcase (erc--run-send-hooks (make-erc--input-split + :string "foo" :lines '("foo"))) + ((cl-struct erc--input-split + (string "foo") (sendp 't) (insertp 't) + (lines '("bar" " " "baz" " ")) (cmdp 'nil)) + t)))) + + (ert-info ("Multiline commands rejected") + (should-error (erc--run-send-hooks (make-erc--input-split + :string "/mycmd foo" + :lines '("/mycmd foo") + :cmdp t)))) + + (ert-info ("Single-line commands pass") + (setq erc-pre-send-functions + (lambda (o) (setf (erc-input-sendp o) nil + (erc-input-string o) "/mycmd bar"))) + (should (pcase (erc--run-send-hooks (make-erc--input-split + :string "/mycmd foo" + :lines '("/mycmd foo") + :cmdp t)) + ((cl-struct erc--input-split + (string "/mycmd foo") (sendp 'nil) (insertp 't) + (lines '("/mycmd bar")) (cmdp 't)) + t)))) + + (ert-info ("Legacy hook respected, special vars confined") + (setq erc-send-pre-hook (lambda (_) (setq erc-send-this nil)) + erc-pre-send-functions (lambda (o) ; propagates + (should-not (erc-input-sendp o)))) + (should (pcase (erc--run-send-hooks (make-erc--input-split + :string "foo" :lines '("foo"))) + ((cl-struct erc--input-split + (string "foo") (sendp 'nil) (insertp 't) + (lines '("foo")) (cmdp 'nil)) + t))) + (should erc-send-this)) + + (ert-info ("Request to resplit honored") + (setq erc-send-pre-hook nil + erc-pre-send-functions + (lambda (o) (setf (erc-input-string o) "foo bar baz" + (erc-input-refoldp o) t))) + (let* ((split (make-erc--input-split :string "foo" :lines '("foo"))) + (erc--current-line-input-split split) + (erc-split-line-length 8)) + (should + (pcase (erc--run-send-hooks split) + ((cl-struct erc--input-split + (string "foo") (sendp 't) (insertp 't) + (lines '("foo bar " "baz")) (cmdp 'nil)) + t)))))))) + ;; Note: if adding an erc-backend-tests.el, please relocate this there. (ert-deftest erc-message () @@ -904,7 +2212,8 @@ calls erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) (cl-letf (((symbol-function 'erc-display-message) - (lambda (_ _ _ line) (push line calls))) + (lambda (_ _ _ msg &rest args) + (push (apply #'erc-format-message msg args) calls))) ((symbol-function 'erc-server-send) (lambda (line _) (push line calls))) ((symbol-function 'erc-server-buffer) @@ -923,6 +2232,7 @@ (erc-mode) (setq erc-server-process (buffer-local-value 'erc-server-process (get-buffer "ExampleNet")) + erc--target (erc--target-from-string "#chan") erc-default-recipients '("#chan") erc-channel-users (make-hash-table :test 'equal) erc-network 'ExampleNet) @@ -945,7 +2255,7 @@ (should-not erc-server-last-peers) (erc-message "PRIVMSG" ". hi") (should-not erc-server-last-peers) - (should (eq 'no-target (pop calls))) + (should (equal "No target" (pop calls))) (erc-message "PRIVMSG" ", hi") (should-not erc-server-last-peers) (should (string-match "alice :hi" (pop calls))))) @@ -978,6 +2288,333 @@ (kill-buffer "ExampleNet") (kill-buffer "#chan"))) +(ert-deftest erc-get-channel-membership-prefix () + (ert-info ("Uses default prefixes when `erc--parsed-prefix' not available") + (should-not (erc--parsed-prefix)) + ;; Baseline. + (should-not (erc-get-channel-membership-prefix nil)) + (should (equal (erc-get-channel-membership-prefix "Bob") "")) + (should (equal (erc-get-channel-membership-prefix (make-erc-channel-user)) + "")) + ;; Defaults. + (should + (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix (make-erc-channel-user :owner t)) + #("~" 0 1 (help-echo "owner")))) + (should + (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix (make-erc-channel-user :admin t)) + #("&" 0 1 (help-echo "admin")))) + (should + (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix (make-erc-channel-user :op t)) + #("@" 0 1 (help-echo "operator")))) + (should + (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix (make-erc-channel-user :halfop t)) + #("%" 0 1 (help-echo "half-op")))) + (should + (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix (make-erc-channel-user :voice t)) + #("+" 0 1 (help-echo "voice"))))) + + (ert-info ("Uses advertised prefixes when `erc--parsed-prefix' is available") + (erc-tests-common-make-server-buf (buffer-name)) + (push '("PREFIX" . "(ov)@+") erc-server-parameters) + (should (erc--parsed-prefix)) + + (with-current-buffer (erc--open-target "#chan") + (erc-update-current-channel-member "Bob" nil t nil nil 'on) + + ;; Baseline. + (should-not (erc-get-channel-membership-prefix nil)) + (should (string-empty-p (erc-get-channel-membership-prefix + (make-erc-channel-user)))) + + ;; Defaults. + (should (string-empty-p (erc-get-channel-membership-prefix + (make-erc-channel-user :owner t)))) + (should (string-empty-p (erc-get-channel-membership-prefix + (make-erc-channel-user :admin t)))) + (should (string-empty-p (erc-get-channel-membership-prefix + (make-erc-channel-user :halfop t)))) + + (should (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix "Bob") + #("@" 0 1 (help-echo "operator")))) + (should (erc-tests-common-equal-with-props + (erc-get-channel-membership-prefix + (make-erc-channel-user :voice t)) + #("+" 0 1 (help-echo "voice")))) + + (kill-buffer)))) + +;; This is an adapter that uses formatting templates from the +;; `-speaker' catalog to mimic `erc-format-privmessage', for testing +;; purposes. +(defun erc-tests--format-privmessage (nick msg privp msgp &optional inputp pfx) + (let ((erc-current-message-catalog erc--message-speaker-catalog)) + (apply #'erc-format-message + (erc--determine-speaker-message-format-args nick msg privp msgp + inputp nil pfx)))) + +;; This asserts that `erc--determine-speaker-message-format-args' +;; behaves identically to `erc-format-privmessage', the function whose +;; role it basically replaced. +(ert-deftest erc--determine-speaker-message-format-args () + ;; Basic PRIVMSG. + (let ((expect #("<bob> oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face))) + (args (list (concat "bob") (concat "oh my") nil 'msgp))) + (should (erc-tests-common-equal-with-props + (apply #'erc-format-privmessage args) + expect)) + (should (erc-tests-common-equal-with-props + (apply #'erc-tests--format-privmessage args) + expect))) + + ;; Basic NOTICE. + (let ((expect #("-bob- oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face))) + (args (list (copy-sequence "bob") (copy-sequence "oh my") nil nil))) + (should (erc-tests-common-equal-with-props + (apply #'erc-format-privmessage args) + expect)) + (should (erc-tests-common-equal-with-props + (apply #'erc-tests--format-privmessage args) + expect))) + + ;; Status-prefixed PRIVMSG. + (let* ((expect + #("<@Bob> oh my" + 0 1 (font-lock-face erc-default-face) + 1 2 (font-lock-face erc-nick-prefix-face help-echo "operator") + 2 5 (erc--speaker "Bob" font-lock-face erc-nick-default-face) + 5 12 (font-lock-face erc-default-face))) + (user (make-erc-server-user :nickname (copy-sequence "Bob"))) + (cuser (make-erc-channel-user :op t)) + (erc-channel-users (make-hash-table :test #'equal))) + (puthash "bob" (cons user cuser) erc-channel-users) + + (with-suppressed-warnings ((obsolete erc-format-@nick)) + (should (erc-tests-common-equal-with-props + (erc-format-privmessage (erc-format-@nick user cuser) + (copy-sequence "oh my") + nil 'msgp) + expect))) + (let ((nick "Bob") + (msg "oh my")) + (should (erc-tests-common-equal-with-props + (erc-tests--format-privmessage nick msg nil 'msgp nil cuser) + expect)) ; overloaded on PREFIX arg + (should (erc-tests-common-equal-with-props + (erc-tests--format-privmessage nick msg nil 'msgp nil t) + expect)) + ;; The new version makes a copy instead of adding properties to + ;; the input. + (should-not + (text-property-not-all 0 (length nick) 'font-lock-face nil nick)) + (should-not + (text-property-not-all 0 (length msg) 'font-lock-face nil msg))))) + +(ert-deftest erc--determine-speaker-message-format-args/queries-as-channel () + (should erc-format-query-as-channel-p) + + (with-current-buffer (get-buffer-create "bob") + (erc-mode) + (setq erc--target (erc--target-from-string "alice")) + + (insert "PRIVMSG\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp 'msgp)) + (should (erc-tests-common-equal-with-props + #("<bob> oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nNOTICE\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp nil)) + (should (erc-tests-common-equal-with-props + #("-bob- oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-default-face) + 4 11 (font-lock-face erc-default-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nInput PRIVMSG\n" + (erc-tests--format-privmessage "bob" "oh my" + 'queryp 'privmsgp 'inputp)) + (should (erc-tests-common-equal-with-props + #("<bob> oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face) + 4 6 (font-lock-face erc-default-face) + 6 11 (font-lock-face erc-input-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nInput NOTICE\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp nil 'inputp)) + (should (erc-tests-common-equal-with-props + #("-bob- oh my" + 0 1 (font-lock-face erc-default-face) + 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face) + 4 6 (font-lock-face erc-default-face) + 6 11 (font-lock-face erc-input-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (when noninteractive (kill-buffer)))) + +(ert-deftest erc--determine-speaker-message-format-args/queries () + (should erc-format-query-as-channel-p) + + (with-current-buffer (get-buffer-create "bob") + (erc-mode) + (setq-local erc-format-query-as-channel-p nil) + (setq erc--target (erc--target-from-string "alice")) + + (insert "PRIVMSG\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp 'msgp)) + (should (erc-tests-common-equal-with-props + #("*bob* oh my" + 0 1 (font-lock-face erc-direct-msg-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-msg-face) + 4 11 (font-lock-face erc-direct-msg-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nNOTICE\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp nil)) + (should (erc-tests-common-equal-with-props + #("-bob- oh my" + 0 1 (font-lock-face erc-direct-msg-face) + 1 4 (erc--speaker "bob" font-lock-face erc-nick-msg-face) + 4 11 (font-lock-face erc-direct-msg-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nInput PRIVMSG\n" + (erc-tests--format-privmessage "bob" "oh my" + 'queryp 'privmsgp 'inputp)) + (should (erc-tests-common-equal-with-props + #("*bob* oh my" + 0 1 (font-lock-face erc-direct-msg-face) + 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face) + 4 6 (font-lock-face erc-direct-msg-face) + 6 11 (font-lock-face erc-input-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (insert "\nInput NOTICE\n" + (erc-tests--format-privmessage "bob" "oh my" 'queryp nil 'inputp)) + (should (erc-tests-common-equal-with-props + #("-bob- oh my" + 0 1 (font-lock-face erc-direct-msg-face) + 1 4 (erc--speaker "bob" font-lock-face erc-my-nick-face) + 4 6 (font-lock-face erc-direct-msg-face) + 6 11 (font-lock-face erc-input-face)) + (buffer-substring (pos-bol) (pos-eol)))) + + (when noninteractive (kill-buffer)))) + +(defun erc-tests--format-my-nick (message) + (concat (erc-format-my-nick) + (propertize message 'font-lock-face 'erc-input-face))) + +;; This tests that the default behavior of the replacement formatting +;; function for prompt input, `erc--format-speaker-input-message' +;; matches that of the original being replaced, `erc-format-my-nick', +;; though it only handled the speaker portion. +(ert-deftest erc--format-speaker-input-message () + ;; No status prefix. + (let ((erc-server-current-nick "tester") + (expect #("<tester> oh my" + 0 1 (font-lock-face erc-default-face) + 1 7 (font-lock-face erc-my-nick-face erc--speaker "tester") + 7 9 (font-lock-face erc-default-face) + 9 14 (font-lock-face erc-input-face)))) + (should (equal (erc-tests--format-my-nick "oh my") expect)) + (should (equal (erc--format-speaker-input-message "oh my") expect))) + + ;; With channel-operator status prefix. + (let* ((erc-server-current-nick "tester") + (cmem (cons (make-erc-server-user :nickname "tester") + (make-erc-channel-user :op t))) + (erc-channel-users (map-into (list "tester" cmem) + '(hash-table :test equal))) + (expect #("<@tester> oh my" + 0 1 (font-lock-face erc-default-face) + 1 2 (font-lock-face erc-my-nick-prefix-face) + 2 5 (font-lock-face erc-my-nick-face erc--speaker "bob") + 5 7 (font-lock-face erc-default-face) + 7 12 (font-lock-face erc-input-face)))) + (should (equal (erc-tests--format-my-nick "oh my") expect)) + (should (equal (erc--format-speaker-input-message "oh my") expect)))) + +(ert-deftest erc--route-insertion () + (erc-tests-common-prep-for-insertion) + (erc-tests-common-init-server-proc "sleep" "1") + (setq erc-networks--id (erc-networks--id-create 'foonet)) + + (let* ((erc-modules) ; for `erc--open-target' + (server-buffer (current-buffer)) + (spam-buffer (save-excursion (erc--open-target "#spam"))) + (chan-buffer (save-excursion (erc--open-target "#chan"))) + calls) + (cl-letf (((symbol-function 'erc-insert-line) + (lambda (&rest r) (push (cons 'line-1 r) calls)))) + + (with-current-buffer chan-buffer + + (ert-info ("Null `buffer' routes to live server-buffer") + (erc--route-insertion "null" nil) + (should (equal (pop calls) `(line-1 "null" ,server-buffer))) + (should-not calls)) + + (ert-info ("Cons `buffer' routes to live members") + ;; Copies a let-bound `erc--msg-props' before mutating. + (let* ((table (map-into '(erc--msg msg) 'hash-table)) + (erc--msg-props table)) + (erc--route-insertion "cons" (list server-buffer spam-buffer)) + (should-not (eq table erc--msg-props))) + (should (equal (pop calls) `(line-1 "cons" ,spam-buffer))) + (should (equal (pop calls) `(line-1 "cons" ,server-buffer))) + (should-not calls)) + + (ert-info ("Variant `all' inserts in all session buffers") + (erc--route-insertion "all" 'all) + (should (equal (pop calls) `(line-1 "all" ,chan-buffer))) + (should (equal (pop calls) `(line-1 "all" ,spam-buffer))) + (should (equal (pop calls) `(line-1 "all" ,server-buffer))) + (should-not calls)) + + (ert-info ("Variant `active' routes to active buffer if alive") + (should (eq chan-buffer (erc-with-server-buffer erc-active-buffer))) + (erc-set-active-buffer spam-buffer) + (erc--route-insertion "act" 'active) + (should (equal (pop calls) `(line-1 "act" ,spam-buffer))) + (should (eq (erc-active-buffer) spam-buffer)) + (should-not calls)) + + (ert-info ("Variant `active' falls back to current buffer") + (should (eq spam-buffer (erc-active-buffer))) + (kill-buffer "#spam") + (erc--route-insertion "nact" 'active) + (should (equal (pop calls) `(line-1 "nact" ,server-buffer))) + (should (eq (erc-with-server-buffer erc-active-buffer) + server-buffer)) + (should-not calls)) + + (ert-info ("Dead single buffer defaults to live server-buffer") + (should-not (get-buffer "#spam")) + (erc--route-insertion "dead" 'spam-buffer) + (should (equal (pop calls) `(line-1 "dead" ,server-buffer))) + (should-not calls)))) + + (should-not (buffer-live-p spam-buffer)) + (kill-buffer chan-buffer))) + (defvar erc-tests--ipv6-examples '("1:2:3:4:5:6:7:8" "::ffff:10.0.0.1" "::ffff:1.2.3.4" "::ffff:0.0.0.0" @@ -999,32 +2636,71 @@ (should (string-match erc--server-connect-dumb-ipv6-regexp (concat "[" a "]"))))) +(ert-deftest erc--with-entrypoint-environment () + (let ((env '((erc-join-buffer . foo) + (erc-server-connect-function . bar)))) + (erc--with-entrypoint-environment env + (should (eq erc-join-buffer 'foo)) + (should (eq erc-server-connect-function 'bar))))) + (ert-deftest erc-select-read-args () - (ert-info ("Does not default to TLS") - (should (equal (ert-simulate-keys "\r\r\r\r" + (ert-info ("Prompts for switch to TLS by default") + (should (equal (ert-simulate-keys "\r\r\r\ry\r" (erc-select-read-args)) (list :server "irc.libera.chat" - :port 6667 + :port 6697 :nick (user-login-name) - :password nil)))) + '&interactive-env + '((erc-server-connect-function . erc-open-tls-stream) + (erc-join-buffer . window)))))) + + (ert-info ("Switches to TLS when port matches default TLS port") + (should (equal (ert-simulate-keys "irc.gnu.org\r6697\r\r\r" + (erc-select-read-args)) + (list :server "irc.gnu.org" + :port 6697 + :nick (user-login-name) + '&interactive-env + '((erc-server-connect-function . erc-open-tls-stream) + (erc-join-buffer . window)))))) + + (ert-info ("Switches to TLS when URL is ircs://") + (let ((erc--display-context '((erc-interactive-display . erc)))) + (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r" + (erc-select-read-args)) + (list :server "irc.gnu.org" + :port 6697 + :nick (user-login-name) + '&interactive-env + '((erc-server-connect-function + . erc-open-tls-stream) + (erc--display-context + . ((erc-interactive-display . erc))) + (erc-join-buffer . window))))))) + + (setq-local erc-interactive-display nil) ; cheat to save space + + (ert-info ("Opt out of non-TLS warning manually") + (should (equal (ert-simulate-keys "\r\r\r\rn\r" + (erc-select-read-args)) + (list :server "irc.libera.chat" + :port 6667 + :nick (user-login-name))))) (ert-info ("Override default TLS") (should (equal (ert-simulate-keys "irc://irc.libera.chat\r\r\r\r" (erc-select-read-args)) (list :server "irc.libera.chat" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("Address includes port") - (should (equal (ert-simulate-keys - "localhost:6667\rnick\r\r" + (should (equal (ert-simulate-keys "localhost:6667\rnick\r\r" (erc-select-read-args)) (list :server "localhost" :port 6667 - :nick "nick" - :password nil)))) + :nick "nick")))) (ert-info ("Address includes nick, password skipped via option") (should (equal (ert-simulate-keys "nick@localhost:6667\r" @@ -1032,8 +2708,7 @@ (erc-select-read-args))) (list :server "localhost" :port 6667 - :nick "nick" - :password nil)))) + :nick "nick")))) (ert-info ("Address includes nick and password") (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r" @@ -1048,37 +2723,55 @@ (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("IPv6 address with port") (should (equal (ert-simulate-keys "[::1]:6667\r\r\r" (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("IPv6 address includes nick") (should (equal (ert-simulate-keys "nick@[::1]:6667\r\r" (erc-select-read-args)) (list :server "[::1]" :port 6667 + :nick "nick")))) + + (ert-info ("Extra args use URL nick by default") + (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r\r\r" + (let ((current-prefix-arg '(4))) + (erc-select-read-args))) + (list :server "localhost" + :port 6667 :nick "nick" - :password nil))))) + :user "nick" + :password "sesame" + :full-name "nick"))))) (ert-deftest erc-tls () - (let (calls) + (let (calls env) (cl-letf (((symbol-function 'user-login-name) (lambda (&optional _) "tester")) ((symbol-function 'erc-open) - (lambda (&rest r) (push r calls)))) + (lambda (&rest r) + (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) + (erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) (ert-info ("Defaults") (erc-tls) (should (equal (pop calls) '("irc.libera.chat" 6697 "tester" "unknown" t - nil nil nil nil nil "user" nil)))) + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) + (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Full") (erc-tls :server "irc.gnu.org" @@ -1091,7 +2784,11 @@ :id 'GNU.org) (should (equal (pop calls) '("irc.gnu.org" 7000 "bob" "Bob's Name" t - "bob:changeme" nil nil nil t "bobo" GNU.org)))) + "bob:changeme" nil nil nil t "bobo" GNU.org))) + (should (equal (pop env) + '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) + (erc-server-connect-function erc-open-tls-stream))))) ;; Values are often nil when called by lisp code, which leads to ;; null params. This is why `erc-open' recomputes almost @@ -1107,31 +2804,141 @@ :password "bob:changeme")) (should (equal (pop calls) '(nil 7000 nil "Bob's Name" t - "bob:changeme" nil nil nil nil "bobo" nil))))))) - -(defun erc-tests--make-server-buf (name) - (with-current-buffer (get-buffer-create name) - (erc-mode) - (setq erc-server-process (start-process "sleep" (current-buffer) - "sleep" "1") - erc-session-server (concat "irc." name ".org") - erc-session-port 6667 - erc-network (intern name)) - (set-process-query-on-exit-flag erc-server-process nil) - (current-buffer))) - -(defun erc-tests--make-client-buf (server name) - (unless (bufferp server) - (setq server (get-buffer server))) - (with-current-buffer (get-buffer-create name) - (erc-mode) - (setq erc--target (erc--target-from-string name)) - (dolist (v '(erc-server-process - erc-session-server - erc-session-port - erc-network)) - (set v (buffer-local-value v server))) - (current-buffer))) + "bob:changeme" nil nil nil nil "bobo" nil))) + (should (equal (pop env) + '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) + (erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Interactive") + (ert-simulate-keys "nick:sesame@localhost:6667\r\r" + (call-interactively #'erc-tls)) + (should (equal (pop calls) + '("localhost" 6667 "nick" "unknown" t "sesame" + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc--display-context + (erc-interactive-display . erc-tls)) + (erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Custom connect function") + (let ((erc-server-connect-function 'my-connect-func)) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer bury) + (erc--display-context + (erc-buffer-display . erc-tls)) + (erc-server-connect-function my-connect-func)))))) + + (ert-info ("Advised default function overlooked") ; intentional + (advice-add 'erc-server-connect-function :around #'ignore + '((name . erc-tests--erc-tls))) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer bury) + (erc--display-context (erc-buffer-display . erc-tls)) + (erc-server-connect-function erc-open-tls-stream)))) + (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls)) + + (ert-info ("Advised non-default function honored") + (let ((f (lambda (&rest r) (ignore r)))) + (cl-letf (((symbol-value 'erc-server-connect-function) f)) + (advice-add 'erc-server-connect-function :around #'ignore + '((name . erc-tests--erc-tls))) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) `((erc-join-buffer bury) + (erc--display-context + (erc-buffer-display . erc-tls)) + (erc-server-connect-function ,f)))) + (advice-remove 'erc-server-connect-function + 'erc-tests--erc-tls))))))) + +;; See `erc-select-read-args' above for argument parsing. +;; This only tests the "hidden" arguments. + +(ert-deftest erc--interactive () + (let (calls env) + (cl-letf (((symbol-function 'user-login-name) + (lambda (&optional _) "tester")) + ((symbol-function 'erc-open) + (lambda (&rest r) + (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) + (erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) + + (ert-info ("Default click-through accept TLS upgrade") + (ert-simulate-keys "\r\r\r\ry\r" + (call-interactively #'erc)) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) + (erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Nick supplied, decline TLS upgrade") + (ert-simulate-keys "\r\rdummy\r\rn\r" + (call-interactively #'erc)) + (should (equal (pop calls) + '("irc.libera.chat" 6667 "dummy" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) + (erc-server-connect-function + erc-open-network-stream)))))))) + +(ert-deftest erc-server-select () + (let (calls env) + (cl-letf (((symbol-function 'user-login-name) + (lambda (&optional _) "tester")) + ((symbol-function 'erc-open) + (lambda (&rest r) + (push `((erc-join-buffer ,erc-join-buffer) + (erc--display-context ,@erc--display-context) + (erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) + + (ert-info ("Selects Libera.Chat Europe, automatic TSL") + (ert-simulate-keys "Libera.Chat\rirc.eu.\t\r\r\r" + (with-suppressed-warnings ((obsolete erc-server-select)) + (call-interactively #'erc-server-select))) + (should (equal (pop calls) + '("irc.eu.libera.chat" 6697 "tester" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) + (erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Selects entry that doesn't support TLS") + (ert-simulate-keys "IRCnet\rirc.fr.\t\rdummy\r\r" + (with-suppressed-warnings ((obsolete erc-server-select)) + (call-interactively #'erc-server-select))) + (should (equal (pop calls) + '("irc.fr.ircnet.net" 6667 "dummy" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-join-buffer window) + (erc--display-context (erc-interactive-display . erc)) + (erc-server-connect-function + erc-open-network-stream)))))))) (ert-deftest erc-handle-irc-url () (let* (calls @@ -1146,10 +2953,10 @@ (cl-letf (((symbol-function 'erc-cmd-JOIN) (lambda (&rest r) (push r calls)))) - (with-current-buffer (erc-tests--make-server-buf "foonet") + (with-current-buffer (erc-tests-common-make-server-buf "foonet") (setq rvbuf (current-buffer))) - (erc-tests--make-server-buf "barnet") - (erc-tests--make-server-buf "baznet") + (erc-tests-common-make-server-buf "barnet") + (erc-tests-common-make-server-buf "baznet") (ert-info ("Unknown network") (erc-handle-irc-url "irc.foonet.org" 6667 "#chan" nil nil "irc") @@ -1173,7 +2980,8 @@ (should-not calls)) (ert-info ("Known network, existing chan with key") - (erc-tests--make-client-buf "foonet" "#chan") + (save-excursion + (with-current-buffer "foonet" (erc--open-target "#chan"))) (erc-handle-irc-url "irc.foonet.org" nil "#chan?sec" nil nil "irc") (should (equal '("#chan" "sec") (pop calls))) (should-not calls)) @@ -1186,7 +2994,7 @@ (ert-info ("Unknown network, connect, chan") (with-current-buffer "foonet" (should-not (local-variable-p 'erc-after-connect))) - (setq rvbuf (lambda () (erc-tests--make-server-buf "gnu"))) + (setq rvbuf (lambda () (erc-tests-common-make-server-buf "gnu"))) (erc-handle-irc-url "irc.gnu.org" nil "#spam" nil nil "irc") (should (equal '("irc" :server "irc.gnu.org") (pop calls))) (should-not calls) @@ -1198,10 +3006,142 @@ (should-not calls)))) (when noninteractive - (kill-buffer "foonet") - (kill-buffer "barnet") - (kill-buffer "baznet") - (kill-buffer "#chan"))) + (erc-tests-common-kill-buffers))) + +(ert-deftest erc-channel-user () + ;; Traditional and alternate constructor swapped for compatibility. + (should (= 0 (erc-channel-user-status (erc-channel-user--make)))) + (should-not (erc-channel-user-last-message-time (erc-channel-user--make))) + + (should (= 42 (erc-channel-user-last-message-time + (make-erc-channel-user :last-message-time 42)))) + + (should (zerop (erc-channel-user-status (make-erc-channel-user)))) + + (let ((u (make-erc-channel-user))) + + (ert-info ("Add voice status to user") + (should (= 0 (erc-channel-user-status u))) + (should-not (erc-channel-user-voice u)) + (should (eq t (setf (erc-channel-user-voice u) t))) + (should (eq t (erc-channel-user-voice u)))) + + (ert-info ("Add op status to user") + (should (= 1 (erc-channel-user-status u))) + (should-not (erc-channel-user-op u)) + (should (eq t (setf (erc-channel-user-op u) t))) + (should (eq t (erc-channel-user-op u)))) + + (ert-info ("Add owner status to user") + (should (= 5 (erc-channel-user-status u))) + (should-not (erc-channel-user-owner u)) + (should (eq t (setf (erc-channel-user-owner u) t))) + (should (eq t (erc-channel-user-owner u)))) + + (ert-info ("Remove owner status from user") + (should (= 21 (erc-channel-user-status u))) + (should-not (setf (erc-channel-user-owner u) nil)) + (should-not (erc-channel-user-owner u))) + + (ert-info ("Remove op status from user") + (should (= 5 (erc-channel-user-status u))) + (should-not (setf (erc-channel-user-op u) nil)) + (should-not (erc-channel-user-op u))) + + (ert-info ("Remove voice status from user") + (should (= 1 (erc-channel-user-status u))) + (should-not (setf (erc-channel-user-voice u) nil)) + (should-not (erc-channel-user-voice u))) + + (ert-info ("Remove voice status from zeroed user") + (should (= 0 (erc-channel-user-status u))) + (should-not (setf (erc-channel-user-voice u) nil)) + (should-not (erc-channel-user-voice u)) + (should (= 0 (erc-channel-user-status u)))))) + +(defconst erc-tests--modules + '( autoaway autojoin bufbar button capab-identify + command-indicator completion dcc fill identd + imenu irccontrols keep-place list log match menu move-to-prompt netsplit + networks nickbar nicks noncommands notifications notify page readonly + replace ring sasl scrolltobottom services smiley sound + spelling stamp track truncate unmorse xdcc)) + +;; Ensure that `:initialize' doesn't change the ordering of the +;; members because otherwise the widget's state is "edited". + +(ert-deftest erc-modules--initialize () + ;; This is `custom--standard-value' from Emacs 28. + (should (equal (eval (car (get 'erc-modules 'standard-value)) t) + erc-modules))) + +;; Ensure the `:initialize' function for `erc-modules' successfully +;; tags all built-in modules with the internal property `erc--module'. + +(ert-deftest erc-modules--internal-property () + (let (ours) + (mapatoms (lambda (s) + (when-let ((v (get s 'erc--module)) + ((eq v s))) + (push s ours)))) + (should (equal (sort ours #'string-lessp) erc-tests--modules)))) + +(ert-deftest erc--normalize-module-symbol () + (dolist (mod erc-tests--modules) + (should (eq (erc--normalize-module-symbol mod) mod))) + (should (eq (erc--normalize-module-symbol 'pcomplete) 'completion)) + (should (eq (erc--normalize-module-symbol 'Completion) 'completion)) + (should (eq (erc--normalize-module-symbol 'ctcp-page) 'page)) + (should (eq (erc--normalize-module-symbol 'ctcp-sound) 'sound)) + (should (eq (erc--normalize-module-symbol 'timestamp) 'stamp)) + (should (eq (erc--normalize-module-symbol 'nickserv) 'services))) + +(defun erc-tests--assert-printed-in-subprocess (code expected) + (let ((proc (erc-tests-common-create-subprocess code '("-batch") nil))) + (while (accept-process-output proc 10)) + (goto-char (point-min)) + (unless (equal (read (current-buffer)) expected) + (message "Expected: %S\nGot: %s" expected (buffer-string)) + (ert-fail "Mismatch")))) + +;; Worrying about which library a module comes from is mostly not +;; worth the hassle so long as ERC can find its minor mode. However, +;; bugs involving multiple modules living in the same library may slip +;; by because a module's loading problems may remain hidden on account +;; of its place in the default ordering. + +(ert-deftest erc--find-mode () + (erc-tests--assert-printed-in-subprocess + `(let ((mods (mapcar #'cadddr (cdddr (get 'erc-modules 'custom-type)))) + moded) + (setq mods (sort mods (lambda (a b) (if (zerop (random 2)) a b)))) + (dolist (mod mods) + (unless (keywordp mod) + (push (if-let ((mode (erc--find-mode mod))) mod (list :missing mod)) + moded))) + (message "%S" + (sort moded (lambda (a b) + (string< (symbol-name a) (symbol-name b)))))) + erc-tests--modules)) + +(ert-deftest erc--essential-hook-ordering () + (erc-tests--assert-printed-in-subprocess + '(progn + (erc-update-modules) + (message "%S" + (list :erc-insert-modify-hook erc-insert-modify-hook + :erc-send-modify-hook erc-send-modify-hook))) + + '( :erc-insert-modify-hook (erc-controls-highlight ; 0 + erc-button-add-buttons ; 30 + erc-match-message ; 50 + erc-fill ; 60 + erc-add-timestamp) ; 70 + + :erc-send-modify-hook ( erc-controls-highlight ; 0 + erc-button-add-buttons ; 30 + erc-fill ; 40 + erc-add-timestamp)))) ; 70 (ert-deftest erc-migrate-modules () (should (equal (erc-migrate-modules '(autojoin timestamp button)) @@ -1209,46 +3149,162 @@ ;; Default unchanged (should (equal (erc-migrate-modules erc-modules) erc-modules))) -(ert-deftest erc--update-modules () - (let (calls - erc-modules - erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) - (cl-letf (((symbol-function 'require) - (lambda (s &rest _) (push s calls))) - - ;; Local modules - ((symbol-function 'erc-fake-bar-mode) - (lambda (n) (push (cons 'fake-bar n) calls))) +(ert-deftest erc--find-group () + ;; These two are loaded by default + (should (eq (erc--find-group 'keep-place nil) 'erc)) + (should (eq (erc--find-group 'networks nil) 'erc-networks)) + ;; These are fake + (cl-letf (((get 'erc-bar 'group-documentation) "") + ((get 'baz 'erc-group) 'erc-foo)) + (should (eq (erc--find-group 'foo 'bar) 'erc-bar)) + (should (eq (erc--find-group 'bar 'foo) 'erc-bar)) + (should (eq (erc--find-group 'bar nil) 'erc-bar)) + (should (eq (erc--find-group 'foo nil) 'erc)) + (should (eq (erc--find-group 'fake 'baz) 'erc-foo)))) + +(ert-deftest erc--find-group--real () + :tags '(:unstable) + (require 'erc-services) + (require 'erc-stamp) + (require 'erc-sound) + (require 'erc-page) + (require 'erc-join) + (require 'erc-capab) + (require 'erc-pcomplete) + (should (eq (erc--find-group 'services 'nickserv) 'erc-services)) + (should (eq (erc--find-group 'stamp 'timestamp) 'erc-stamp)) + (should (eq (erc--find-group 'sound 'ctcp-sound) 'erc-sound)) + (should (eq (erc--find-group 'page 'ctcp-page) 'erc-page)) + (should (eq (erc--find-group 'autojoin) 'erc-autojoin)) + (should (eq (erc--find-group 'pcomplete 'Completion) 'erc-pcomplete)) + (should (eq (erc--find-group 'capab-identify) 'erc-capab)) + ;; No group specified. + (should (eq (erc--find-group 'smiley nil) 'erc)) + (should (eq (erc--find-group 'unmorse nil) 'erc))) + +(ert-deftest erc--sort-modules () + (should (equal (erc--sort-modules '(networks foo fill bar fill stamp bar)) + ;; Third-party mods appear in original order. + '(fill networks stamp foo bar)))) + +(defun erc-tests--update-modules (fn) + (let* ((calls nil) + (custom-modes nil) + (on-load nil) + (text-quoting-style 'grave) + + (get-calls (lambda () (prog1 (nreverse calls) (setq calls nil)))) + + (add-onload (lambda (m k v) + (put (intern m) 'erc--feature k) + (push (cons k (lambda () (funcall v m))) on-load))) + + (mk-cmd (lambda (module) + (let ((mode (intern (format "erc-%s-mode" module)))) + (fset mode (lambda (n) (push (cons mode n) calls)))))) + + (mk-builtin (lambda (module-string) + (let ((s (intern module-string))) + (put s 'erc--module s)))) + + (mk-global (lambda (module) + (push (intern (format "erc-%s-mode" module)) + custom-modes)))) - ;; Global modules - ((symbol-function 'erc-fake-foo-mode) - (lambda (n) (push (cons 'fake-foo n) calls))) - ((get 'erc-fake-foo-mode 'standard-value) 'ignore) + (cl-letf (((symbol-function 'require) + (lambda (s &rest _) + ;; Simulate library being loaded, things defined. + (when-let ((h (alist-get s on-load))) (funcall h)) + (push (cons 'req s) calls))) + + ;; Spoof global module detection. + ((symbol-function 'custom-variable-p) + (lambda (v) (memq v custom-modes)))) + + (funcall fn get-calls add-onload mk-cmd mk-builtin mk-global)) + (should-not erc--aberrant-modules))) + +(ert-deftest erc--update-modules/unknown () + (erc-tests--update-modules + + (lambda (get-calls _ mk-cmd _ mk-global) + + (ert-info ("Baseline") + (let* ((erc-modules '(foo)) + (obarray (obarray-make)) + (err (should-error (erc--update-modules erc-modules)))) + (should (equal (cadr err) "`foo' is not a known ERC module")) + (should (equal (mapcar #'prin1-to-string (funcall get-calls)) + '("(req . erc-foo)"))))) + + ;; Module's mode command exists but lacks an associated file. + (ert-info ("Bad autoload flagged as suspect") + (should-not erc--aberrant-modules) + (let* ((erc--aberrant-modules nil) + (obarray (obarray-make)) + (erc-modules (list (intern "foo")))) + + ;; Create a mode-activation command and make mode-var global. + (funcall mk-cmd "foo") + (funcall mk-global "foo") + + ;; No local modules to return. + (should-not (erc--update-modules erc-modules)) + (should (equal (mapcar #'prin1-to-string erc--aberrant-modules) + '("foo"))) + ;; ERC requires the library via prefixed module name. + (should (equal (mapcar #'prin1-to-string (funcall get-calls)) + '("(req . erc-foo)" "(erc-foo-mode . 1)")))))))) + +;; A local module (here, `lo2') lacks a mode toggle, so ERC tries to +;; load its defining library, first via the symbol property +;; `erc--feature', and then via an "erc-" prefixed symbol. +(ert-deftest erc--update-modules/local () + (erc-tests--update-modules + + (lambda (get-calls add-onload mk-cmd mk-builtin mk-global) + + (let* ((obarray (obarray-make 20)) + (erc-modules (mapcar #'intern '("glo" "lo1" "lo2")))) + + ;; Create a global and a local module. + (mapc mk-cmd '("glo" "lo1")) + (mapc mk-builtin '("glo" "lo1")) + (funcall mk-global "glo") + (funcall add-onload "lo2" 'explicit-feature-lib mk-cmd) + + ;; Returns local modules. + (should (equal (mapcar #'symbol-name (erc--update-modules erc-modules)) + '("erc-lo2-mode" "erc-lo1-mode"))) + + ;; Requiring `erc-lo2' defines `erc-lo2-mode'. + (should (equal (mapcar #'prin1-to-string (funcall get-calls)) + `("(erc-glo-mode . 1)" + "(req . explicit-feature-lib)"))))))) + +(ert-deftest erc--update-modules/realistic () + (let ((calls nil) + ;; Module `pcomplete' "resolves" to `completion'. + (erc-modules '(pcomplete autojoin networks))) + (cl-letf (((symbol-function 'require) + (lambda (s &rest _) (push (cons 'req s) calls))) + + ;; Spoof global module detection. + ((symbol-function 'custom-variable-p) + (lambda (v) + (memq v '(erc-autojoin-mode erc-networks-mode + erc-completion-mode)))) + ;; Mock and spy real builtins. ((symbol-function 'erc-autojoin-mode) (lambda (n) (push (cons 'autojoin n) calls))) - ((get 'erc-autojoin-mode 'standard-value) 'ignore) ((symbol-function 'erc-networks-mode) (lambda (n) (push (cons 'networks n) calls))) - ((get 'erc-networks-mode 'standard-value) 'ignore) ((symbol-function 'erc-completion-mode) - (lambda (n) (push (cons 'completion n) calls))) - ((get 'erc-completion-mode 'standard-value) 'ignore)) - - (ert-info ("Local modules") - (setq erc-modules '(fake-foo fake-bar)) - (should (equal (erc--update-modules) '(erc-fake-bar-mode))) - ;; Bar the feature is still required but the mode is not activated - (should (equal (nreverse calls) - '(erc-fake-foo (fake-foo . 1) erc-fake-bar))) - (setq calls nil)) - - (ert-info ("Module name overrides") - (setq erc-modules '(completion autojoin networks)) - (should-not (erc--update-modules)) ; no locals - (should (equal (nreverse calls) '( erc-pcomplete (completion . 1) - erc-join (autojoin . 1) - erc-networks (networks . 1)))) - (setq calls nil))))) + (lambda (n) (push (cons 'completion n) calls)))) + + (should-not (erc--update-modules erc-modules)) ; no locals + (should (equal (nreverse calls) + '((completion . 1) (autojoin . 1) (networks . 1))))))) (ert-deftest erc--merge-local-modes () (cl-letf (((get 'erc-b-mode 'erc-module) 'b) @@ -1276,36 +3332,51 @@ (ert-deftest define-erc-module--global () (let ((global-module '(define-erc-module mname malias - "Some docstring" + "Some docstring." ((ignore a) (ignore b)) ((ignore c) (ignore d))))) - (should (equal (macroexpand global-module) + (should (equal (cl-letf (((symbol-function + 'erc--prepare-custom-module-type) + #'symbol-name)) + (macroexpand global-module)) `(progn (define-minor-mode erc-mname-mode "Toggle ERC mname mode. -With a prefix argument ARG, enable mname if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. -Some docstring" +With a prefix argument ARG, enable mname if ARG is positive, and +disable it otherwise. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Some docstring." :global t - :group 'erc-mname - (if erc-mname-mode - (erc-mname-enable) - (erc-mname-disable))) + :group (erc--find-group 'mname 'malias) + :require 'nil + :type "mname" + (let ((erc--module-toggle-prefix-arg arg)) + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable)))) (defun erc-mname-enable () "Enable ERC mname mode." (interactive) - (cl-pushnew 'mname erc-modules) + (unless (or erc--inside-mode-toggle-p + (memq 'mname erc-modules)) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + 'mname #'cons))) (setq erc-mname-mode t) (ignore a) (ignore b)) (defun erc-mname-disable () "Disable ERC mname mode." (interactive) - (setq erc-modules (delq 'mname erc-modules)) + (unless (or erc--inside-mode-toggle-p + (not (memq 'mname erc-modules))) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + 'mname #'delq))) (setq erc-mname-mode nil) (ignore c) (ignore d)) @@ -1319,7 +3390,7 @@ Some docstring" (ert-deftest define-erc-module--local () (let* ((global-module '(define-erc-module mname nil ; no alias - "Some docstring" + "Some docstring." ((ignore a) (ignore b)) ((ignore c) (ignore d)) 'local)) @@ -1331,19 +3402,22 @@ Some docstring" `(progn (define-minor-mode erc-mname-mode "Toggle ERC mname mode. -With a prefix argument ARG, enable mname if ARG is positive, -and disable it otherwise. If called from Lisp, enable the mode -if ARG is omitted or nil. -Some docstring" +With a prefix argument ARG, enable mname if ARG is positive, and +disable it otherwise. If called from Lisp, enable the mode if +ARG is omitted or nil. + +Some docstring." :global nil - :group 'erc-mname - (if erc-mname-mode - (erc-mname-enable) - (erc-mname-disable))) + :group (erc--find-group 'mname nil) + (let ((erc--module-toggle-prefix-arg arg)) + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable)))) (defun erc-mname-enable (&optional ,arg-en) "Enable ERC mname mode. -When called interactively, do so in all buffers for the current connection." +When called interactively, do so in all buffers for the current +connection." (interactive "p") (when (derived-mode-p 'erc-mode) (if ,arg-en @@ -1355,7 +3429,8 @@ When called interactively, do so in all buffers for the current connection." (defun erc-mname-disable (&optional ,arg-dis) "Disable ERC mname mode. -When called interactively, do so in all buffers for the current connection." +When called interactively, do so in all buffers for the current +connection." (interactive "p") (when (derived-mode-p 'erc-mode) (if ,arg-dis @@ -1370,4 +3445,86 @@ When called interactively, do so in all buffers for the current connection." (put 'erc-mname-enable 'definition-name 'mname) (put 'erc-mname-disable 'definition-name 'mname)))))) +(ert-deftest erc-tests-common-string-to-propertized-parts () + :tags '(:unstable) ; only run this locally + (unless (>= emacs-major-version 28) (ert-skip "Missing `object-intervals'")) + + (should (equal (erc-tests-common-string-to-propertized-parts + #("abc" + 0 1 (face default foo 1) + 1 3 (face (default italic) bar "2"))) + '(concat (propertize "a" 'foo 1 'face 'default) + (propertize "bc" 'bar "2" 'face '(default italic))))) + (should (equal #("abc" + 0 1 (face default foo 1) + 1 3 (face (default italic) bar "2")) + (concat (propertize "a" 'foo 1 'face 'default) + (propertize "bc" 'bar "2" 'face '(default italic)))))) + +(ert-deftest erc--make-message-variable-name () + (should (erc--make-message-variable-name 'english 'QUIT 'softp)) + (should (erc--make-message-variable-name 'english 'QUIT nil)) + + (let ((obarray (obarray-make))) + (should-not (erc--make-message-variable-name 'testcat 'testkey 'softp)) + (should (erc--make-message-variable-name 'testcat 'testkey nil)) + (should (intern-soft "erc-message-testcat-testkey" obarray)) + (should-not (erc--make-message-variable-name 'testcat 'testkey 'softp)) + (set (intern "erc-message-testcat-testkey" obarray) "hello world") + (should (equal (symbol-value + (erc--make-message-variable-name 'testcat 'testkey nil)) + "hello world"))) + + ;; Hyphenated (internal catalog). + (let ((obarray (obarray-make))) + (should-not (erc--make-message-variable-name '-testcat 'testkey 'softp)) + (should (erc--make-message-variable-name '-testcat 'testkey nil)) + (should (intern-soft "erc--message-testcat-testkey" obarray)) + (should-not (erc--make-message-variable-name '-testcat 'testkey 'softp)) + (set (intern "erc--message-testcat-testkey" obarray) "hello world") + (should (equal (symbol-value + (erc--make-message-variable-name '-testcat 'testkey nil)) + "hello world")))) + +(ert-deftest erc-retrieve-catalog-entry () + (should (eq 'english erc-current-message-catalog)) + (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m")) + + ;; Local binding. + (with-temp-buffer + (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m")) + (setq erc-current-message-catalog 'test) + ;; No catalog named `test'. + (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m")) + + (let ((obarray (obarray-make))) + (set (intern "erc-message-test-s221") "test 221 val") + (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val")) + (set (intern "erc-message-english-s221") "eng 221 val") + + (let ((erc-current-message-catalog 'english)) + (should (equal (erc-retrieve-catalog-entry 's221) "eng 221 val"))) + + (with-temp-buffer + (should (equal (erc-retrieve-catalog-entry 's221) "eng 221 val")) + (let ((erc-current-message-catalog 'test)) + (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val")))) + + (should (equal (erc-retrieve-catalog-entry 's221) "test 221 val"))) + + (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m")) + (should (equal erc-current-message-catalog 'test))) + + ;; Default top-level value. + (set-default-toplevel-value 'erc-current-message-catalog 'test-top) + (should (equal (erc-retrieve-catalog-entry 's221) "User modes for %n: %m")) + (set (intern "erc-message-test-top-s221") "test-top 221 val") + (should (equal (erc-retrieve-catalog-entry 's221) "test-top 221 val")) + + (setq erc-current-message-catalog 'test-local) + (should (equal (erc-retrieve-catalog-entry 's221) "test-top 221 val")) + + (makunbound (intern "erc-message-test-top-s221")) + (unintern "erc-message-test-top-s221" obarray)) + ;;; erc-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index ab8d708b721..ed3d190928f 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -104,6 +104,42 @@ '("#emacs" "#vi")) '("#e" "#v"))) )) +(ert-deftest erc-track--shortened-names () + (let (erc-track--shortened-names + erc-track--shortened-names-current-hash + results) + + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("a" "b" "c")) + (should (integerp (car erc-track--shortened-names))) + (should (equal (cdr erc-track--shortened-names) '("a" "b" "c"))) + (push erc-track--shortened-names results) + + ;; Redundant call doesn't run. + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + (should-not 'run) + '("a" "b" "c")) + (should (equal erc-track--shortened-names (car results))) + + ;; Change in environment or context forces run. + (with-temp-buffer + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("x" "y" "z"))) + (should (and (integerp (car erc-track--shortened-names)) + (/= (car erc-track--shortened-names) (caar results)))) + (should (equal (cdr erc-track--shortened-names) '("x" "y" "z"))) + (push erc-track--shortened-names results) + + (with-memoization (erc-track--shortened-names-get + '("apple" "banana" "cherries")) + '("1" "2" "3")) + (should (and (integerp (car erc-track--shortened-names)) + (/= (car erc-track--shortened-names) (caar results)))) + (should (equal (cdr erc-track--shortened-names) '("1" "2" "3"))))) + (ert-deftest erc-track--erc-faces-in () "`erc-faces-in' should pick up both 'face and 'font-lock-face properties." (let ((str0 (copy-sequence "is bold")) @@ -120,4 +156,134 @@ (should (erc-faces-in str0)) (should (erc-faces-in str1)) )) +;; This simulates an alternating bold/non-bold [#c] in the mode-line, +;; i.e., an `erc-modified-channels-alist' that vacillates between +;; +;; ((#<buffer #chan> 42 . erc-default-face)) +;; +;; and +;; +;; ((#<buffer #chan> 42 erc-nick-default-face erc-default-face)) +;; +;; This is a fairly typical scenario where consecutive messages +;; feature speaker and addressee button highlighting and otherwise +;; plain message bodies. This mapping of phony to real faces +;; describes the picture in 5.6: +;; +;; `1': (erc-button erc-default-face) ; URL +;; `2': (erc-nick-default-face erc-default-face) ; mention +;; `3': erc-default-face ; body +;; `_': (erc-nick-default-face erc-nick-default-face) ; speaker +;; +;; The `_' represents a commonly occurring face (a <speaker>) that's +;; not present in either option's default (standard) value. It's a +;; no-op from the POV of `erc-track-select-mode-line-face'. + +(ert-deftest erc-track-select-mode-line-face () + + ;; Observed (see key above). + (let ((erc-track-faces-priority-list '(1 2 3)) + (erc-track-faces-normal-list '(1 2 3))) + + (should (equal 2 (erc-track-select-mode-line-face 3 '(2 _ 3)))) + (should (equal 2 (erc-track-select-mode-line-face 2 '(2 _ 3)))) + (should (equal 3 (erc-track-select-mode-line-face 2 '(_ 3)))) + (should (equal 2 (erc-track-select-mode-line-face 3 '(2 3)))) + (should (equal 3 (erc-track-select-mode-line-face 2 '(3)))) + + (should (equal 1 (erc-track-select-mode-line-face 1 '(2 1 3)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(1 3 2)))) + (should (equal 1 (erc-track-select-mode-line-face 1 '(3 1))))) + + ;; When the current face outranks all new faces and doesn't appear + ;; among them, it's eligible to be replaced with a fellow "normal" + ;; from those new faces. But if it does appear among them, it's + ;; never replaced. + (let ((erc-track-faces-priority-list '(a b)) + (erc-track-faces-normal-list '(a b))) + + (should (equal 'a (erc-track-select-mode-line-face 'a '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'a '(a b)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(a b)))) + + (should (equal 'a (erc-track-select-mode-line-face 'b '(a)))) + (should (equal 'b (erc-track-select-mode-line-face 'a '(b))))) + + ;; The ordering of the "normal" list doesn't matter. + (let ((erc-track-faces-priority-list '(a b)) + (erc-track-faces-normal-list '(b a))) + + (should (equal 'a (erc-track-select-mode-line-face 'a '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'a '(a b)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(b a)))) + (should (equal 'a (erc-track-select-mode-line-face 'b '(a b)))))) + +(defun erc-track-tests--select-mode-line-face (ranked normals cases) + (setq normals (map-into (mapcar (lambda (f) (cons f t)) normals) + '(hash-table :test equal))) + (pcase-dolist (`(,want ,cur-face ,new-faces) cases) + + (ert-info ((format "Observed: {cur: %S, new: %S, want: %S}" + cur-face new-faces want)) + (setq new-faces (cons (map-into + (mapcar (lambda (f) (cons f t)) new-faces) + '(hash-table :test equal)) + (reverse new-faces))) + (should (equal want (funcall #'erc-track--select-mode-line-face + cur-face new-faces ranked normals)))))) + +;; The main difference between these variants is that with the above, +;; when given alternating lines like +;; +;; CUR NEW CHOICE +;; text (mention $speaker text) => mention +;; mention ($speaker text) => text +;; +;; we see the effect of alternating faces in the indicator. But when +;; given consecutive lines with a similar composition, like +;; +;; text (mention $speaker text) => mention +;; text (mention $speaker text) => mention +;; +;; we lose the effect. With the variant below, we get +;; +;; text (mention $speaker text) => mention +;; text (mention $speaker text) => text +;; + +(ert-deftest erc-track--select-mode-line-face () + (should-not erc-track-ignore-normal-contenders-p) + + ;; These are the same test cases from the previous test. The syntax + ;; is (expected cur-face new-faces). + (erc-track-tests--select-mode-line-face + '(1 2 3) '(1 2 3) + '((2 3 (2 _ 3)) + (3 2 (2 _ 3)) + (3 2 (_ 3)) + (2 3 (2 3)) + (3 2 (3)) + (2 1 (2 1 3)) + (3 1 (1 3)) + (2 1 (1 3 2)) + (3 1 (3 1)))) + + (erc-track-tests--select-mode-line-face + '(a b) '(a b) + '((b a (b a)) + (b a (a b)) + (a b (b a)) + (a b (a b)) + (a b (a)) + (b a (b)))) + + (erc-track-tests--select-mode-line-face + '(a b) '(b a) + '((b a (b a)) + (b a (a b)) + (a b (b a)) + (a b (a b))))) + ;;; erc-track-tests.el ends here diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld index 35a9a570b6d..060f4178723 100644 --- a/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld +++ b/test/lisp/erc/resources/base/assoc/bouncer-history/barnet.eld @@ -17,7 +17,7 @@ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.barnet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer ^ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@xrir8fpe4d7ak.irc JOIN #chan") @@ -34,7 +34,7 @@ (0 ":irc.barnet.org NOTICE tester :[07:00:01] 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.") (0 ":irc.barnet.org 305 tester :You are no longer marked as being away")) -((mode 6 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1619593200") (0.25 ":joe!~u@svpn88yjcdj42.irc PRIVMSG #chan :mike: But, in defense, by mercy, 'tis most just.") diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld index 58df79e19fa..ecde8adaec4 100644 --- a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld +++ b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld @@ -17,7 +17,7 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer ^ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@nvfhxvqm92rm6.irc JOIN #chan") @@ -27,6 +27,7 @@ (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:02] alice: Here come the lovers, full of joy and mirth.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:07] bob: According to the fool's bolt, sir, and such dulcet diseases.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:10] alice: And hang himself. I pray you, do my greeting.") + (0 ":someone!~u@abcdefg.irc PRIVMSG #chan :[07:04:10] hi everyone.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:18] bob: And you sat smiling at his cruel prey.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:21] alice: Or never after look me in the face.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:25] bob: If that may be, than all is well. Come, sit down, every mother's son, and rehearse your parts. Pyramus, you begin: when you have spoken your speech, enter into that brake; and so every one according to his cue.") @@ -38,7 +39,7 @@ (0 ":irc.foonet.org NOTICE tester :[07:00:32] 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.") (0 ":irc.foonet.org 305 tester :You are no longer marked as being away")) -((mode 6 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1619593200") (0.9 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :bob: Grows, lives, and dies, in single blessedness.") diff --git a/test/lisp/erc/resources/base/assoc/bumped/again.eld b/test/lisp/erc/resources/base/assoc/bumped/again.eld index ab3c7b06214..aef164b6237 100644 --- a/test/lisp/erc/resources/base/assoc/bumped/again.eld +++ b/test/lisp/erc/resources/base/assoc/bumped/again.eld @@ -1,10 +1,10 @@ ;; -*- mode: lisp-data; -*- -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0.0 ":irc.foonet.org 433 * tester :Nickname is reserved by a different account") (0.0 ":irc.foonet.org FAIL NICK NICKNAME_RESERVED tester :Nickname is reserved by a different account")) -((nick 3 "NICK tester`") +((nick 10 "NICK tester`") (0.1 ":irc.foonet.org 001 tester` :Welcome to the foonet IRC Network tester`") (0.0 ":irc.foonet.org 002 tester` :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5") (0.0 ":irc.foonet.org 003 tester` :This server was created Fri, 24 Sep 2021 01:38:36 UTC") @@ -21,10 +21,10 @@ (0.2 ":irc.foonet.org 266 tester` 3 3 :Current global users 3, max 3") (0.0 ":irc.foonet.org 422 tester` :MOTD File is missing")) -((mode-user 3.2 "MODE tester` +i") +((mode-user 10 "MODE tester` +i") (0.0 ":irc.foonet.org 221 tester` +i") (0.0 ":irc.foonet.org NOTICE tester` :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.")) -((privmsg 42.6 "PRIVMSG NickServ :IDENTIFY tester changeme") +((privmsg 10 "PRIVMSG NickServ :IDENTIFY tester changeme") (0.01 ":tester`!~u@rpaau95je67ci.irc NICK tester") (0.0 ":NickServ!NickServ@localhost NOTICE tester :You're now logged in as tester")) diff --git a/test/lisp/erc/resources/base/assoc/bumped/foisted.eld b/test/lisp/erc/resources/base/assoc/bumped/foisted.eld index 5c36e58d9d3..0f7aadac564 100644 --- a/test/lisp/erc/resources/base/assoc/bumped/foisted.eld +++ b/test/lisp/erc/resources/base/assoc/bumped/foisted.eld @@ -1,6 +1,6 @@ ;; -*- mode: lisp-data; -*- -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0.0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5") (0.0 ":irc.foonet.org 003 tester :This server was created Fri, 24 Sep 2021 01:38:36 UTC") @@ -17,14 +17,14 @@ (0.0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0.0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0.0 ":irc.foonet.org 221 tester +i") (0.0 ":irc.foonet.org NOTICE tester :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.")) -((privmsg 17.21 "PRIVMSG bob :hi") +((privmsg 10 "PRIVMSG bob :hi") (0.02 ":bob!~u@ecnnh95wr67pv.net PRIVMSG tester :hola") (0.01 ":bob!~u@ecnnh95wr67pv.net PRIVMSG tester :how r u?")) -((quit 18.19 "QUIT :" quit) +((quit 10 "QUIT :" quit) (0.01 ":tester!~u@rpaau95je67ci.irc QUIT :Quit: " quit)) ((drop 1 DROP)) diff --git a/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld b/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld index 33e4168ac46..63366d3f576 100644 --- a/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld +++ b/test/lisp/erc/resources/base/assoc/bumped/refoisted.eld @@ -1,6 +1,6 @@ ;; -*- mode: lisp-data; -*- -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0.1 ":irc.foonet.org 001 dummy :Welcome to the foonet IRC Network dummy") (0.0 ":irc.foonet.org 002 dummy :Your host is irc.foonet.org, running version oragono-2.6.1-937b9b02368748e5") (0.0 ":irc.foonet.org 003 dummy :This server was created Fri, 24 Sep 2021 01:38:36 UTC") @@ -22,10 +22,10 @@ (0.01 ":bob!~u@ecnnh95wr67pv.net PRIVMSG dummy :back?") ) -((mode-user 1.2 "MODE dummy +i") +((mode-user 10 "MODE dummy +i") (0.0 ":irc.foonet.org 221 dummy +i") (0.0 ":irc.foonet.org NOTICE dummy :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.")) -((renick 42.6 "NICK tester") +((renick 10 "NICK tester") (0.01 ":dummy!~u@rpaau95je67ci.irc NICK tester") (0.0 ":NickServ!NickServ@localhost NOTICE dummy :You're now logged in as tester")) diff --git a/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld b/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld index c62a22a11c7..4c2b1d61e24 100644 --- a/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld +++ b/test/lisp/erc/resources/base/assoc/multi-net/barnet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.barnet.org 003 tester :This server was created Tue, 04 May 2021 05:06:19 UTC") @@ -18,16 +18,16 @@ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.barnet.org 422 tester :MOTD File is missing")) -((mode-user 8 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.barnet.org 221 tester +i") (0 ":irc.barnet.org NOTICE tester :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.")) -((join 2 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@jnu48g2wrycbw.irc JOIN #chan") (0 ":irc.barnet.org 353 tester = #chan :@mike joe tester") (0 ":irc.barnet.org 366 tester #chan :End of NAMES list")) -((mode 2 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620104779") (0.1 ":mike!~u@kd7gmjbnbkn8c.irc PRIVMSG #chan :tester, welcome!") diff --git a/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld b/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld index f30b7deca11..bfa324642ce 100644 --- a/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld +++ b/test/lisp/erc/resources/base/assoc/multi-net/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") @@ -18,16 +18,16 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 8 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.foonet.org 221 tester +i") (0 ":irc.foonet.org NOTICE tester :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.")) -((join 2 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@9g6b728983yd2.irc JOIN #chan") (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob") (0 ":irc.foonet.org 366 tester #chan :End of NAMES list")) -((mode 2 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620104779") (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!") diff --git a/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld b/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld index f916fea2374..15bcca2a623 100644 --- a/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld +++ b/test/lisp/erc/resources/base/assoc/reconplay/foonet.eld @@ -1,5 +1,5 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) +((pass 10 "PASS :changeme")) ((nick 1 "NICK tester")) ((user 1 "USER user 0 * :tester") (0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") diff --git a/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld b/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld new file mode 100644 index 00000000000..c3791ac3d49 --- /dev/null +++ b/test/lisp/erc/resources/base/channel-buffer-revival/reattach.eld @@ -0,0 +1,56 @@ +;; -*- mode: lisp-data; -*- +((pass 10 "PASS :tester@vanilla/foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.00 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.00 ":irc.foonet.org 003 tester :This server was created Thu, 13 Apr 2023 05:55:22 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.00 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.00 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode 10 "MODE tester +i") + (0.01 ":irc.foonet.org 221 tester +Zi")) + +((privmsg-play 10 "PRIVMSG *status :playbuffer #chan") + (0.05 ":***!znc@znc.in PRIVMSG #chan :Buffer Playback...") + (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:24] alice: Was I a child, to fear I know not what.") + (0.02 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:29] bob: My lord, I do confess the ring was hers.") + (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:08:40] alice: My sons would never so dishonour me.") + (0.01 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:09:54] bob: By the hand of a soldier, I will undertake it.") + (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:09:57] alice: Thou counterfeit'st most lively.") + (0.01 ":***!znc@znc.in PRIVMSG #chan :Playback Complete.")) + +((privmsg-attach 10 "PRIVMSG *status :attach #chan") + (0.01 ":tester!~u@78a58pgahbr24.irc JOIN #chan")) + +((mode-chan 10 "MODE #chan") + (0.01 ":irc.foonet.org 353 tester = #chan :@alice bob tester") + (0.00 ":irc.foonet.org 366 tester #chan :End of /NAMES list.") + (0.00 ":***!znc@znc.in PRIVMSG #chan :Buffer Playback...") + (0.00 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:10:01] bob: With what it loathes for that which is away.") + (0.00 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:10:30] alice: Ties up my tongue, and will not let me speak.") + (0.00 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:11:26] bob: They say he is already in the forest of Arden, and a many merry men with him; and there they live like the old Robin Hood of England. They say many young gentlemen flock to him every day, and fleet the time carelessly, as they did in the golden world.") + (0.01 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :[06:11:29] alice: Not by his breath that is more miserable.") + (0.00 ":***!znc@znc.in PRIVMSG #chan :Playback Complete.") + (0.00 ":*status!znc@znc.in PRIVMSG tester :There was 1 channel matching [#chan]") + (0.03 ":*status!znc@znc.in PRIVMSG tester :Attached 1 channel") + (0.00 ":irc.foonet.org 324 tester #chan +Cnt") + (0.00 ":irc.foonet.org 329 tester #chan 1681365340") + (0.03 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Five or six thousand horse, I said,I will say true,or thereabouts, set down, for I'll speak truth.") + (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: Riddling confession finds but riddling shrift.") + (0.04 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Ay, and the captain of his horse, Count Rousillon.")) + +((privmsg-bob 10 "PRIVMSG #chan :bob: hi") + (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: But thankful even for hate, that is meant love.") + (0.02 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :tester: Come, come, elder brother, you are too young in this.") + (0.02 ":alice!~u@q2weir96jk3r2.irc PRIVMSG #chan :bob: Sir, we have known together in Orleans.") + (0.05 ":bob!~u@q2weir96jk3r2.irc PRIVMSG #chan :alice: Pawn me to this your honour, she is his.")) diff --git a/test/lisp/erc/resources/base/display-message/multibuf.eld b/test/lisp/erc/resources/base/display-message/multibuf.eld new file mode 100644 index 00000000000..424a687e749 --- /dev/null +++ b/test/lisp/erc/resources/base/display-message/multibuf.eld @@ -0,0 +1,45 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sat, 14 Oct 2023 16:08:20 UTC") + (0.02 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 5 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 5 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 5 5 :Current local users 5, max 5") + (0.02 ":irc.foonet.org 266 tester 5 5 :Current global users 5, max 5") + (0.01 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.00 ":irc.foonet.org 221 tester +i") + (0.01 ":irc.foonet.org NOTICE tester :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.")) + +((mode 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i")) + +((join 10 "JOIN #chan") + (0.03 ":tester!~u@rdjcgiwfuwqmc.irc JOIN #chan") + (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice dummy tester") + (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.00 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :tester, welcome!") + (0.01 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :tester, welcome!")) + +((mode 10 "MODE #chan") + (0.01 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :alice: Persuade this rude wretch willingly to die.") + (0.01 ":irc.foonet.org 324 tester #chan +Cnt") + (0.01 ":irc.foonet.org 329 tester #chan 1697299707") + (0.03 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :bob: It might be yours or hers, for aught I know.") + (0.07 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :Would all themselves laugh mortal.") + (0.04 ":dummy!~u@rdjcgiwfuwqmc.irc PRIVMSG tester :hi") + (0.06 ":bob!~u@uee7kge7ua5sy.irc PRIVMSG #chan :alice: It hath pleased the devil drunkenness to give place to the devil wrath; one unperfectness shows me another, to make me frankly despise myself.") + (0.05 ":dummy!~u@rdjcgiwfuwqmc.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)") + (0.08 ":alice!~u@uee7kge7ua5sy.irc PRIVMSG #chan :You speak of him when he was less furnished than now he is with that which makes him both without and within.")) + +((quit 10 "QUIT :\2ERC\2") + (0.04 ":tester!~u@rdjcgiwfuwqmc.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)") + (0.02 "ERROR :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)")) diff --git a/test/lisp/erc/resources/base/display-message/statusmsg.eld b/test/lisp/erc/resources/base/display-message/statusmsg.eld new file mode 100644 index 00000000000..7c42117080c --- /dev/null +++ b/test/lisp/erc/resources/base/display-message/statusmsg.eld @@ -0,0 +1,47 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.02 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Thu, 07 Dec 2023 08:04:35 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.02 ":irc.foonet.org 265 tester 4 5 :Current local users 4, max 5") + (0.00 ":irc.foonet.org 266 tester 4 5 :Current global users 4, max 5") + (0.00 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.")) + +((mode-tester 10 "MODE tester +i")) + +((join-mine 10 "JOIN #mine") + (0.01 ":irc.foonet.org 221 tester +i") + (0.00 ":tester!~u@2jv6nwu4af69s.irc JOIN #mine") + (0.02 ":irc.foonet.org 353 tester = #mine :@tester +dummy") + (0.01 ":irc.foonet.org 366 tester #mine :End of NAMES list")) + +((mode-mine 10 "MODE #mine") + (0.00 ":irc.foonet.org 324 tester #mine +Cnt") + (0.02 ":irc.foonet.org 329 tester #mine 1702026418") + (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :hello") + (0.03 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :there") + (0.05 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION sad\1") + (0.03 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION glad\1")) + +((privmsg-statusmsg 10 "PRIVMSG +#mine :howdy")) +((privmsg-statusmsg-action 10 "PRIVMSG +#mine :tenderfoot") + ;; These are simulated "echoed messages" + (0.05 ":tester!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION mad\1") + (0.05 ":tester!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION chad\1")) + +((privmsg-prefixed 10 "PRIVMSG #mine :\1ACTION ready\1") + (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :okie") + (0.05 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG +#mine :\1ACTION dokie\1") + (0.04 ":dummy!~u@2jv6nwu4af69s.irc PRIVMSG #mine :\1ACTION out\1")) diff --git a/test/lisp/erc/resources/base/flood/ascii.eld b/test/lisp/erc/resources/base/flood/ascii.eld new file mode 100644 index 00000000000..a3d127326c3 --- /dev/null +++ b/test/lisp/erc/resources/base/flood/ascii.eld @@ -0,0 +1,49 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((mode-tester 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.") + (0.05 ":irc.foonet.org 221 tester +i")) + +((join-spam 10 "JOIN #ascii") + (0 ":tester!~u@9g6b728983yd2.irc JOIN #ascii") + (0 ":irc.foonet.org 353 tester = #ascii :alice tester @bob") + (0 ":irc.foonet.org 366 tester #ascii :End of NAMES list")) + +((mode-spam 10 "MODE #ascii") + (0 ":irc.foonet.org 324 tester #ascii +nt") + (0 ":irc.foonet.org 329 tester #ascii 1620104779") + (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #ascii :tester, welcome!") + (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #ascii :tester, welcome!")) + +((privmsg 10 "PRIVMSG #ascii :twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters 12345678")) +((privmsg 10 "PRIVMSG #ascii :twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters twenty-three characters ")) +((privmsg 10 "PRIVMSG #ascii :123456789")) +((privmsg 10 "PRIVMSG #ascii :xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx")) +((privmsg 10 "PRIVMSG #ascii :yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy")) +((privmsg 10 "PRIVMSG #ascii :z")) + +((quit 10 "QUIT :\2ERC\2") + (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)") + (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")) diff --git a/test/lisp/erc/resources/base/flood/koi8-r.eld b/test/lisp/erc/resources/base/flood/koi8-r.eld new file mode 100644 index 00000000000..0f10717fc2c --- /dev/null +++ b/test/lisp/erc/resources/base/flood/koi8-r.eld @@ -0,0 +1,47 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((mode-tester 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.") + (0.05 ":irc.foonet.org 221 tester +i")) + +((join-chan 6 "JOIN #koi8") + (0 ":tester!~u@9g6b728983yd2.irc JOIN #koi8") + (0 ":irc.foonet.org 353 tester = #koi8 :alice tester @bob") + (0 ":irc.foonet.org 366 tester #koi8 :End of NAMES list")) + +((mode-chan 8 "MODE #koi8") + (0 ":irc.foonet.org 324 tester #koi8 +nt") + (0 ":irc.foonet.org 329 tester #koi8 1620104779") + (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :tester, welcome!") + (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :tester, welcome!") + (0.0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317")) + +((privmsg 10 "PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317")) +((privmsg 10 "PRIVMSG #koi8 :\313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \313\317\322\317\336\305 \324\305\320\305\322\330 \305\323\314\311 \320\317 \322\325\323\323\313\311 \316\301\320\311\323\301\324\330 \327\323\305 \336\305\324\313\317 \311\314\311 \327\323\305 \322\301\327\316\317 \302\325\304\305\324 ")) +((privmsg 10 "PRIVMSG #koi8 :\322\301\332\322\331\327 \323\324\322\317\313\311 \316\305\320\317\316\321\324\316\317 \307\304\305")) + +((quit 10 "QUIT :\2ERC\2") + (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)") + (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")) diff --git a/test/lisp/erc/resources/base/flood/soju.eld b/test/lisp/erc/resources/base/flood/soju.eld index 05266ca9411..9e936499a2d 100644 --- a/test/lisp/erc/resources/base/flood/soju.eld +++ b/test/lisp/erc/resources/base/flood/soju.eld @@ -8,7 +8,7 @@ (0.0 ":soju.im 005 tester CHATHISTORY=1000 CASEMAPPING=ascii NETWORK=Soju :are supported") (0.0 ":soju.im 422 tester :No MOTD")) -((mode 1 "MODE tester +i") +((mode 10 "MODE tester +i") (0.0 ":tester!tester@10.0.2.100 JOIN #chan/foonet") (0.25 ":soju.im 331 tester #chan/foonet :No topic is set") (0.0 ":soju.im 353 tester = #chan/foonet :@bob/foonet alice/foonet tester") diff --git a/test/lisp/erc/resources/base/flood/utf-8.eld b/test/lisp/erc/resources/base/flood/utf-8.eld new file mode 100644 index 00000000000..8e7f8f7eed2 --- /dev/null +++ b/test/lisp/erc/resources/base/flood/utf-8.eld @@ -0,0 +1,54 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((mode-tester 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.") + (0.05 ":irc.foonet.org 221 tester +i")) + +((join-spam 10 "JOIN #utf-8") + (0 ":tester!~u@9g6b728983yd2.irc JOIN #utf-8") + (0 ":irc.foonet.org 353 tester = #utf-8 :alice tester @bob") + (0 ":irc.foonet.org 366 tester #utf-8 :End of NAMES list")) + +((mode-spam 10 "MODE #utf-8") + (0 ":irc.foonet.org 324 tester #utf-8 +nt") + (0 ":irc.foonet.org 329 tester #utf-8 1620104779") + (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :tester, welcome!") + (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :tester, welcome!")) + +((privmsg-a 10 "PRIVMSG #utf-8 :\320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 ")) +((privmsg-b 10 "PRIVMSG #utf-8 :\320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\272\320\276\321\200\320\276\321\207\320\265 \321\202\320\265\320\277\320\265\321\200\321\214 \320\265\321\201\320\273\320\270 \320\277\320\276 \321\200\321\203\321\201\321\201\320\272\320\270 \320\275\320\260\320\277\320\270\321\201\320\260\321\202\321\214 \320\262\321\201\320\265 \321\207\320\265\321\202\320\272\320\276 \320\270\320\273\320\270 \320\262\321\201\320\265 \321\200\320\260\320\262\320\275\320\276 \320\261\321\203\320\264\320\265\321\202 \321\200\320\260\320\267\321\200\321\213\320\262 \321\201\321\202\321\200\320\276\320\272\320\270 \320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276 \320\263\320\264\320\265 \320\261\321\203\320\264\320\265\321\202 ")) +((privmsg-c 10 "PRIVMSG #utf-8 :\321\200\320\260\320\267\321\200\321\213\320\262 \321\201\321\202\321\200\320\276\320\272\320\270 \320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276 \320\263\320\264\320\265") + (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :alice: Entirely honour; I would not be delay'd.")) + +((privmsg-g 10 "PRIVMSG #utf-8 :\350\251\261\350\252\252\345\244\251\344\270\213\345\244\247\345\213\242\357\274\214\345\210\206\344\271\205\345\277\205\345\220\210\357\274\214\345\220\210\344\271\205\345\277\205\345\210\206\357\274\232\345\221\250\346\234\253\344\270\203\345\234\213\345\210\206\347\210\255\357\274\214\345\271\266\345\205\245\346\226\274\347\247\246\343\200\202\345\217\212\347\247\246\346\273\205\344\271\213\345\276\214\357\274\214\346\245\232\343\200\201\346\274\242\345\210\206\347\210\255\357\274\214\345\217\210\345\271\266\345\205\245\346\226\274\346\274\242\343\200\202\346\274\242\346\234\235\350\207\252\351\253\230\347\245\226\346\226\254\347\231\275\350\233\207\350\200\214\350\265\267\347\276\251\357\274\214\344\270\200\347\265\261\345\244\251\344\270\213\343\200\202\345\276\214\344\276\206\345\205\211\346\255\246\344\270\255\350\210\210\357\274\214\345\202\263\350\207\263\347\215\273\345\270\235\357\274\214\351\201\202\345\210\206\347\202\272\344\270\211\345\234\213\343\200\202\346\216\250\345\205\266\350\207\264\344\272\202\344\271\213\347\224\261\357\274\214\346\256\206\345\247\213\346\226\274\346\241\223\343\200\201\351\235\210\344\272\214\345\270\235\343\200\202\346\241\223\345\270\235\347\246\201\351\214\256\345\226\204\351\241\236\357\274\214\345\264\207\344\277\241\345\256\246\345\256\230\343\200\202\345\217\212\346\241\223\345\270\235\345\264\251\357\274\214\351\235\210\345\270\235\345\215\263\344\275\215\357\274\214\345\244\247\345\260\207\350\273\215\347\253\207\346\255\246\343\200\201\345\244\252\345\202\205\351\231\263\350\225\203\357\274\214\345\205\261\347\233\270\350\274\224\344\275\220\343\200\202\346\231\202\346\234\211\345\256\246\345\256\230\346\233\271\347\257\200\347\255\211\345\274\204\346\254\212\357\274\214")) +((privmsg-h 10 "PRIVMSG #utf-8 :\347\253\207\346\255\246\343\200\201\351\231\263\350\225\203\350\254\200\350\252\205\344\271\213\357\274\214\344\275\234\344\272\213\344\270\215\345\257\206\357\274\214\345\217\215\347\202\272\346\211\200\345\256\263\343\200\202\344\270\255\346\266\223\350\207\252\346\255\244\346\204\210\346\251\253") + (0.0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #utf-8 :Shall seize this prey out of his father's hands.")) + +((privmsg-d 10 "PRIVMSG #utf-8 :\320\261\321\203\320\264\320\265\321\202\302\240\321\200\320\260\320\267\321\200\321\213\320\262\302\240\321\201\321\202\321\200\320\276\320\272\320\270\302\240\320\275\320\265\320\277\320\276\320\275\321\217\321\202\320\275\320\276\302\240\320\263\320\264\320\265\360\237\217\201\360\237\232\251\360\237\216\214\360\237\217\264\360\237\217\263\357\270\217")) +((privmsg-e 10 "PRIVMSG #utf-8 :\360\237\217\263\357\270\217\342\200\215\360\237\214\210\360\237\217\263\357\270\217\342\200\215\342\232\247\357\270\217\360\237\217\264\342\200\215\342\230\240\357\270\217")) + +((quit 10 "QUIT :\2ERC\2") + (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)") + (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")) diff --git a/test/lisp/erc/resources/base/gapless-connect/foonet.eld b/test/lisp/erc/resources/base/gapless-connect/foonet.eld index 4ac4a3e5968..10b742fdb34 100644 --- a/test/lisp/erc/resources/base/gapless-connect/foonet.eld +++ b/test/lisp/erc/resources/base/gapless-connect/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") @@ -21,7 +21,7 @@ ;; No mode answer (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@xrir8fpe4d7ak.irc JOIN #foo") - (0 ":irc.foonet.org 353 tester = #foo :joe @mike tester") + (0 ":irc.foonet.org 353 tester = #foo :alice @bob tester") (0 ":irc.foonet.org 366 tester #foo :End of /NAMES list.") (0 ":***!znc@znc.in PRIVMSG #foo :Buffer Playback...") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #foo :[07:02:41] bob: To-morrow is the joyful day, Audrey; to-morrow will we be married.") diff --git a/test/lisp/erc/resources/base/local-modules/first.eld b/test/lisp/erc/resources/base/local-modules/first.eld index f9181a80fb7..4e923270e24 100644 --- a/test/lisp/erc/resources/base/local-modules/first.eld +++ b/test/lisp/erc/resources/base/local-modules/first.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- ((cap 10 "CAP REQ :sasl")) -((nick 1 "NICK tester")) -((user 1 "USER tester 0 * :tester")) +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester")) ((authenticate 5 "AUTHENTICATE PLAIN") (0.0 ":irc.foonet.org CAP * ACK sasl") @@ -11,7 +11,7 @@ (0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester") (0.01 ":irc.foonet.org 903 * :Authentication successful")) -((cap 3.2 "CAP END") +((cap 10 "CAP END") (0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0.0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0") (0.2 ":irc.foonet.org 003 tester :This server was created Sun, 20 Nov 2022 23:10:36 UTC") diff --git a/test/lisp/erc/resources/base/local-modules/second.eld b/test/lisp/erc/resources/base/local-modules/second.eld index a96103b2aa1..5823d63b874 100644 --- a/test/lisp/erc/resources/base/local-modules/second.eld +++ b/test/lisp/erc/resources/base/local-modules/second.eld @@ -41,7 +41,7 @@ (0.07 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: To you that know them not. This to my mother.") (0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Some enigma, some riddle: come, thy l'envoy; begin.")) -((quit 1 "QUIT :\2ERC\2") +((quit 10 "QUIT :\2ERC\2") (0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT")) ((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/local-modules/third.eld b/test/lisp/erc/resources/base/local-modules/third.eld index 19bdd6efcce..e24825c3217 100644 --- a/test/lisp/erc/resources/base/local-modules/third.eld +++ b/test/lisp/erc/resources/base/local-modules/third.eld @@ -37,7 +37,7 @@ (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: No remedy, my lord, when walls are so wilful to hear without warning.") (0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Let our reciprocal vows be remembered. You have many opportunities to cut him off; if your will want not, time and place will be fruitfully offered. There is nothing done if he return the conqueror; then am I the prisoner, and his bed my gaol; from the loathed warmth whereof deliver me, and supply the place for your labor.")) -((quit 1 "QUIT :\2ERC\2") +((quit 10 "QUIT :\2ERC\2") (0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT :Quit")) ((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/modes/chan-changed.eld b/test/lisp/erc/resources/base/modes/chan-changed.eld new file mode 100644 index 00000000000..6cf6596b0b2 --- /dev/null +++ b/test/lisp/erc/resources/base/modes/chan-changed.eld @@ -0,0 +1,55 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.03 ":cadmium.libera.chat 001 tester :Welcome to the Libera.Chat Internet Relay Chat Network tester") + (0.02 ":cadmium.libera.chat 002 tester :Your host is cadmium.libera.chat[103.196.37.95/6697], running version solanum-1.0-dev") + (0.01 ":cadmium.libera.chat 003 tester :This server was created Wed Jan 25 2023 at 10:22:45 UTC") + (0.01 ":cadmium.libera.chat 004 tester cadmium.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI") + (0.00 ":cadmium.libera.chat 005 tester CALLERID=g WHOX ETRACE FNC SAFELIST ELIST=CMNTU KNOCK MONITOR=100 CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server") + (0.01 ":cadmium.libera.chat 251 tester :There are 70 users and 42996 invisible on 28 servers") + (0.02 ":cadmium.libera.chat 252 tester 38 :IRC Operators online") + (0.01 ":cadmium.libera.chat 253 tester 57 :unknown connection(s)") + (0.01 ":cadmium.libera.chat 254 tester 22912 :channels formed") + (0.01 ":cadmium.libera.chat 255 tester :I have 2499 clients and 1 servers") + (0.01 ":cadmium.libera.chat 265 tester 2499 4187 :Current local users 2499, max 4187") + (0.01 ":cadmium.libera.chat 266 tester 43066 51827 :Current global users 43066, max 51827") + (0.01 ":cadmium.libera.chat 250 tester :Highest connection count: 4188 (4187 clients) (319420 connections received)") + (0.01 ":cadmium.libera.chat 375 tester :- cadmium.libera.chat Message of the Day - ") + (0.01 ":cadmium.libera.chat 372 tester :- This server kindly provided by Mach Dilemma (www.m-d.net)") + (0.01 ":cadmium.libera.chat 372 tester :- Welcome to Libera Chat, the IRC network for") + (0.00 ":cadmium.libera.chat 372 tester :- Email: support@libera.chat") + (0.00 ":cadmium.libera.chat 376 tester :End of /MOTD command.") + (0.00 ":tester MODE tester :+Ziw")) + +((mode-tester 10 "MODE tester +i")) + +((join-chan 10 "JOIN #chan") + (0.09 ":tester!~tester@127.0.0.1 JOIN #chan")) + +((mode-chan 10 "MODE #chan") + (0.03 ":cadmium.libera.chat 353 tester = #chan :tester @Chad dummy") + (0.02 ":cadmium.libera.chat 366 tester #chan :End of /NAMES list.") + (0.00 ":cadmium.libera.chat 324 tester #chan +nt") + (0.01 ":cadmium.libera.chat 329 tester #chan 1621432263")) + +((privmsg-before 10 "PRIVMSG #chan :ready before") + (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan before") + (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +Qu")) + +((privmsg-key 10 "PRIVMSG #chan :ready key") + (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan :doing key") + (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +k hunter2")) + +((privmsg-limit 10 "PRIVMSG #chan :ready limit") + (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan :doing limit") + (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan +l 3")) + +((privmsg-drop 10 "PRIVMSG #chan :ready drop") + (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan dropping") + (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan -lu") + (0.00 ":Chad!~u@ggpg6r3a68wak.irc MODE #chan -Qk *") + (0.02 ":Chad!~u@ggpg6r3a68wak.irc PRIVMSG #chan after")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld b/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld index 686a47f68a3..04959954c4f 100644 --- a/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld +++ b/test/lisp/erc/resources/base/netid/bouncer/barnet-drop.eld @@ -22,14 +22,14 @@ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":irc.barnet.org 305 tester :You are no longer marked as being away")) -((join 1 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") (0 ":irc.barnet.org 353 tester = #chan :@joe mike tester") (0 ":irc.barnet.org 366 tester #chan :End of NAMES list") (0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!") (0 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!")) -((mode 1 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620805269") (0.1 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: But you have outfaced them all.") diff --git a/test/lisp/erc/resources/base/netid/bouncer/barnet.eld b/test/lisp/erc/resources/base/netid/bouncer/barnet.eld index d0fe3af8ea4..596383c2699 100644 --- a/test/lisp/erc/resources/base/netid/bouncer/barnet.eld +++ b/test/lisp/erc/resources/base/netid/bouncer/barnet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 3 "PASS :barnet:changeme")) -((nick 3 "NICK tester")) -((user 3 "USER user 0 * :tester") +((pass 10 "PASS :barnet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.barnet.org 003 tester :This server was created Wed, 12 May 2021 07:41:08 UTC") @@ -17,19 +17,19 @@ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.barnet.org 422 tester :MOTD File is missing")) -((mode-user 10.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer ^ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":irc.barnet.org 305 tester :You are no longer marked as being away")) -((join 1 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") (0 ":irc.barnet.org 353 tester = #chan :@joe mike tester") (0 ":irc.barnet.org 366 tester #chan :End of NAMES list") (0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!") (0 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :tester, welcome!")) -((mode 3 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620805269") (0.1 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: But you have outfaced them all.") @@ -38,4 +38,4 @@ (0.05 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: As he regards his aged father's life.") (0.05 ":mike!~u@awyxgybtkx7uq.irc PRIVMSG #chan :joe: It is a rupture that you may easily heal; and the cure of it not only saves your brother, but keeps you from dishonor in doing it.")) -((linger 1 LINGER)) +((linger 2 LINGER)) diff --git a/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld b/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld index b99621cc311..d0445cd1dd5 100644 --- a/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld +++ b/test/lisp/erc/resources/base/netid/bouncer/foonet-drop.eld @@ -1,5 +1,5 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) +((pass 10 "PASS :foonet:changeme")) ((nick 1 "NICK tester")) ((user 1 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") @@ -22,14 +22,14 @@ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":irc.foonet.org 305 tester :You are no longer marked as being away")) -((join 1 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@ertp7idh9jtgi.irc JOIN #chan") (0 ":irc.foonet.org 353 tester = #chan :@alice bob tester") (0 ":irc.foonet.org 366 tester #chan :End of NAMES list") (0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!") (0 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!")) -((mode 1 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620805271") (0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: He cannot be heard of. Out of doubt he is transported.") diff --git a/test/lisp/erc/resources/base/netid/bouncer/foonet.eld b/test/lisp/erc/resources/base/netid/bouncer/foonet.eld index b0964fb9537..2e1a3ac27da 100644 --- a/test/lisp/erc/resources/base/netid/bouncer/foonet.eld +++ b/test/lisp/erc/resources/base/netid/bouncer/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 3 "PASS :foonet:changeme")) -((nick 3 "NICK tester")) -((user 3 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Wed, 12 May 2021 07:41:09 UTC") @@ -17,19 +17,19 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 4.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer ^ (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":irc.foonet.org 305 tester :You are no longer marked as being away")) -((join 1 "JOIN #chan") +((join 10 "JOIN #chan") (0 ":tester!~u@ertp7idh9jtgi.irc JOIN #chan") (0 ":irc.foonet.org 353 tester = #chan :@alice bob tester") (0 ":irc.foonet.org 366 tester #chan :End of NAMES list") (0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!") (0 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :tester, welcome!")) -((mode 3 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620805271") (0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: He cannot be heard of. Out of doubt he is transported.") @@ -43,4 +43,4 @@ (0.1 ":alice!~u@ertp7idh9jtgi.irc PRIVMSG #chan :bob: Orlando, my liege; the youngest son of Sir Rowland de Boys.") (0.1 ":bob!~u@ertp7idh9jtgi.irc PRIVMSG #chan :alice: The ape is dead, and I must conjure him.")) -((linger 1 LINGER)) +((linger 2 LINGER)) diff --git a/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld b/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld index 8e299ec44c0..35906f608b5 100644 --- a/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld +++ b/test/lisp/erc/resources/base/reconnect/aborted-dupe.eld @@ -19,7 +19,7 @@ (-0.02 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (-0.02 ":irc.foonet.org 422 tester :MOTD File is missing")) -((~mode-user 3.2 "MODE tester +i") +((~mode-user 10 "MODE tester +i") (-0.02 ":irc.foonet.org 221 tester +i") (-0.02 ":irc.foonet.org NOTICE tester :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.")) diff --git a/test/lisp/erc/resources/base/reconnect/aborted.eld b/test/lisp/erc/resources/base/reconnect/aborted.eld index 5c32070d85f..e3abcdf8415 100644 --- a/test/lisp/erc/resources/base/reconnect/aborted.eld +++ b/test/lisp/erc/resources/base/reconnect/aborted.eld @@ -18,7 +18,7 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.foonet.org 221 tester +i") (0 ":irc.foonet.org NOTICE tester :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.")) diff --git a/test/lisp/erc/resources/base/reconnect/just-eof.eld b/test/lisp/erc/resources/base/reconnect/just-eof.eld new file mode 100644 index 00000000000..c80a39b3170 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/just-eof.eld @@ -0,0 +1,3 @@ +;; -*- mode: lisp-data; -*- +((eof 5 EOF)) +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/reconnect/just-ping.eld b/test/lisp/erc/resources/base/reconnect/just-ping.eld new file mode 100644 index 00000000000..d57888b42d3 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/just-ping.eld @@ -0,0 +1,4 @@ +;; -*- mode: lisp-data; -*- +((ping 20 "PING")) + +((eof 10 EOF)) diff --git a/test/lisp/erc/resources/base/reconnect/options-again.eld b/test/lisp/erc/resources/base/reconnect/options-again.eld index f1fcc439cc3..8a3264fda9c 100644 --- a/test/lisp/erc/resources/base/reconnect/options-again.eld +++ b/test/lisp/erc/resources/base/reconnect/options-again.eld @@ -32,13 +32,13 @@ (0 ":irc.foonet.org 353 tester = #spam :alice tester @bob") (0 ":irc.foonet.org 366 tester #spam :End of NAMES list")) -((~mode-chan 4 "MODE #chan") +((~mode-chan 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620104779") (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: But, as it seems, did violence on herself.") (0.1 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Well, this is the forest of Arden.")) -((mode-spam 4 "MODE #spam") +((mode-spam 20 "MODE #spam") (0 ":irc.foonet.org 324 tester #spam +nt") (0 ":irc.foonet.org 329 tester #spam 1620104779") (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #spam :alice: Signior Iachimo will not from it. Pray, let us follow 'em.") diff --git a/test/lisp/erc/resources/base/reconnect/options.eld b/test/lisp/erc/resources/base/reconnect/options.eld index 3b305d85594..e0952a2aece 100644 --- a/test/lisp/erc/resources/base/reconnect/options.eld +++ b/test/lisp/erc/resources/base/reconnect/options.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") @@ -18,7 +18,7 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.foonet.org 221 tester +i") (0 ":irc.foonet.org NOTICE tester :This server is in debug mode.") @@ -26,7 +26,7 @@ (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob") (0 ":irc.foonet.org 366 tester #chan :End of NAMES list")) -((mode-chan 4 "MODE #chan") +((mode-chan 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620104779") (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!") diff --git a/test/lisp/erc/resources/base/reconnect/ping-pong.eld b/test/lisp/erc/resources/base/reconnect/ping-pong.eld new file mode 100644 index 00000000000..b3d36cf6cec --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/ping-pong.eld @@ -0,0 +1,6 @@ +;; -*- mode: lisp-data; -*- +((ping 10 "PING ") + (0 "PONG fake")) + +((eof 10 EOF)) +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld new file mode 100644 index 00000000000..386d0f4b085 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld @@ -0,0 +1,24 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") + (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") + (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0 ":irc.foonet.org 254 tester 1 :channels formed") + (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 10 "MODE tester +i") + (0 ":irc.foonet.org 221 tester +i") + (0 ":irc.foonet.org NOTICE tester :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.")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld b/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld index 0c8cdac0379..c9080cf39e9 100644 --- a/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld +++ b/test/lisp/erc/resources/base/renick/queries/bouncer-barnet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 3 "PASS :barnet:changeme")) -((nick 3 "NICK tester")) -((user 3 "USER user 0 * :tester") +((pass 10 "PASS :barnet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.barnet.org 003 tester :This server was created Tue, 01 Jun 2021 07:49:23 UTC") @@ -17,7 +17,7 @@ (0 ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.barnet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@286u8jcpis84e.irc JOIN #chan") @@ -32,18 +32,18 @@ (0 ":irc.barnet.org NOTICE tester :[09:13:24] 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.") (0 ":irc.barnet.org 305 tester :You are no longer marked as being away")) -((mode 5 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1622538742") (0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: By favors several which they did bestow.") (0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: You, Roderigo! come, sir, I am for you.")) -((privmsg-a 5 "PRIVMSG rando :Linda said you were gonna kill me.") +((privmsg-a 10 "PRIVMSG rando :Linda said you were gonna kill me.") (0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: Play, music, then! Nay, you must do it soon.") (0.1 ":rando!~u@95i756tt32ym8.irc PRIVMSG tester :Linda said? I never saw her before I came up here.") (0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: Of arts inhibited and out of warrant.")) -((privmsg-b 3 "PRIVMSG rando :You aren't with Wage?") +((privmsg-b 10 "PRIVMSG rando :You aren't with Wage?") (0.1 ":joe!~u@286u8jcpis84e.irc PRIVMSG #chan :mike: But most of all, agreeing with the proclamation.") (0.1 ":rando!~u@95i756tt32ym8.irc PRIVMSG tester :I think you screwed up, Case.") (0.1 ":mike!~u@286u8jcpis84e.irc PRIVMSG #chan :joe: Good gentleman, go your gait, and let poor volk pass. An chud ha' bin zwaggered out of my life, 'twould not ha' bin zo long as 'tis by a vortnight. Nay, come not near th' old man; keep out, che vor ye, or ise try whether your costard or my ballow be the harder. Chill be plain with you.") diff --git a/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld b/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld index 162e8bf9655..2421651ebe8 100644 --- a/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld +++ b/test/lisp/erc/resources/base/renick/queries/bouncer-foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Tue, 01 Jun 2021 07:49:22 UTC") @@ -17,7 +17,7 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 5.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer (0 ":irc.znc.in 306 tester :You have been marked as being away") (0 ":tester!~u@u4mvbswyw8gbg.irc JOIN #chan") @@ -38,12 +38,12 @@ (0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: When there is nothing living but thee, thou shalt be welcome. I had rather be a beggar's dog than Apemantus.") (0.1 ":alice!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :bob: You have simply misused our sex in your love-prate: we must have your doublot and hose plucked over your head, and show the world what the bird hath done to her own nest.")) -((privmsg-a 6 "PRIVMSG rando :I here") +((privmsg-a 10 "PRIVMSG rando :I here") (0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: And I will make thee think thy swan a crow.") (0.1 ":rando!~u@bivkhq8yav938.irc PRIVMSG tester :u are dumb") (0.1 ":alice!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :bob: Lie not, to say mine eyes are murderers.")) -((privmsg-b 3 "PRIVMSG rando :not so") +((privmsg-b 10 "PRIVMSG rando :not so") (0.1 ":bob!~u@u4mvbswyw8gbg.irc PRIVMSG #chan :alice: Commit myself, my person, and the cause.") ;; Nick change (0.1 ":rando!~u@bivkhq8yav938.irc NICK frenemy") diff --git a/test/lisp/erc/resources/base/renick/queries/solo.eld b/test/lisp/erc/resources/base/renick/queries/solo.eld index 12fa7d264e9..fa4c075adac 100644 --- a/test/lisp/erc/resources/base/renick/queries/solo.eld +++ b/test/lisp/erc/resources/base/renick/queries/solo.eld @@ -30,7 +30,7 @@ (0 ":irc.foonet.org NOTICE tester :[09:56:57] 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.") (0 ":irc.foonet.org 305 tester :You are no longer marked as being away")) -((mode 1 "MODE #foo") +((mode 10 "MODE #foo") (0 ":irc.foonet.org 324 tester #foo +nt") (0 ":irc.foonet.org 329 tester #foo 1622454985") (0.1 ":alice!~u@gq7yjr7gsu7nn.irc PRIVMSG #foo :bob: Farewell, pretty lady: you must hold the credit of your father.") diff --git a/test/lisp/erc/resources/base/renick/self/qual-chester.eld b/test/lisp/erc/resources/base/renick/self/qual-chester.eld index 75b50fe68bd..a224e0451d7 100644 --- a/test/lisp/erc/resources/base/renick/self/qual-chester.eld +++ b/test/lisp/erc/resources/base/renick/self/qual-chester.eld @@ -18,7 +18,7 @@ (0 ":irc.foonet.org 266 chester 3 4 :Current global users 3, max 4") (0 ":irc.foonet.org 422 chester :MOTD File is missing")) -((mode-user 1.2 "MODE chester +i") +((mode-user 10 "MODE chester +i") (0 ":irc.foonet.org 221 chester +i") (0 ":irc.foonet.org NOTICE chester :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.")) diff --git a/test/lisp/erc/resources/base/renick/self/qual-tester.eld b/test/lisp/erc/resources/base/renick/self/qual-tester.eld index 25199226658..27061c65223 100644 --- a/test/lisp/erc/resources/base/renick/self/qual-tester.eld +++ b/test/lisp/erc/resources/base/renick/self/qual-tester.eld @@ -18,7 +18,7 @@ (0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.foonet.org 221 tester +i") (0 ":irc.foonet.org NOTICE tester :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.")) diff --git a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld index efc2506fd6f..d106a45cf66 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/channel/barnet.eld @@ -56,7 +56,7 @@ (0.1 ":mike!~u@wvys46tx8tpmk.irc PRIVMSG #chan :tester, welcome!") (0 ":joe!~u@wvys46tx8tpmk.irc PRIVMSG #chan :tester, welcome!")) -((mode 1 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620205534") (0.1 ":mike!~u@wvys46tx8tpmk.irc PRIVMSG #chan :joe: Chi non te vede, non te pretia.") diff --git a/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld b/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld index a11cfac2e73..603afa2fc3e 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/channel/foonet.eld @@ -52,7 +52,7 @@ (0.1 ":alice!~u@yppdd5tt4admc.irc PRIVMSG #chan :tester, welcome!") (0 ":bob!~u@yppdd5tt4admc.irc PRIVMSG #chan :tester, welcome!")) -((mode 1 "MODE #chan") +((mode 10 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620205534") (0.1 ":bob!~u@yppdd5tt4admc.irc PRIVMSG #chan :alice: Thou desirest me to stop in my tale against the hair.") diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld index cc7aff10076..5b64a58c98f 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/server/barnet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :barnet:changeme")) -((nick 1 "NICK tester")) -((user 2 "USER user 0 * :tester") +((pass 10 "PASS :barnet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.barnet.org 001 tester :Welcome to the barnet IRC Network tester") (0 ":irc.barnet.org 002 tester :Your host is irc.barnet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.barnet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") diff --git a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld index 3a846108466..260ff74c20c 100644 --- a/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld +++ b/test/lisp/erc/resources/base/reuse-buffers/server/foonet.eld @@ -1,7 +1,7 @@ ;; -*- mode: lisp-data; -*- -((pass 1 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((pass 10 "PASS :foonet:changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Sun, 25 Apr 2021 11:28:28 UTC") diff --git a/test/lisp/erc/resources/base/send-message/noncommands.eld b/test/lisp/erc/resources/base/send-message/noncommands.eld new file mode 100644 index 00000000000..ba210bfff6f --- /dev/null +++ b/test/lisp/erc/resources/base/send-message/noncommands.eld @@ -0,0 +1,52 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Nov 2023 17:40:20 UTC") + (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.02 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.01 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.01 ":irc.foonet.org 254 tester 2 :channels formed") + (0.01 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.01 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.01 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.02 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.00 ":irc.foonet.org 221 tester +i") + (0.01 ":irc.foonet.org NOTICE tester :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.")) + +((mode-tester 10 "MODE tester +i")) + +((join-chan 10 "JOIN #chan") + (0.00 ":irc.foonet.org 221 tester +i") + (0.01 ":tester!~u@ggpg6r3a68wak.irc JOIN #chan") + (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice tester") + (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.00 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :tester, welcome!") + (0.01 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :tester, welcome!")) + +((mode-chan 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester #chan +Cnt") + (0.02 ":irc.foonet.org 329 tester #chan 1699810829") + (0.01 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :bob: To prove him false that says I love thee not.") + (0.02 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :alice: For hands, to do Rome service, are but vain.")) + +((privmsg-action 10 "PRIVMSG #chan :\1ACTION sad\1") + (0.07 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :bob: Spotted, detested, and abominable.")) + +((privmsg-me 10 "PRIVMSG #chan :/me sad") + (0.03 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :Marcus, my brother! 'tis sad Titus calls.")) + +((privmsg-sv 10 "PRIVMSG #chan :I'm using ERC " (+ (not " ")) " with GNU Emacs") + (0.07 ":bob!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :alice: You still wrangle with her, Boyet, and she strikes at the brow.")) + +((privmsg-sm 10 "PRIVMSG #chan :I'm using the following modules: `erc-autojoin-mode', ") + (0.04 ":alice!~u@cjn7mjwx57gbi.irc PRIVMSG #chan :No, not till Thursday; there is time enough.")) + +((quit 10 "QUIT :\2ERC\2") + (0.05 ":tester!~u@ggpg6r3a68wak.irc QUIT :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)") + (0.02 "ERROR :Quit: \2ERC\2 5.x (IRC client for GNU Emacs)")) diff --git a/test/lisp/erc/resources/commands/motd.eld b/test/lisp/erc/resources/commands/motd.eld new file mode 100644 index 00000000000..6d10ee122e2 --- /dev/null +++ b/test/lisp/erc/resources/commands/motd.eld @@ -0,0 +1,48 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((mode 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.") + (0.05 ":irc.foonet.org 221 tester +i")) + +((motd-1 10 "MOTD") + (0.08 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.02 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.00 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((motd-2 10 "MOTD irc1.foonet.org") + (0.08 ":irc1.foonet.org 375 tester :- irc1.foonet.org Message of the day - ") + (0.02 ":irc1.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc1.foonet.org 372 tester :- ") + (0.00 ":irc1.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc1.foonet.org 376 tester :End of MOTD command")) + +((motd-3 10 "MOTD fake.foonet.org") + (0.00 ":irc.foonet.org 402 tester fake.foonet.org :No such server")) + +((quit 10 "QUIT :\2ERC\2") + (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)") + (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")) diff --git a/test/lisp/erc/resources/commands/squery.eld b/test/lisp/erc/resources/commands/squery.eld new file mode 100644 index 00000000000..bcd176e515b --- /dev/null +++ b/test/lisp/erc/resources/commands/squery.eld @@ -0,0 +1,31 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.07 ":ircnet.hostsailor.com 020 * :Please wait while we process your connection.") + (0.03 ":ircnet.hostsailor.com 001 tester :Welcome to the Internet Relay Network tester!~user@93.184.216.34") + (0.02 ":ircnet.hostsailor.com 002 tester :Your host is ircnet.hostsailor.com, running version 2.11.2p3+0PNv1.06") + (0.03 ":ircnet.hostsailor.com 003 tester :This server was created Thu May 20 2021 at 17:13:24 EDT") + (0.01 ":ircnet.hostsailor.com 004 tester ircnet.hostsailor.com 2.11.2p3+0PNv1.06 aoOirw abeiIklmnoOpqrRstv") + (0.00 ":ircnet.hostsailor.com 005 tester RFC2812 PREFIX=(ov)@+ CHANTYPES=#&!+ MODES=3 CHANLIMIT=#&!+:42 NICKLEN=15 TOPICLEN=255 KICKLEN=255 MAXLIST=beIR:64 CHANNELLEN=50 IDCHAN=!:5 CHANMODES=beIR,k,l,imnpstaqrzZ :are supported by this server") + (0.01 ":ircnet.hostsailor.com 005 tester PENALTY FNC EXCEPTS=e INVEX=I CASEMAPPING=ascii NETWORK=IRCnet :are supported by this server") + (0.01 ":ircnet.hostsailor.com 042 tester 0PNHANAWX :your unique ID") + (0.01 ":ircnet.hostsailor.com 251 tester :There are 18711 users and 2 services on 26 servers") + (0.01 ":ircnet.hostsailor.com 252 tester 63 :operators online") + (0.01 ":ircnet.hostsailor.com 253 tester 4 :unknown connections") + (0.01 ":ircnet.hostsailor.com 254 tester 10493 :channels formed") + (0.01 ":ircnet.hostsailor.com 255 tester :I have 933 users, 0 services and 1 servers") + (0.01 ":ircnet.hostsailor.com 265 tester 933 1328 :Current local users 933, max 1328") + (0.01 ":ircnet.hostsailor.com 266 tester 18711 25625 :Current global users 18711, max 25625") + (0.02 ":ircnet.hostsailor.com 375 tester :- ircnet.hostsailor.com Message of the Day - ") + (0.01 ":ircnet.hostsailor.com 372 tester :- 17/11/2023 3:08") + (0.02 ":ircnet.hostsailor.com 376 tester :End of MOTD command.")) + +((mode 10 "MODE tester +i") + (0.00 ":ircnet.hostsailor.com NOTICE tester :Your connection is secure (SSL/TLS).") + (0.01 ":tester MODE tester :+i")) + +((squery 10 "SQUERY alis :help list") + (0.08 ":Alis@hub.uk NOTICE tester :Searches for a channel") + (0.01 ":Alis@hub.uk NOTICE tester :/SQUERY Alis LIST mask [-options]") + (0.04 ":Alis@hub.uk NOTICE tester :[...]") + (0.01 ":Alis@hub.uk NOTICE tester :See also: HELP EXAMPLES")) diff --git a/test/lisp/erc/resources/commands/vhost.eld b/test/lisp/erc/resources/commands/vhost.eld new file mode 100644 index 00000000000..42013198fbc --- /dev/null +++ b/test/lisp/erc/resources/commands/vhost.eld @@ -0,0 +1,40 @@ +;; -*- mode: lisp-data; -*- +((pass 10 "PASS :changeme")) +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") + (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") + (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0 ":irc.foonet.org 254 tester 1 :channels formed") + (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 10 "MODE tester +i") + (0 ":irc.foonet.org 221 tester +i") + (0 ":irc.foonet.org NOTICE tester :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.")) + +((join 10 "JOIN #chan") + (0 ":tester!~u@9g6b728983yd2.irc JOIN #chan") + (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob") + (0 ":irc.foonet.org 366 tester #chan :End of NAMES list")) + +((mode-chan 10 "MODE #chan") + (0 ":irc.foonet.org 324 tester #chan +nt") + (0 ":irc.foonet.org 329 tester #chan 1620104779") + (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!")) + +((vhost 10 "VHOST tester changeme") + (0 ":irc.foonet.org NOTICE tester :Setting your VHost: some.host.test.cc") + (0 ":irc.foonet.org 396 tester some.host.test.cc :is now your displayed host") + (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: But, as it seems, did violence on herself.") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Well, this is the forest of Arden.")) diff --git a/test/lisp/erc/resources/dcc/chat/accept.eld b/test/lisp/erc/resources/dcc/chat/accept.eld index a23e9580bcc..463f931d26f 100644 --- a/test/lisp/erc/resources/dcc/chat/accept.eld +++ b/test/lisp/erc/resources/dcc/chat/accept.eld @@ -17,7 +17,7 @@ (0 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") ;; No mode answer (0 ":irc.foonet.org NOTICE tester :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.") (0.2 ":dummy!~u@34n9brushbpj2.irc PRIVMSG tester :\C-aDCC CHAT chat 2130706433 " port "\C-a")) diff --git a/test/lisp/erc/resources/erc-d/erc-d-t.el b/test/lisp/erc/resources/erc-d/erc-d-t.el index 7b2adf4f07b..7126165fd91 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-t.el +++ b/test/lisp/erc/resources/erc-d/erc-d-t.el @@ -83,6 +83,8 @@ returning." (ignore-errors (kill-buffer buf))))) (sleep-for erc-d-t-cleanup-sleep-secs))))) +(defvar erc-d-t--wait-message-prefix "Awaiting: ") + (defmacro erc-d-t-wait-for (max-secs msg &rest body) "Wait for BODY to become non-nil. Or signal error with MSG after MAX-SECS. When MAX-SECS is negative, @@ -99,7 +101,7 @@ be desirable." (let ((inverted (make-symbol "inverted")) (time-out (make-symbol "time-out")) (result (make-symbol "result"))) - `(ert-info ((concat "Awaiting: " ,msg)) + `(ert-info ((concat erc-d-t--wait-message-prefix ,msg)) (let ((,time-out (abs ,max-secs)) (,inverted (< ,max-secs 0)) (,result ',result)) @@ -120,7 +122,8 @@ On failure, emit MSG." (unless (or (stringp msg) (memq (car-safe msg) '(format concat))) (push msg body) (setq msg (prin1-to-string body))) - `(erc-d-t-wait-for (- (abs ,max-secs)) ,msg (not (progn ,@body)))) + `(let ((erc-d-t--wait-message-prefix "Sustaining: ")) + (erc-d-t-wait-for (- (abs ,max-secs)) ,msg (not (progn ,@body))))) (defun erc-d-t-search-for (timeout text &optional from on-success) "Wait for TEXT to appear in current buffer before TIMEOUT secs. @@ -154,6 +157,7 @@ ON-SUCCESS, is nonexistent. To reset, specify a FROM argument." (let (positions) (lambda (timeout text &optional reset-from) (let* ((pos (cdr (assq (current-buffer) positions))) + (erc-d-t--wait-message-prefix (and (< timeout 0) "Sustaining: ")) (cb (lambda () (unless pos (push (cons (current-buffer) (setq pos (make-marker))) diff --git a/test/lisp/erc/resources/erc-d/erc-d-tests.el b/test/lisp/erc/resources/erc-d/erc-d-tests.el index a501cd55494..0ae70087fd1 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-tests.el +++ b/test/lisp/erc/resources/erc-d/erc-d-tests.el @@ -674,7 +674,7 @@ nonzero for this to work." (ert-deftest erc-d-run-linger () :tags '(:unstable :expensive-test) (erc-d-tests-with-server (dumb-s _) linger - (with-current-buffer (erc-d-t-wait-for 6 (get-buffer "#chan")) + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) (erc-d-t-search-for 2 "hey")) (with-current-buffer (process-buffer dumb-s) (erc-d-t-search-for 2 "Lingering for 1.00 seconds")) diff --git a/test/lisp/erc/resources/erc-d/erc-d-u.el b/test/lisp/erc/resources/erc-d/erc-d-u.el index e26fa8b47dd..c7d6859e3e1 100644 --- a/test/lisp/erc/resources/erc-d/erc-d-u.el +++ b/test/lisp/erc/resources/erc-d/erc-d-u.el @@ -74,6 +74,7 @@ (let ((hunks (erc-d-u-scan-e-sd info)) (pos (erc-d-u-scan-e-pos info))) (or (and (erc-d-u-scan-d-hunks hunks) + (buffer-live-p (erc-d-u-scan-d-buf hunks)) (with-current-buffer (erc-d-u-scan-d-buf hunks) (goto-char pos) (condition-case _err diff --git a/test/lisp/erc/resources/erc-d/erc-d.el b/test/lisp/erc/resources/erc-d/erc-d.el index f4491bbb834..a87904e5830 100644 --- a/test/lisp/erc/resources/erc-d/erc-d.el +++ b/test/lisp/erc/resources/erc-d/erc-d.el @@ -254,7 +254,7 @@ return a replacement.") (ending (process-get process :dialog-ending)) (dialog (make-erc-d-dialog :name name :process process - :queue (make-ring 5) + :queue (make-ring 10) :exchanges (make-ring 10) :match-handlers mat-h :server-fqdn fqdn))) @@ -292,32 +292,27 @@ With int SKIP, advance past that many exchanges." (defvar erc-d--m-debug (getenv "ERC_D_DEBUG")) -(defmacro erc-d--m (process format-string &rest args) - "Output ARGS using FORMAT-STRING somewhere depending on context. -PROCESS should be a client connection or a server network process." - `(let ((format-string (if erc-d--m-debug - (concat (format-time-string "%s.%N: ") - ,format-string) - ,format-string)) - (want-insert (and ,process erc-d--in-process))) - (when want-insert - (with-current-buffer (process-buffer (process-get ,process :server)) - (goto-char (point-max)) - (insert (concat (format ,format-string ,@args) "\n")))) - (when (or erc-d--m-debug (not want-insert)) - (message format-string ,@args)))) - -(defmacro erc-d--log (process string &optional outbound) - "Log STRING sent to (OUTBOUND) or received from PROCESS peer." - `(let ((id (or (process-get ,process :log-id) - (let ((port (erc-d-u--get-remote-port ,process))) - (process-put ,process :log-id port) - port))) - (name (erc-d-dialog-name (process-get ,process :dialog)))) - (if ,outbound - (erc-d--m process "-> %s:%s %s" name id ,string) - (dolist (line (split-string ,string (process-get process :ending))) - (erc-d--m process "<- %s:%s %s" name id line))))) +(defun erc-d--m (process format-string &rest args) + "Output ARGS using FORMAT-STRING to PROCESS's buffer or elsewhere." + (when erc-d--m-debug + (setq format-string (concat (format-time-string "%s.%N: ") format-string))) + (let ((insertp (and process erc-d--in-process)) + (buffer (and process (process-buffer (process-get process :server))))) + (when (and insertp (buffer-live-p buffer)) + (princ (concat (apply #'format format-string args) "\n") buffer)) + (when (or erc-d--m-debug (not insertp)) + (apply #'message format-string args)))) + +(defun erc-d--log (process string &optional outbound) + "Log STRING received from or OUTBOUND to PROCESS peer." + (let ((id (or (process-get process :log-id) + (let ((port (erc-d-u--get-remote-port process))) + (process-put process :log-id port) port))) + (name (erc-d-dialog-name (process-get process :dialog)))) + (if outbound + (erc-d--m process "-> %s:%s %s" name id string) + (dolist (line (split-string string (process-get process :ending))) + (erc-d--m process "<- %s:%s %s" name id line))))) (defun erc-d--log-process-event (server process msg) (erc-d--m server "%s: %s" process (string-trim-right msg))) @@ -455,14 +450,14 @@ including line delimiters." (setq string (unless (= (match-end 0) (length string)) (substring string (match-end 0)))) (erc-d--log process line nil) - (ring-insert queue (erc-d-i--parse-message line 'decode)))) + (ring-insert queue (erc-d-i--parse-message line nil)))) (when string (setf (process-get process :stashed-input) string)))) ;; Misc process properties: ;; ;; The server property `:dialog-dialogs' is an alist of (symbol -;; . erc-d-u-scan-d) conses, each of which pairs a dialogs name with +;; . erc-d-u-scan-d) conses, each of which pairs a dialog's name with ;; info on its read progress (described above in the Commentary). ;; This list is populated by `erc-d-run' at the start of each session. ;; diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld b/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld index 4994e9c5503..e8feb2e6fd8 100644 --- a/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld +++ b/test/lisp/erc/resources/erc-d/resources/dynamic-barnet.eld @@ -18,14 +18,14 @@ (0. ":irc.barnet.org 266 tester 3 3 :Current global users 3, max 3") (0. ":irc.barnet.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 2 "MODE tester +i") (0. ":irc.barnet.org 221 tester +Zi") (0. ":irc.barnet.org 306 tester :You have been marked as being away") (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") (0 ":irc.barnet.org 353 joe = #chan :+joe!~joe@example.com @%+mike!~mike@example.org") (0 ":irc.barnet.org 366 joe #chan :End of NAMES list")) -((mode 1 "MODE #chan") +((mode 3 "MODE #chan") (0 ":irc.barnet.org 324 tester #chan +nt") (0 ":irc.barnet.org 329 tester #chan 1620805269") (0.1 ":joe!~u@awyxgybtkx7uq.irc PRIVMSG #chan :mike: Yes, a dozen; and as many to the vantage, as would store the world they played for.") diff --git a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld index a47998e7d32..2db750e49da 100644 --- a/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld +++ b/test/lisp/erc/resources/erc-d/resources/dynamic-foonet.eld @@ -17,14 +17,14 @@ (0. ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0. ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 4 "MODE tester +i") (0. ":irc.foonet.org 221 tester +Zi") (0. ":irc.foonet.org 306 tester :You have been marked as being away") (0 ":tester!~u@awyxgybtkx7uq.irc JOIN #chan") (0 ":irc.foonet.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") (0 ":irc.foonet.org 366 alice #chan :End of NAMES list")) -((mode 2 "MODE #chan") +((mode 3 "MODE #chan") (0 ":irc.foonet.org 324 tester #chan +nt") (0 ":irc.foonet.org 329 tester #chan 1620805269") (0.1 ":alice!~u@awyxgybtkx7uq.irc PRIVMSG #chan :bob: Yes, a dozen; and as many to the vantage, as would store the world they played for.") diff --git a/test/lisp/erc/resources/erc-d/resources/linger.eld b/test/lisp/erc/resources/erc-d/resources/linger.eld index 36c81a3af4b..e456370a800 100644 --- a/test/lisp/erc/resources/erc-d/resources/linger.eld +++ b/test/lisp/erc/resources/erc-d/resources/linger.eld @@ -20,14 +20,14 @@ (0 ":irc.example.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.example.org 422 tester :MOTD File is missing")) -((mode-user 1.2 "MODE tester +i") +((mode-user 2 "MODE tester +i") (0 ":irc.example.org 221 tester +Zi") (0 ":irc.example.org 306 tester :You have been marked as being away") (0 ":tester!~tester@localhost JOIN #chan") (0 ":irc.example.org 353 alice = #chan :+alice!~alice@example.com @%+bob!~bob@example.org") (0 ":irc.example.org 366 alice #chan :End of NAMES list")) -((mode-chan 1.2 "MODE #chan") +((mode-chan 2 "MODE #chan") (0 ":bob!~bob@example.org PRIVMSG #chan :hey")) ((linger 1.0 LINGER)) diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el index 0d9a79ae9ce..d842454d085 100644 --- a/test/lisp/erc/resources/erc-scenarios-common.el +++ b/test/lisp/erc/resources/erc-scenarios-common.el @@ -51,7 +51,7 @@ ;; argument, a `let*'-style VAR-LIST. Relying on such a macro is ;; unfortunate because in many ways it actually hampers readability by ;; favoring magic over verbosity. But without it (or something -;; similar), any failing test would cause all subsequent tests in this +;; similar), any failing test would cause all subsequent tests in a ;; file to fail like dominoes (making all but the first backtrace ;; useless). ;; @@ -61,6 +61,25 @@ ;; always associated with the fake network FooNet, while nicks Joe and ;; Mike are always on BarNet. (Networks are sometimes downcased.) ;; +;; Environment variables: +;; +;; `ERC_TESTS_GRAPHICAL': Internal variable to unskip those few tests +;; capable of running consecutively while interactive on a graphical +;; display. This triggers both the tests and the suite to commence +;; with teardown activities normally skipped to allow for inspection +;; while interactive. This is also handy when needing to quickly +;; run `ert-results-rerun-test-at-point-debugging-errors' on a +;; failing test because you don't have to go around hunting for and +;; killing associated buffers and processes. +;; +;; `ERC_TESTS_GRAPHICAL_ALL': Currently targets a single "meta" test, +;; `erc-scenarios-internal--run-interactive-all', that runs all +;; tests tagged `:erc--graphical' in an interactive subprocess. +;; +;; `ERC_TESTS_SUBPROCESS': Used internally to detect nested tests. +;; +;; `ERC_D_DEBUG': Tells `erc-d' to emit debugging info to stderr. +;; ;; XXX This file should *not* contain any test cases. ;;; Code: @@ -91,6 +110,7 @@ (defvar erc-scenarios-common-dialog nil) (defvar erc-scenarios-common-extra-teardown nil) +(defvar erc-scenarios-common--graphical-p nil) (defun erc-scenarios-common--add-silence () (advice-add #'erc-login :around #'erc-d-t-silence-around) @@ -110,7 +130,11 @@ (eval-and-compile (defun erc-scenarios-common--make-bindings (bindings) - `((erc-d-u-canned-dialog-dir (expand-file-name + `((erc-scenarios-common--graphical-p + (and (or erc-scenarios-common--graphical-p + (memq :erc--graphical (ert-test-tags (ert-running-test)))) + (not (and noninteractive (ert-skip "Interactive only"))))) + (erc-d-u-canned-dialog-dir (expand-file-name (or erc-scenarios-common-dialog (cadr (assq 'erc-scenarios-common-dialog ',bindings))) @@ -119,8 +143,10 @@ (quit . ,(erc-quit/part-reason-default)) (erc-version . ,erc-version))) (erc-modules (copy-sequence erc-modules)) - (inhibit-interaction t) + (inhibit-interaction noninteractive) (auth-source-do-cache nil) + (timer-list (copy-sequence timer-list)) + (timer-idle-list (copy-sequence timer-idle-list)) (erc-auth-source-parameters-join-function nil) (erc-autojoin-channels-alist nil) (erc-server-auto-reconnect nil) @@ -137,13 +163,19 @@ disabled by BODY. Other defaults common to these test cases are added below and can be overridden, except when wanting the \"real\" default value, which must be looked up or captured outside of the calling form. +When running tests tagged as serially runnable while interactive +and the flag `erc-scenarios-common--graphical-p' is non-nil, run +teardown tasks normally inhibited when interactive. That is, +behave almost as if `noninteractive' were also non-nil, and +ensure buffers and other resources are destroyed on completion. + Dialog resource directories are located by expanding the variable `erc-scenarios-common-dialog' or its value in BINDINGS." (declare (indent 1)) (let* ((orig-autojoin-mode (make-symbol "orig-autojoin-mode")) (combined `((,orig-autojoin-mode (bound-and-true-p erc-autojoin-mode)) - ,@(erc-scenarios-common--make-bindings bindings)))) + ,@(erc-scenarios-common--make-bindings bindings)))) `(erc-d-t-with-cleanup (,@combined) @@ -163,8 +195,9 @@ Dialog resource directories are located by expanding the variable (not (eq erc-autojoin-mode ,orig-autojoin-mode))) (erc-autojoin-mode (if ,orig-autojoin-mode +1 -1))) - (when noninteractive - (erc-scenarios-common--print-trace) + (when (or noninteractive erc-scenarios-common--graphical-p) + (when noninteractive + (erc-scenarios-common--print-trace)) (erc-d-t-kill-related-buffers) (delete-other-windows))) @@ -177,11 +210,118 @@ Dialog resource directories are located by expanding the variable (erc-d-t-search-for 3 "Starting"))))) (ert-info ("Activate erc-debug-irc-protocol") - (unless (and noninteractive (not erc-debug-irc-protocol)) + (unless (and (or noninteractive erc-scenarios-common--graphical-p) + (not erc-debug-irc-protocol)) (erc-toggle-debug-irc-protocol))) ,@body))) +(defvar erc-scenarios-common--term-size '(34 . 80)) +(declare-function term-char-mode "term" nil) +(declare-function term-line-mode "term" nil) + +;; Much of this concerns accommodating test environments outside of +;; the emacs.git tree, such as CI jobs running ERC's ELPA-package on +;; older Emacsen. See also `erc-tests--assert-printed-in-subprocess'. +(defun erc-scenarios-common--run-in-term (&optional debug) + (require 'term) + (let* ((default-directory (or (getenv "EMACS_TEST_DIRECTORY") + (expand-file-name + ".." erc-scenarios-common--resources-dir))) + ;; In the emacs.git tree, "HOME" will be "/nonexistent", which + ;; is fine because we don't need any ELPA packages. + (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)))))) + ;; The `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)) + (init (and-let* ((found (getenv "ERC_TESTS_INIT")) + (files (split-string found ","))) + (mapcan (lambda (f) (list "-l" f)) files))) + (setup `(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))) + ;; Make subprocess terminal bigger than controlling. + (buf (cl-letf (((symbol-function 'window-screen-lines) + (lambda () (car erc-scenarios-common--term-size))) + ((symbol-function 'window-max-chars-per-line) + (lambda () (cdr erc-scenarios-common--term-size)))) + (apply #'make-term (symbol-name name) + (expand-file-name invocation-name invocation-directory) + nil `(,@(or init '("-Q")) "-nw" + "-eval" ,(format "%S" 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))))) + (unless noninteractive + (set-window-buffer (selected-window) buf) + (delete-other-windows)) + (with-current-buffer buf + (set-process-query-on-exit-flag proc nil) + (unless noninteractive (term-char-mode)) + (erc-d-t-wait-for 30 (process-live-p proc)) + (while (accept-process-output proc)) + (term-line-mode) + (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))))) + +(defvar erc-scenarios-common-interactive-debug-term-p nil + "Non-nil means run test in an inferior Emacs, even if interactive.") + +(defmacro erc-scenarios-common-with-noninteractive-in-term (&rest body) + "Run BODY via `erc-scenarios-common-with-cleanup' in a `term' subprocess. +Also do so when `erc-scenarios-common-interactive-debug-term-p' +is non-nil. When debugging, leave the `term-mode' buffer around +for inspection and name it after the test, bounded by asterisks. +When debugging, ensure the test always fails, as a reminder to +disable `erc-scenarios-common-interactive-debug-term-p'. + +See Info node `(emacs) Term Mode' for the various commands." + (declare (indent 1)) + `(if (and (or erc-scenarios-common-interactive-debug-term-p + noninteractive) + (not (getenv "ERC_TESTS_SUBPROCESS"))) + (progn + (when (memq system-type '(windows-nt ms-dos cygwin haiku)) + (ert-skip "System must be UNIX-like")) + (erc-scenarios-common--run-in-term + erc-scenarios-common-interactive-debug-term-p)) + (erc-scenarios-common-with-cleanup ,@body))) + (defun erc-scenarios-common-assert-initial-buf-name (id port) ;; Assert no limbo period when explicit ID given (should (string= (if id @@ -208,9 +348,111 @@ Dialog resource directories are located by expanding the variable (insert str) (erc-send-current-line))) +(defun erc-scenarios-common--at-win-end-p (&optional window) + (= (window-body-height window) + (count-screen-lines (window-start window) (point-max) nil window))) + +(defun erc-scenarios-common--above-win-end-p (&optional window) + (> (window-body-height window) + (count-screen-lines (window-start window) (point-max)))) + +(defun erc-scenarios-common--prompt-past-win-end-p (&optional window) + (< (window-body-height window) + (count-screen-lines (window-start window) (point-max)))) + +(defun erc-scenarios-common--recenter-top-bottom-around (orig &rest args) + (let (this-command last-command) (apply orig args))) + +(defun erc-scenarios-common--recenter-top-bottom () + (advice-add 'recenter-top-bottom + :around #'erc-scenarios-common--recenter-top-bottom-around) + (execute-kbd-macro "\C-l") + (advice-remove 'recenter-top-bottom + #'erc-scenarios-common--recenter-top-bottom-around)) + ;;;; Fixtures +(defun erc-scenarios-common-scrolltobottom--normal (test) + (erc-scenarios-common-with-noninteractive-in-term + ((erc-scenarios-common-dialog "scrolltobottom") + (dumb-server (erc-d-run "localhost" t 'help)) + (port (process-contact dumb-server :service)) + (erc-modules `(scrolltobottom fill-wrap ,@erc-modules)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :full-name "tester" + :nick "tester") + (funcall expect 10 "debug mode"))) + + (with-current-buffer "foonet" + (should (looking-at " and")) + (set-window-buffer nil (current-buffer)) + (delete-other-windows) + (split-window-below 15) + (recenter 0) + + (ert-info ("Moving into prompt in other window triggers scroll") + (with-selected-window (next-window) + (should-not (erc-scenarios-common--at-win-end-p)) + (goto-char (1- erc-insert-marker)) + (execute-kbd-macro "\C-n") + ;; Ensure point is at prompt and aligned to bottom. + (should (erc-scenarios-common--at-win-end-p)))) + + (ert-info ("Module `move-to-prompt' still works") + ;; Prompt is somewhere in the middle of the window. + (should (erc-scenarios-common--above-win-end-p)) + ;; Hitting a self-insert key triggers `move-to-prompt' as well + ;; as a scroll (to bottom). + (execute-kbd-macro "hi") + ;; Prompt and input appear on last line of window. + (should (erc-scenarios-common--at-win-end-p))) + + (ert-info ("Command `recenter-top-bottom' disallowed at prompt") + ;; Hitting C-l does not recenter the window. + (erc-scenarios-common--recenter-top-bottom) + (should (erc-scenarios-common--at-win-end-p)) + (erc-scenarios-common--recenter-top-bottom) + (should (erc-scenarios-common--at-win-end-p))) + + (ert-info ("Command `beginning-of-buffer' allowed at prompt") + ;; Hitting C-< goes to beginning of buffer. + (call-interactively #'beginning-of-buffer) + (should (= 1 (point))) + (redisplay) + (should (zerop (count-screen-lines (window-start) (point)))) + (should (erc-scenarios-common--prompt-past-win-end-p))) + + (ert-info ("New message doesn't trigger scroll when away from prompt") + ;; Arriving insertions don't trigger a scroll when away from the + ;; prompt. New output not seen. + (erc-cmd-MSG "NickServ help register") + (save-excursion (erc-d-t-search-for 10 "End of NickServ")) + (should (= 1 (point))) + (redisplay) + (should (zerop (count-screen-lines (window-start) (window-point)))) + (should (erc-scenarios-common--prompt-past-win-end-p))) + + (funcall test) + + (ert-info ("New message does trigger a scroll when at prompt") + ;; Recenter so prompt is above rather than at window's end. + (funcall expect 10 "If you are currently logged in") + (recenter 0) + ;; Prompt is somewhere in the middle of the window. + (erc-d-t-wait-for 10 (erc-scenarios-common--above-win-end-p)) + (erc-scenarios-common-say "/msg NickServ help identify") + ;; New arriving messages trigger a snap when inserted. + (erc-d-t-wait-for 10 (erc-scenarios-common--at-win-end-p)) + (funcall expect 10 "IDENTIFY lets you login")) + + (erc-scrolltobottom-mode -1)))) + (cl-defun erc-scenarios-common--base-network-id-bouncer ((&key autop foo-id bar-id after &aux @@ -247,7 +489,7 @@ buffer-naming collisions involving bouncers in ERC." :id foo-id)) (setq erc-server-process-foo erc-server-process) (erc-scenarios-common-assert-initial-buf-name foo-id port) - (erc-d-t-wait-for 3 (eq (erc-network) 'foonet)) + (erc-d-t-wait-for 6 (eq (erc-network) 'foonet)) (erc-d-t-wait-for 3 (string= (buffer-name) serv-buf-foo)) (funcall expect 5 "foonet"))) @@ -287,7 +529,7 @@ buffer-naming collisions involving bouncers in ERC." (erc-d-t-search-for 1 "<bob>") (erc-d-t-absent-for 0.1 "<joe>") (should (eq erc-server-process erc-server-process-foo)) - (erc-d-t-search-for 10 "ape is dead") + (erc-d-t-search-for 15 "ape is dead") (erc-d-t-wait-for 5 (not (erc-server-process-alive))))) (ert-info ("#chan@<esid> is exclusive to barnet") @@ -366,7 +608,7 @@ buffer-naming collisions involving bouncers in ERC." :password "changeme" :full-name "tester") (erc-scenarios-common-assert-initial-buf-name nil port) - (erc-d-t-wait-for 3 (eq (erc-network) 'foonet)) + (erc-d-t-wait-for 6 (eq (erc-network) 'foonet)) (erc-d-t-wait-for 3 (string= (buffer-name) "foonet")) (funcall expect 5 "foonet"))) @@ -446,10 +688,17 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC." (with-current-buffer erc-server-buffer-foo (erc-cmd-JOIN "#chan")) (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) (funcall expect 5 "vile thing") - (erc-cmd-QUIT ""))) + (erc-cmd-QUIT "") + + (ert-info ("Prompt hidden in channel buffer upon quitting") + (erc-d-t-wait-for 10 (erc--prompt-hidden-p)) + (should (overlays-in erc-insert-marker erc-input-marker))))) - (erc-d-t-wait-for 2 "Foonet connection deceased" - (not (erc-server-process-alive erc-server-buffer-foo))) + (with-current-buffer erc-server-buffer-foo + (ert-info ("Prompt hidden after process dies in server buffer") + (erc-d-t-wait-for 2 (not (erc-server-process-alive))) + (erc-d-t-wait-for 10 (erc--prompt-hidden-p)) + (should (overlays-in erc-insert-marker erc-input-marker)))) (should (equal erc-autojoin-channels-alist (if foo-id '((oofnet "#chan")) '((foonet "#chan"))))) @@ -498,6 +747,10 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC." (setq erc-server-process-foo erc-server-process) (erc-d-t-wait-for 2 (eq erc-network 'foonet)) (should (string= (buffer-name) (if foo-id "oofnet" "foonet"))) + + (ert-info ("Prompt unhidden") + (should-not (erc--prompt-hidden-p)) + (should-not (overlays-in erc-insert-marker erc-input-marker))) (funcall expect 5 "foonet"))) (ert-info ("#chan@foonet is clean, no cross-contamination") @@ -505,7 +758,11 @@ Bug#48598: 28.0.50; buffer-naming collisions involving bouncers in ERC." (erc-d-t-wait-for 3 (eq erc-server-process erc-server-process-foo)) (funcall expect 3 "<bob>") (erc-d-t-absent-for 0.1 "<joe>") - (funcall expect 10 "not given me"))) + (funcall expect 30 "not given me") + + (ert-info ("Prompt unhidden") + (should-not (erc--prompt-hidden-p)) + (should-not (overlays-in erc-insert-marker erc-input-marker))))) (ert-info ("All #chan@barnet output received") (with-current-buffer chan-buf-bar diff --git a/test/lisp/erc/resources/erc-tests-common.el b/test/lisp/erc/resources/erc-tests-common.el new file mode 100644 index 00000000000..20b3a56facc --- /dev/null +++ b/test/lisp/erc/resources/erc-tests-common.el @@ -0,0 +1,301 @@ +;;; erc-tests-common.el --- Common helpers for ERC tests -*- 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: + +;; 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) + + +(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)))) + (erc-tests-common-prep-for-insertion) + (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." + (unless name + (cl-assert (string-prefix-p " *temp*" (setq name (buffer-name))))) + (with-current-buffer (get-buffer-create 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 nil)) + (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-eval-expression sexp)))) + +;; 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)) + +;; 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))) + + +;;;; 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 fiter 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)))) + (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)) + ;; 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 (read (with-temp-buffer + (insert-file-contents-literally expect-file) + (buffer-string))))) + (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)) + +(provide 'erc-tests-common) diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld new file mode 100644 index 00000000000..3c32719a052 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero.[07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #5#) 459 466 (wrap-prefix #1# line-prefix #5#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #5# display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 (8)))) 475 480 (wrap-prefix #1# line-prefix #7#) 480 486 (wrap-prefix #1# line-prefix #7#) 487 488 (erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #8=(space :width (- 27 0)) display #9="") 488 493 (wrap-prefix #1# line-prefix #8# display #9#) 493 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 499 (wrap-prefix #1# line-prefix #8#) 500 501 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 501 504 (wrap-prefix #1# line-prefix #10#) 504 512 (wrap-prefix #1# line-prefix #10#) 513 514 (erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #9#) 514 517 (wrap-prefix #1# line-prefix #11# display #9#) 517 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 524 (wrap-prefix #1# line-prefix #11#) 525 526 (erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 (8)))) 526 531 (wrap-prefix #1# line-prefix #12#) 531 538 (wrap-prefix #1# line-prefix #12#) 539 540 (erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 0)) display #9#) 540 545 (wrap-prefix #1# line-prefix #13# display #9#) 545 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 551 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld new file mode 100644 index 00000000000..e2064b914c4 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero.[07:00]\n<alice> one.\n<alice> two.\n<bob> three.\n<bob> four.\n<Dummy> five.\n<Dummy> six.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18))) field erc-timestamp) 21 22 (wrap-prefix #1# line-prefix #2=(space :width (- 29 (4))) erc--msg notice erc--ts 0) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (wrap-prefix #1# line-prefix #2# field erc-timestamp display (#6=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (wrap-prefix #1# line-prefix #3=(space :width (- 29 (8))) erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix (space :width (- 29 (8)))) 349 350 (wrap-prefix #1# line-prefix #4=(space :width (- 29 (6))) erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (wrap-prefix #1# line-prefix (space :width (- 29 (18))) field erc-timestamp) 455 456 (wrap-prefix #1# line-prefix #5=(space :width (- 29 (6))) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG) 456 459 (wrap-prefix #1# line-prefix #5#) 459 466 (wrap-prefix #1# line-prefix #5#) 466 473 (wrap-prefix #1# line-prefix #5# field erc-timestamp display (#6# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (wrap-prefix #1# line-prefix #7=(space :width (- 29 (8))) erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG) 475 480 (wrap-prefix #1# line-prefix #7#) 480 486 (wrap-prefix #1# line-prefix #7#) 487 488 (wrap-prefix #1# line-prefix #8=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "alice" erc--cmd PRIVMSG display #9="") 488 493 (wrap-prefix #1# line-prefix #8# display #9#) 493 495 (wrap-prefix #1# line-prefix #8# display #9#) 495 499 (wrap-prefix #1# line-prefix #8#) 500 501 (wrap-prefix #1# line-prefix #10=(space :width (- 29 (6))) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG) 501 504 (wrap-prefix #1# line-prefix #10#) 504 512 (wrap-prefix #1# line-prefix #10#) 513 514 (wrap-prefix #1# line-prefix #11=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "bob" erc--cmd PRIVMSG display #9#) 514 517 (wrap-prefix #1# line-prefix #11# display #9#) 517 519 (wrap-prefix #1# line-prefix #11# display #9#) 519 524 (wrap-prefix #1# line-prefix #11#) 525 526 (wrap-prefix #1# line-prefix #12=(space :width (- 29 (8))) erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG) 526 531 (wrap-prefix #1# line-prefix #12#) 531 538 (wrap-prefix #1# line-prefix #12#) 539 540 (wrap-prefix #1# line-prefix #13=(space :width (- 29 0)) erc--msg msg erc--ts 1680332400 erc--spkr "Dummy" erc--cmd PRIVMSG display #9#) 540 545 (wrap-prefix #1# line-prefix #13# display #9#) 545 547 (wrap-prefix #1# line-prefix #13# display #9#) 547 551 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld new file mode 100644 index 00000000000..feaba85ec90 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-01.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero.[07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #10#) 499 505 (wrap-prefix #1# line-prefix #10#) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 507 510 (wrap-prefix #1# line-prefix #11# display #8#) 510 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 515 (wrap-prefix #1# line-prefix #11#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #12#) 518 521 (wrap-prefix #1# line-prefix #12#) 521 527 (wrap-prefix #1# line-prefix #12#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #13#) 532 539 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld new file mode 100644 index 00000000000..ed1488c8595 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-post-01.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero.[07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 0)) display #8="") 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #10=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #10#) 499 505 (wrap-prefix #1# line-prefix #10#) 505 506 (display #("~\n" 0 2 (font-lock-face shadow))) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 0)) display #8#) 507 510 (wrap-prefix #1# line-prefix #11# display #8#) 510 512 (wrap-prefix #1# line-prefix #11# display #8#) 512 515 (wrap-prefix #1# line-prefix #11#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #12=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #12#) 518 521 (wrap-prefix #1# line-prefix #12#) 521 527 (wrap-prefix #1# line-prefix #12#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #13=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #13#) 532 539 (wrap-prefix #1# line-prefix #13#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld new file mode 100644 index 00000000000..a3530a6c44d --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-wrap-indicator-pre-01.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n<bob> zero.[07:00]\n<bob> 0.5\n* bob one.\n<bob> two.\n<bob> 2.5\n* bob three\n<bob> four.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display (#5=(margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--spkr "alice" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--spkr "bob" erc--ts 0 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 436 437 (erc--msg datestamp erc--ts 1680307200 field erc-timestamp) 437 454 (field erc-timestamp wrap-prefix #1# line-prefix (space :width (- 27 (18)))) 455 456 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #6=(space :width (- 27 (6)))) 456 459 (wrap-prefix #1# line-prefix #6#) 459 466 (wrap-prefix #1# line-prefix #6#) 466 473 (field erc-timestamp wrap-prefix #1# line-prefix #6# display (#5# #("[07:00]" 0 7 (invisible timestamp)))) 474 475 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #7=(space :width (- 27 #10=(2))) display #8=#("> " 0 1 (font-lock-face shadow))) 475 478 (wrap-prefix #1# line-prefix #7# display #8#) 478 480 (wrap-prefix #1# line-prefix #7# display #8#) 480 483 (wrap-prefix #1# line-prefix #7#) 484 485 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 485 486 (wrap-prefix #1# line-prefix #9#) 486 489 (wrap-prefix #1# line-prefix #9#) 489 494 (wrap-prefix #1# line-prefix #9#) 495 496 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #11=(space :width (- 27 (6)))) 496 499 (wrap-prefix #1# line-prefix #11#) 499 505 (wrap-prefix #1# line-prefix #11#) 506 507 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #12=(space :width (- 27 #10#)) display #8#) 507 510 (wrap-prefix #1# line-prefix #12# display #8#) 510 512 (wrap-prefix #1# line-prefix #12# display #8#) 512 515 (wrap-prefix #1# line-prefix #12#) 516 517 (erc--msg ctcp-action erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG erc--ctcp ACTION wrap-prefix #1# line-prefix #13=(space :width (- 27 (2)))) 517 518 (wrap-prefix #1# line-prefix #13#) 518 521 (wrap-prefix #1# line-prefix #13#) 521 527 (wrap-prefix #1# line-prefix #13#) 528 529 (erc--msg msg erc--spkr "bob" erc--ts 1680332400 erc--cmd PRIVMSG wrap-prefix #1# line-prefix #14=(space :width (- 27 (6)))) 529 532 (wrap-prefix #1# line-prefix #14#) 532 539 (wrap-prefix #1# line-prefix #14#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld new file mode 100644 index 00000000000..c94629cf357 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld new file mode 100644 index 00000000000..127c0b29bc9 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 29) line-prefix (space :width (- 29 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 29 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 29 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 29 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld new file mode 100644 index 00000000000..a9f3f1d1904 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 25) line-prefix (space :width (- 25 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 25 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 25 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 25 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld new file mode 100644 index 00000000000..c94629cf357 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld new file mode 100644 index 00000000000..754d7989cea --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/spacing-01-mono.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n<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.\n<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n<bob> This buffer is for text.\n*** one two three\n*** four five six\n<bob> Somebody stop me\n" 2 3 (erc--msg datestamp erc--ts 0 field erc-timestamp) 3 20 (field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix (space :width (- 27 (18)))) 21 22 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #2=(space :width (- 27 (4)))) 22 183 (wrap-prefix #1# line-prefix #2#) 183 190 (field erc-timestamp wrap-prefix #1# line-prefix #2# display ((margin right-margin) #("[00:00]" 0 7 (invisible timestamp)))) 190 191 (line-spacing 0.5) 191 192 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #3=(space :width (- 27 (8)))) 192 197 (wrap-prefix #1# line-prefix #3#) 197 199 (wrap-prefix #1# line-prefix #3#) 199 202 (wrap-prefix #1# line-prefix #3#) 202 315 (wrap-prefix #1# line-prefix #3#) 316 348 (wrap-prefix #1# line-prefix #3#) 348 349 (line-spacing 0.5) 349 350 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #4=(space :width (- 27 (6)))) 350 353 (wrap-prefix #1# line-prefix #4#) 353 355 (wrap-prefix #1# line-prefix #4#) 355 360 (wrap-prefix #1# line-prefix #4#) 360 435 (wrap-prefix #1# line-prefix #4#) 435 436 (line-spacing 0.5) 436 437 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #5=(space :width (- 27 0)) display #6="") 437 440 (wrap-prefix #1# line-prefix #5# display #6#) 440 442 (wrap-prefix #1# line-prefix #5# display #6#) 442 466 (wrap-prefix #1# line-prefix #5#) 466 467 (line-spacing 0.5) 467 468 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #7=(space :width (- 27 (4)))) 468 484 (wrap-prefix #1# line-prefix #7#) 485 486 (erc--msg notice erc--ts 0 wrap-prefix #1# line-prefix #8=(space :width (- 27 (4)))) 486 502 (wrap-prefix #1# line-prefix #8#) 502 503 (line-spacing 0.5) 503 504 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG wrap-prefix #1# line-prefix #9=(space :width (- 27 (6)))) 504 507 (wrap-prefix #1# line-prefix #9#) 507 525 (wrap-prefix #1# line-prefix #9#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld b/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld new file mode 100644 index 00000000000..1b22b6c5cfd --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/stamps-left-01.eld @@ -0,0 +1 @@ +#("\n\n[00:00]*** 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.\n[00:00]<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.\n[00:00]<bob> alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 3 (erc--msg notice erc--ts 0 display #3=(#5=(margin left-margin) #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1=(space :width 27) line-prefix #2=(space :width (- 27 (4)))) 3 9 (display #3# field erc-timestamp wrap-prefix #1# line-prefix #2#) 9 171 (wrap-prefix #1# line-prefix #2#) 172 173 (erc--msg msg erc--ts 0 erc--spkr "alice" erc--cmd PRIVMSG display #6=(#5# #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1# line-prefix #4=(space :width (- 27 (8)))) 173 179 (display #6# field erc-timestamp wrap-prefix #1# line-prefix #4#) 179 180 (wrap-prefix #1# line-prefix #4#) 180 185 (wrap-prefix #1# line-prefix #4#) 185 187 (wrap-prefix #1# line-prefix #4#) 187 190 (wrap-prefix #1# line-prefix #4#) 190 303 (wrap-prefix #1# line-prefix #4#) 304 336 (wrap-prefix #1# line-prefix #4#) 337 338 (erc--msg msg erc--ts 0 erc--spkr "bob" erc--cmd PRIVMSG display #8=(#5# #("[00:00]" 0 7 (invisible timestamp font-lock-face erc-timestamp-face))) field erc-timestamp wrap-prefix #1# line-prefix #7=(space :width (- 27 (6)))) 338 344 (display #8# field erc-timestamp wrap-prefix #1# line-prefix #7#) 344 345 (wrap-prefix #1# line-prefix #7#) 345 348 (wrap-prefix #1# line-prefix #7#) 348 350 (wrap-prefix #1# line-prefix #7#) 350 355 (wrap-prefix #1# line-prefix #7#) 355 430 (wrap-prefix #1# line-prefix #7#))
\ No newline at end of file diff --git a/test/lisp/erc/resources/join/buffer-display/mode-context.eld b/test/lisp/erc/resources/join/buffer-display/mode-context.eld new file mode 100644 index 00000000000..6ebbdc7e824 --- /dev/null +++ b/test/lisp/erc/resources/join/buffer-display/mode-context.eld @@ -0,0 +1,38 @@ +;; -*- mode: lisp-data; -*- +((nick 1 "NICK tester")) +((user 1 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.00 ":irc.foonet.org 003 tester :This server was created Tue, 24 May 2022 05:28:42 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.00 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode 6 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :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.") + (0.02 ":irc.foonet.org 221 tester +i")) + +((join-chan 10 "JOIN #chan") + (0.03 ":tester!~u@w9rfqveugz722.irc JOIN #chan")) + +((~mode-chan 10 "MODE #chan") + (0.01 ":irc.foonet.org 353 tester = #chan :@tester") + (0.00 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.01 ":irc.foonet.org 324 tester #chan +nt") + (0.03 ":irc.foonet.org 329 tester #chan 1653370308")) + +((~join-spam 10 "JOIN #spam") + (0.03 ":irc.foonet.org 471 tester #spam :Cannot join channel (+l)")) + +((~join-foo 10 "JOIN #foo") + (0.03 ":irc.foonet.org 473 tester #foo :Cannot join channel (+i)")) diff --git a/test/lisp/erc/resources/join/legacy/foonet.eld b/test/lisp/erc/resources/join/legacy/foonet.eld index 4025094a59c..5c0ea13b6a7 100644 --- a/test/lisp/erc/resources/join/legacy/foonet.eld +++ b/test/lisp/erc/resources/join/legacy/foonet.eld @@ -18,7 +18,7 @@ (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") (0 ":irc.foonet.org 422 tester :MOTD File is missing")) -((mode-user 3.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0 ":irc.foonet.org 221 tester +i") (0 ":irc.foonet.org NOTICE tester :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.")) diff --git a/test/lisp/erc/resources/join/network-id/barnet.eld b/test/lisp/erc/resources/join/network-id/barnet.eld index e33dd6be29e..ad6a7c820a9 100644 --- a/test/lisp/erc/resources/join/network-id/barnet.eld +++ b/test/lisp/erc/resources/join/network-id/barnet.eld @@ -40,4 +40,4 @@ (0.05 ":mike!~u@6yximxrnkg65a.irc PRIVMSG #chan :joe: And now, dear maid, be you as free to us.") (0.00 ":joe!~u@6yximxrnkg65a.irc PRIVMSG #chan :mike: He hath an uncle here in Messina will be very much glad of it.")) -((linger 3.5 LINGER)) +((linger 30 LINGER)) diff --git a/test/lisp/erc/resources/join/network-id/foonet-again.eld b/test/lisp/erc/resources/join/network-id/foonet-again.eld index b230eff27c7..a8b8a52f87a 100644 --- a/test/lisp/erc/resources/join/network-id/foonet-again.eld +++ b/test/lisp/erc/resources/join/network-id/foonet-again.eld @@ -43,4 +43,4 @@ (0.1 ":bob!~u@q6ddatxcq6txy.irc PRIVMSG #chan :alice: But we are spirits of another sort.") (0.1 ":alice!~u@q6ddatxcq6txy.irc PRIVMSG #chan :bob: It was not given me, nor I did not buy it.")) -((linger 6 LINGER)) +((linger 30 LINGER)) diff --git a/test/lisp/erc/resources/join/network-id/foonet.eld b/test/lisp/erc/resources/join/network-id/foonet.eld index 7d63f5f0c6c..74a107f8144 100644 --- a/test/lisp/erc/resources/join/network-id/foonet.eld +++ b/test/lisp/erc/resources/join/network-id/foonet.eld @@ -1,8 +1,8 @@ ;; -*- mode: lisp-data; -*- ((pass 10 "PASS :foonet:changeme")) -((nick 1 "NICK tester")) +((nick 10 "NICK tester")) -((user 1 "USER user 0 * :tester") +((user 10 "USER user 0 * :tester") (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") (0 ":irc.foonet.org 003 tester :This server was created Mon, 10 May 2021 00:58:22 UTC") diff --git a/test/lisp/erc/resources/keep-place/follow.eld b/test/lisp/erc/resources/keep-place/follow.eld new file mode 100644 index 00000000000..db9352d93be --- /dev/null +++ b/test/lisp/erc/resources/keep-place/follow.eld @@ -0,0 +1,78 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Tue, 26 Dec 2023 08:36:35 UTC") + (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 2 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.00 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.03 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.01 ":irc.foonet.org NOTICE tester :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.")) + +((mode 10 "MODE tester +i")) + +((join 10 "JOIN #chan") + (0.01 ":irc.foonet.org 221 tester +i") + (0.01 ":tester!~u@p64eqfwvvbxrk.irc JOIN #chan") + (0.03 ":irc.foonet.org 353 tester = #chan :@fsbot bob alice tester") + (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.00 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :tester, welcome!") + (0.01 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :tester, welcome!")) + +((join 10 "JOIN #spam") + (0.00 ":tester!~u@p64eqfwvvbxrk.irc JOIN #spam") + (0.06 ":irc.foonet.org 353 tester = #spam :@fsbot bob alice tester") + (0.01 ":irc.foonet.org 366 tester #spam :End of NAMES list") + (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #spam :tester, welcome!") + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :tester, welcome!")) + +((mode 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester #chan +Cnt") + (0.02 ":irc.foonet.org 329 tester #chan 1703579802") + (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: Madam, my lord is gone, for ever gone.") + (0.10 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :The kinder we, to give them thanks for nothing.")) + +((mode 10 "MODE #spam") + (0.00 ":irc.foonet.org 324 tester #spam +Cnt") + (0.02 ":irc.foonet.org 329 tester #spam 1703579805") + (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :Most manifest, and not denied by himself.") + (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: To bed, to bed: there's knocking at the gate. Come, come, come, come, give me your hand. What's done cannot be undone.") + (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: And what I spake, I spake it to my face.") + (0.08 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Since you can cog, I'll play no more with you.") + (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: The little casket bring me hither.") + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Not to-night, good Iago: I have very poor and unhappy brains for drinking: I could well wish courtesy would invent some other custom of entertainment.") + (0.02 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :Yes, faith will I, Fridays and Saturdays and all.")) + +((privmsg 10 "PRIVMSG #spam :one") + (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: This is the first truth that e'er thine own tongue was guilty of.") + (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: Drown the lamenting fool in sea-salt tears.") + + ;; Insert some lines ^ before rendezvous, so #chan can update scrolltobottom. + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Ay, the heads of the maids, or their maidenheads; take it in what sense thou wilt.") + + (0.05 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: And work confusion on his enemies.") + (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :bob: Truly, she must be given, or the marriage is not lawful.")) + +((privmsg 10 "PRIVMSG #spam :two") + (0.02 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :To be whipped; and yet a better love than my master.") + (0.06 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :And duty in his service perishing.") + + ;; Second check point. + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Cause they take vengeance of such kind of men.") + + (0.03 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :alice: No egma, no riddle, no l'envoy; no salve in the mail, sir. O! sir, plantain, a plain plantain: no l'envoy, no l'envoy: no salve, sir, but a plantain.") + (0.03 ":alice!~u@2q6ysndq32az6.irc PRIVMSG #chan :Signior Iachimo will not from it. Pray, let us follow 'em.")) + +((privmsg 10 "PRIVMSG #spam :three") + ;; Third check point. + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #spam :Moved.") + (0.01 ":bob!~u@2q6ysndq32az6.irc PRIVMSG #chan :Ready.")) diff --git a/test/lisp/erc/resources/match/fools/fill-wrap.eld b/test/lisp/erc/resources/match/fools/fill-wrap.eld new file mode 100644 index 00000000000..dff75ef9cd2 --- /dev/null +++ b/test/lisp/erc/resources/match/fools/fill-wrap.eld @@ -0,0 +1,41 @@ +;; -*- mode: lisp-data; -*- +((pass 10 "PASS :changeme")) +((nick 1 "NICK tester")) +((user 1 "USER user 0 * :tester") + (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") + (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") + (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=FooNet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0 ":irc.foonet.org 254 tester 1 :channels formed") + (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 10 "MODE tester +i") + (0 ":irc.foonet.org 221 tester +i") + (0 ":irc.foonet.org NOTICE tester :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.")) + +((join 6 "JOIN #chan") + (0 ":tester!~u@9g6b728983yd2.irc JOIN #chan") + (0 ":irc.foonet.org 353 tester = #chan :alice tester @bob") + (0 ":irc.foonet.org 366 tester #chan :End of NAMES list")) + +((mode 5 "MODE #chan") + (0 ":irc.foonet.org 324 tester #chan +nt") + (0 ":irc.foonet.org 329 tester #chan 1620104779") + (0.1 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :None better than to let him fetch off his drum, which you hear him so confidently undertake to do.") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: Still we went coupled and inseparable.") + (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :alice: Give me your hand. This hand is moist, my lady.")) + +((privmsg 5 "PRIVMSG #chan :hey") + (0 ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :You have paid the heavens your function, and the prisoner the very debt of your calling. I have laboured for the poor gentleman to the extremest shore of my modesty; but my brother justice have I found so severe, that he hath forced me to tell him he is indeed Justice.") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :bob: In the sick air: let not thy sword skip one.") + (0 ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :The web of our life is of a mingled yarn, good and ill together: our virtues would be proud if our faults whipped them not; and our crimes would despair if they were not cherished by our virtues.")) diff --git a/test/lisp/erc/resources/sasl/plain-failed.eld b/test/lisp/erc/resources/sasl/plain-failed.eld index 336700290c5..47d13de18e5 100644 --- a/test/lisp/erc/resources/sasl/plain-failed.eld +++ b/test/lisp/erc/resources/sasl/plain-failed.eld @@ -1,16 +1,16 @@ ;; -*- mode: lisp-data; -*- ((cap-req 10 "CAP REQ :sasl")) -((nick 1 "NICK tester")) -((user 1 "USER tester 0 * :tester") +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester") (0.0 ":irc.foonet.org NOTICE * :*** Looking up your hostname...") (0.0 ":irc.foonet.org NOTICE * :*** Found your hostname") (0.0 ":irc.foonet.org CAP * ACK :cap-notify sasl")) -((authenticate-plain 3.2 "AUTHENTICATE PLAIN") +((authenticate-plain 10 "AUTHENTICATE PLAIN") (0.0 ":irc.foonet.org AUTHENTICATE +")) -((authenticate-gimme 3.2 "AUTHENTICATE AHRlc3RlcgB3cm9uZw==") +((authenticate-gimme 10 "AUTHENTICATE AHRlc3RlcgB3cm9uZw==") (0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester") (0.0 ":irc.foonet.org 904 * :SASL authentication failed: Invalid account credentials")) -((cap-end 3.2 "CAP END")) +((eof 10 EOF)) diff --git a/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld new file mode 100644 index 00000000000..6ed8981be0f --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld @@ -0,0 +1,39 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 10 "NICK emersion")) +((user 10 "USER emersion 0 * :emersion") + (0.0 ":irc.example.org NOTICE * :*** Looking up your hostname...") + (0.0 ":irc.example.org NOTICE * :*** Found your hostname") + (0.0 ":irc.example.org CAP * ACK :sasl")) + +((authenticate-plain 10 "AUTHENTICATE PLAIN") + (0.0 ":irc.example.org AUTHENTICATE +")) +((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2Jpcw==")) +((authenticate-gimme-2 10 "AUTHENTICATE +") + (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 10 "CAP END") + (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion") + (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1") + (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 emersion AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.0 ":irc.example.org 005 emersion MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server") + (0.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online") + (0.0 ":irc.example.org 253 emersion 0 :unregistered connections") + (0.0 ":irc.example.org 254 emersion 0 :channels formed") + (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1") + (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 emersion :MOTD File is missing")) + +((mode-user 10 "MODE emersion +i") + (0.0 ":irc.example.org 221 emersion +Zi") + (0.0 ":irc.example.org NOTICE emersion :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.")) + +((quit 5 "QUIT :\2ERC\2") + (0 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit")) +((drop 1 DROP)) diff --git a/test/lisp/erc/resources/sasl/plain-overlong-split.eld b/test/lisp/erc/resources/sasl/plain-overlong-split.eld new file mode 100644 index 00000000000..3e6870790f3 --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain-overlong-split.eld @@ -0,0 +1,39 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 10 "NICK emersion")) +((user 10 "USER emersion 0 * :emersion") + (0.0 ":irc.example.org NOTICE * :*** Looking up your hostname...") + (0.0 ":irc.example.org NOTICE * :*** Found your hostname") + (0.0 ":irc.example.org CAP * ACK :sasl")) + +((authenticate-plain 10 "AUTHENTICATE PLAIN") + (0.0 ":irc.example.org AUTHENTICATE +")) +((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2JpcyBz")) +((authenticate-gimme-2 10 "AUTHENTICATE dW50IGF1dCB1dC4gRG9sb3JlcyB1dCBsYXVkYW50aXVtIG1haW9yZXMgdGVtcG9yaWJ1cyB2b2x1cHRhdGVzLiBSZWljaWVuZGlzIGltcGVkaXQgb21uaXMgZXQgdW5kZSBkZWxlY3R1cyBxdWFzIGFiLiBRdWFlIGVsaWdlbmRpIG5lY2Vzc2l0YXRpYnVzIGRvbG9yaWJ1cyBtb2xlc3RpYXMgdGVtcG9yYSBtYWduYW0gYXNzdW1lbmRhLg==") + (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 10 "CAP END") + (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion") + (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1") + (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 emersion AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.0 ":irc.example.org 005 emersion MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server") + (0.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online") + (0.0 ":irc.example.org 253 emersion 0 :unregistered connections") + (0.0 ":irc.example.org 254 emersion 0 :channels formed") + (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1") + (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 emersion :MOTD File is missing")) + +((mode-user 10 "MODE emersion +i") + (0.0 ":irc.example.org 221 emersion +Zi") + (0.0 ":irc.example.org NOTICE emersion :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.")) + +((quit 5 "QUIT :\2ERC\2") + (0 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit")) +((drop 1 DROP)) diff --git a/test/lisp/erc/resources/sasl/scram-sha-1.eld b/test/lisp/erc/resources/sasl/scram-sha-1.eld index 49980e9e12a..d6adf529c5d 100644 --- a/test/lisp/erc/resources/sasl/scram-sha-1.eld +++ b/test/lisp/erc/resources/sasl/scram-sha-1.eld @@ -42,6 +42,6 @@ (0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~") (0 ":jaguar.test 376 jilles :End of message of the day.")) -((mode-user 1.2 "MODE jilles +i") +((mode-user 10 "MODE jilles +i") (0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri") (0 ":jaguar.test 306 jilles :You have been marked as being away")) diff --git a/test/lisp/erc/resources/sasl/scram-sha-256.eld b/test/lisp/erc/resources/sasl/scram-sha-256.eld index 74de9a23ecf..8b16f7109cf 100644 --- a/test/lisp/erc/resources/sasl/scram-sha-256.eld +++ b/test/lisp/erc/resources/sasl/scram-sha-256.eld @@ -42,6 +42,6 @@ (0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~") (0 ":jaguar.test 376 jilles :End of message of the day.")) -((mode-user 1.2 "MODE jilles +i") +((mode-user 10 "MODE jilles +i") (0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri") (0 ":jaguar.test 306 jilles :You have been marked as being away")) diff --git a/test/lisp/erc/resources/scrolltobottom/help.eld b/test/lisp/erc/resources/scrolltobottom/help.eld new file mode 100644 index 00000000000..ba44a0def39 --- /dev/null +++ b/test/lisp/erc/resources/scrolltobottom/help.eld @@ -0,0 +1,46 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Mon, 21 Aug 2023 06:18:36 UTC") + (0.02 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :are supported by this server") + (0.01 ":irc.foonet.org 251 tester :There are 0 users and 4 invisible on 1 server(s)") + (0.01 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.01 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.01 ":irc.foonet.org 254 tester 2 :channels formed") + (0.01 ":irc.foonet.org 255 tester :I have 4 clients and 0 servers") + (0.01 ":irc.foonet.org 265 tester 4 4 :Current local users 4, max 4") + (0.01 ":irc.foonet.org 266 tester 4 4 :Current global users 4, max 4") + (0.01 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode 10 "MODE tester +i") + (0.00 ":irc.foonet.org 221 tester +i") + (0.01 ":irc.foonet.org NOTICE tester :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.") + (0.02 ":irc.foonet.org 221 tester +i")) + +((privmsg-help-register 10 "PRIVMSG NickServ :help register") + (0.05 ":NickServ!NickServ@localhost NOTICE tester :*** \2NickServ HELP\2 ***") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :Syntax: \2REGISTER <password> [email]\2") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :") + (0.01 ":NickServ!NickServ@localhost NOTICE tester :REGISTER lets you register your current nickname as a user account. If the") + (0.01 ":NickServ!NickServ@localhost NOTICE tester :server allows anonymous registration, you can omit the e-mail address.") + (0.01 ":NickServ!NickServ@localhost NOTICE tester :") + (0.01 ":NickServ!NickServ@localhost NOTICE tester :If you are currently logged in with a TLS client certificate and wish to use") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :it instead of a password to log in, send * as the password.") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :*** \2End of NickServ HELP\2 ***")) + +((privmsg-help-identify 20 "PRIVMSG NickServ :help identify") + (0.06 ":NickServ!NickServ@localhost NOTICE tester :*** \2NickServ HELP\2 ***") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :Syntax: \2IDENTIFY <username> [password]\2") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :IDENTIFY lets you login to the given username using either password auth, or") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :certfp (your client certificate) if a password is not given.") + (0.02 ":NickServ!NickServ@localhost NOTICE tester :*** \2End of NickServ HELP\2 ***")) + +((quit 10 "QUIT :\2ERC\2 ") + (0.07 ":tester!~u@26axz8nh8zaag.irc QUIT :Quit: \2ERC\2") + (0.02 "ERROR :Quit: \2ERC\2")) diff --git a/test/lisp/erc/resources/services/auth-source/libera.eld b/test/lisp/erc/resources/services/auth-source/libera.eld index c8dbc9d425a..dfc25221508 100644 --- a/test/lisp/erc/resources/services/auth-source/libera.eld +++ b/test/lisp/erc/resources/services/auth-source/libera.eld @@ -1,6 +1,6 @@ ;; -*- mode: lisp-data; -*- -((nick 1 "NICK tester")) -((user 1 "USER user 0 * :tester") +((nick 10 "NICK tester")) +((user 5 "USER user 0 * :tester") (0.26 ":zirconium.libera.chat NOTICE * :*** Checking Ident") (0.01 ":zirconium.libera.chat NOTICE * :*** Looking up your hostname...") (0.01 ":zirconium.libera.chat NOTICE * :*** No Ident response") @@ -35,15 +35,15 @@ (0.01 ":zirconium.libera.chat 372 tester :- Email: support@libera.chat") (0.00 ":zirconium.libera.chat 376 tester :End of /MOTD command.")) -((mode-user 1.2 "MODE tester +i") +((mode-user 10 "MODE tester +i") (0.02 ":tester MODE tester :+Zi") (0.02 ":NickServ!NickServ@services.libera.chat NOTICE tester :This nickname is registered. Please choose a different nickname, or identify via \2/msg NickServ IDENTIFY tester <password>\2")) -((privmsg 2 "PRIVMSG NickServ :IDENTIFY changeme") +((privmsg 10 "PRIVMSG NickServ :IDENTIFY changeme") (0.96 ":NickServ!NickServ@services.libera.chat NOTICE tester :You are now identified for \2tester\2.") (0.25 ":NickServ!NickServ@services.libera.chat NOTICE tester :Last login from: \2~tester@school.edu/tester\2 on Jun 18 01:15:56 2021 +0000.")) -((quit 5 "QUIT :\2ERC\2") +((quit 10 "QUIT :\2ERC\2") (0.19 ":tester!~user@static-198-54-131-100.cust.tzulo.com QUIT :Client Quit")) ((linger 1 LINGER)) diff --git a/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld b/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld new file mode 100644 index 00000000000..c0529052c70 --- /dev/null +++ b/test/lisp/erc/resources/services/regain/reconnect-retry-again.eld @@ -0,0 +1,56 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl")) +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester")) + +((authenticate 10 "AUTHENTICATE PLAIN") + (0.04 ":tantalum.libera.chat NOTICE * :*** Checking Ident") + (0.01 ":tantalum.libera.chat NOTICE * :*** Looking up your hostname...") + (0.01 ":tantalum.libera.chat NOTICE * :*** Couldn't look up your hostname") + (0.06 ":tantalum.libera.chat NOTICE * :*** No Ident response") + (0.02 ":tantalum.libera.chat CAP * ACK :sasl") + (0.03 ":tantalum.libera.chat 433 * tester :Nickname is already in use.")) + +((nick 10 "NICK tester`") + (0.03 "AUTHENTICATE +")) + +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.06 ":tantalum.libera.chat 900 tester` tester`!tester@127.0.0.1 tester :You are now logged in as tester") + (0.02 ":tantalum.libera.chat 903 tester` :SASL authentication successful")) + +((cap 10 "CAP END") + (0.02 ":tantalum.libera.chat 001 tester` :Welcome to the Libera.Chat Internet Relay Chat Network tester`") + (0.02 ":tantalum.libera.chat 002 tester` :Your host is tantalum.libera.chat[93.158.237.2/6697], running version solanum-1.0-dev") + (0.02 ":tantalum.libera.chat 003 tester` :This server was created Mon Feb 13 2023 at 12:05:04 UTC") + (0.01 ":tantalum.libera.chat 004 tester` tantalum.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI") + (0.01 ":tantalum.libera.chat 005 tester` WHOX MONITOR=100 SAFELIST ELIST=CMNTU ETRACE FNC CALLERID=g KNOCK CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server") + (0.01 ":tantalum.libera.chat 005 tester` CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server") + (0.03 ":tantalum.libera.chat 005 tester` TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server") + (0.01 ":tantalum.libera.chat 251 tester` :There are 70 users and 42977 invisible on 28 servers") + (0.00 ":tantalum.libera.chat 252 tester` 38 :IRC Operators online") + (0.00 ":tantalum.libera.chat 253 tester` 87 :unknown connection(s)") + (0.00 ":tantalum.libera.chat 254 tester` 22908 :channels formed") + (0.00 ":tantalum.libera.chat 255 tester` :I have 2507 clients and 1 servers") + (0.00 ":tantalum.libera.chat 265 tester` 2507 3232 :Current local users 2507, max 3232") + (0.00 ":tantalum.libera.chat 266 tester` 43047 51777 :Current global users 43047, max 51777") + (0.00 ":tantalum.libera.chat 250 tester` :Highest connection count: 3233 (3232 clients) (284887 connections received)") + (0.03 ":tantalum.libera.chat 375 tester` :- tantalum.libera.chat Message of the Day - ") + (0.00 ":tantalum.libera.chat 372 tester` :- This server provided by Hyperfilter (https://hyperfilter.com)") + (0.00 ":tantalum.libera.chat 372 tester` :- Email: support@libera.chat") + (0.02 ":tantalum.libera.chat 376 tester` :End of /MOTD command.")) + +((mode 10 "MODE tester` +i") + (0.01 ":tester` MODE tester` :+Ziw") + (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester` :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:36:25 2023 +0000.")) + +((nick 10 "NICK tester") + (0.02 ":tester`!~tester@127.0.0.1 NICK :tester")) + +((join 10 "JOIN #test") + (0.02 ":tester!~tester@127.0.0.1 JOIN #test") + (0.02 ":tantalum.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc jvyyr wrnaogeq Wnarg cnefavc0 Xbentt RcvpArb flfqrs wfgbxre hafcrag__ Lbevpx_") + (0.02 ":tantalum.libera.chat 366 tester #test :End of /NAMES list.")) + +((mode 10 "MODE #test") + (0.02 ":tantalum.libera.chat 324 tester #test +nt") + (0.02 ":tantalum.libera.chat 329 tester #test 1621432263")) diff --git a/test/lisp/erc/resources/services/regain/reconnect-retry.eld b/test/lisp/erc/resources/services/regain/reconnect-retry.eld new file mode 100644 index 00000000000..9f4df70e580 --- /dev/null +++ b/test/lisp/erc/resources/services/regain/reconnect-retry.eld @@ -0,0 +1,53 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl")) +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester")) + +((authenticate 10 "AUTHENTICATE PLAIN") + (0.02 ":cadmium.libera.chat NOTICE * :*** Checking Ident") + (0.01 ":cadmium.libera.chat NOTICE * :*** Looking up your hostname...") + (0.01 ":cadmium.libera.chat NOTICE * :*** Couldn't look up your hostname") + (0.06 ":cadmium.libera.chat NOTICE * :*** No Ident response") + (0.09 ":cadmium.libera.chat CAP * ACK :sasl") + (0.01 "AUTHENTICATE +")) + +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.03 ":cadmium.libera.chat 900 tester tester!tester@127.0.0.1 tester :You are now logged in as tester") + (0.01 ":cadmium.libera.chat 903 tester :SASL authentication successful")) + +((cap 10 "CAP END") + (0.03 ":cadmium.libera.chat 001 tester :Welcome to the Libera.Chat Internet Relay Chat Network tester") + (0.02 ":cadmium.libera.chat 002 tester :Your host is cadmium.libera.chat[103.196.37.95/6697], running version solanum-1.0-dev") + (0.01 ":cadmium.libera.chat 003 tester :This server was created Wed Jan 25 2023 at 10:22:45 UTC") + (0.01 ":cadmium.libera.chat 004 tester cadmium.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI") + (0.00 ":cadmium.libera.chat 005 tester CALLERID=g WHOX ETRACE FNC SAFELIST ELIST=CMNTU KNOCK MONITOR=100 CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server") + (0.01 ":cadmium.libera.chat 251 tester :There are 70 users and 42996 invisible on 28 servers") + (0.02 ":cadmium.libera.chat 252 tester 38 :IRC Operators online") + (0.01 ":cadmium.libera.chat 253 tester 57 :unknown connection(s)") + (0.01 ":cadmium.libera.chat 254 tester 22912 :channels formed") + (0.01 ":cadmium.libera.chat 255 tester :I have 2499 clients and 1 servers") + (0.01 ":cadmium.libera.chat 265 tester 2499 4187 :Current local users 2499, max 4187") + (0.01 ":cadmium.libera.chat 266 tester 43066 51827 :Current global users 43066, max 51827") + (0.01 ":cadmium.libera.chat 250 tester :Highest connection count: 4188 (4187 clients) (319420 connections received)") + (0.01 ":cadmium.libera.chat 375 tester :- cadmium.libera.chat Message of the Day - ") + (0.01 ":cadmium.libera.chat 372 tester :- This server kindly provided by Mach Dilemma (www.m-d.net)") + (0.01 ":cadmium.libera.chat 372 tester :- Welcome to Libera Chat, the IRC network for") + (0.00 ":cadmium.libera.chat 372 tester :- Email: support@libera.chat") + (0.00 ":cadmium.libera.chat 376 tester :End of /MOTD command.") + (0.00 ":tester MODE tester :+Ziw") + (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:02:11 2023 +0000.")) + +((mode 10 "MODE tester +i")) + +((join 10 "JOIN #test") + (0.09 ":tester!~tester@127.0.0.1 JOIN #test")) + +((mode 10 "MODE #test") + (0.03 ":cadmium.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc Lbevpx_ hafcrag__ wfgbxre flfqrs RcvpArb Xbentt jvyyr cnefavc0 Wnarg wrnaogeq") + (0.02 ":cadmium.libera.chat 366 tester #test :End of /NAMES list.") + (0.00 ":cadmium.libera.chat 324 tester #test +nt") + (0.01 ":cadmium.libera.chat 329 tester #test 1621432263")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/services/regain/taken-ghost.eld b/test/lisp/erc/resources/services/regain/taken-ghost.eld new file mode 100644 index 00000000000..d5afd124a43 --- /dev/null +++ b/test/lisp/erc/resources/services/regain/taken-ghost.eld @@ -0,0 +1,42 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl") + (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...") + (0.01 ":irc.example.net NOTICE * :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead.")) +((nick 10 "NICK dummy")) +((user 10 "USER dummy 0 * :tester")) +((authenticate 10 "AUTHENTICATE PLAIN") + (0.00 ":irc.example.net CAP * ACK :sasl") + (0.03 ":irc.example.net 433 * dummy :Nickname is already in use.") + (0.04 "AUTHENTICATE :+")) +((nick 10 "NICK dummy`") + (0.00 "PING :orrMOjk^|V")) +((~pong 10 "PONG :orrMOjk^|V")) +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.01 ":irc.example.net 900 dummy` dummy`!dummy@10.0.2.100 tester :You are now logged in as tester") + (0.01 ":irc.example.net 903 dummy` :SASL authentication successful")) +((cap 10 "CAP END") + (0.00 ":irc.example.net 001 dummy` :Welcome to the FooNet IRC Network dummy`!dummy@10.0.2.100") + (0.03 ":irc.example.net 002 dummy` :Your host is irc.example.net, running version InspIRCd-3") + (0.01 ":irc.example.net 003 dummy` :This server was created 13:01:55 Jun 08 2023") + (0.01 ":irc.example.net 004 dummy` irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTXabcefghijklmnopqrstvz :HIXabefghjkloqv") + (0.00 ":irc.example.net 005 dummy` ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server") + (0.01 ":irc.example.net 005 dummy` EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=FooNet :are supported by this server") + (0.01 ":irc.example.net 005 dummy` NICKLEN=30 PREFIX=(qaohv)~&@%+ SAFELIST SILENCE=32 STATUSMSG=~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server") + (0.01 ":irc.example.net 251 dummy` :There are 2 users and 1 invisible on 2 servers") + (0.01 ":irc.example.net 253 dummy` 1 :unknown connections") + (0.00 ":irc.example.net 254 dummy` 1 :channels formed") + (0.00 ":irc.example.net 255 dummy` :I have 3 clients and 1 servers") + (0.00 ":irc.example.net 265 dummy` :Current local users: 3 Max: 4") + (0.00 ":irc.example.net 266 dummy` :Current global users: 3 Max: 4") + (0.00 ":irc.example.net 375 dummy` :irc.example.net message of the day") + (0.00 ":irc.example.net 372 dummy` : Have fun with the image!") + (0.00 ":irc.example.net 376 dummy` :End of message of the day.")) + +((mode 10 "MODE dummy` +i")) +((privmsg 10 "PRIVMSG NickServ :GHOST dummy") + (0.00 ":irc.example.net 501 dummy` x :is not a recognised user mode.") + (0.00 ":irc.example.net NOTICE dummy` :*** You are connected to irc.example.net using TLS (SSL) cipher 'TLS1.3-ECDHE-RSA-AES-256-GCM-AEAD'") + (0.03 ":dummy`!dummy@10.0.2.100 MODE dummy` :+i") + (0.02 ":NickServ!NickServ@services.int NOTICE dummy` :\2dummy\2 has been ghosted.")) +((nick 10 "NICK dummy") + (0.02 ":dummy`!dummy@10.0.2.100 NICK :dummy")) diff --git a/test/lisp/erc/resources/services/regain/taken-regain.eld b/test/lisp/erc/resources/services/regain/taken-regain.eld new file mode 100644 index 00000000000..22635d4cc89 --- /dev/null +++ b/test/lisp/erc/resources/services/regain/taken-regain.eld @@ -0,0 +1,42 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl") + (0.00 ":irc.example.net NOTICE * :*** Looking up your hostname...") + (0.01 ":irc.example.net NOTICE * :*** Could not resolve your hostname: Domain not found; using your IP address (10.0.2.100) instead.")) +((nick 10 "NICK dummy")) +((user 10 "USER dummy 0 * :tester")) +;; This also happens to a test late ACK (see ghost variant for server-sent PING) +((authenticate 10 "AUTHENTICATE PLAIN") + (0.00 ":irc.example.net CAP * ACK :sasl") + (0.09 ":irc.example.net 433 * dummy :Nickname is already in use.") + (0.04 "AUTHENTICATE :+")) +((nick 10 "NICK dummy`")) +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.00 ":irc.example.net 900 dummy` dummy`!dummy@10.0.2.100 tester :You are now logged in as tester") + (0.01 ":irc.example.net 903 dummy` :SASL authentication successful")) + +((cap 10 "CAP END") + (0.00 ":irc.example.net 001 dummy` :Welcome to the FooNet IRC Network dummy`!dummy@10.0.2.100") + (0.02 ":irc.example.net 002 dummy` :Your host is irc.example.net, running version InspIRCd-3") + (0.02 ":irc.example.net 003 dummy` :This server was created 08:16:52 Jun 08 2023") + (0.01 ":irc.example.net 004 dummy` irc.example.net InspIRCd-3 BIRcgikorsw ACHIKMORTXabcefghijklmnopqrstvz :HIXabefghjkloqv") + (0.00 ":irc.example.net 005 dummy` ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=ascii CHANLIMIT=#:20 CHANMODES=IXbeg,k,Hfjl,ACKMORTcimnprstz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server") + (0.01 ":irc.example.net 005 dummy` EXTBAN=,ACORTUacjrwz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=FooNet :are supported by this server") + (0.01 ":irc.example.net 005 dummy` NICKLEN=30 PREFIX=(qaohv)~&@%+ SAFELIST SILENCE=32 STATUSMSG=~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=10 USERMODES=,,s,BIRcgikorw WHOX :are supported by this server") + (0.01 ":irc.example.net 251 dummy` :There are 2 users and 1 invisible on 2 servers") + (0.01 ":irc.example.net 253 dummy` 1 :unknown connections") + (0.00 ":irc.example.net 254 dummy` 1 :channels formed") + (0.02 ":irc.example.net 255 dummy` :I have 3 clients and 1 servers") + (0.00 ":irc.example.net 265 dummy` :Current local users: 3 Max: 4") + (0.00 ":irc.example.net 266 dummy` :Current global users: 3 Max: 4") + (0.00 ":irc.example.net 375 dummy` :irc.example.net message of the day") + (0.00 ":irc.example.net 372 dummy` : Have fun with the image!") + (0.00 ":irc.example.net 376 dummy` :End of message of the day.") + (0.00 ":irc.example.net 501 dummy` x :is not a recognised user mode.") + (0.00 ":irc.example.net NOTICE dummy` :*** You are connected to irc.example.net using TLS (SSL) cipher 'TLS1.3-ECDHE-RSA-AES-256-GCM-AEAD'")) + +((mode 10 "MODE dummy` +i")) + +((privmsg 10 "PRIVMSG NickServ :REGAIN dummy") + (0.00 ":dummy`!dummy@10.0.2.100 MODE dummy` :+i") + (0.02 ":NickServ!NickServ@services.int NOTICE dummy` :\2dummy\2 has been regained.") + (0.02 ":dummy`!dummy@10.0.2.100 NICK :dummy")) diff --git a/test/lisp/eshell/em-alias-tests.el b/test/lisp/eshell/em-alias-tests.el index 273e19d580b..ec1704545a4 100644 --- a/test/lisp/eshell/em-alias-tests.el +++ b/test/lisp/eshell/em-alias-tests.el @@ -72,6 +72,15 @@ (eshell-match-command-output "show-all-args a" "a\n") (eshell-match-command-output "show-all-args a b c" "a\nb\nc\n"))) +(ert-deftest em-alias-test/alias-all-args-var-splice () + "Test alias with splicing the $* variable" + (with-temp-eshell + (eshell-insert-command "alias show-all-args 'echo args: $@*'") + (eshell-match-command-output "show-all-args" "args:\n") + (eshell-match-command-output "show-all-args a" "(\"args:\" \"a\")\n") + (eshell-match-command-output "show-all-args a b c" + "(\"args:\" \"a\" \"b\" \"c\")\n"))) + (ert-deftest em-alias-test/alias-all-args-var-indices () "Test alias with the $* variable using indices" (with-temp-eshell diff --git a/test/lisp/eshell/em-cmpl-tests.el b/test/lisp/eshell/em-cmpl-tests.el new file mode 100644 index 00000000000..dd3c338ac54 --- /dev/null +++ b/test/lisp/eshell/em-cmpl-tests.el @@ -0,0 +1,380 @@ +;;; em-cmpl-tests.el --- em-cmpl test suite -*- 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: + +;; Tests for Eshell's interactive completion. + +;;; Code: + +(require 'ert) +(require 'eshell) +(require 'em-cmpl) +(require 'em-dirs) +(require 'em-hist) +(require 'em-tramp) +(require 'em-unix) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +(defvar eshell-test-value nil) + +(defun eshell-insert-and-complete (input) + "Insert INPUT and invoke completion, returning the result." + (insert input) + (completion-at-point) + (eshell-get-old-input)) + +(defun eshell-arguments-equal (actual expected) + "Return t if ACTUAL and EXPECTED are equal, including properties of strings. +ACTUAL and EXPECTED should both be lists of strings." + (when (length= actual (length expected)) + (catch 'not-equal + (cl-mapc (lambda (i j) + (unless (equal-including-properties i j) + (throw 'not-equal nil))) + actual expected) + t))) + +(defun eshell-arguments-equal--equal-explainer (actual expected) + "Explain the result of `eshell-arguments-equal'." + `(nonequal-result + (actual ,actual) + (expected ,expected))) + +(put 'eshell-arguments-equal 'ert-explainer + #'eshell-arguments-equal--equal-explainer) + +;;; Tests: + +(ert-deftest em-cmpl-test/parse-arguments/pipeline () + "Test that parsing arguments for completion discards earlier commands." + (with-temp-eshell + (insert "echo hi | cat") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + '("cat"))))) + +(ert-deftest em-cmpl-test/parse-arguments/multiple-dots () + "Test parsing arguments with multiple dots like \".../\"." + (with-temp-eshell + (insert "echo .../file.txt") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize "../../file.txt" + 'pcomplete-arg-value + ".../file.txt")))))) + +(ert-deftest em-cmpl-test/parse-arguments/variable/numeric () + "Test parsing arguments with a numeric variable interpolation." + (with-temp-eshell + (let ((eshell-test-value 42)) + (insert "echo $eshell-test-value") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize "42" 'pcomplete-arg-value 42))))))) + +(ert-deftest em-cmpl-test/parse-arguments/variable/nil () + "Test parsing arguments with a nil variable interpolation." + (with-temp-eshell + (let ((eshell-test-value nil)) + (insert "echo $eshell-test-value") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize "" 'pcomplete-arg-value nil))))))) + +(ert-deftest em-cmpl-test/parse-arguments/variable/list () + "Test parsing arguments with a list variable interpolation." + (with-temp-eshell + (let ((eshell-test-value '("foo" "bar"))) + (insert "echo $eshell-test-value") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize "(\"foo\" \"bar\")" + 'pcomplete-arg-value + eshell-test-value))))))) + +(ert-deftest em-cmpl-test/parse-arguments/variable/splice () + "Test parsing arguments with a spliced variable interpolation." + (with-temp-eshell + (let ((eshell-test-value '("foo" "bar"))) + (insert "echo $@eshell-test-value") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + '("echo" "foo" "bar")))))) + +(ert-deftest em-cmpl-test/parse-arguments/unevaluated-subcommand () + "Test that subcommands return a stub when parsing for completion." + (with-temp-eshell + (insert "echo {echo hi}") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize + "\0" 'eshell-argument-stub 'named-command))))) + (with-temp-eshell + (insert "echo ${echo hi}") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize + "\0" 'eshell-argument-stub 'named-command)))))) + +(ert-deftest em-cmpl-test/parse-arguments/unevaluated-lisp-form () + "Test that Lisp forms return a stub when parsing for completion." + (with-temp-eshell + (insert "echo (concat \"hi\")") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize + "\0" 'eshell-argument-stub 'lisp-command))))) + (with-temp-eshell + (insert "echo $(concat \"hi\")") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize + "\0" 'eshell-argument-stub 'lisp-command)))))) + +(ert-deftest em-cmpl-test/parse-arguments/unevaluated-inner-subcommand () + "Test that nested subcommands return a stub when parsing for completion." + (with-temp-eshell + (insert "echo $exec-path[${echo 0}]") + (should (eshell-arguments-equal + (car (eshell-complete-parse-arguments)) + `("echo" ,(propertize + "\0" 'eshell-argument-stub 'named-command)))))) + +(ert-deftest em-cmpl-test/file-completion/unique () + "Test completion of file names when there's a unique result." + (with-temp-eshell + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (should (equal (eshell-insert-and-complete "echo fi") + "echo file.txt "))))) + +(ert-deftest em-cmpl-test/file-completion/non-unique () + "Test completion of file names when there are multiple results." + (with-temp-eshell + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (write-region nil nil (expand-file-name "file.el")) + (should (equal (eshell-insert-and-complete "echo fi") + "echo file.")) + ;; Now try completing again. + (let ((minibuffer-message-timeout 0) + (inhibit-message t)) + (completion-at-point)) + ;; FIXME: We can't use `current-message' here. + (with-current-buffer (messages-buffer) + (save-excursion + (goto-char (point-max)) + (forward-line -1) + (should (looking-at "Complete, but not unique"))))))) + +(ert-deftest em-cmpl-test/file-completion/glob () + "Test completion of file names using a glob." + (with-temp-eshell + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (write-region nil nil (expand-file-name "file.el")) + (should (equal (eshell-insert-and-complete "echo fi*.el") + "echo file.el "))))) + +(ert-deftest em-cmpl-test/file-completion/after-list () + "Test completion of file names after previous list arguments. +See bug#59956." + (with-temp-eshell + (let ((eshell-test-value '("foo" "bar"))) + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (should (equal (eshell-insert-and-complete "echo $eshell-test-value fi") + "echo $eshell-test-value file.txt ")))))) + +(ert-deftest em-cmpl-test/command-completion () + "Test completion of command names like \"command\"." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "listif") + "listify ")))) + +(ert-deftest em-cmpl-test/subcommand-completion () + "Test completion of command names like \"{command}\"." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "{ listif") + "{ listify "))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo ${ listif") + "echo ${ listify ")))) + +(ert-deftest em-cmpl-test/lisp-symbol-completion () + "Test completion of Lisp forms like \"#'symbol\" and \"`symbol\". +See <lisp/eshell/esh-cmd.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo #'system-nam") + "echo #'system-name "))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo `system-nam") + "echo `system-name ")))) + +(ert-deftest em-cmpl-test/lisp-function-completion () + "Test completion of Lisp forms like \"(func)\". +See <lisp/eshell/esh-cmd.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo (eshell/ech") + "echo (eshell/echo"))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $(eshell/ech") + "echo $(eshell/echo")))) + +(ert-deftest em-cmpl-test/special-ref-completion/type () + "Test completion of the start of special reference types like \"#<buffer\". +See <lisp/eshell/esh-arg.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<buf") + "echo hi > #<buffer "))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<proc") + "echo hi > #<process "))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<mark") + "echo hi > #<marker ")))) + +(ert-deftest em-cmpl-test/special-ref-completion/implicit-buffer () + "Test completion of special references like \"#<buf>\". +See <lisp/eshell/esh-arg.el>." + (let (bufname) + (with-temp-buffer + (setq bufname (rename-buffer "my-buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<my-buf") + (format "echo hi > #<%s> " bufname)))) + (setq bufname (rename-buffer "another buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<anoth") + (format "echo hi > #<%s> " + (string-replace " " "\\ " bufname)))))))) + +(ert-deftest em-cmpl-test/special-ref-completion/buffer () + "Test completion of special references like \"#<buffer buf>\". +See <lisp/eshell/esh-arg.el>." + (let (bufname) + (with-temp-buffer + (setq bufname (rename-buffer "my-buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<buffer my-buf") + (format "echo hi > #<buffer %s> " bufname)))) + (setq bufname (rename-buffer "another buffer" t)) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo hi > #<buffer anoth") + (format "echo hi > #<buffer %s> " + (string-replace " " "\\ " bufname)))))))) + +(ert-deftest em-cmpl-test/special-ref-completion/marker () + "Test completion of special references like \"#<marker 1 buf>\". +See <lisp/eshell/esh-arg.el>." + (let (bufname) + (with-temp-buffer + (setq bufname (rename-buffer "my-buffer" t)) + ;; Complete the buffer name in various forms. + (with-temp-eshell + (should (equal (eshell-insert-and-complete + "echo hi > #<marker 1 my-buf") + (format "echo hi > #<marker 1 %s> " bufname)))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete + "echo hi > #<marker 1 #<my-buf") + (format "echo hi > #<marker 1 #<%s>> " bufname)))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete + "echo hi > #<marker 1 #<buffer my-buf") + (format "echo hi > #<marker 1 #<buffer %s>> " bufname)))) + ;; Partially-complete the "buffer" type name. + (with-temp-eshell + (should (equal (eshell-insert-and-complete + "echo hi > #<marker 1 #<buf") + "echo hi > #<marker 1 #<buffer ")))))) + +(ert-deftest em-cmpl-test/variable-ref-completion () + "Test completion of variable references like \"$var\". +See <lisp/eshell/esh-var.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $system-nam") + "echo $system-name ")))) + +(ert-deftest em-cmpl-test/quoted-variable-ref-completion () + "Test completion of variable references like \"$'var'\". +See <lisp/eshell/esh-var.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $'system-nam") + "echo $'system-name' "))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $\"system-nam") + "echo $\"system-name\" ")))) + +(ert-deftest em-cmpl-test/variable-ref-completion/directory () + "Test completion of variable references that expand to directories. +See <lisp/eshell/esh-var.el>." + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $PW") + "echo $PWD/"))) + (with-temp-eshell + (let ((minibuffer-message-timeout 0) + (inhibit-message t)) + (should (equal (eshell-insert-and-complete "echo $PWD") + "echo $PWD/")))) + (with-temp-eshell + (should (equal (eshell-insert-and-complete "echo $'PW") + "echo $'PWD'/")))) + +(ert-deftest em-cmpl-test/variable-assign-completion () + "Test completion of variable assignments like \"var=value\". +See <lisp/eshell/esh-var.el>." + (with-temp-eshell + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (should (equal (eshell-insert-and-complete "VAR=f") + "VAR=file.txt "))))) + +(ert-deftest em-cmpl-test/variable-assign-completion/non-assignment () + "Test completion of things that look like variable assignment, but aren't. +For example, the second argument in \"tar --directory=dir\" looks +like it could be a variable assignment, but it's not. We should +let `pcomplete/tar' handle it instead. + +See <lisp/eshell/esh-var.el>." + (with-temp-eshell + (ert-with-temp-directory default-directory + (write-region nil nil (expand-file-name "file.txt")) + (make-directory "dir") + (should (equal (eshell-insert-and-complete "tar --directory=") + "tar --directory=dir/"))))) + +(ert-deftest em-cmpl-test/user-ref-completion () + "Test completion of user references like \"~user\". +See <lisp/eshell/em-dirs.el>." + (unwind-protect + (with-temp-eshell + (cl-letf (((symbol-function 'eshell-read-user-names) + (lambda () (setq eshell-user-names '((1234 . "user")))))) + (should (equal (eshell-insert-and-complete "echo ~us") + "echo ~user/")))) + ;; Clear the cached user names we set above. + (setq eshell-user-names nil))) + +;;; em-cmpl-tests.el ends here diff --git a/test/lisp/eshell/em-dirs-tests.el b/test/lisp/eshell/em-dirs-tests.el index d30b3d7d73f..9864b72ba78 100644 --- a/test/lisp/eshell/em-dirs-tests.el +++ b/test/lisp/eshell/em-dirs-tests.el @@ -99,4 +99,27 @@ (eshell-match-command-output "echo $-[1][/ 1 3]" "(\"some\" \"here\")\n")))) +(ert-deftest em-dirs-test/cd () + "Test that changing directories with `cd' works." + (ert-with-temp-directory tmpdir + (write-region "text" nil (expand-file-name "file.txt" tmpdir)) + (with-temp-eshell + (eshell-match-command-output (format "cd '%s'" tmpdir) + "\\`\\'") + (should (equal default-directory tmpdir))))) + +(ert-deftest em-dirs-test/cd/list-files-after-cd () + "Test that listing files after `cd' works." + (let ((eshell-list-files-after-cd t)) + (ert-with-temp-directory tmpdir + (write-region "text" nil (expand-file-name "file.txt" tmpdir)) + (with-temp-eshell + (eshell-match-command-output (format "cd '%s'" tmpdir) + "file.txt\n") + (should (equal default-directory tmpdir)) + ;; Make sure we didn't update the last-command information when + ;; running "ls". + (should (equal eshell-last-command-name "#<function eshell/cd>")) + (should (equal eshell-last-arguments (list tmpdir))))))) + ;; em-dirs-tests.el ends here diff --git a/test/lisp/eshell/em-extpipe-tests.el b/test/lisp/eshell/em-extpipe-tests.el index 6d6d4daac9d..6984ec2de59 100644 --- a/test/lisp/eshell/em-extpipe-tests.el +++ b/test/lisp/eshell/em-extpipe-tests.el @@ -42,32 +42,37 @@ (shell-command-switch "-c")) ;; Strip `eshell-trap-errors'. (should (equal ,expected - (cadr (eshell-parse-command input)))))) + (cadadr (eshell-parse-command input)))))) (with-substitute-for-temp (&rest body) ;; Substitute name of an actual temporary file and/or ;; buffer into `input'. The substitution logic is ;; appropriate for only the use we put it to in this file. `(ert-with-temp-file temp - (let ((temp-buffer (generate-new-buffer " *temp*" t))) + (let ((temp-buffer (generate-new-buffer " *tmp*" t))) (unwind-protect (let ((input (replace-regexp-in-string "temp\\([^>]\\|\\'\\)" temp - (string-replace "#<buffer temp>" - (buffer-name temp-buffer) - input)))) + (string-replace + "#<buffer temp>" + (format "#<buffer %s>" + (eshell-quote-argument + (buffer-name temp-buffer))) + input)))) ,@body) (when (buffer-name temp-buffer) (kill-buffer temp-buffer)))))) (temp-should-string= (expected) - `(string= ,expected (string-trim-right - (with-temp-buffer - (insert-file-contents temp) - (buffer-string))))) + `(should (string= ,expected + (string-trim-right + (with-temp-buffer + (insert-file-contents temp) + (buffer-string)))))) (temp-buffer-should-string= (expected) - `(string= ,expected (string-trim-right - (with-current-buffer temp-buffer - (buffer-string)))))) + `(should (string= ,expected + (string-trim-right + (with-current-buffer temp-buffer + (buffer-string))))))) (skip-unless shell-file-name) (skip-unless shell-command-switch) (skip-unless (executable-find shell-file-name)) @@ -107,7 +112,7 @@ '(progn (ignore (eshell-set-output-handle 1 'overwrite - (get-buffer-create "temp"))) + (eshell-get-buffer "temp"))) (eshell-named-command "sh" (list "-c" "echo \"bar\" | rev")))) (with-substitute-for-temp @@ -130,7 +135,7 @@ '(progn (ignore (eshell-set-output-handle 1 'overwrite - (get-buffer-create "quux"))) + (eshell-get-buffer "quux"))) (ignore (eshell-set-output-handle 1 'append (get-process "other"))) diff --git a/test/lisp/eshell/em-glob-tests.el b/test/lisp/eshell/em-glob-tests.el index c33af88a374..6e07225657c 100644 --- a/test/lisp/eshell/em-glob-tests.el +++ b/test/lisp/eshell/em-glob-tests.el @@ -26,6 +26,13 @@ (require 'ert) (require 'em-glob) +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +(defvar eshell-prefer-lisp-functions) + (defmacro with-fake-files (files &rest body) "Evaluate BODY forms, pretending that FILES exist on the filesystem. FILES is a list of file names that should be reported as @@ -54,6 +61,60 @@ component ending in \"symlink\" is treated as a symbolic link." ;;; Tests: +(ert-deftest em-glob-test/expand/splice-results () + "Test that globs are spliced into the argument list when +`eshell-glob-splice-results' is non-nil." + (let ((eshell-prefer-lisp-functions t) + (eshell-glob-splice-results t)) + (with-fake-files '("a.el" "b.el" "c.txt") + ;; Ensure the default expansion splices the glob. + (eshell-command-result-equal "list *.el" '("a.el" "b.el")) + (eshell-command-result-equal "list *.txt" '("c.txt")) + (eshell-command-result-equal "list *.no" '("*.no"))))) + +(ert-deftest em-glob-test/expand/no-splice-results () + "Test that globs are treated as lists when +`eshell-glob-splice-results' is nil." + (let ((eshell-prefer-lisp-functions t) + (eshell-glob-splice-results nil)) + (with-fake-files '("a.el" "b.el" "c.txt") + ;; Ensure the default expansion splices the glob. + (eshell-command-result-equal "list *.el" '(("a.el" "b.el"))) + (eshell-command-result-equal "list *.txt" '(("c.txt"))) + ;; The no-matches case is special here: the glob is just the + ;; string, not the list of results. + (eshell-command-result-equal "list *.no" '("*.no"))))) + +(ert-deftest em-glob-test/expand/explicitly-splice-results () + "Test explicitly splicing globs works the same no matter the +value of `eshell-glob-splice-results'." + (let ((eshell-prefer-lisp-functions t)) + (dolist (eshell-glob-splice-results '(nil t)) + (ert-info ((format "eshell-glob-splice-results: %s" + eshell-glob-splice-results)) + (with-fake-files '("a.el" "b.el" "c.txt") + (eshell-command-result-equal "list $@{listify *.el}" + '("a.el" "b.el")) + (eshell-command-result-equal "list $@{listify *.txt}" + '("c.txt")) + (eshell-command-result-equal "list $@{listify *.no}" + '("*.no"))))))) + +(ert-deftest em-glob-test/expand/explicitly-listify-results () + "Test explicitly listifying globs works the same no matter the +value of `eshell-glob-splice-results'." + (let ((eshell-prefer-lisp-functions t)) + (dolist (eshell-glob-splice-results '(nil t)) + (ert-info ((format "eshell-glob-splice-results: %s" + eshell-glob-splice-results)) + (with-fake-files '("a.el" "b.el" "c.txt") + (eshell-command-result-equal "list ${listify *.el}" + '(("a.el" "b.el"))) + (eshell-command-result-equal "list ${listify *.txt}" + '(("c.txt"))) + (eshell-command-result-equal "list ${listify *.no}" + '(("*.no")))))))) + (ert-deftest em-glob-test/match-any-string () "Test that \"*\" pattern matches any string." (with-fake-files '("a.el" "b.el" "c.txt" "dir/a.el") @@ -191,6 +252,9 @@ component ending in \"symlink\" is treated as a symbolic link." (with-fake-files '("foo.el" "bar.el") (should (equal (eshell-extended-glob "*.txt") "*.txt")) + (let ((eshell-glob-splice-results t)) + (should (equal (eshell-extended-glob "*.txt") + '("*.txt")))) (let ((eshell-error-if-no-glob t)) (should-error (eshell-extended-glob "*.txt"))))) diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index 35ae6bdc239..078bcb490e5 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -19,11 +19,107 @@ ;;; Code: +(eval-when-compile + (require 'cl-lib)) + (require 'ert) (require 'ert-x) (require 'em-hist) +(require 'eshell) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +(cl-defun em-hist-test/check-history-file (file-name expected &optional + (expected-ring t)) + "Check that the contents of FILE-NAME match the EXPECTED history entries. +Additionally, check that after loading the file, the history ring +matches too. If EXPECTED-RING is a list, compare the ring +elements against that; if t (the default), check against EXPECTED." + (when (eq expected-ring t) (setq expected-ring expected)) + ;; First check the actual file. + (should (equal (with-temp-buffer + (insert-file-contents file-name) + (buffer-string)) + (mapconcat (lambda (i) (concat i "\n")) expected))) + ;; Now read the history ring and check that too. + (let (eshell-history-ring eshell-history-index eshell-hist--new-items) + (eshell-read-history file-name) + (should (equal (nreverse (ring-elements eshell-history-ring)) + expected-ring)))) + +;;; Tests: + +(ert-deftest em-hist-test/write-history/append () + "Test appending new history to history file." + (ert-with-temp-file histfile + (with-temp-eshell + (em-hist-test/check-history-file histfile nil) + (eshell-insert-command "echo hi") + (eshell-write-history histfile 'append) + (em-hist-test/check-history-file histfile '("echo hi")) + (eshell-insert-command "echo bye") + (eshell-write-history histfile 'append) + (em-hist-test/check-history-file histfile '("echo hi" "echo bye"))))) + +(ert-deftest em-hist-test/write-history/append-multiple-eshells () + "Test appending new history to history file from multiple Eshells." + (ert-with-temp-file histfile + (with-temp-eshell + (with-temp-eshell + ;; Enter some commands and save them. + (eshell-insert-command "echo foo") + (eshell-insert-command "echo bar") + (eshell-write-history histfile 'append) + (em-hist-test/check-history-file histfile '("echo foo" "echo bar"))) + ;; Now do the same in the first Eshell buffer. + (eshell-insert-command "echo goat") + (eshell-insert-command "echo panda") + (eshell-write-history histfile 'append) + (em-hist-test/check-history-file + histfile '("echo foo" "echo bar" "echo goat" "echo panda"))))) -(ert-deftest eshell-write-readonly-history () +(ert-deftest em-hist-test/write-history/overwrite () + "Test overwriting history file." + (ert-with-temp-file histfile + (with-temp-eshell + (em-hist-test/check-history-file histfile nil) + (eshell-insert-command "echo hi") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo hi") + (eshell-write-history histfile) + (em-hist-test/check-history-file + histfile '("echo hi" "echo bye" "echo bye" "echo hi")) + (let ((eshell-hist-ignoredups t)) + (em-hist-test/check-history-file + histfile '("echo hi" "echo bye" "echo bye" "echo hi") + '("echo hi" "echo bye" "echo hi"))) + (let ((eshell-hist-ignoredups 'erase)) + (em-hist-test/check-history-file + histfile '("echo hi" "echo bye" "echo bye" "echo hi") + '("echo bye" "echo hi")))))) + +(ert-deftest em-hist-test/write-history/overwrite-multiple-shells () + "Test overwriting history file from multiple Eshells." + (ert-with-temp-file histfile + (with-temp-eshell + (with-temp-eshell + ;; Enter some commands and save them. + (eshell-insert-command "echo foo") + (eshell-insert-command "echo bar") + (eshell-write-history histfile) + (em-hist-test/check-history-file histfile '("echo foo" "echo bar"))) + ;; Now do the same in the first Eshell buffer. + (eshell-insert-command "echo goat") + (eshell-insert-command "echo panda") + (eshell-write-history histfile) + (em-hist-test/check-history-file + histfile '("echo goat" "echo panda"))))) + +(ert-deftest em-hist-test/write-history/read-only () "Test that having read-only strings in history is okay." (ert-with-temp-file histfile (let ((eshell-history-ring (make-ring 2))) @@ -31,7 +127,41 @@ (propertize "echo foo" 'read-only t)) (ring-insert eshell-history-ring (propertize "echo bar" 'read-only t)) - (eshell-write-history histfile)))) + (eshell-write-history histfile) + (em-hist-test/check-history-file histfile '("echo foo" "echo bar"))))) + +(ert-deftest em-hist-test/add-to-history/allow-dups () + "Test adding to history, allowing dups." + (let ((eshell-hist-ignoredups nil)) + (with-temp-eshell + (eshell-insert-command "echo hi") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo hi") + (should (equal (ring-elements eshell-history-ring) + '("echo hi" "echo bye" "echo bye" "echo hi")))))) + +(ert-deftest em-hist-test/add-to-history/no-consecutive-dups () + "Test adding to history, ignoring consecutive dups." + (let ((eshell-hist-ignoredups t)) + (with-temp-eshell + (eshell-insert-command "echo hi") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo hi") + (should (equal (ring-elements eshell-history-ring) + '("echo hi" "echo bye" "echo hi")))))) + +(ert-deftest em-hist-test/add-to-history/erase-dups () + "Test adding to history, erasing any old dups." + (let ((eshell-hist-ignoredups 'erase)) + (with-temp-eshell + (eshell-insert-command "echo hi") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo bye") + (eshell-insert-command "echo hi") + (should (equal (ring-elements eshell-history-ring) + '("echo hi" "echo bye")))))) (provide 'em-hist-test) diff --git a/test/lisp/eshell/em-prompt-tests.el b/test/lisp/eshell/em-prompt-tests.el new file mode 100644 index 00000000000..46e74e64983 --- /dev/null +++ b/test/lisp/eshell/em-prompt-tests.el @@ -0,0 +1,192 @@ +;;; em-prompt-tests.el --- em-prompt test suite -*- 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: + +;; Tests for Eshell's prompt support. + +;;; Code: + +(require 'ert) +(require 'eshell) +(require 'em-prompt) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +(defmacro em-prompt-test--with-multiline (&rest body) + "Execute BODY with a multiline Eshell prompt." + `(let ((eshell-prompt-function (lambda () "multiline prompt\n$ "))) + ,@body)) + +;;; Tests: + +(ert-deftest em-prompt-test/field-properties () + "Check that field properties are properly set on Eshell output/prompts." + (with-temp-eshell + (eshell-insert-command "echo hello") + (let ((last-prompt (field-string (1- eshell-last-input-start))) + (last-input (field-string (1+ eshell-last-input-start))) + (last-output (field-string (1+ eshell-last-input-end)))) + (should (equal-including-properties + last-prompt + (propertize + (format "%s %s " (directory-file-name default-directory) + (if (= (file-user-uid) 0) "#" "$")) + 'read-only t + 'field 'prompt + 'font-lock-face 'eshell-prompt + 'front-sticky '(read-only field font-lock-face) + 'rear-nonsticky '(read-only field font-lock-face)))) + (should (equal last-input "echo hello\n")) + (should (equal-including-properties + last-output + (apply #'propertize "hello\n" + eshell-command-output-properties)))))) + +(ert-deftest em-prompt-test/field-properties/no-highlight () + "Check that field properties are properly set on Eshell output/prompts. +This tests the case when `eshell-highlight-prompt' is nil." + (let ((eshell-highlight-prompt nil)) + (with-temp-eshell + (eshell-insert-command "echo hello") + (let ((last-prompt (field-string (1- eshell-last-input-start))) + (last-input (field-string (1+ eshell-last-input-start))) + (last-output (field-string (1+ eshell-last-input-end)))) + (should (equal-including-properties + last-prompt + (propertize + (format "%s %s " (directory-file-name default-directory) + (if (= (file-user-uid) 0) "#" "$")) + 'field 'prompt + 'front-sticky '(field) + 'rear-nonsticky '(field)))) + (should (equal last-input "echo hello\n")) + (should (equal-including-properties + last-output + (apply #'propertize "hello\n" + eshell-command-output-properties))))))) + +(ert-deftest em-prompt-test/after-failure () + "Check that current prompt shows the exit code of the last failed command." + (with-temp-eshell + (let ((debug-on-error nil)) + (eshell-insert-command "(zerop \"foo\")")) + (let ((current-prompt (field-string (1- (point))))) + (should (equal-including-properties + current-prompt + (propertize + (concat (directory-file-name default-directory) + (unless (eshell-exit-success-p) + (format " [%d]" eshell-last-command-status)) + (if (= (file-user-uid) 0) " # " " $ ")) + 'read-only t + 'field 'prompt + 'font-lock-face 'eshell-prompt + 'front-sticky '(read-only field font-lock-face) + 'rear-nonsticky '(read-only field font-lock-face))))))) + +(defun em-prompt-test/next-previous-prompt-1 () + "Helper for checking forward/backward navigation of old prompts." + (with-temp-eshell + (eshell-insert-command "echo one") + (eshell-insert-command "echo two") + (eshell-insert-command "echo three") + (let ((debug-on-error nil)) ; A failed command. + (eshell-insert-command "(zerop \"foo\")")) + (insert "echo fou") ; A partially-entered command. + (ert-info ("Go back one prompt") + (eshell-previous-prompt) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "(zerop \"foo\")\n"))) + (ert-info ("Go back three prompts, starting from the end of the input") + (end-of-line) + (eshell-previous-prompt 3) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo one\n"))) + (ert-info ("Go to the current prompt, starting from the end of the input") + (end-of-line) + (eshell-previous-prompt 0) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo one\n"))) + (ert-info ("Go forward one prompt") + (eshell-next-prompt) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo two\n"))) + (ert-info ("Go forward three prompts") + (eshell-next-prompt 3) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo fou"))) + (ert-info ("Go back one prompt, starting from the beginning of the line") + (forward-line 0) + (eshell-previous-prompt 1) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "(zerop \"foo\")\n"))) + (ert-info ("Go back one prompt, starting from the previous prompt's output") + (forward-line -1) + (eshell-previous-prompt 1) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo three\n"))))) + +(ert-deftest em-prompt-test/next-previous-prompt () + "Check that navigating forward/backward through old prompts works correctly." + (em-prompt-test/next-previous-prompt-1)) + +(ert-deftest em-prompt-test/next-previous-prompt-multiline () + "Check old prompt forward/backward navigation for multiline prompts." + (em-prompt-test--with-multiline + (em-prompt-test/next-previous-prompt-1))) + +(defun em-prompt-test/forward-backward-matching-input-1 () + "Helper for checking forward/backward navigation via regexps." + (with-temp-eshell + (eshell-insert-command "echo one") + (eshell-insert-command "printnl something else") + (eshell-insert-command "echo two") + (eshell-insert-command "echo three") + (let ((debug-on-error nil)) ; A failed command. + (eshell-insert-command "(zerop \"foo\")")) + (insert "echo fou") ; A partially-entered command. + (ert-info ("Search for \"echo\", back one prompt") + (eshell-backward-matching-input "echo" 1) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo three\n"))) + (ert-info ((concat "Search for \"echo\", back two prompts, " + "starting from the end of this line")) + (end-of-line) + (eshell-backward-matching-input "echo" 2) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo one\n"))) + (ert-info ("Search for \"echo\", forward three prompts") + (eshell-forward-matching-input "echo" 3) + (should (equal (point) (field-beginning))) + (should (equal (field-string) "echo fou"))))) + +(ert-deftest em-prompt-test/forward-backward-matching-input () + "Check that navigating forward/backward via regexps works correctly." + (em-prompt-test/forward-backward-matching-input-1)) + +(ert-deftest em-prompt-test/forward-backward-matching-input-multiline () + "Check forward/backward regexp navigation for multiline prompts." + (em-prompt-test--with-multiline + (em-prompt-test/forward-backward-matching-input-1))) + +;;; em-prompt-tests.el ends here diff --git a/test/lisp/eshell/em-script-tests.el b/test/lisp/eshell/em-script-tests.el index 4e557fada73..02e4125d827 100644 --- a/test/lisp/eshell/em-script-tests.el +++ b/test/lisp/eshell/em-script-tests.el @@ -35,21 +35,56 @@ ;;; Tests: (ert-deftest em-script-test/source-script () - "Test sourcing script with no argumentss" + "Test sourcing a simple script." (ert-with-temp-file temp-file :text "echo hi" (with-temp-eshell (eshell-match-command-output (format "source %s" temp-file) "hi\n")))) -(ert-deftest em-script-test/source-script-arg-vars () - "Test sourcing script with $0, $1, ... variables" +(ert-deftest em-script-test/source-script/redirect () + "Test sourcing a script and redirecting its output." + (ert-with-temp-file temp-file + :text "echo hi\necho bye" + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-match-command-output + (format "source %s > #<%s>" temp-file bufname) + "\\`\\'")) + (should (equal (buffer-string) "hibye"))))) + +(ert-deftest em-script-test/source-script/redirect/dev-null () + "Test sourcing a script and redirecting its output, including to /dev/null." + (ert-with-temp-file temp-file + :text "echo hi\necho bad > /dev/null\necho bye" + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-match-command-output + (format "source %s > #<%s>" temp-file bufname) + "\\`\\'")) + (should (equal (buffer-string) "hibye"))))) + +(ert-deftest em-script-test/source-script/background () + "Test sourcing a script in the background." + (skip-unless (executable-find "echo")) + (ert-with-temp-file temp-file + :text "*echo hi\nif {[ foo = foo ]} {*echo bye}" + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-match-command-output + (format "source %s > #<%s> &" temp-file bufname) + "\\`\\'") + (eshell-wait-for-subprocess t)) + (should (equal (buffer-string) "hi\nbye\n"))))) + +(ert-deftest em-script-test/source-script/arg-vars () + "Test sourcing script with $0, $1, ... variables." (ert-with-temp-file temp-file :text "printnl $0 \"$1 $2\"" (with-temp-eshell (eshell-match-command-output (format "source %s one two" temp-file) (format "%s\none two\n" temp-file))))) -(ert-deftest em-script-test/source-script-all-args-var () - "Test sourcing script with the $* variable" +(ert-deftest em-script-test/source-script/all-args-var () + "Test sourcing script with the $* variable." (ert-with-temp-file temp-file :text "printnl $*" (with-temp-eshell (eshell-match-command-output (format "source %s" temp-file) diff --git a/test/lisp/eshell/em-tramp-tests.el b/test/lisp/eshell/em-tramp-tests.el index 1d4ad9dc632..a3bda970b63 100644 --- a/test/lisp/eshell/em-tramp-tests.el +++ b/test/lisp/eshell/em-tramp-tests.el @@ -23,37 +23,41 @@ (require 'em-tramp) (require 'tramp) +(defmacro em-tramp-test/should-replace-command (form replacement) + "Check that calling FORM results in it being replaced with REPLACEMENT." + (declare (indent 1)) + `(should (equal + (catch 'eshell-replace-command ,form) + (list 'eshell-with-copied-handles + (list 'eshell-trap-errors + ,replacement) + t)))) + (ert-deftest em-tramp-test/su-default () "Test Eshell `su' command with no arguments." - (should (equal - (catch 'eshell-replace-command (eshell/su)) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/su:root@%s:%s" - tramp-default-host default-directory))))))) + (em-tramp-test/should-replace-command (eshell/su) + `(eshell-named-command + "cd" + (list ,(format "/su:root@%s:%s" + tramp-default-host default-directory))))) (ert-deftest em-tramp-test/su-user () "Test Eshell `su' command with USER argument." - (should (equal - (catch 'eshell-replace-command (eshell/su "USER")) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/su:USER@%s:%s" - tramp-default-host default-directory))))))) + (em-tramp-test/should-replace-command (eshell/su "USER") + `(eshell-named-command + "cd" + (list ,(format "/su:USER@%s:%s" + tramp-default-host default-directory))))) (ert-deftest em-tramp-test/su-login () "Test Eshell `su' command with -/-l/--login option." (dolist (args '(("--login") ("-l") ("-"))) - (should (equal - (catch 'eshell-replace-command (apply #'eshell/su args)) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/su:root@%s:~/" tramp-default-host)))))))) + (em-tramp-test/should-replace-command (apply #'eshell/su args) + `(eshell-named-command + "cd" + (list ,(format "/su:root@%s:~/" tramp-default-host)))))) (defun mock-eshell-named-command (&rest args) "Dummy function to test Eshell `sudo' command rewriting." @@ -89,23 +93,19 @@ "Test Eshell `sudo' command with -s/--shell option." (dolist (args '(("--shell") ("-s"))) - (should (equal - (catch 'eshell-replace-command (apply #'eshell/sudo args)) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/sudo:root@%s:%s" - tramp-default-host default-directory)))))))) + (em-tramp-test/should-replace-command (apply #'eshell/sudo args) + `(eshell-named-command + "cd" + (list ,(format "/sudo:root@%s:%s" + tramp-default-host default-directory)))))) (ert-deftest em-tramp-test/sudo-user-shell () "Test Eshell `sudo' command with -s and -u options." - (should (equal - (catch 'eshell-replace-command (eshell/sudo "-u" "USER" "-s")) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/sudo:USER@%s:%s" - tramp-default-host default-directory))))))) + (em-tramp-test/should-replace-command (eshell/sudo "-u" "USER" "-s") + `(eshell-named-command + "cd" + (list ,(format "/sudo:USER@%s:%s" + tramp-default-host default-directory))))) (ert-deftest em-tramp-test/doas-basic () "Test Eshell `doas' command with default user." @@ -142,22 +142,18 @@ "Test Eshell `doas' command with -s/--shell option." (dolist (args '(("--shell") ("-s"))) - (should (equal - (catch 'eshell-replace-command (apply #'eshell/doas args)) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/doas:root@%s:%s" - tramp-default-host default-directory)))))))) + (em-tramp-test/should-replace-command (apply #'eshell/doas args) + `(eshell-named-command + "cd" + (list ,(format "/doas:root@%s:%s" + tramp-default-host default-directory)))))) (ert-deftest em-tramp-test/doas-user-shell () "Test Eshell `doas' command with -s and -u options." - (should (equal - (catch 'eshell-replace-command (eshell/doas "-u" "USER" "-s")) - `(eshell-trap-errors - (eshell-named-command - "cd" - (list ,(format "/doas:USER@%s:%s" - tramp-default-host default-directory))))))) + (em-tramp-test/should-replace-command (eshell/doas "-u" "USER" "-s") + `(eshell-named-command + "cd" + (list ,(format "/doas:USER@%s:%s" + tramp-default-host default-directory))))) ;;; em-tramp-tests.el ends here diff --git a/test/lisp/eshell/em-unix-tests.el b/test/lisp/eshell/em-unix-tests.el new file mode 100644 index 00000000000..d7b6c55fe45 --- /dev/null +++ b/test/lisp/eshell/em-unix-tests.el @@ -0,0 +1,68 @@ +;;; em-unix-tests.el --- em-unix test suite -*- 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: + +;; Tests for Eshell's implementation of various UNIX commands. + +;;; Code: + +(require 'ert) +(require 'em-unix) + +(require 'eshell-tests-helpers + (expand-file-name "eshell-tests-helpers" + (file-name-directory (or load-file-name + default-directory)))) + +;;; Tests: + +(ert-deftest em-unix-test/compile/interactive () + "Check that `eshell/compile' opens a compilation buffer interactively." + (skip-unless (executable-find "echo")) + (with-temp-eshell + (eshell-match-command-output "compile echo hello" + "#<buffer \\*compilation\\*>") + (with-current-buffer "*compilation*" + (forward-line 3) + (should (looking-at "echo hello"))))) + +(ert-deftest em-unix-test/compile/noninteractive () + "Check that `eshell/compile' writes to stdout noninteractively." + (skip-unless (executable-find "echo")) + (eshell-command-result-equal "compile echo hello" + "hello\n")) + +(ert-deftest em-unix-test/compile/pipeline () + "Check that `eshell/compile' writes to stdout from a pipeline." + (skip-unless (and (executable-find "echo") + (executable-find "cat"))) + (with-temp-eshell + (eshell-match-command-output "compile echo hello | *cat" + "\\`hello\n"))) + +(ert-deftest em-unix-test/compile/subcommand () + "Check that `eshell/compile' writes to stdout from a subcommand." + (skip-unless (and (executable-find "echo") + (executable-find "cat"))) + (with-temp-eshell + (eshell-match-command-output "echo ${compile echo hello}" + "\\`hello\n"))) + +;; em-unix-tests.el ends here diff --git a/test/lisp/eshell/esh-arg-tests.el b/test/lisp/eshell/esh-arg-tests.el index 918ad3a949f..1eb8e08b883 100644 --- a/test/lisp/eshell/esh-arg-tests.el +++ b/test/lisp/eshell/esh-arg-tests.el @@ -102,4 +102,95 @@ treated literally, as a backslash and a newline." (eshell-match-command-output "echo \"hi\\\nthere\"" "hithere\n"))) +(ert-deftest esh-arg-test/special-reference/default () + "Test that \"#<buf>\" refers to the buffer \"buf\"." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (eshell-command-result-equal + (format "echo #<%s>" (buffer-name)) + (current-buffer)))) + +(ert-deftest esh-arg-test/special-reference/buffer () + "Test that \"#<buffer buf>\" refers to the buffer \"buf\"." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (eshell-command-result-equal + (format "echo #<buffer %s>" (buffer-name)) + (current-buffer)))) + +(ert-deftest esh-arg-test/special-reference/marker () + "Test that \"#<marker N buf>\" refers to a marker in the buffer \"buf\"." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (insert "hello") + (let ((marker (make-marker))) + (set-marker marker 1 (current-buffer)) + (eshell-command-result-equal + (format "echo #<marker 1 %s>" (buffer-name)) + marker)))) + +(ert-deftest esh-arg-test/special-reference/quoted () + "Test that '#<buffer \"foo bar\">' refers to the buffer \"foo bar\"." + (with-temp-buffer + (rename-buffer "foo bar" t) + (eshell-command-result-equal + (format "echo #<buffer \"%s\">" (buffer-name)) + (current-buffer)) + (eshell-command-result-equal + (format "echo #<buffer '%s'>" (buffer-name)) + (current-buffer)))) + +(ert-deftest esh-arg-test/special-reference/nested () + "Test that nested special references work correctly." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (insert "hello") + (let ((marker (make-marker))) + (set-marker marker 1 (current-buffer)) + (eshell-command-result-equal + (format "echo #<marker 1 #<%s>>" (buffer-name)) + marker) + (eshell-command-result-equal + (format "echo #<marker 1 #<buffer %s>>" (buffer-name)) + marker)))) + +(ert-deftest esh-arg-test/special-reference/var-expansion () + "Test that variable expansion inside special references works." + (with-temp-buffer + (rename-buffer "my-buffer" t) + (let ((eshell-test-value (buffer-name))) + (eshell-command-result-equal + "echo #<buffer $eshell-test-value>" + (current-buffer)) + (eshell-command-result-equal + "echo #<buffer \"$eshell-test-value\">" + (current-buffer))))) + +(ert-deftest esh-arg-test/special-reference/lisp-form () + "Test that Lisp forms inside special references work." + (with-temp-eshell + (let ((marker (make-marker)) + eshell-test-value) + (set-marker marker 1 (current-buffer)) + (eshell-insert-command + "setq eshell-test-value #<marker 1 (current-buffer)>") + (should (equal eshell-test-value marker)) + (eshell-insert-command + "setq eshell-test-value #<marker 1 #<buffer (buffer-name)>>") + (should (equal eshell-test-value marker))))) + +(ert-deftest esh-arg-test/special-reference/special-characters () + "Test that \"#<...>\" works correctly when escaping special characters." + (with-temp-buffer + (rename-buffer "<my buffer>" t) + (let ((escaped-bufname (replace-regexp-in-string + (rx (group (or "\\" "<" ">" space))) "\\\\\\1" + (buffer-name)))) + (eshell-command-result-equal + (format "echo #<%s>" escaped-bufname) + (current-buffer)) + (eshell-command-result-equal + (format "echo #<buffer %s>" escaped-bufname) + (current-buffer))))) + ;; esh-arg-tests.el ends here diff --git a/test/lisp/eshell/esh-cmd-tests.el b/test/lisp/eshell/esh-cmd-tests.el index 912822eeddb..e0783b26ad6 100644 --- a/test/lisp/eshell/esh-cmd-tests.el +++ b/test/lisp/eshell/esh-cmd-tests.el @@ -73,6 +73,62 @@ Test that trailing arguments outside the subcommand are ignored. e.g. \"{(+ 1 2)} 3\" => 3" (eshell-command-result-equal "{(+ 1 2)} 3" 3)) +(ert-deftest esh-cmd-test/subcommand-shadow-value () + "Test that the variable `value' isn't shadowed inside subcommands." + (with-temp-eshell + (with-no-warnings (setq-local value "hello")) + (eshell-match-command-output "echo ${echo $value}" + "hello\n"))) + +(ert-deftest esh-cmd-test/skip-leading-nils () + "Test that Eshell skips leading nil arguments for named commands." + (eshell-command-result-equal "$eshell-test-value echo hello" "hello") + (eshell-command-result-equal + "$eshell-test-value $eshell-test-value echo hello" "hello")) + +(ert-deftest esh-cmd-test/let-rebinds-after-defer () + "Test that let-bound values are properly updated after `eshell-defer'. +When inside a `let' block in an Eshell command form, we need to +ensure that deferred commands update any let-bound variables so +they have the correct values when resuming evaluation. See +bug#59469." + (skip-unless (executable-find "echo")) + (with-temp-eshell + (eshell-match-command-output + (concat "{" + " export LOCAL=value; " + " echo \"$LOCAL\"; " + " *echo external; " ; This will throw `eshell-defer'. + " echo \"$LOCAL\"; " + "}") + "value\nexternal\nvalue\n"))) + + +;; Background command invocation + +(ert-deftest esh-cmd-test/background/simple-command () + "Test invocation with a simple background command." + (skip-unless (executable-find "echo")) + (eshell-with-temp-buffer bufname "" + (with-temp-eshell + (eshell-match-command-output + (format "*echo hi > #<%s> &" bufname) + (rx "[echo" (? ".exe") "] " (+ digit) "\n")) + (eshell-wait-for-subprocess t)) + (should (equal (buffer-string) "hi\n")))) + +(ert-deftest esh-cmd-test/background/subcommand () + "Test invocation with a background command containing subcommands." + (skip-unless (and (executable-find "echo") + (executable-find "rev"))) + (eshell-with-temp-buffer bufname "" + (with-temp-eshell + (eshell-match-command-output + (format "*echo ${*echo hello | rev} > #<%s> &" bufname) + (rx "[echo" (? ".exe") "] " (+ digit) "\n")) + (eshell-wait-for-subprocess t)) + (should (equal (buffer-string) "olleh\n")))) + ;; Lisp forms @@ -114,6 +170,78 @@ e.g. \"{(+ 1 2)} 3\" => 3" "hi\n"))) +;; Pipelines + +(ert-deftest esh-cmd-test/pipeline-wait/head-proc () + "Check that piping a non-process to a process command waits for the process." + (skip-unless (executable-find "cat")) + (with-temp-eshell + (eshell-match-command-output "echo hi | *cat" + "hi"))) + +(ert-deftest esh-cmd-test/pipeline-wait/tail-proc () + "Check that piping a process to a non-process command waits for the process." + (skip-unless (executable-find "echo")) + (with-temp-eshell + (eshell-match-command-output "*echo hi | echo bye" + "bye\nhi\n"))) + +(ert-deftest esh-cmd-test/pipeline-wait/multi-proc () + "Check that a pipeline waits for all its processes before returning." + (skip-unless (and (executable-find "echo") + (executable-find "sh") + (executable-find "rev"))) + (with-temp-eshell + (eshell-match-command-output + "*echo hello | sh -c 'sleep 1; rev' 1>&2 | *echo goodbye" + "goodbye\nolleh\n"))) + +(ert-deftest esh-cmd-test/pipeline-wait/subcommand () + "Check that piping with an asynchronous subcommand waits for the subcommand." + (skip-unless (and (executable-find "echo") + (executable-find "cat"))) + (with-temp-eshell + (eshell-match-command-output "echo ${*echo hi} | *cat" + "hi"))) + +(ert-deftest esh-cmd-test/pipeline-wait/subcommand-with-pipe () + "Check that piping with an asynchronous subcommand with its own pipe works. +This should also wait for the subcommand." + (skip-unless (and (executable-find "echo") + (executable-find "cat"))) + (with-temp-eshell + (eshell-match-command-output "echo ${*echo hi | *cat} | *cat" + "hi"))) + +(ert-deftest esh-cmd-test/reset-in-pipeline/subcommand () + "Check that subcommands reset `eshell-in-pipeline-p'." + (skip-unless (executable-find "cat")) + (dolist (template '("echo {%s} | *cat" + "echo ${%s} | *cat" + "*cat $<%s> | *cat")) + (eshell-command-result-equal + (format template "echo $eshell-in-pipeline-p") + nil) + (eshell-command-result-equal + (format template "echo | echo $eshell-in-pipeline-p") + "last") + (eshell-command-result-equal + (format template "echo $eshell-in-pipeline-p | echo") + "first") + (eshell-command-result-equal + (format template "echo | echo $eshell-in-pipeline-p | echo") + "t"))) + +(ert-deftest esh-cmd-test/reset-in-pipeline/lisp () + "Check that interpolated Lisp forms reset `eshell-in-pipeline-p'." + (skip-unless (executable-find "cat")) + (dolist (template '("echo (%s) | *cat" + "echo $(%s) | *cat")) + (eshell-command-result-equal + (format template "format \"%s\" eshell-in-pipeline-p") + "nil"))) + + ;; Control flow statements (ert-deftest esh-cmd-test/for-loop () @@ -134,13 +262,13 @@ e.g. \"{(+ 1 2)} 3\" => 3" (eshell-match-command-output "for i in 1 2 (list 3 4) { echo $i }" "1\n2\n3\n4\n"))) -(ert-deftest esh-cmd-test/for-name-loop () ; bug#15231 +(ert-deftest esh-cmd-test/for-loop-name () ; bug#15231 "Test invocation of a for loop using `name'." (let ((process-environment (cons "name" process-environment))) (eshell-command-result-equal "for name in 3 { echo $name }" 3))) -(ert-deftest esh-cmd-test/for-name-shadow-loop () ; bug#15372 +(ert-deftest esh-cmd-test/for-loop-name-shadow () ; bug#15372 "Test invocation of a for loop using an env-var." (let ((process-environment (cons "name=env-value" process-environment))) (with-temp-eshell @@ -148,14 +276,28 @@ e.g. \"{(+ 1 2)} 3\" => 3" "echo $name; for name in 3 { echo $name }; echo $name" "env-value\n3\nenv-value\n")))) +(ert-deftest esh-cmd-test/for-loop-for-items-shadow () + "Test that the variable `for-items' isn't shadowed inside for loops." + (with-temp-eshell + (with-no-warnings (setq-local for-items "hello")) + (eshell-match-command-output "for i in 1 { echo $for-items }" + "hello\n"))) + +(ert-deftest esh-cmd-test/for-loop-pipe () + "Test invocation of a for loop piped to another command." + (skip-unless (executable-find "rev")) + (with-temp-eshell + (eshell-match-command-output "for i in foo bar baz { echo $i } | rev" + "zabraboof"))) + (ert-deftest esh-cmd-test/while-loop () "Test invocation of a while loop." (with-temp-eshell (let ((eshell-test-value '(0 1 2))) (eshell-match-command-output (concat "while $eshell-test-value " - "{ setq eshell-test-value (cdr eshell-test-value) }") - "(1 2)\n(2)\n")))) + "{ (pop eshell-test-value) }") + "0\n1\n2\n")))) (ert-deftest esh-cmd-test/while-loop-lisp-form () "Test invocation of a while loop using a Lisp form." @@ -176,6 +318,17 @@ e.g. \"{(+ 1 2)} 3\" => 3" "{ setq eshell-test-value (1+ eshell-test-value) }") "1\n2\n3\n")))) +(ert-deftest esh-cmd-test/while-loop-pipe () + "Test invocation of a while loop piped to another command." + (skip-unless (executable-find "rev")) + (with-temp-eshell + (let ((eshell-test-value '("foo" "bar" "baz"))) + (eshell-match-command-output + (concat "while $eshell-test-value " + "{ (pop eshell-test-value) }" + " | rev") + "zabraboof")))) + (ert-deftest esh-cmd-test/until-loop () "Test invocation of an until loop." (with-temp-eshell @@ -253,6 +406,30 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." (eshell-command-result-equal "if {[ foo = bar ]} {echo yes} {echo no}" "no")) +(ert-deftest esh-cmd-test/if-statement-pipe () + "Test invocation of an if statement piped to another command." + (skip-unless (executable-find "rev")) + (with-temp-eshell + (let ((eshell-test-value t)) + (eshell-match-command-output "if $eshell-test-value {echo yes} | rev" + "\\`sey\n?")) + (let ((eshell-test-value nil)) + (eshell-match-command-output "if $eshell-test-value {echo yes} | rev" + "\\`\n?")))) + +(ert-deftest esh-cmd-test/if-else-statement-pipe () + "Test invocation of an if/else statement piped to another command." + (skip-unless (executable-find "rev")) + (with-temp-eshell + (let ((eshell-test-value t)) + (eshell-match-command-output + "if $eshell-test-value {echo yes} {echo no} | rev" + "\\`sey\n?")) + (let ((eshell-test-value nil)) + (eshell-match-command-output + "if $eshell-test-value {echo yes} {echo no} | rev" + "\\`on\n?")))) + (ert-deftest esh-cmd-test/unless-statement () "Test invocation of an unless statement." (let ((eshell-test-value t)) @@ -291,4 +468,19 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." (eshell-command-result-equal "unless {[ foo = bar ]} {echo no} {echo yes}" "no")) + +;; Error handling + +(ert-deftest esh-cmd-test/throw () + "Test that calling `throw' as an Eshell command unwinds everything properly." + (with-temp-eshell + (should (= (catch 'tag + (eshell-insert-command + "echo hi; (throw 'tag 42); echo bye")) + 42)) + (should (eshell-match-output "\\`hi\n\\'")) + (should-not eshell-foreground-command) + ;; Make sure we can call another command after throwing. + (eshell-match-command-output "echo again" "\\`again\n"))) + ;; esh-cmd-tests.el ends here diff --git a/test/lisp/eshell/esh-ext-tests.el b/test/lisp/eshell/esh-ext-tests.el index ef073d3487d..aae297cd413 100644 --- a/test/lisp/eshell/esh-ext-tests.el +++ b/test/lisp/eshell/esh-ext-tests.el @@ -23,6 +23,7 @@ ;;; Code: +(require 'tramp) (require 'ert) (require 'esh-mode) (require 'esh-ext) @@ -73,4 +74,35 @@ (eshell-match-command-output "echo $PATH" (concat original-path "\n"))))) +(ert-deftest esh-ext-test/explicitly-remote-command () + "Test that an explicitly-remote command is remote no matter the current dir." + (skip-unless (and (eshell-tests-remote-accessible-p) + (executable-find "sh"))) + (dolist (default-directory (list default-directory + ert-remote-temporary-file-directory)) + (dolist (cmd (list "sh" (executable-find "sh"))) + (ert-info ((format "Directory: %s; executable: %s" default-directory cmd)) + (with-temp-eshell + ;; Check the value of $INSIDE_EMACS using `sh' in order to + ;; delay variable expansion. + (eshell-match-command-output + (format "%s%s -c 'echo $INSIDE_EMACS'" + (file-remote-p ert-remote-temporary-file-directory) cmd) + "eshell,tramp")))))) + +(ert-deftest esh-ext-test/explicitly-local-command () + "Test that an explicitly-local command is local no matter the current dir." + (skip-unless (and (eshell-tests-remote-accessible-p) + (executable-find "sh"))) + (dolist (default-directory (list default-directory + ert-remote-temporary-file-directory)) + (dolist (cmd (list "sh" (executable-find "sh"))) + (ert-info ((format "In directory: %s" default-directory)) + (with-temp-eshell + ;; Check the value of $INSIDE_EMACS using `sh' in order to + ;; delay variable expansion. + (eshell-match-command-output + (format "/:%s -c 'echo $INSIDE_EMACS'" cmd) + "eshell\n")))))) + ;; esh-ext-tests.el ends here diff --git a/test/lisp/eshell/esh-io-tests.el b/test/lisp/eshell/esh-io-tests.el index b38d6090f13..bc3d9c6e5d5 100644 --- a/test/lisp/eshell/esh-io-tests.el +++ b/test/lisp/eshell/esh-io-tests.el @@ -31,6 +31,9 @@ (defvar eshell-test-value nil) +(defvar eshell-test-value-with-fun nil) +(defun eshell-test-value-with-fun ()) + (defun eshell-test-file-string (file) "Return the contents of FILE as a string." (with-temp-buffer @@ -117,6 +120,13 @@ (eshell-insert-command "echo new >> #'eshell-test-value")) (should (equal eshell-test-value "oldnew")))) +(ert-deftest esh-io-test/redirect-symbol/with-function-slot () + "Check that redirecting to a symbol with function slot set works." + (let ((eshell-test-value-with-fun)) + (with-temp-eshell + (eshell-insert-command "echo hi > #'eshell-test-value-with-fun")) + (should (equal eshell-test-value-with-fun "hi")))) + (ert-deftest esh-io-test/redirect-marker () "Check that redirecting to a marker works." (with-temp-buffer @@ -146,6 +156,45 @@ (should (equal (buffer-string) "new")) (should (equal eshell-test-value "new"))))) +(ert-deftest esh-io-test/redirect-subcommands () + "Check that redirecting subcommands applies to all subcommands." + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-insert-command (format "{echo foo; echo bar} > #<%s>" bufname))) + (should (equal (buffer-string) "foobar")))) + +(ert-deftest esh-io-test/redirect-subcommands/override () + "Check that redirecting subcommands applies to all subcommands. +Include a redirect to another location in the subcommand to +ensure only its statement is redirected." + (eshell-with-temp-buffer bufname "old" + (eshell-with-temp-buffer bufname-2 "also old" + (with-temp-eshell + (eshell-insert-command + (format "{echo foo; echo bar > #<%s>; echo baz} > #<%s>" + bufname-2 bufname))) + (should (equal (buffer-string) "bar"))) + (should (equal (buffer-string) "foobaz")))) + +(ert-deftest esh-io-test/redirect-subcommands/dev-null () + "Check that redirecting subcommands applies to all subcommands. +Include a redirect to /dev/null to ensure it only applies to its +statement." + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-insert-command + (format "{echo foo; echo bar > /dev/null; echo baz} > #<%s>" + bufname))) + (should (equal (buffer-string) "foobaz")))) + +(ert-deftest esh-io-test/redirect-subcommands/interpolated () + "Check that redirecting interpolated subcommands applies to all subcommands." + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-insert-command + (format "echo ${echo foo; echo bar} > #<%s>" bufname))) + (should (equal (buffer-string) "foobar")))) + ;; Redirecting specific handles @@ -262,24 +311,67 @@ stdout originally pointed (the terminal)." "stderr\n")) (should (equal (buffer-string) "stdout\n")))) -(ert-deftest esh-io-test/redirect-pipe () - "Check that \"redirecting\" to a pipe works." - ;; `|' should only redirect stdout. + +;; Pipelines + +(ert-deftest esh-io-test/pipeline/default () + "Check that `|' only pipes stdout." + (skip-unless (executable-find "rev")) (eshell-command-result-equal "test-output | rev" - "stderr\ntuodts\n") - ;; `|&' should redirect stdout and stderr. + "stderr\ntuodts\n")) + + +(ert-deftest esh-io-test/pipeline/all () + "Check that `|&' only pipes stdout and stderr." + (skip-unless (executable-find "rev")) (eshell-command-result-equal "test-output |& rev" "tuodts\nrredts\n")) +(ert-deftest esh-io-test/pipeline/subcommands () + "Check that all commands in a subcommand are properly piped." + (skip-unless (executable-find "rev")) + (with-temp-eshell + (eshell-match-command-output "{echo foo; echo bar} | rev" + "\\`raboof\n?"))) + +(ert-deftest esh-io-test/pipeline/stdin-to-head () + "Check that standard input is sent to the head process in a pipeline." + (skip-unless (and (executable-find "tr") + (executable-find "rev"))) + (with-temp-eshell + (eshell-insert-command "tr a-z A-Z | rev") + (eshell-insert-command "hello") + (eshell-send-eof-to-process) + (eshell-wait-for-subprocess) + (should (eshell-match-output "OLLEH\n")))) + ;; Virtual targets -(ert-deftest esh-io-test/virtual-dev-eshell () +(ert-deftest esh-io-test/virtual/dev-null () + "Check that redirecting to /dev/null works." + (with-temp-eshell + (eshell-match-command-output "echo hi > /dev/null" "\\`\\'"))) + +(ert-deftest esh-io-test/virtual/dev-null/multiple () + "Check that redirecting to /dev/null works alongside other redirections." + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-match-command-output + (format "echo new > /dev/null > #<%s>" bufname) "\\`\\'")) + (should (equal (buffer-string) "new"))) + (eshell-with-temp-buffer bufname "old" + (with-temp-eshell + (eshell-match-command-output + (format "echo new > #<%s> > /dev/null" bufname) "\\`\\'")) + (should (equal (buffer-string) "new")))) + +(ert-deftest esh-io-test/virtual/dev-eshell () "Check that redirecting to /dev/eshell works." (with-temp-eshell (eshell-match-command-output "echo hi > /dev/eshell" "hi"))) -(ert-deftest esh-io-test/virtual-dev-kill () +(ert-deftest esh-io-test/virtual/dev-kill () "Check that redirecting to /dev/kill works." (with-temp-eshell (eshell-insert-command "echo one > /dev/kill") diff --git a/test/lisp/eshell/esh-proc-tests.el b/test/lisp/eshell/esh-proc-tests.el index 7d0432dbe68..9118bcd1c61 100644 --- a/test/lisp/eshell/esh-proc-tests.el +++ b/test/lisp/eshell/esh-proc-tests.el @@ -86,7 +86,7 @@ "\\`\\'")) (should (equal (buffer-string) "stdout\nstderr\n")))) -(ert-deftest esh-var-test/output/remote-redirect () +(ert-deftest esh-proc-test/output/remote-redirect () "Check that redirecting stdout for a remote process works." (skip-unless (and (eshell-tests-remote-accessible-p) (executable-find "echo"))) @@ -137,18 +137,19 @@ (skip-unless (and (executable-find "sh") (executable-find "echo") (executable-find "sleep"))) - (with-temp-eshell - (eshell-match-command-output - ;; The first command is like `yes' but slower. This is to prevent - ;; it from taxing Emacs's process filter too much and causing a - ;; hang. Note that we use "|&" to connect the processes so that - ;; Emacs doesn't create an extra pipe process for the first "sh" - ;; invocation. - (concat "sh -c 'while true; do echo y; sleep 1; done' |& " - "sh -c 'read NAME; echo ${NAME}'") - "y\n") - (eshell-wait-for-subprocess t) - (should (eq (process-list) nil)))) + (let ((starting-process-list (process-list))) + (with-temp-eshell + (eshell-match-command-output + ;; The first command is like `yes' but slower. This is to prevent + ;; it from taxing Emacs's process filter too much and causing a + ;; hang. Note that we use "|&" to connect the processes so that + ;; Emacs doesn't create an extra pipe process for the first "sh" + ;; invocation. + (concat "sh -c 'while true; do echo y; sleep 1; done' |& " + "sh -c 'read NAME; echo ${NAME}'") + "y\n") + (eshell-wait-for-subprocess t) + (should (equal (process-list) starting-process-list))))) (ert-deftest esh-proc-test/pipeline-connection-type/no-pipeline () "Test that all streams are PTYs when a command is not in a pipeline." @@ -173,23 +174,70 @@ pipeline." (skip-unless (and (executable-find "sh") (executable-find "cat"))) - ;; An `eshell-pipe-broken' signal might occur internally; let Eshell - ;; handle it! - (let ((debug-on-error nil)) - (eshell-command-result-equal - (concat "echo hi | " esh-proc-test--detect-pty-cmd " | cat") - nil))) + (eshell-command-result-equal + (concat "(ignore) | " esh-proc-test--detect-pty-cmd " | cat") + nil)) (ert-deftest esh-proc-test/pipeline-connection-type/last () "Test that only output streams are PTYs when a command ends a pipeline." (skip-unless (executable-find "sh")) - ;; An `eshell-pipe-broken' signal might occur internally; let Eshell - ;; handle it! - (let ((debug-on-error nil)) - (eshell-command-result-equal - (concat "echo hi | " esh-proc-test--detect-pty-cmd) - (unless (eq system-type 'windows-nt) - "stdout\nstderr\n")))) + (eshell-command-result-equal + (concat "(ignore) | " esh-proc-test--detect-pty-cmd) + (unless (eq system-type 'windows-nt) + "stdout\nstderr\n"))) + + +;; Synchronous processes + +;; These tests check that synchronous subprocesses (only used on +;; MS-DOS by default) work correctly. To help them run on MS-DOS as +;; well, we use the Emacs executable as our subprocess to test +;; against; that way, users don't need to have GNU coreutils (or +;; similar) installed. + +(defsubst esh-proc-test/emacs-command (command) + "Evaluate COMMAND in a new Emacs batch instance." + (mapconcat #'shell-quote-argument + `(,(expand-file-name invocation-name invocation-directory) + "-Q" "--batch" "--eval" ,(prin1-to-string command)) + " ")) + +(defvar esh-proc-test/emacs-echo + (esh-proc-test/emacs-command '(princ "hello\n")) + "A command that prints \"hello\" to stdout using Emacs.") + +(defvar esh-proc-test/emacs-upcase + (esh-proc-test/emacs-command + '(princ (upcase (concat (read-string "") "\n")))) + "A command that upcases the text from stdin using Emacs.") + +(ert-deftest esh-proc-test/synchronous-proc/simple/interactive () + "Test that synchronous processes work in an interactive shell." + (let ((eshell-supports-asynchronous-processes nil)) + (with-temp-eshell + (eshell-match-command-output esh-proc-test/emacs-echo + "\\`hello\n")))) + +(ert-deftest esh-proc-test/synchronous-proc/simple/command-result () + "Test that synchronous processes work via `eshell-command-result'." + (let ((eshell-supports-asynchronous-processes nil)) + (eshell-command-result-equal esh-proc-test/emacs-echo + "hello\n"))) + +(ert-deftest esh-proc-test/synchronous-proc/pipeline/interactive () + "Test that synchronous pipelines work in an interactive shell." + (let ((eshell-supports-asynchronous-processes nil)) + (with-temp-eshell + (eshell-match-command-output (concat esh-proc-test/emacs-echo " | " + esh-proc-test/emacs-upcase) + "\\`HELLO\n")))) + +(ert-deftest esh-proc-test/synchronous-proc/pipeline/command-result () + "Test that synchronous pipelines work via `eshell-command-result'." + (let ((eshell-supports-asynchronous-processes nil)) + (eshell-command-result-equal (concat esh-proc-test/emacs-echo " | " + esh-proc-test/emacs-upcase) + "HELLO\n"))) ;; Killing processes @@ -228,7 +276,7 @@ prompt. See bug#54136." (executable-find "sleep"))) ;; This test doesn't work on EMBA with AOT nativecomp, but works ;; fine elsewhere. - (skip-unless (not (getenv "EMACS_EMBA_CI"))) + (skip-when (getenv "EMACS_EMBA_CI")) (with-temp-eshell (eshell-insert-command (concat "sh -c 'while true; do echo y; sleep 1; done' | " @@ -259,6 +307,15 @@ write the exit status to the pipe. See bug#54136." output-start (eshell-end-of-output)) ""))))) +(ert-deftest esh-proc-test/kill-process/redirect-message () + "Test that killing a process with a redirected stderr omits the exit status." + (skip-unless (executable-find "sleep")) + (eshell-with-temp-buffer bufname "" + (with-temp-eshell + (eshell-insert-command (format "sleep 100 2> #<buffer %s>" bufname)) + (kill-process (eshell-head-process))) + (should (equal (buffer-string) "")))) + ;; Remote processes diff --git a/test/lisp/eshell/esh-util-tests.el b/test/lisp/eshell/esh-util-tests.el index 9546a4a62fd..7bd71b260ff 100644 --- a/test/lisp/eshell/esh-util-tests.el +++ b/test/lisp/eshell/esh-util-tests.el @@ -52,14 +52,116 @@ (ert-deftest esh-util-test/eshell-stringify/list () "Test that `eshell-stringify' correctly stringifies lists." + ;; These tests depend on the particulars of how Emacs pretty-prints + ;; lists; changes to the pretty-printer could result in different + ;; whitespace. We don't care about that, except to ensure there's + ;; no leading/trailing whitespace. (should (equal (eshell-stringify '(1 2 3)) "(1 2 3)")) - (should (equal (eshell-stringify '((1 2) (3 . 4))) - "((1 2)\n (3 . 4))"))) + (should (equal (replace-regexp-in-string + (rx (+ (any space "\n"))) " " + (eshell-stringify '((1 2) (3 . 4)))) + "((1 2) (3 . 4))"))) (ert-deftest esh-util-test/eshell-stringify/complex () "Test that `eshell-stringify' correctly stringifies complex objects." (should (equal (eshell-stringify (list 'quote 'hello)) "'hello"))) +(ert-deftest esh-util-test/eshell-convert-to-number/integer () + "Test that `eshell-convert-to-number' correctly converts integers." + (should (equal (eshell-convert-to-number "123") 123)) + (should (equal (eshell-convert-to-number "-123") -123)) + ;; These are technially integers, since Emacs Lisp requires at least + ;; one digit after the "." to be a float: + (should (equal (eshell-convert-to-number "123.") 123)) + (should (equal (eshell-convert-to-number "-123.") -123))) + +(ert-deftest esh-util-test/eshell-convert-to-number/floating-point () + "Test that `eshell-convert-to-number' correctly converts floats." + (should (equal (eshell-convert-to-number "1.23") 1.23)) + (should (equal (eshell-convert-to-number "-1.23") -1.23)) + (should (equal (eshell-convert-to-number ".1") 0.1)) + (should (equal (eshell-convert-to-number "-.1") -0.1))) + +(ert-deftest esh-util-test/eshell-convert-to-number/floating-point-exponent () + "Test that `eshell-convert-to-number' correctly converts exponent notation." + ;; Positive exponent: + (dolist (exp '("e2" "e+2" "E2" "E+2")) + (should (equal (eshell-convert-to-number (concat "123" exp)) 12300.0)) + (should (equal (eshell-convert-to-number (concat "-123" exp)) -12300.0)) + (should (equal (eshell-convert-to-number (concat "1.23" exp)) 123.0)) + (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -123.0)) + (should (equal (eshell-convert-to-number (concat "1." exp)) 100.0)) + (should (equal (eshell-convert-to-number (concat "-1." exp)) -100.0)) + (should (equal (eshell-convert-to-number (concat ".1" exp)) 10.0)) + (should (equal (eshell-convert-to-number (concat "-.1" exp)) -10.0))) + ;; Negative exponent: + (dolist (exp '("e-2" "E-2")) + (should (equal (eshell-convert-to-number (concat "123" exp)) 1.23)) + (should (equal (eshell-convert-to-number (concat "-123" exp)) -1.23)) + (should (equal (eshell-convert-to-number (concat "1.23" exp)) 0.0123)) + (should (equal (eshell-convert-to-number (concat "-1.23" exp)) -0.0123)) + (should (equal (eshell-convert-to-number (concat "1." exp)) 0.01)) + (should (equal (eshell-convert-to-number (concat "-1." exp)) -0.01)) + (should (equal (eshell-convert-to-number (concat ".1" exp)) 0.001)) + (should (equal (eshell-convert-to-number (concat "-.1" exp)) -0.001)))) + +(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/infinite () + "Test that `eshell-convert-to-number' correctly converts infinite floats." + (should (equal (eshell-convert-to-number "1.0e+INF") 1.0e+INF)) + (should (equal (eshell-convert-to-number "2.e+INF") 1.0e+INF)) + (should (equal (eshell-convert-to-number "-1.0e+INF") -1.0e+INF)) + (should (equal (eshell-convert-to-number "-2.e+INF") -1.0e+INF))) + +(ert-deftest esh-util-test/eshell-convert-to-number/floating-point/nan () + "Test that `eshell-convert-to-number' correctly converts NaNs." + (should (equal (eshell-convert-to-number "1.0e+NaN") 1.0e+NaN)) + (should (equal (eshell-convert-to-number "2.e+NaN") 2.0e+NaN)) + (should (equal (eshell-convert-to-number "-1.0e+NaN") -1.0e+NaN)) + (should (equal (eshell-convert-to-number "-2.e+NaN") -2.0e+NaN))) + +(ert-deftest esh-util-test/eshell-convert-to-number/non-numeric () + "Test that `eshell-convert-to-number' does nothing to non-numeric values." + (should (equal (eshell-convert-to-number "foo") "foo")) + (should (equal (eshell-convert-to-number "") "")) + (should (equal (eshell-convert-to-number "123foo") "123foo"))) + +(ert-deftest esh-util-test/eshell-convert-to-number/no-convert () + "Test that `eshell-convert-to-number' does nothing when disabled." + (let ((eshell-convert-numeric-arguments nil)) + (should (equal (eshell-convert-to-number "123") "123")) + (should (equal (eshell-convert-to-number "1.23") "1.23")))) + +(ert-deftest esh-util-test/eshell-printable-size () + (should (equal (eshell-printable-size (expt 2 16)) "65536")) + (should (equal (eshell-printable-size (expt 2 32)) "4294967296"))) + +(ert-deftest esh-util-test/eshell-printable-size/zero () + (should (equal (eshell-printable-size 0 1000 nil t) "0"))) + +(ert-deftest esh-util-test/eshell-printable-size/terabyte () + (should (equal (eshell-printable-size (1- (expt 2 40)) 1024 nil t) "1024G")) + (should (equal (eshell-printable-size (expt 2 40) 1024 nil t) "1T")) + (should (equal (eshell-printable-size (1- (expt 10 12)) 1000 nil t) "1000G")) + (should (equal (eshell-printable-size (expt 10 12) 1000 nil t) "1T"))) + +(ert-deftest esh-util-test/eshell-printable-size/use-colors () + (should (equal-including-properties + (eshell-printable-size (1- (expt 2 20)) 1024 nil t) + "1024k")) + (should (equal-including-properties + (eshell-printable-size (1- (expt 2 30)) 1024 nil t) + (propertize "1024M" 'face 'bold))) + (should (equal-including-properties + (eshell-printable-size (1- (expt 2 40)) 1024 nil t) + (propertize "1024G" 'face 'bold-italic)))) + +(ert-deftest esh-util-test/eshell-printable-size/block-size () + (should (equal (eshell-printable-size (1- (expt 2 20)) nil 4096) "256")) + (should (equal (eshell-printable-size (1- (expt 2 30)) nil 4096) "262144"))) + +(ert-deftest esh-util-test/eshell-printable-size/human-readable-arg () + (should-error (eshell-printable-size 0 999 nil t))) + (ert-deftest esh-util-test/path/get () "Test that getting the Eshell path returns the expected results." (let ((expected-path (butlast (exec-path)))) diff --git a/test/lisp/eshell/esh-var-tests.el b/test/lisp/eshell/esh-var-tests.el index 7ec1731f94e..83c0f480627 100644 --- a/test/lisp/eshell/esh-var-tests.el +++ b/test/lisp/eshell/esh-var-tests.el @@ -60,41 +60,101 @@ (eshell-command-result-equal "echo $\"user-login-name\"-foo" (concat user-login-name "-foo"))) -(ert-deftest esh-var-test/interp-var-indices () - "Interpolate list variable with indices" - (let ((eshell-test-value '("zero" "one" "two" "three" "four"))) +(ert-deftest esh-var-test/interp-list-var () + "Interpolate list variable" + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo $eshell-test-value" + '(1 2 3)))) + +(ert-deftest esh-var-test/interp-list-var-concat () + "Interpolate and concat list variable" + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo a$'eshell-test-value'z" + '("a1" 2 "3z")))) + +(defun esh-var-test/interp-var-indices (function &optional range-function) + "Test interpolation of an indexable value with indices. +FUNCTION is a function that takes a list of elements and returns +the object to test. + +RANGE-FUNCTION is a function that takes a list of elements and +returns the expected result of an index range for the object; if +nil, use FUNCTION instead." + (let ((eshell-test-value + (funcall function '("zero" "one" "two" "three" "four"))) + (range-function (or range-function function))) + ;; Positive indices (eshell-command-result-equal "echo $eshell-test-value[0]" "zero") (eshell-command-result-equal "echo $eshell-test-value[0 2]" '("zero" "two")) (eshell-command-result-equal "echo $eshell-test-value[0 2 4]" - '("zero" "two" "four")))) + '("zero" "two" "four")) + ;; Negative indices + (eshell-command-result-equal "echo $eshell-test-value[-1]" + "four") + (eshell-command-result-equal "echo $eshell-test-value[-1 -3]" + '("four" "two")) + ;; Index ranges + (eshell-command-result-equal + "echo $eshell-test-value[1..4]" + (funcall range-function '("one" "two" "three"))) + (eshell-command-result-equal + "echo $eshell-test-value[..2]" + (funcall range-function '("zero" "one"))) + (eshell-command-result-equal + "echo $eshell-test-value[-2..]" + (funcall range-function '("three" "four"))) + (eshell-command-result-equal + "echo $eshell-test-value[..]" + (funcall range-function '("zero" "one" "two" "three" "four"))) + (eshell-command-result-equal + "echo $eshell-test-value[1..4 -2..]" + (list (funcall range-function '("one" "two" "three")) + (funcall range-function '("three" "four")))))) -(ert-deftest esh-var-test/interp-var-split-indices () - "Interpolate string variable with indices" - (let ((eshell-test-value "zero one two three four")) - (eshell-command-result-equal "echo $eshell-test-value[0]" - "zero") - (eshell-command-result-equal "echo $eshell-test-value[0 2]" - '("zero" "two")) - (eshell-command-result-equal "echo $eshell-test-value[0 2 4]" - '("zero" "two" "four")))) +(ert-deftest esh-var-test/interp-var-indices/list () + "Interpolate list variable with indices." + (esh-var-test/interp-var-indices #'identity)) + +(ert-deftest esh-var-test/interp-var-indices/vector () + "Interpolate vector variable with indices." + (esh-var-test/interp-var-indices #'vconcat)) + +(ert-deftest esh-var-test/interp-var-indices/ring () + "Interpolate ring variable with indices." + (esh-var-test/interp-var-indices #'ring-convert-sequence-to-ring)) + +(ert-deftest esh-var-test/interp-var-indices/split () + "Interpolate string variable with indices." + (esh-var-test/interp-var-indices + (lambda (values) (string-join values " ")) + #'identity)) (ert-deftest esh-var-test/interp-var-string-split-indices () - "Interpolate string variable with string splitter and indices" + "Interpolate string variable with string splitter and indices." + ;; Test using punctuation as a delimiter. (let ((eshell-test-value "zero:one:two:three:four")) (eshell-command-result-equal "echo $eshell-test-value[: 0]" "zero") (eshell-command-result-equal "echo $eshell-test-value[: 0 2]" '("zero" "two"))) + ;; Test using a letter as a delimiter. (let ((eshell-test-value "zeroXoneXtwoXthreeXfour")) (eshell-command-result-equal "echo $eshell-test-value[X 0]" "zero") (eshell-command-result-equal "echo $eshell-test-value[X 0 2]" + '("zero" "two"))) + ;; Test using a number as a delimiter. + (let ((eshell-test-value "zero0one0two0three0four")) + (eshell-command-result-equal "echo $eshell-test-value[\"0\" 0]" + "zero") + (eshell-command-result-equal "echo $eshell-test-value[\"0\" 0 2]" '("zero" "two")))) (ert-deftest esh-var-test/interp-var-regexp-split-indices () - "Interpolate string variable with regexp splitter and indices" + "Interpolate string variable with regexp splitter and indices." + ;; Test using a regexp as a delimiter. (let ((eshell-test-value "zero:one!two:three!four")) (eshell-command-result-equal "echo $eshell-test-value['[:!]' 0]" "zero") @@ -103,18 +163,37 @@ (eshell-command-result-equal "echo $eshell-test-value[\"[:!]\" 0]" "zero") (eshell-command-result-equal "echo $eshell-test-value[\"[:!]\" 0 2]" + '("zero" "two"))) + ;; Test using a regexp that looks like range syntax as a delimiter. + (let ((eshell-test-value "zero0..0one0..0two0..0three0..0four")) + (eshell-command-result-equal "echo $eshell-test-value[\"0..0\" 0]" + "zero") + (eshell-command-result-equal "echo $eshell-test-value[\"0..0\" 0 2]" '("zero" "two")))) (ert-deftest esh-var-test/interp-var-assoc () - "Interpolate alist variable with index" - (let ((eshell-test-value '(("foo" . 1) (bar . 2)))) + "Interpolate alist variable with index." + (let ((eshell-test-value '(("foo" . 1) (bar . 2) ("3" . "three")))) (eshell-command-result-equal "echo $eshell-test-value[foo]" 1) (eshell-command-result-equal "echo $eshell-test-value[#'bar]" - 2))) + 2) + (eshell-command-result-equal "echo $eshell-test-value[\"3\"]" + "three"))) + +(ert-deftest esh-var-test/interp-var-indices-subcommand () + "Interpolate list variable with subcommand expansion for indices." + (skip-unless (executable-find "echo")) + (let ((eshell-test-value '("zero" "one" "two" "three" "four"))) + (eshell-command-result-equal + "echo $eshell-test-value[${*echo 0}]" + "zero") + (eshell-command-result-equal + "echo $eshell-test-value[${*echo 0} ${*echo 2}]" + '("zero" "two")))) (ert-deftest esh-var-test/interp-var-length-list () - "Interpolate length of list variable" + "Interpolate length of list variable." (let ((eshell-test-value '((1 2) (3) (5 (6 7 8 9))))) (eshell-command-result-equal "echo $#eshell-test-value" 3) (eshell-command-result-equal "echo $#eshell-test-value[1]" 1) @@ -126,55 +205,75 @@ (eshell-command-result-equal "echo $#eshell-test-value" 6))) (ert-deftest esh-var-test/interp-var-length-alist () - "Interpolate length of alist variable" + "Interpolate length of alist variable." (let ((eshell-test-value '(("foo" . (1 2 3))))) (eshell-command-result-equal "echo $#eshell-test-value" 1) (eshell-command-result-equal "echo $#eshell-test-value[foo]" 3))) +(ert-deftest esh-var-test/interp-var-splice () + "Splice-interpolate list variable." + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo a $@eshell-test-value z" + '("a" 1 2 3 "z")))) + +(ert-deftest esh-var-test/interp-var-splice-concat () + "Splice-interpolate and concat list variable." + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo it is a$@'eshell-test-value'z" + '("it" "is" "a1" 2 "3z")) + ;; This is a tricky case. We're concatenating a spliced list and + ;; a non-spliced list. The general rule is that splicing should + ;; work as though the user typed "$X[0] $X[1] ... $X[N]". That + ;; means that the last value of our splice should get concatenated + ;; into the first value of the non-spliced list. + (eshell-command-result-equal + "echo it is $@'eshell-test-value'$eshell-test-value" + '("it" "is" 1 2 (31 2 3))))) + (ert-deftest esh-var-test/interp-lisp () - "Interpolate Lisp form evaluation" + "Interpolate Lisp form evaluation." (eshell-command-result-equal "+ $(+ 1 2) 3" 6)) (ert-deftest esh-var-test/interp-lisp-indices () - "Interpolate Lisp form evaluation with index" + "Interpolate Lisp form evaluation with index." (eshell-command-result-equal "+ $(list 1 2)[1] 3" 5)) (ert-deftest esh-var-test/interp-cmd () - "Interpolate command result" + "Interpolate command result." (eshell-command-result-equal "+ ${+ 1 2} 3" 6)) (ert-deftest esh-var-test/interp-cmd-indices () - "Interpolate command result with index" + "Interpolate command result with index." (eshell-command-result-equal "+ ${listify 1 2}[1] 3" 5)) (ert-deftest esh-var-test/interp-cmd-external () - "Interpolate command result from external command" + "Interpolate command result from external command." (skip-unless (executable-find "echo")) (with-temp-eshell (eshell-match-command-output "echo ${*echo hi}" "hi\n"))) (ert-deftest esh-var-test/interp-cmd-external-indices () - "Interpolate command result from external command with index" + "Interpolate command result from external command with index." (skip-unless (executable-find "echo")) (with-temp-eshell (eshell-match-command-output "echo ${*echo \"hi\nbye\"}[1]" "bye\n"))) (ert-deftest esh-var-test/interp-temp-cmd () - "Interpolate command result redirected to temp file" + "Interpolate command result redirected to temp file." (eshell-command-result-equal "cat $<echo hi>" "hi")) (ert-deftest esh-var-test/interp-concat-lisp () - "Interpolate and concat Lisp form" + "Interpolate and concat Lisp form." (eshell-command-result-equal "+ $(+ 1 2)3 3" 36)) (ert-deftest esh-var-test/interp-concat-lisp2 () - "Interpolate and concat two Lisp forms" + "Interpolate and concat two Lisp forms." (eshell-command-result-equal "+ $(+ 1 2)$(+ 1 2) 3" 36)) (ert-deftest esh-var-test/interp-concat-cmd () - "Interpolate and concat command with literal" + "Interpolate and concat command with literal." (eshell-command-result-equal "+ ${+ 1 2}3 3" 36) (eshell-command-result-equal "echo ${*echo \"foo\nbar\"}-baz" '("foo" "bar-baz")) @@ -187,18 +286,21 @@ '("hi" "23"))) (ert-deftest esh-var-test/interp-concat-cmd2 () - "Interpolate and concat two commands" + "Interpolate and concat two commands." (eshell-command-result-equal "+ ${+ 1 2}${+ 1 2} 3" 36)) (ert-deftest esh-var-test/interp-concat-cmd-external () - "Interpolate command result from external command with concatenation" + "Interpolate command result from external command with concatenation." (skip-unless (executable-find "echo")) (with-temp-eshell (eshell-match-command-output "echo ${echo hi}-${*echo there}" "hi-there\n"))) + +;; Quoted variable interpolation + (ert-deftest esh-var-test/quoted-interp-var () - "Interpolate variable inside double-quotes" + "Interpolate variable inside double-quotes." (eshell-command-result-equal "echo \"$user-login-name\"" user-login-name)) @@ -209,8 +311,20 @@ (eshell-command-result-equal "echo \"hi, $\\\"user-login-name\\\"\"" (concat "hi, " user-login-name))) +(ert-deftest esh-var-test/quoted-interp-list-var () + "Interpolate list variable inside double-quotes." + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo \"$eshell-test-value\"" + "(1 2 3)"))) + +(ert-deftest esh-var-test/quoted-interp-list-var-concat () + "Interpolate and concat list variable inside double-quotes" + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo \"a$'eshell-test-value'z\"" + "a(1 2 3)z"))) + (ert-deftest esh-var-test/quoted-interp-var-indices () - "Interpolate string variable with indices inside double-quotes" + "Interpolate string variable with indices inside double-quotes." (let ((eshell-test-value '("zero" "one" "two" "three" "four"))) (eshell-command-result-equal "echo \"$eshell-test-value[0]\"" "zero") @@ -224,8 +338,21 @@ (eshell-command-result-equal "echo \"$eshell-test-value[1 2 4]\"" "(\"one\" \"two\" \"four\")"))) +(ert-deftest esh-var-test/quote-interp-var-indices-subcommand () + "Interpolate list variable with subcommand expansion for indices inside double-quotes." + (skip-unless (executable-find "echo")) + (let ((eshell-test-value '("zero" "one" "two" "three" "four"))) + (eshell-command-result-equal + "echo \"$eshell-test-value[${*echo 0}]\"" + "zero") + ;; FIXME: These tests would use the 0th index like the other tests + ;; here, but see above. + (eshell-command-result-equal + "echo \"$eshell-test-value[${*echo 1} ${*echo 2}]\"" + "(\"one\" \"two\")"))) + (ert-deftest esh-var-test/quoted-interp-var-split-indices () - "Interpolate string variable with indices inside double-quotes" + "Interpolate string variable with indices inside double-quotes." (let ((eshell-test-value "zero one two three four")) (eshell-command-result-equal "echo \"$eshell-test-value[0]\"" "zero") @@ -233,8 +360,7 @@ "(\"zero\" \"two\")"))) (ert-deftest esh-var-test/quoted-interp-var-string-split-indices () - "Interpolate string variable with string splitter and indices -inside double-quotes" + "Interpolate string variable with string splitter and indices inside double-quotes." (let ((eshell-test-value "zero:one:two:three:four")) (eshell-command-result-equal "echo \"$eshell-test-value[: 0]\"" "zero") @@ -247,7 +373,7 @@ inside double-quotes" "(\"zero\" \"two\")"))) (ert-deftest esh-var-test/quoted-interp-var-regexp-split-indices () - "Interpolate string variable with regexp splitter and indices" + "Interpolate string variable with regexp splitter and indices." (let ((eshell-test-value "zero:one!two:three!four")) (eshell-command-result-equal "echo \"$eshell-test-value['[:!]' 0]\"" "zero") @@ -260,7 +386,7 @@ inside double-quotes" "(\"zero\" \"two\")"))) (ert-deftest esh-var-test/quoted-interp-var-assoc () - "Interpolate alist variable with index inside double-quotes" + "Interpolate alist variable with index inside double-quotes." (let ((eshell-test-value '(("foo" . 1) (bar . 2)))) (eshell-command-result-equal "echo \"$eshell-test-value[foo]\"" "1") @@ -268,7 +394,7 @@ inside double-quotes" "2"))) (ert-deftest esh-var-test/quoted-interp-var-length-list () - "Interpolate length of list variable inside double-quotes" + "Interpolate length of list variable inside double-quotes." (let ((eshell-test-value '((1 2) (3) (5 (6 7 8 9))))) (eshell-command-result-equal "echo \"$#eshell-test-value\"" "3") @@ -278,63 +404,90 @@ inside double-quotes" "4"))) (ert-deftest esh-var-test/quoted-interp-var-length-string () - "Interpolate length of string variable inside double-quotes" + "Interpolate length of string variable inside double-quotes." (let ((eshell-test-value "foobar")) (eshell-command-result-equal "echo \"$#eshell-test-value\"" "6"))) (ert-deftest esh-var-test/quoted-interp-var-length-alist () - "Interpolate length of alist variable inside double-quotes" + "Interpolate length of alist variable inside double-quotes." (let ((eshell-test-value '(("foo" . (1 2 3))))) (eshell-command-result-equal "echo \"$#eshell-test-value\"" "1") (eshell-command-result-equal "echo \"$#eshell-test-value[foo]\"" "3"))) +(ert-deftest esh-var-test/quoted-interp-var-splice () + "Splice-interpolate list variable inside double-quotes." + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo a \"$@eshell-test-value\" z" + '("a" "1 2 3" "z")))) + +(ert-deftest esh-var-test/quoted-interp-var-splice-concat () + "Splice-interpolate and concat list variable inside double-quotes" + (let ((eshell-test-value '(1 2 3))) + (eshell-command-result-equal "echo \"a$@'eshell-test-value'z\"" + "a1 2 3z"))) + (ert-deftest esh-var-test/quoted-interp-lisp () - "Interpolate Lisp form evaluation inside double-quotes" + "Interpolate Lisp form evaluation inside double-quotes." (eshell-command-result-equal "echo \"hi $(concat \\\"the\\\" \\\"re\\\")\"" "hi there")) (ert-deftest esh-var-test/quoted-interp-lisp-indices () - "Interpolate Lisp form evaluation with index" + "Interpolate Lisp form evaluation with index." (eshell-command-result-equal "concat \"$(list 1 2)[1]\" cool" "2cool")) (ert-deftest esh-var-test/quoted-interp-cmd () - "Interpolate command result inside double-quotes" + "Interpolate command result inside double-quotes." (eshell-command-result-equal "echo \"hi ${echo \\\"there\\\"}\"" "hi there")) (ert-deftest esh-var-test/quoted-interp-cmd-indices () - "Interpolate command result with index inside double-quotes" + "Interpolate command result with index inside double-quotes." (eshell-command-result-equal "concat \"${listify 1 2}[1]\" cool" "2cool")) (ert-deftest esh-var-test/quoted-interp-temp-cmd () - "Interpolate command result redirected to temp file inside double-quotes" + "Interpolate command result redirected to temp file inside double-quotes." (let ((temporary-file-directory (file-name-as-directory (make-temp-file "esh-vars-tests" t)))) (unwind-protect - (eshell-command-result-equal "cat \"$<echo hi>\"" "hi") + (eshell-command-result-equal "cat \"$<echo \\\"hi\\\">\"" "hi") (delete-directory temporary-file-directory t)))) (ert-deftest esh-var-test/quoted-interp-concat-cmd () - "Interpolate and concat command with literal" + "Interpolate and concat command with literal." (eshell-command-result-equal "echo \"${echo \\\"foo\nbar\\\"} baz\"" "foo\nbar baz")) +;; Interpolating commands + +(ert-deftest esh-var-test/command-interp () + "Interpolate a variable as a command name." + (let ((eshell-test-value "printnl")) + (eshell-command-result-equal "$eshell-test-value hello there" + "hello\nthere\n"))) + +(ert-deftest esh-var-test/command-interp-splice () + "Interpolate a splice variable as a command name with arguments." + (let ((eshell-test-value '("printnl" "hello" "there"))) + (eshell-command-result-equal "$@eshell-test-value" + "hello\nthere\n"))) + + ;; Interpolated variable conversion (ert-deftest esh-var-test/interp-convert-var-number () - "Interpolate numeric variable" + "Interpolate numeric variable." (let ((eshell-test-value 123)) (eshell-command-result-equal "type-of $eshell-test-value" 'integer))) (ert-deftest esh-var-test/interp-convert-var-split-indices () - "Interpolate and convert string variable with indices" + "Interpolate and convert string variable with indices." ;; Check that numeric forms are converted to numbers. (let ((eshell-test-value "000 010 020 030 040")) (eshell-command-result-equal "echo $eshell-test-value[0]" @@ -349,7 +502,7 @@ inside double-quotes" "baz\n"))) (ert-deftest esh-var-test/interp-convert-quoted-var-number () - "Interpolate numeric quoted numeric variable" + "Interpolate numeric quoted numeric variable." (let ((eshell-test-value 123)) (eshell-command-result-equal "type-of $'eshell-test-value'" 'integer) @@ -357,7 +510,7 @@ inside double-quotes" 'integer))) (ert-deftest esh-var-test/interp-convert-quoted-var-split-indices () - "Interpolate and convert quoted string variable with indices" + "Interpolate and convert quoted string variable with indices." (let ((eshell-test-value "000 010 020 030 040")) (eshell-command-result-equal "echo $'eshell-test-value'[0]" 0) @@ -365,11 +518,11 @@ inside double-quotes" '(0 20)))) (ert-deftest esh-var-test/interp-convert-cmd-string-newline () - "Interpolate trailing-newline command result" + "Interpolate trailing-newline command result." (eshell-command-result-equal "echo ${echo \"foo\n\"}" "foo")) (ert-deftest esh-var-test/interp-convert-cmd-multiline () - "Interpolate multi-line command result" + "Interpolate multi-line command result." (eshell-command-result-equal "echo ${echo \"foo\nbar\"}" '("foo" "bar")) ;; Numeric output should be converted to numbers... @@ -380,24 +533,24 @@ inside double-quotes" '("01" "02" "hi"))) (ert-deftest esh-var-test/interp-convert-cmd-number () - "Interpolate numeric command result" + "Interpolate numeric command result." (eshell-command-result-equal "echo ${echo \"1\"}" 1)) (ert-deftest esh-var-test/interp-convert-cmd-split-indices () - "Interpolate command result with indices" + "Interpolate command result with indices." (eshell-command-result-equal "echo ${echo \"000 010 020\"}[0]" 0) (eshell-command-result-equal "echo ${echo \"000 010 020\"}[0 2]" '(0 20))) (ert-deftest esh-var-test/quoted-interp-convert-var-number () - "Interpolate numeric variable inside double-quotes" + "Interpolate numeric variable inside double-quotes." (let ((eshell-test-value 123)) (eshell-command-result-equal "type-of \"$eshell-test-value\"" 'string))) (ert-deftest esh-var-test/quoted-interp-convert-var-split-indices () - "Interpolate string variable with indices inside double-quotes" + "Interpolate string variable with indices inside double-quotes." (let ((eshell-test-value "000 010 020 030 040")) (eshell-command-result-equal "echo \"$eshell-test-value[0]\"" "000") @@ -405,7 +558,7 @@ inside double-quotes" "(\"000\" \"020\")"))) (ert-deftest esh-var-test/quoted-interp-convert-quoted-var-number () - "Interpolate numeric quoted variable inside double-quotes" + "Interpolate numeric quoted variable inside double-quotes." (let ((eshell-test-value 123)) (eshell-command-result-equal "type-of \"$'eshell-test-value'\"" 'string) @@ -413,7 +566,7 @@ inside double-quotes" 'string))) (ert-deftest esh-var-test/quoted-interp-convert-quoted-var-split-indices () - "Interpolate quoted string variable with indices inside double-quotes" + "Interpolate quoted string variable with indices inside double-quotes." (let ((eshell-test-value "000 010 020 030 040")) (eshell-command-result-equal "echo \"$eshell-test-value[0]\"" "000") @@ -421,23 +574,23 @@ inside double-quotes" "(\"000\" \"020\")"))) (ert-deftest esh-var-test/quoted-interp-convert-cmd-string-newline () - "Interpolate trailing-newline command result inside double-quotes" + "Interpolate trailing-newline command result inside double-quotes." (eshell-command-result-equal "echo \"${echo \\\"foo\n\\\"}\"" "foo") (eshell-command-result-equal "echo \"${echo \\\"foo\n\n\\\"}\"" "foo")) (ert-deftest esh-var-test/quoted-interp-convert-cmd-multiline () - "Interpolate multi-line command result inside double-quotes" + "Interpolate multi-line command result inside double-quotes." (eshell-command-result-equal "echo \"${echo \\\"foo\nbar\\\"}\"" "foo\nbar")) (ert-deftest esh-var-test/quoted-interp-convert-cmd-number () - "Interpolate numeric command result inside double-quotes" + "Interpolate numeric command result inside double-quotes." (eshell-command-result-equal "echo \"${echo \\\"1\\\"}\"" "1")) (ert-deftest esh-var-test/quoted-interp-convert-cmd-split-indices () - "Interpolate command result with indices inside double-quotes" + "Interpolate command result with indices inside double-quotes." (eshell-command-result-equal "echo \"${echo \\\"000 010 020\\\"}[0]\"" "000")) @@ -492,6 +645,14 @@ inside double-quotes" (eshell-match-command-output "VAR=hello env" "VAR=hello\n") (should (equal (getenv "VAR") "value")))) +(ert-deftest esh-var-test/local-variables/skip-nil () + "Test that Eshell skips leading nil arguments after local variable setting." + (with-temp-eshell + (push "VAR=value" process-environment) + (eshell-match-command-output "VAR=hello $eshell-test-value env" + "VAR=hello\n") + (should (equal (getenv "VAR") "value")))) + ;; Variable aliases @@ -596,23 +757,69 @@ it, since the setter is nil." (window-body-height nil 'remap))) (ert-deftest esh-var-test/columns-var () - "$COLUMNS should equal (window-body-width nil 'remap)" + "$COLUMNS should equal (window-body-width nil 'remap)." (eshell-command-result-equal "echo $COLUMNS" (window-body-width nil 'remap))) (ert-deftest esh-var-test/inside-emacs-var () - "Test presence of \"INSIDE_EMACS\" in subprocesses" + "Test presence of \"INSIDE_EMACS\" in subprocesses." (with-temp-eshell (eshell-match-command-output "env" (format "INSIDE_EMACS=%s,eshell" emacs-version)))) (ert-deftest esh-var-test/inside-emacs-var-split-indices () - "Test using \"INSIDE_EMACS\" with split indices" + "Test using \"INSIDE_EMACS\" with split indices." (with-temp-eshell (eshell-match-command-output "echo $INSIDE_EMACS[, 1]" "eshell"))) +(ert-deftest esh-var-test/pager-var/default () + "Test that retrieving the default value of $PAGER works. +This should be the value of `comint-pager' if non-nil, otherwise +the value of the $PAGER env var." + (let ((comint-pager nil) + (process-environment (cons "PAGER=cat" process-environment))) + (eshell-command-result-equal "echo $PAGER" "cat") + (setq comint-pager "less") + (eshell-command-result-equal "echo $PAGER" "less"))) + +(ert-deftest esh-var-test/pager-var/set () + "Test that setting $PAGER in Eshell overrides the default value." + (let ((comint-pager nil) + (process-environment (cons "PAGER=cat" process-environment))) + (with-temp-eshell + (eshell-match-command-output "set PAGER bat" "bat") + (eshell-match-command-output "echo $PAGER" "bat")) + (setq comint-pager "less") + (with-temp-eshell + (eshell-match-command-output "set PAGER bat" "bat") + (eshell-match-command-output "echo $PAGER" "bat")))) + +(ert-deftest esh-var-test/pager-var/unset () + "Test that unsetting $PAGER in Eshell overrides the default value." + (let ((comint-pager nil) + (process-environment (cons "PAGER=cat" process-environment))) + (with-temp-eshell + (eshell-insert-command "unset PAGER") + (eshell-match-command-output "echo $PAGER" "\\`\\'")) + (setq comint-pager "less") + (with-temp-eshell + (eshell-insert-command "unset PAGER") + (eshell-match-command-output "echo $PAGER" "\\`\\'")))) + +(ert-deftest esh-var-test/pager-var/set-locally () + "Test setting $PAGER temporarily for a single command." + (let ((comint-pager nil) + (process-environment (cons "PAGER=cat" process-environment))) + (with-temp-eshell + (eshell-match-command-output "PAGER=bat env" "PAGER=bat\n") + (eshell-match-command-output "echo $PAGER" "cat")) + (setq comint-pager "less") + (with-temp-eshell + (eshell-match-command-output "PAGER=bat env" "PAGER=bat\n") + (eshell-match-command-output "echo $PAGER" "less")))) + (ert-deftest esh-var-test/path-var/local-directory () "Test using $PATH in a local directory." (let ((expected-path (string-join (eshell-get-path t) (path-separator)))) @@ -672,8 +879,16 @@ it, since the setter is nil." (format "cd %s" ert-remote-temporary-file-directory)) (eshell-match-command-output "echo $PATH" (regexp-quote remote-path))))) +(ert-deftest esh-var-test/uid-var () + "Test that $UID is equivalent to (user-uid) for local directories." + (eshell-command-result-equal "echo $UID" (user-uid))) + +(ert-deftest esh-var-test/gid-var () + "Test that $GID is equivalent to (group-gid) for local directories." + (eshell-command-result-equal "echo $GID" (group-gid))) + (ert-deftest esh-var-test/last-status-var-lisp-command () - "Test using the \"last exit status\" ($?) variable with a Lisp command" + "Test using the \"last exit status\" ($?) variable with a Lisp command." (with-temp-eshell (eshell-match-command-output "zerop 0; echo $?" "t\n0\n") @@ -683,7 +898,7 @@ it, since the setter is nil." "1\n" nil t))) (ert-deftest esh-var-test/last-status-var-lisp-form () - "Test using the \"last exit status\" ($?) variable with a Lisp form" + "Test using the \"last exit status\" ($?) variable with a Lisp form." (let ((eshell-lisp-form-nil-is-failure t)) (with-temp-eshell (eshell-match-command-output "(zerop 0); echo $?" @@ -706,7 +921,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." "1\n" nil t)))) (ert-deftest esh-var-test/last-status-var-ext-cmd () - "Test using the \"last exit status\" ($?) variable with an external command" + "Test using the \"last exit status\" ($?) variable with an external command." (skip-unless (executable-find "[")) (with-temp-eshell (eshell-match-command-output "[ foo = foo ]; echo $?" @@ -715,19 +930,19 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." "1\n"))) (ert-deftest esh-var-test/last-result-var () - "Test using the \"last result\" ($$) variable" + "Test using the \"last result\" ($$) variable." (with-temp-eshell (eshell-match-command-output "+ 1 2; + $$ 2" "3\n5\n"))) (ert-deftest esh-var-test/last-result-var-twice () - "Test using the \"last result\" ($$) variable twice" + "Test using the \"last result\" ($$) variable twice." (with-temp-eshell (eshell-match-command-output "+ 1 2; + $$ $$" "3\n6\n"))) (ert-deftest esh-var-test/last-result-var-ext-cmd () - "Test using the \"last result\" ($$) variable with an external command" + "Test using the \"last result\" ($$) variable with an external command." (skip-unless (executable-find "[")) (with-temp-eshell ;; MS-DOS/MS-Windows have an external command 'format', which we @@ -739,7 +954,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." "nil\n")))) (ert-deftest esh-var-test/last-result-var-split-indices () - "Test using the \"last result\" ($$) variable with split indices" + "Test using the \"last result\" ($$) variable with split indices." (with-temp-eshell (eshell-match-command-output "string-join (list \"01\" \"02\") :; + $$[: 1] 3" @@ -749,13 +964,13 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." "01:02\n02\n"))) (ert-deftest esh-var-test/last-arg-var () - "Test using the \"last arg\" ($_) variable" + "Test using the \"last arg\" ($_) variable." (with-temp-eshell (eshell-match-command-output "+ 1 2; + $_ 4" "3\n6\n"))) (ert-deftest esh-var-test/last-arg-var-indices () - "Test using the \"last arg\" ($_) variable with indices" + "Test using the \"last arg\" ($_) variable with indices." (with-temp-eshell (eshell-match-command-output "+ 1 2; + $_[0] 4" "3\n5\n") @@ -763,7 +978,7 @@ This tests when `eshell-lisp-form-nil-is-failure' is nil." "3\n6\n"))) (ert-deftest esh-var-test/last-arg-var-split-indices () - "Test using the \"last arg\" ($_) variable with split indices" + "Test using the \"last arg\" ($_) variable with split indices." (with-temp-eshell (eshell-match-command-output "concat 01:02 03:04; + $_[0][: 1] 5" "01:0203:04\n7\n") diff --git a/test/lisp/eshell/eshell-tests-helpers.el b/test/lisp/eshell/eshell-tests-helpers.el index f1d12dbe9f3..c983c8fd2bb 100644 --- a/test/lisp/eshell/eshell-tests-helpers.el +++ b/test/lisp/eshell/eshell-tests-helpers.el @@ -33,9 +33,9 @@ (defvar eshell-history-file-name nil) (defvar eshell-last-dir-ring-file-name nil) -(defvar eshell-test--max-subprocess-time 5 - "The maximum amount of time to wait for a subprocess to finish, in seconds. -See `eshell-wait-for-subprocess'.") +(defvar eshell-test--max-wait-time 5 + "The maximum amount of time to wait for a condition to resolve, in seconds. +See `eshell-wait-for'.") (defun eshell-tests-remote-accessible-p () "Return if a test involving remote files can proceed. @@ -54,6 +54,13 @@ beginning of the test file." (let* (;; We want no history file, so prevent Eshell from falling ;; back on $HISTFILE. (process-environment (cons "HISTFILE" process-environment)) + ;; Enable process debug instrumentation. We may be able + ;; to remove this eventually once we're confident that + ;; all the process bugs have been worked out. (At that + ;; point, we can just enable this selectively when + ;; needed.) See also `eshell-test-command-result' + ;; below. + (eshell-debug-command (cons 'process eshell-debug-command)) (eshell-history-file-name nil) (eshell-last-dir-ring-file-name nil) (eshell-buffer (eshell t))) @@ -73,19 +80,35 @@ BUFNAME will be set to the name of the temporary buffer." (let ((,bufname (buffer-name))) ,@body))) +(defun eshell-wait-for (predicate &optional message) + "Wait until PREDICATE returns non-nil. +If this takes longer than `eshell-test--max-wait-time', raise an +error. MESSAGE is an optional message to use if this times out." + (let ((start (current-time)) + (message (or message "timed out waiting for condition"))) + (while (not (funcall predicate)) + (when (> (float-time (time-since start)) + eshell-test--max-wait-time) + (error message)) + (sit-for 0.1)))) + (defun eshell-wait-for-subprocess (&optional all) "Wait until there is no interactive subprocess running in Eshell. If ALL is non-nil, wait until there are no Eshell subprocesses at all running. -If this takes longer than `eshell-test--max-subprocess-time', +If this takes longer than `eshell-test--max-wait-time', raise an error." - (let ((start (current-time))) - (while (if all eshell-process-list (eshell-interactive-process-p)) - (when (> (float-time (time-since start)) - eshell-test--max-subprocess-time) - (error "timed out waiting for subprocess(es)")) - (sit-for 0.1)))) + (eshell-wait-for + (lambda () + (not (if all eshell-process-list (eshell-interactive-process-p)))))) + +(defun eshell-get-debug-logs () + "Get debug command logs for displaying on test failures." + (when (get-buffer eshell-debug-command-buffer) + (let ((separator (make-string 40 ?-))) + (with-current-buffer eshell-debug-command-buffer + (string-replace "\f" separator (buffer-string)))))) (defun eshell-insert-command (command &optional func) "Insert a COMMAND at the end of the buffer. @@ -126,17 +149,21 @@ FUNC is the function to call after inserting the text (see If IGNORE-ERRORS is non-nil, ignore any errors signaled when inserting the command." - (let ((debug-on-error (and (not ignore-errors) debug-on-error))) - (eshell-insert-command command func)) - (eshell-wait-for-subprocess) - (should (eshell-match-output regexp))) + (ert-info (#'eshell-get-debug-logs :prefix "Command logs: ") + (let ((debug-on-error (and (not ignore-errors) debug-on-error))) + (eshell-insert-command command func)) + (eshell-wait-for-subprocess) + (should (eshell-match-output regexp)))) (defvar eshell-history-file-name) (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." (ert-with-temp-directory eshell-directory-name - (let ((eshell-history-file-name nil)) + (let ((eshell-history-file-name nil) + ;; Enable process debug instrumentation. See + ;; `with-temp-eshell' above. + (eshell-debug-command (cons 'process eshell-debug-command))) (eshell-command-result command)))) (defun eshell-command-result--equal (_command actual expected) @@ -155,10 +182,11 @@ inserting the command." (defun eshell-command-result-equal (command result) "Execute COMMAND non-interactively and compare it to RESULT." - (should (eshell-command-result--equal - command - (eshell-test-command-result command) - result))) + (ert-info (#'eshell-get-debug-logs :prefix "Command logs: ") + (should (eshell-command-result--equal + command + (eshell-test-command-result command) + result)))) (provide 'eshell-tests-helpers) diff --git a/test/lisp/eshell/eshell-tests-unload.el b/test/lisp/eshell/eshell-tests-unload.el new file mode 100644 index 00000000000..cdd58efef18 --- /dev/null +++ b/test/lisp/eshell/eshell-tests-unload.el @@ -0,0 +1,99 @@ +;;; eshell-tests-unload.el --- test unloading Eshell -*- 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: + +;; Tests for unloading Eshell. + +;;; Code: + +(require 'ert) +(require 'ert-x) + +;; In order to test unloading Eshell, don't require any of its files +;; at the top level. This means we need to explicitly declare some of +;; the variables and functions we'll use. +(defvar eshell-directory-name) +(defvar eshell-history-file-name) +(defvar eshell-last-dir-ring-file-name) +(defvar eshell-modules-list) + +(declare-function eshell-module--feature-name "esh-module" + (module &optional kind)) +(declare-function eshell-subgroups "esh-util" (groupsym)) + +(defvar max-unload-time 5 + "The maximum amount of time to wait to unload Eshell modules, in seconds. +See `unload-eshell'.") + +(defun load-eshell () + "Load Eshell by calling the `eshell' function and immediately closing it." + (save-current-buffer + (ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-last-dir-ring-file-name nil) + (eshell-buffer (eshell t))) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer)))))) + +(defun unload-eshell () + "Unload Eshell, waiting until the core modules are unloaded as well." + (let ((debug-on-error t) + (inhibit-message t)) + (unload-feature 'eshell) + ;; We unload core modules are unloaded from a timer, since they + ;; need to wait until after `eshell' itself is unloaded. Wait for + ;; this to finish. + (let ((start (current-time))) + (while (featurep 'esh-arg) + (when (> (float-time (time-since start)) + max-unload-time) + (error "timed out waiting to unload Eshell modules")) + (sit-for 0.1))))) + +;;; Tests: + +(ert-deftest eshell-test-unload/default () + "Test unloading Eshell with the default list of extension modules." + (load-eshell) + (unload-eshell)) + +(ert-deftest eshell-test-unload/no-modules () + "Test unloading Eshell with no extension modules." + (require 'esh-module) + (let (eshell-modules-list) + (load-eshell)) + (dolist (module (eshell-subgroups 'eshell-module)) + (should-not (featurep (intern (eshell-module--feature-name module))))) + (unload-eshell)) + +(ert-deftest eshell-test-unload/all-modules () + "Test unloading Eshell with every extension module." + (require 'esh-module) + (let ((eshell-modules-list (eshell-subgroups 'eshell-module))) + (load-eshell)) + (dolist (module (eshell-subgroups 'eshell-module)) + (should (featurep (intern (eshell-module--feature-name module))))) + (unload-eshell)) + +(provide 'eshell-tests-unload) +;;; eshell-tests-unload.el ends here diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index fbff51a8873..d2ef44ae507 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -34,76 +34,9 @@ (file-name-directory (or load-file-name default-directory)))) -;;; Tests: - -(ert-deftest eshell-test/pipe-headproc () - "Check that piping a non-process to a process command waits for the process" - (skip-unless (executable-find "cat")) - (with-temp-eshell - (eshell-match-command-output "echo hi | *cat" - "hi"))) - -(ert-deftest eshell-test/pipe-tailproc () - "Check that piping a process to a non-process command waits for the process" - (skip-unless (executable-find "echo")) - (with-temp-eshell - (eshell-match-command-output "*echo hi | echo bye" - "bye\nhi\n"))) - -(ert-deftest eshell-test/pipe-headproc-stdin () - "Check that standard input is sent to the head process in a pipeline" - (skip-unless (and (executable-find "tr") - (executable-find "rev"))) - (with-temp-eshell - (eshell-insert-command "tr a-z A-Z | rev") - (eshell-insert-command "hello") - (eshell-send-eof-to-process) - (eshell-wait-for-subprocess) - (should (eshell-match-output "OLLEH\n")))) - -(ert-deftest eshell-test/pipe-subcommand () - "Check that piping with an asynchronous subcommand works" - (skip-unless (and (executable-find "echo") - (executable-find "cat"))) - (with-temp-eshell - (eshell-match-command-output "echo ${*echo hi} | *cat" - "hi"))) +(defvar eshell-test-value nil) -(ert-deftest eshell-test/pipe-subcommand-with-pipe () - "Check that piping with an asynchronous subcommand with its own pipe works" - (skip-unless (and (executable-find "echo") - (executable-find "cat"))) - (with-temp-eshell - (eshell-match-command-output "echo ${*echo hi | *cat} | *cat" - "hi"))) - -(ert-deftest eshell-test/subcommand-reset-in-pipeline () - "Check that subcommands reset `eshell-in-pipeline-p'." - (skip-unless (executable-find "cat")) - (dolist (template '("echo {%s} | *cat" - "echo ${%s} | *cat" - "*cat $<%s> | *cat")) - (eshell-command-result-equal - (format template "echo $eshell-in-pipeline-p") - nil) - (eshell-command-result-equal - (format template "echo | echo $eshell-in-pipeline-p") - "last") - (eshell-command-result-equal - (format template "echo $eshell-in-pipeline-p | echo") - "first") - (eshell-command-result-equal - (format template "echo | echo $eshell-in-pipeline-p | echo") - "t"))) - -(ert-deftest eshell-test/lisp-reset-in-pipeline () - "Check that interpolated Lisp forms reset `eshell-in-pipeline-p'." - (skip-unless (executable-find "cat")) - (dolist (template '("echo (%s) | *cat" - "echo $(%s) | *cat")) - (eshell-command-result-equal - (format template "format \"%s\" eshell-in-pipeline-p") - "nil"))) +;;; Tests: (ert-deftest eshell-test/eshell-command/simple () "Test that the `eshell-command' function writes to the current buffer." @@ -125,21 +58,28 @@ This test uses a pipeline for the command." (eshell-command "*echo hi | *cat" t) (should (equal (buffer-string) "hi\n")))))) +(ert-deftest eshell-test/eshell-command/pipeline-wait () + "Check that `eshell-command' waits for all its processes before returning." + (skip-unless (and (executable-find "echo") + (executable-find "sh") + (executable-find "rev"))) + (ert-with-temp-directory eshell-directory-name + (let ((eshell-history-file-name nil)) + (with-temp-buffer + (eshell-command + "*echo hello | sh -c 'sleep 1; rev' 1>&2 | *echo goodbye" t) + (should (equal (buffer-string) "goodbye\nolleh\n")))))) + (ert-deftest eshell-test/eshell-command/background () "Test that `eshell-command' works for background commands." (skip-unless (executable-find "echo")) (ert-with-temp-directory eshell-directory-name - (let ((eshell-history-file-name nil)) - ;; XXX: We can't write to the current buffer here, since - ;; `eshell-command' will produce an invalid command in that - ;; case. Just make sure the command runs and produces an output - ;; buffer. - (eshell-command "*echo hi &") - (with-current-buffer "*Eshell Async Command Output*" - (while (get-buffer-process (current-buffer)) - (accept-process-output)) - (goto-char (point-min)) - (should (looking-at "\\[echo\\(\\.exe\\)?\\(<[0-9]+>\\)?\\]")))))) + (let ((orig-processes (process-list)) + (eshell-history-file-name nil)) + (with-temp-buffer + (eshell-command "*echo hi &" t) + (eshell-wait-for (lambda () (equal (process-list) orig-processes))) + (should (equal (buffer-string) "hi\n")))))) (ert-deftest eshell-test/eshell-command/background-pipeline () "Test that `eshell-command' works for background commands. @@ -147,14 +87,35 @@ This test uses a pipeline for the command." (skip-unless (and (executable-find "echo") (executable-find "cat"))) (ert-with-temp-directory eshell-directory-name + (let ((orig-processes (process-list)) + (eshell-history-file-name nil)) + (with-temp-buffer + (eshell-command "*echo hi | *cat &" t) + (eshell-wait-for (lambda () (equal (process-list) orig-processes))) + (should (equal (buffer-string) "hi\n")))))) + +(ert-deftest eshell-test/eshell-command/output-buffer/sync () + "Test that the `eshell-command' function writes to its output buffer." + (skip-unless (executable-find "echo")) + (ert-with-temp-directory eshell-directory-name (let ((eshell-history-file-name nil)) - ;; XXX: As above, we can't write to the current buffer here. - (eshell-command "*echo hi | *cat &") + (eshell-command "*echo 'hi\nbye'") + (with-current-buffer "*Eshell Command Output*" + (should (equal (buffer-string) "hi\nbye"))) + (kill-buffer "*Eshell Command Output*")))) + +(ert-deftest eshell-test/eshell-command/output-buffer/async () + "Test that the `eshell-command' function writes to its async output buffer." + (skip-unless (executable-find "echo")) + (ert-with-temp-directory eshell-directory-name + (let ((orig-processes (process-list)) + (eshell-history-file-name nil)) + (eshell-command "*echo hi &") + (eshell-wait-for (lambda () (equal (process-list) orig-processes))) (with-current-buffer "*Eshell Async Command Output*" - (while (get-buffer-process (current-buffer)) - (accept-process-output)) (goto-char (point-min)) - (should (looking-at "\\[cat\\(\\.exe\\)?\\(<[0-9]+>\\)?\\]")))))) + (forward-line) + (should (looking-at "hi\n")))))) (ert-deftest eshell-test/command-running-p () "Modeline should show no command running" @@ -167,28 +128,26 @@ This test uses a pipeline for the command." "Test moving across command arguments" (with-temp-eshell (eshell-insert-command "echo $(+ 1 (- 4 3)) \"alpha beta\" file" 'ignore) - (let ((here (point)) begin valid) - (eshell-bol) + (let ((end (point)) begin) + (beginning-of-line) (setq begin (point)) (eshell-forward-argument 4) - (setq valid (= here (point))) + (should (= end (point))) (eshell-backward-argument 4) - (prog1 - (and valid (= begin (point))) - (eshell-bol) - (delete-region (point) (point-max)))))) + (should (= begin (point)))))) (ert-deftest eshell-test/queue-input () - "Test queuing command input" + "Test queuing command input. +This should let the current command finish, then automatically +insert the queued one at the next prompt, and finally run it." (with-temp-eshell - (eshell-insert-command "sleep 2") - (eshell-insert-command "echo alpha" 'eshell-queue-input) - (let ((count 10)) - (while (and eshell-current-command - (> count 0)) - (sit-for 1) - (setq count (1- count)))) - (should (eshell-match-output "alpha\n")))) + (eshell-insert-command "sleep 1; echo slept") + (eshell-insert-command "echo alpha" #'eshell-queue-input) + (let ((start (marker-position (eshell-beginning-of-output)))) + (eshell-wait-for (lambda () (not eshell-foreground-command))) + (should (string-match "^slept\n.*echo alpha\nalpha\n$" + (buffer-substring-no-properties + start (eshell-end-of-output))))))) (ert-deftest eshell-test/flush-output () "Test flushing of previous output" @@ -198,12 +157,62 @@ This test uses a pipeline for the command." (should (eshell-match-output (concat "^" (regexp-quote "*** output flushed ***\n") "$"))))) -(ert-deftest eshell-test/run-old-command () - "Re-run an old command" +(ert-deftest eshell-test/get-old-input () + "Test that we can get the input of a previous command." (with-temp-eshell (eshell-insert-command "echo alpha") (goto-char eshell-last-input-start) - (string= (eshell-get-old-input) "echo alpha"))) + (should (string= (eshell-get-old-input) "echo alpha")) + ;; Make sure that `eshell-get-old-input' works even if the point is + ;; inside the prompt. + (let ((inhibit-field-text-motion t)) + (beginning-of-line)) + (should (string= (eshell-get-old-input) "echo alpha")))) + +(ert-deftest eshell-test/get-old-input/rerun-command () + "Test that we can rerun an old command when point is on it." + (with-temp-eshell + (let ((eshell-test-value "first")) + (eshell-match-command-output "echo $eshell-test-value" "first")) + ;; Go to the previous prompt. + (forward-line -2) + (let ((inhibit-field-text-motion t)) + (end-of-line)) + ;; Rerun the command, but with a different variable value. + (let ((eshell-test-value "second")) + (eshell-send-input)) + (eshell-match-output "second"))) + +(ert-deftest eshell-test/get-old-input/run-output () + "Test that we can run a line of output as a command when point is on it." + (with-temp-eshell + (eshell-match-command-output "echo \"echo there\"" "echo there") + ;; Go to the output, and insert "hello" after "echo". + (forward-line -1) + (forward-word) + (insert " hello") + ;; Run the line as a command. + (eshell-send-input) + (eshell-match-output "(\"hello\" \"there\")"))) + +(ert-deftest eshell-test/yank-output () + "Test that yanking a line of output into the next prompt works (bug#66469)." + (with-temp-eshell + (eshell-insert-command "echo hello") + ;; Go to the output and kill the line of text. + (forward-line -1) + (kill-line) + ;; Go to the last prompt and yank the previous output. + (goto-char (point-max)) + (yank) + ;; Go to the beginning of the prompt and add some text. + (move-beginning-of-line 1) + (insert-and-inherit "echo ") + ;; Make sure when we go to the beginning of the line, we go to the + ;; right spot (before the "echo"). + (move-end-of-line 1) + (move-beginning-of-line 1) + (should (looking-at "echo hello")))) (provide 'eshell-tests) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index bc094345ffe..eb485a10a92 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -939,10 +939,13 @@ delivered." :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) - ;; `auto-revert-buffers' runs every 5". And we must wait, until the - ;; file has been reverted. - (let ((timeout (if (file-remote-p temporary-file-directory) 60 10)) - buf) + ;; Run with shortened `auto-revert-interval' for a faster test. + (let* ((auto-revert-interval 1) + (timeout (if (file-remote-p temporary-file-directory) + 60 ; FIXME: can this be shortened? + (* auto-revert-interval 2.5))) + buf) + (auto-revert-set-timer) (unwind-protect (progn ;; In the remote case, `vc-refresh-state' returns undesired @@ -960,10 +963,9 @@ delivered." (sleep-for 1) (auto-revert-mode 1) - ;; `auto-revert-buffers' runs every 5". (with-timeout (timeout (ignore)) (while (null auto-revert-notify-watch-descriptor) - (sleep-for 1))) + (sleep-for 0.2))) ;; `file-notify--test-monitor' needs to know ;; `file-notify--test-desc' in order to compute proper @@ -971,8 +973,7 @@ delivered." (setq file-notify--test-desc auto-revert-notify-watch-descriptor) ;; GKqueueFileMonitor does not report the `changed' event. - (skip-unless - (not (eq (file-notify--test-monitor) 'GKqueueFileMonitor))) + (skip-when (eq (file-notify--test-monitor) 'GKqueueFileMonitor)) ;; Check, that file notification has been used. (should auto-revert-mode) @@ -1032,7 +1033,7 @@ delivered." (file-notify--test-cleanup)))) (file-notify--deftest-remote file-notify-test04-autorevert - "Check autorevert via file notification for remote files.") + "Check autorevert via file notification for remote files." t) (ert-deftest file-notify-test05-file-validity () "Check `file-notify-valid-p' for files." @@ -1581,7 +1582,7 @@ the file watch." :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) ;; This test does not work for kqueue (yet). - (skip-unless (not (string-equal (file-notify--test-library) "kqueue"))) + (skip-when (string-equal (file-notify--test-library) "kqueue")) (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) file-notify--test-tmpfile1 (file-notify--test-make-temp-name)) @@ -1706,6 +1707,71 @@ the file watch." (file-notify--deftest-remote file-notify-test11-symlinks "Check `file-notify-test11-symlinks' for remote files.") +(ert-deftest file-notify-test12-unmount () + "Check that file notification stop after unmounting the filesystem." + :tags '(:expensive-test) + (skip-unless (file-notify--test-local-enabled)) + ;; This test does not work for w32notify. + (skip-when (string-equal (file-notify--test-library) "w32notify")) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + ;; File monitors like kqueue insist, that the watched file + ;; exists. Directory monitors are not bound to this + ;; restriction. + (when (string-equal (file-notify--test-library) "kqueue") + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message)) + + (should + (setq file-notify--test-desc + (file-notify--test-add-watch + file-notify--test-tmpfile + '(attribute-change change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + + ;; Unmounting the filesystem should stop watching. + (file-notify--test-with-actions '(stopped) + ;; We emulate unmounting by calling + ;; `file-notify-handle-event' with a corresponding event. + (file-notify-handle-event + (make-file-notify + :-event + (list file-notify--test-desc + (pcase (file-notify--test-library) + ((or "inotify" "inotifywait") '(unmount isdir)) + ((or "gfilenotify" "gio") '(unmounted)) + ("kqueue" '(revoke)) + (err (ert-fail (format "Library %s not supported" err)))) + (pcase (file-notify--test-library) + ("kqueue" (file-local-name file-notify--test-tmpfile)) + (_ (file-local-name file-notify--test-tmpdir))) + ;; In the inotify case, there is a 4th slot `cookie'. + ;; Since it is unused for `unmount', we ignore it. + ) + :-callback + (pcase (file-notify--test-library) + ("inotify" #'file-notify--callback-inotify) + ("gfilenotify" #'file-notify--callback-gfilenotify) + ("kqueue" #'file-notify--callback-kqueue) + ((or "inotifywait" "gio") #'file-notify-callback) + (err (ert-fail (format "Library %s not supported" err))))))) + + ;; The watch has been stopped. + (should-not (file-notify-valid-p file-notify--test-desc)) + + ;; The environment shall be cleaned up. + (when (string-equal (file-notify--test-library) "kqueue") + (delete-file file-notify--test-tmpfile)) + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test12-unmount + "Check `file-notify-test12-unmount' for remote files.") + (defun file-notify-test-all (&optional interactive) "Run all tests for \\[file-notify]." (interactive "p") diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 78d469580ba..24b144c4247 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -166,6 +166,27 @@ form.") (hack-local-variables) (should (eq lexical-binding nil))))) +(ert-deftest files-tests-safe-local-variable-directories () + ;; safe-local-variable-directories should be risky, + ;; so use it as an arbitrary risky variable. + (let ((test-alist '((safe-local-variable-directories . "some_val"))) + (fakedir default-directory) + (enable-local-eval t)) + (with-temp-buffer + (setq safe-local-variable-directories (list fakedir)) + (hack-local-variables-filter test-alist fakedir) + (should (equal file-local-variables-alist test-alist))) + (with-temp-buffer + (setq safe-local-variable-directories (list fakedir)) + (setq noninteractive t) + (hack-local-variables-filter test-alist "wrong") + (should-not (equal file-local-variables-alist test-alist))) + (with-temp-buffer + (setq safe-local-variable-directories '()) + (setq noninteractive t) + (hack-local-variables-filter test-alist fakedir) + (should-not (equal file-local-variables-alist test-alist))))) + (defvar files-test-bug-18141-file (ert-resource-file "files-bug18141.el.gz") "Test file for bug#18141.") @@ -1201,30 +1222,30 @@ unquoted file names." (let ((process-environment (cons "FOO=foo" process-environment)) (nospecial-foo (files-tests--new-name nospecial "$FOO"))) ;; The "/:" prevents substitution. - (equal (substitute-in-file-name nospecial-foo) nospecial-foo))) + (should (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))) (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) (let ((process-environment (cons "FOO=foo" process-environment)) (nospecial-foo (files-tests--new-name nospecial "$FOO"))) ;; The "/:" prevents substitution. - (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))) + (should (equal (substitute-in-file-name nospecial-foo) nospecial-foo))))) (ert-deftest files-tests-file-name-non-special-temporary-file-directory () (files-tests--with-temp-non-special (tmpdir nospecial-dir t) (let ((default-directory nospecial-dir)) - (equal (temporary-file-directory) temporary-file-directory))) + (should (equal (temporary-file-directory) temporary-file-directory)))) (files-tests--with-temp-non-special-and-file-name-handler (tmpdir nospecial-dir t) (let ((default-directory nospecial-dir)) - (equal (temporary-file-directory) temporary-file-directory)))) + (should (equal (temporary-file-directory) temporary-file-directory))))) (ert-deftest files-tests-file-name-non-special-unhandled-file-name-directory () (files-tests--with-temp-non-special (tmpdir nospecial-dir t) - (equal (unhandled-file-name-directory nospecial-dir) - (file-name-as-directory tmpdir))) + (should (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir)))) (files-tests--with-temp-non-special-and-file-name-handler (tmpdir nospecial-dir t) - (equal (unhandled-file-name-directory nospecial-dir) - (file-name-as-directory tmpdir)))) + (should-not (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir))))) (ert-deftest files-tests-file-name-non-special-vc-registered () (files-tests--with-temp-non-special (tmpfile nospecial) @@ -1635,6 +1656,31 @@ The door of all subtleties! (should (equal (file-name-base "foo") "foo")) (should (equal (file-name-base "foo/bar") "bar"))) +(defun files-tests--check-shebang (shebang expected-mode) + "Assert that mode for SHEBANG derives from EXPECTED-MODE." + (let ((actual-mode + (ert-with-temp-file script-file + :text shebang + (find-file script-file) + (if (derived-mode-p expected-mode) + expected-mode + major-mode)))) + ;; Tuck all the information we need in the `should' form: input + ;; shebang, expected mode vs actual. + (should + (equal (list shebang actual-mode) + (list shebang expected-mode))))) + +(ert-deftest files-tests-auto-mode-interpreter () + "Test that `set-auto-mode' deduces correct modes from shebangs." + (files-tests--check-shebang "#!/bin/bash" 'sh-mode) + (files-tests--check-shebang "#!/usr/bin/env bash" 'sh-mode) + (files-tests--check-shebang "#!/usr/bin/env python" 'python-base-mode) + (files-tests--check-shebang "#!/usr/bin/env python3" 'python-base-mode) + (files-tests--check-shebang "#!/usr/bin/env -S awk -v FS=\"\\t\" -v OFS=\"\\t\" -f" 'awk-mode) + (files-tests--check-shebang "#!/usr/bin/env -S make -f" 'makefile-mode) + (files-tests--check-shebang "#!/usr/bin/make -f" 'makefile-mode)) + (ert-deftest files-test-dir-locals-auto-mode-alist () "Test an `auto-mode-alist' entry in `.dir-locals.el'" (find-file (ert-resource-file "whatever.quux")) @@ -1696,6 +1742,157 @@ let-bound to PRED and passing nil as second arg of (set-buffer-modified-p nil) (kill-buffer buf))))))) +(defmacro files-tests--with-yes-or-no-p (reply &rest body) + "Execute BODY, providing replies to `yes-or-no-p' queries. +REPLY should be a cons (PROMPT . VALUE), and during execution of +BODY this macro provides VALUE as return value to all +`yes-or-no-p' calls prompting for PROMPT and nil to all other +`yes-or-no-p' calls. After execution of BODY, this macro ensures +that exactly one `yes-or-no-p' call prompting for PROMPT has been +executed during execution of BODY." + (declare (indent 1) (debug (sexp body))) + `(cl-letf* + ((reply ,reply) + (prompts nil) + ((symbol-function 'yes-or-no-p) + (lambda (prompt) + (let ((reply (cdr (assoc prompt (list reply))))) + (push (cons prompt reply) prompts) + reply)))) + ,@body + (should (equal prompts (list reply))))) + +(ert-deftest files-tests-save-buffer-read-only-file () + "Test writing to write-protected files with `save-buffer'. +Ensure that the issues from bug#66546 are fixed." + (ert-with-temp-directory dir + (cl-flet (;; Define convenience functions. + (file-contents (file) + (if (file-exists-p file) + (condition-case err + (with-temp-buffer + (insert-file-contents-literally file) + (buffer-string)) + (error err)) + 'missing)) + (signal-write-failed (&rest _) + (signal 'file-error "Write failed"))) + + (let* (;; Sanitize environment. + ;; The tests below test text for equality, so we need to + ;; disable any code- and EOL-conversions to avoid false + ;; positives and false negatives. + (coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (auto-save-default nil) + (backup-enable-predicate nil) + (before-save-hook nil) + (write-contents-functions nil) + (write-file-functions nil) + (after-save-hook nil) + + ;; Set the name of the game. + (base "read-only-test") + (file (expand-file-name base dir)) + (backup (make-backup-file-name file)) + + (override-read-only-prompt + (format "File %s is write-protected; try to save anyway? " + base))) + + ;; Ensure that set-file-modes renders our test file read-only, + ;; otherwise skip this test. Use `file-writable-p' to test + ;; for read-only-ness, because that's what function + ;; `save-buffer' uses as well. + (with-temp-file file (insert "foo\n")) + (skip-unless (file-writable-p file)) + (set-file-modes file (logand (file-modes file) + (lognot #o0222))) + (skip-unless (not (file-writable-p file))) + + (with-current-buffer (find-file-noselect file) + ;; Prepare for tests backing up the file. + (setq buffer-read-only nil) + (goto-char (point-min)) + (insert "bar\n") + + ;; Save to read-only file with backup, declining prompt. + (files-tests--with-yes-or-no-p + (cons override-read-only-prompt nil) + (should-error + (save-buffer) + ;; "Attempt to save to a file that you aren't allowed to write" + :type 'error)) + (should-not buffer-backed-up) + (should (buffer-modified-p)) + (should-not (file-writable-p file)) + (should (equal (file-contents file) "foo\n")) + (should (equal (file-contents backup) 'missing)) + + ;; Save to read-only file with backup, accepting prompt, + ;; experiencing a write error. + (files-tests--with-yes-or-no-p + (cons override-read-only-prompt t) + (should-error + (cl-letf (((symbol-function 'write-region) + #'signal-write-failed)) + (save-buffer)) + ;; "Write failed" + :type 'file-error)) + (should-not buffer-backed-up) + (should (buffer-modified-p)) + (should-not (file-writable-p file)) + (should (equal (file-contents file) "foo\n")) + (should (equal (file-contents backup) 'missing)) + + ;; Save to read-only file with backup, accepting prompt. + (files-tests--with-yes-or-no-p + (cons override-read-only-prompt t) + (save-buffer)) + (should buffer-backed-up) + (should-not (buffer-modified-p)) + (should-not (file-writable-p file)) + (should-not (file-writable-p backup)) + (should (equal (file-contents file) "bar\nfoo\n")) + (should (equal (file-contents backup) "foo\n")) + + ;; Prepare for tests not backing up the file. + (setq buffer-backed-up nil) + (delete-file backup) + (goto-char (point-min)) + (insert "baz\n") + + ;; Save to read-only file without backup, accepting prompt, + ;; experiencing a write error. This tests that issue B of + ;; bug#66546 is fixed. The results of the "with backup" and + ;; "without backup" subtests are identical when a write + ;; error occurs, but the code paths to reach these results + ;; are not. In other words, this subtest is not redundant. + (files-tests--with-yes-or-no-p + (cons override-read-only-prompt t) + (should-error + (cl-letf (((symbol-function 'write-region) + #'signal-write-failed)) + (save-buffer 0)) + ;; "Write failed" + :type 'file-error)) + (should-not buffer-backed-up) + (should (buffer-modified-p)) + (should-not (file-writable-p file)) + (should (equal (file-contents file) "bar\nfoo\n")) + (should (equal (file-contents backup) 'missing)) + + ;; Save to read-only file without backup, accepting prompt. + ;; This tests that issue A of bug#66546 is fixed. + (files-tests--with-yes-or-no-p + (cons override-read-only-prompt t) + (save-buffer 0)) + (should-not buffer-backed-up) + (should-not (buffer-modified-p)) + (should-not (file-writable-p file)) + (should (equal (file-contents file) "baz\nbar\nfoo\n")) + (should (equal (file-contents backup) 'missing))))))) + (ert-deftest files-tests-save-some-buffers () "Test `save-some-buffers'. Test the 3 cases for the second argument PRED, i.e., nil, t, or @@ -1904,5 +2101,9 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." (should (documentation 'bar)) (should (documentation 'zot))))) +(ert-deftest files-tests--expand-wildcards () + (should (file-expand-wildcards + (concat (directory-file-name default-directory) "*/")))) + (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/files-x-tests.el b/test/lisp/files-x-tests.el index 4e14ae68fb8..c7a56611497 100644 --- a/test/lisp/files-x-tests.el +++ b/test/lisp/files-x-tests.el @@ -39,6 +39,7 @@ (defconst files-x-test--variables5 '((remote-lazy-var . nil) (remote-null-device . "/dev/null"))) +(defvar remote-shell-file-name) (defvar remote-null-device) (defvar remote-lazy-var nil) (put 'remote-shell-file-name 'safe-local-variable #'identity) @@ -482,5 +483,80 @@ If it's not initialized yet, initialize it." `(connection-local-profile-alist ',clpa now) `(connection-local-criteria-alist ',clca now)))) +(ert-deftest files-x-test-connection-local-value () + "Test getting connection-local values." + + (let ((clpa connection-local-profile-alist) + (clca connection-local-criteria-alist)) + (connection-local-set-profile-variables + 'remote-bash files-x-test--variables1) + (connection-local-set-profile-variables + 'remote-ksh files-x-test--variables2) + (connection-local-set-profile-variables + 'remote-nullfile files-x-test--variables3) + + (connection-local-set-profiles + nil 'remote-ksh 'remote-nullfile) + + (connection-local-set-profile-variables + 'remote-lazy files-x-test--variables5) + (connection-local-set-profiles + files-x-test--application 'remote-lazy 'remote-bash) + + (with-temp-buffer + ;; We need a remote `default-directory'. + (let ((enable-connection-local-variables t) + (default-directory "/method:host:") + (remote-null-device "null")) + (should-not connection-local-variables-alist) + (should-not (local-variable-p 'remote-shell-file-name)) + (should-not (local-variable-p 'remote-null-device)) + (should-not (boundp 'remote-shell-file-name)) + (should (string-equal (symbol-value 'remote-null-device) "null")) + + ;; The proper variable values are set. + (should (connection-local-p remote-shell-file-name)) + (should + (string-equal + (connection-local-value remote-shell-file-name) "/bin/ksh")) + (should (connection-local-p remote-null-device)) + (should + (string-equal + (connection-local-value remote-null-device) "/dev/null")) + (should-not (connection-local-p remote-lazy-var)) + + ;; Run with a different application. + (should + (connection-local-p + remote-shell-file-name (cadr files-x-test--application))) + (should + (string-equal + (connection-local-value + remote-shell-file-name (cadr files-x-test--application)) + "/bin/bash")) + (should + (connection-local-p + remote-null-device (cadr files-x-test--application))) + (should + (string-equal + (connection-local-value + remote-null-device (cadr files-x-test--application)) + "/dev/null")) + (should + (connection-local-p + remote-lazy-var (cadr files-x-test--application))) + + ;; The previous bindings haven't changed. + (should-not connection-local-variables-alist) + (should-not (local-variable-p 'remote-shell-file-name)) + (should-not (local-variable-p 'remote-null-device)) + (should-not (boundp 'remote-shell-file-name)) + (should (string-equal (symbol-value 'remote-null-device) "null")))) + + ;; Cleanup. + (custom-set-variables + `(connection-local-profile-alist ',clpa now) + `(connection-local-criteria-alist ',clca now)))) + (provide 'files-x-tests) ;;; files-x-tests.el ends here diff --git a/test/lisp/find-cmd-tests.el b/test/lisp/find-cmd-tests.el index a0b9a80ef47..3fbd0fc4ea3 100644 --- a/test/lisp/find-cmd-tests.el +++ b/test/lisp/find-cmd-tests.el @@ -25,7 +25,7 @@ (ert-deftest find-cmd-test-find-cmd () (should (string-match - (rx "find " (+ any) + (rx "find " (+ nonl) " \\( \\( -name .svn -or -name .git -or -name .CVS \\)" " -prune -or -true \\)" " \\( \\( \\(" " -name \\*.pl -or -name \\*.pm -or -name \\*.t \\)" diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el index 37e84c148af..a5dadf21c8c 100644 --- a/test/lisp/gnus/mml-sec-tests.el +++ b/test/lisp/gnus/mml-sec-tests.el @@ -66,34 +66,29 @@ This fixture temporarily unsets GPG_AGENT_INFO to enable passphrase tests, which will neither work with gpgsm nor GnuPG 2.1 any longer, I guess. Actually, I'm not sure why people would want to cache passwords in Emacs instead of gpg-agent." - (unwind-protect - (let ((agent-info (getenv "GPG_AGENT_INFO")) - (gpghome (getenv "GNUPGHOME"))) - (condition-case error - (let ((epg-gpg-home-directory (ert-resource-directory)) - (mml-smime-use 'epg) - ;; Create debug output in empty epg-debug-buffer. - (epg-debug t) - (epg-debug-buffer (get-buffer-create " *epg-test*")) - (mml-secure-fail-when-key-problem (not interactive))) - (with-current-buffer epg-debug-buffer - (erase-buffer)) - ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. - ;; Just for testing. Jens does not recommend this for daily use. - (setenv "GPG_AGENT_INFO") - ;; Set GNUPGHOME as gpg-agent started by gpgsm does - ;; not look in the proper places otherwise, see: - ;; https://bugs.gnupg.org/gnupg/issue2126 - (setenv "GNUPGHOME" epg-gpg-home-directory) - (unwind-protect - (funcall body) - (mml-sec-test--kill-gpg-agent))) - (error - (setenv "GPG_AGENT_INFO" agent-info) - (setenv "GNUPGHOME" gpghome) - (signal (car error) (cdr error)))) - (setenv "GPG_AGENT_INFO" agent-info) - (setenv "GNUPGHOME" gpghome)))) + (let ((agent-info (getenv "GPG_AGENT_INFO")) + (gpghome (getenv "GNUPGHOME"))) + (unwind-protect + (let ((epg-gpg-home-directory (ert-resource-directory)) + (mml-smime-use 'epg) + ;; Create debug output in empty epg-debug-buffer. + (epg-debug t) + (epg-debug-buffer (get-buffer-create " *epg-test*")) + (mml-secure-fail-when-key-problem (not interactive))) + (with-current-buffer epg-debug-buffer + (erase-buffer)) + ;; Unset GPG_AGENT_INFO to enable passphrase caching inside Emacs. + ;; Just for testing. Jens does not recommend this for daily use. + (setenv "GPG_AGENT_INFO") + ;; Set GNUPGHOME as gpg-agent started by gpgsm does + ;; not look in the proper places otherwise, see: + ;; https://bugs.gnupg.org/gnupg/issue2126 + (setenv "GNUPGHOME" epg-gpg-home-directory) + (unwind-protect + (funcall body) + (mml-sec-test--kill-gpg-agent))) + (setenv "GPG_AGENT_INFO" agent-info) + (setenv "GNUPGHOME" gpghome)))) (defun mml-secure-test-message-setup (method to from &optional text bcc) "Setup a buffer with MML METHOD, TO, and FROM headers. diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 4d715cde1d5..56c521e765e 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -132,6 +132,12 @@ Return first line of the output of (describe-function-1 FUNC)." ;;; Tests for describe-keymap + +(defvar-keymap help-fns-test-map + "a" 'test-cmd-a + "b" 'test-cmd-b + "c" 'test-cmd-c) + (ert-deftest help-fns-test-find-keymap-name () (should (equal (help-fns-find-keymap-name lisp-mode-map) 'lisp-mode-map)) ;; Follow aliasing. @@ -142,27 +148,32 @@ Return first line of the output of (describe-function-1 FUNC)." (makunbound 'foo-test-map))) (ert-deftest help-fns-test-describe-keymap/symbol () - (describe-keymap 'minibuffer-local-must-match-map) + (describe-keymap 'help-fns-test-map) (with-current-buffer "*Help*" - (should (looking-at "^minibuffer-local-must-match-map is")))) + (should (looking-at "^help-fns-test-map is")) + (should (re-search-forward (rx word-start "a" word-end + (+ blank) + word-start "test-cmd-a" word-end) + nil t)))) (ert-deftest help-fns-test-describe-keymap/value () - (describe-keymap minibuffer-local-must-match-map) + (describe-keymap help-fns-test-map) (with-current-buffer "*Help*" (should (looking-at "\nKey")))) (ert-deftest help-fns-test-describe-keymap/not-keymap () (should-error (describe-keymap nil)) - (should-error (describe-keymap emacs-version))) + (should-error (describe-keymap emacs-version)) + (should-error (describe-keymap 'some-undefined-variable-foobar))) (ert-deftest help-fns-test-describe-keymap/let-bound () - (let ((foobar minibuffer-local-must-match-map)) + (let ((foobar help-fns-test-map)) (describe-keymap foobar) (with-current-buffer "*Help*" (should (looking-at "\nKey"))))) (ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () - (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) + (setq help-fns-test--describe-keymap-foo help-fns-test-map) (describe-keymap 'help-fns-test--describe-keymap-foo) (with-current-buffer "*Help*" (should (looking-at "^help-fns-test--describe-keymap-foo is")))) @@ -181,10 +192,6 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns--analyze-function-recursive () (defalias 'help-fns--a 'help-fns--b) (should (equal (help-fns--analyze-function 'help-fns--a) - '(help-fns--a help-fns--b t help-fns--b))) - ;; Make a loop and see that it doesn't infloop. - (defalias 'help-fns--b 'help-fns--a) - (should (equal (help-fns--analyze-function 'help-fns--a) '(help-fns--a help-fns--b t help-fns--b)))) ;;; help-fns-tests.el ends here diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 6c440f9e238..b0b487ab169 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -378,7 +378,7 @@ Key Binding (foo menu-item "Foo" foo :enable mark-active :help "Help text")))))) - (describe-map-tree map nil nil nil nil t nil nil nil) + (help--describe-map-tree map nil nil nil nil t nil nil nil) (should (string-match " Key Binding -+ @@ -393,7 +393,7 @@ C-a foo\n" (foo menu-item "Foo" foo :enable mark-active :help "Help text")))))) - (describe-map-tree map nil nil nil nil nil nil nil nil) + (help--describe-map-tree map nil nil nil nil nil nil nil nil) (should (string-match " Key Binding -+ @@ -408,7 +408,7 @@ C-a foo (map '(keymap . ((1 . foo) (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) - (describe-map-tree map t shadow-maps nil nil t nil nil t) + (help--describe-map-tree map t shadow-maps nil nil t nil nil t) (should (string-match " Key Binding -+ @@ -423,7 +423,7 @@ C-b bar\n" (map '(keymap . ((1 . foo) (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) - (describe-map-tree map t shadow-maps nil nil t nil nil nil) + (help--describe-map-tree map t shadow-maps nil nil t nil nil nil) (should (string-match " Key Binding -+ @@ -435,7 +435,7 @@ C-b bar\n" (let ((standard-output (current-buffer)) (map '(keymap . ((1 . foo) (2 . undefined))))) - (describe-map-tree map t nil nil nil nil nil nil nil) + (help--describe-map-tree map t nil nil nil nil nil nil nil) (should (string-match " Key Binding -+ @@ -447,7 +447,7 @@ C-a foo\n" (let ((standard-output (current-buffer)) (map '(keymap . ((1 . foo) (2 . undefined))))) - (describe-map-tree map nil nil nil nil nil nil nil nil) + (help--describe-map-tree map nil nil nil nil nil nil nil nil) (should (string-match " Key Binding -+ diff --git a/test/lisp/hl-line-tests.el b/test/lisp/hl-line-tests.el index 56924ff8e3e..9c120e0d7ff 100644 --- a/test/lisp/hl-line-tests.el +++ b/test/lisp/hl-line-tests.el @@ -104,10 +104,10 @@ (run-hooks 'post-command-hook) (should (hl-line-tests-verify 257 t)) (with-current-buffer second-buffer - (should (hl-line-tests-verify 999 nil))))) - (let (kill-buffer-query-functions) - (ignore-errors (kill-buffer first-buffer)) - (ignore-errors (kill-buffer second-buffer))))) + (should (hl-line-tests-verify 999 nil)))) + (let (kill-buffer-query-functions) + (ignore-errors (kill-buffer first-buffer)) + (ignore-errors (kill-buffer second-buffer)))))) (provide 'hl-line-tests) diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index 83bfa1f68af..ec0ba85da39 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -34,7 +34,7 @@ (ert-deftest ibuffer-0autoload () ; sort first "Tests to see whether ibuffer has been autoloaded" - (skip-unless (not (featurep 'ibuf-ext))) + (skip-when (featurep 'ibuf-ext)) (should (fboundp 'ibuffer-mark-unsaved-buffers)) (should diff --git a/test/lisp/image/image-dired-util-tests.el b/test/lisp/image/image-dired-util-tests.el index bd3d65bdd3a..1f3747a82b1 100644 --- a/test/lisp/image/image-dired-util-tests.el +++ b/test/lisp/image/image-dired-util-tests.el @@ -47,10 +47,11 @@ (should (equal (file-name-directory (image-dired-thumb-name "foo.jpg")) (file-name-directory (image-dired-thumb-name "/tmp/foo.jpg")))) - (should (equal (file-name-nondirectory - ;; The checksum is based on the file name. - (image-dired-thumb-name "/some/path/foo.jpg")) - "dc4e6f7068157023e7f2e8362d15bdd2e3ca89e4.jpg")) + (should + (let* ((test-fn "/some/path/foo.jpg") + (thumb-fn (image-dired-thumb-name test-fn))) + (equal (file-name-nondirectory thumb-fn) + (concat (sha1 (expand-file-name test-fn)) ".jpg")))) (should (equal (file-name-extension (image-dired-thumb-name "foo.gif")) "jpg"))))) @@ -62,8 +63,12 @@ (should (equal (file-name-nondirectory (image-dired-thumb-name "foo.jpg")) (file-name-nondirectory (image-dired-thumb-name "/tmp/foo.jpg")))) - (should (equal (file-name-split (image-dired-thumb-name "/tmp/foo.jpg")) - '("" "tmp" ".image-dired" "foo.jpg.thumb.jpg"))) + ;; The cdr below avoids the system dependency in the car of the + ;; list returned by 'file-name-split': it's "" on Posix systems, + ;; but the drive letter on MS-Windows. + (should (equal (cdr (file-name-split + (image-dired-thumb-name "/tmp/foo.jpg"))) + '("tmp" ".image-dired" "foo.jpg.thumb.jpg"))) (should (equal (file-name-nondirectory (image-dired-thumb-name "foo.jpg")) "foo.jpg.thumb.jpg")))) diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index e874bf3ebde..002aa3b8c21 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -219,8 +219,8 @@ Must be called with `ucs-normalize-tests--norm-buf' as current buffer." (ert-deftest ucs-normalize-part1 () :tags '(:expensive-test) - (skip-unless (not (or (getenv "EMACS_HYDRA_CI") - (getenv "EMACS_EMBA_CI")))) ; SLOW ~ 1800s + (skip-when (or (getenv "EMACS_HYDRA_CI") + (getenv "EMACS_EMBA_CI"))) ; SLOW ~ 1800s ;; This takes a long time, so make sure we're compiled. (dolist (fun '(ucs-normalize-tests--part1-rule2 ucs-normalize-tests--rule1-failing-for-partX diff --git a/test/lisp/isearch-tests.el b/test/lisp/isearch-tests.el index e71f0a5785f..693f15336f2 100644 --- a/test/lisp/isearch-tests.el +++ b/test/lisp/isearch-tests.el @@ -39,6 +39,157 @@ (isearch-done)) +;; Search invisible. + +(declare-function outline-hide-sublevels "outline") + +(ert-deftest isearch--test-invisible () + (require 'outline) + (with-temp-buffer + (set-window-buffer nil (current-buffer)) + (insert "\n1\n" + (propertize "2" 'invisible t) + (propertize "3" 'inhibit-isearch t) + "\n* h\n4\n\n") + (outline-mode) + (outline-hide-sublevels 1) + (goto-char (point-min)) + + (let ((isearch-lazy-count nil) + (search-invisible t) + (inhibit-message t)) + + (isearch-forward-regexp nil 1) + (isearch-process-search-string "[0-9]" "[0-9]") + (should (eq (point) 3)) + + (isearch-lazy-highlight-start) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2))) + + (isearch-repeat-forward) + (should (eq (point) 5)) + (should (get-char-property 4 'invisible)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should (get-char-property 11 'invisible)) + + (goto-char isearch-opoint) + (isearch-done t) + + (isearch-forward-regexp nil 1) + (setq isearch-invisible nil) ;; isearch-toggle-invisible + (isearch-process-search-string "[0-9]" "[0-9]") + + (isearch-lazy-highlight-start) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2))) + + (goto-char isearch-opoint) + (isearch-done t) + + (isearch-forward-regexp nil 1) + (setq isearch-invisible 'open) ;; isearch-toggle-invisible + (isearch-process-search-string "[0-9]" "[0-9]") + (should (eq (point) 3)) + + (isearch-lazy-highlight-start) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2 11))) + + (let ((isearch-hide-immediately t)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should-not (get-char-property 11 'invisible)) + (isearch-delete-char) + (should (get-char-property 11 'invisible))) + + (let ((isearch-hide-immediately nil)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should-not (get-char-property 11 'invisible)) + (isearch-delete-char) + (should-not (get-char-property 11 'invisible))) + + (goto-char isearch-opoint) + (isearch-done t) + (isearch-clean-overlays) + (should (get-char-property 11 'invisible))) + + (let ((isearch-lazy-count t) + (search-invisible t) + (inhibit-message t)) + + (isearch-forward-regexp nil 1) + (isearch-process-search-string "[0-9]" "[0-9]") + (should (eq (point) 3)) + + (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil) + (isearch-lazy-highlight-start) + (isearch-lazy-highlight-buffer-update) + (should (eq isearch-lazy-count-invisible nil)) + (should (eq isearch-lazy-count-total 3)) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2))) + + (isearch-repeat-forward) + (should (eq (point) 5)) + (should (get-char-property 4 'invisible)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should (get-char-property 11 'invisible)) + + (goto-char isearch-opoint) + (isearch-done t) + + (isearch-forward-regexp nil 1) + (setq isearch-invisible nil) ;; isearch-toggle-invisible + (isearch-process-search-string "[0-9]" "[0-9]") + + (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil) + (isearch-lazy-highlight-start) + (isearch-lazy-highlight-buffer-update) + (should (eq isearch-lazy-count-invisible 2)) + (should (eq isearch-lazy-count-total 1)) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2))) + + (goto-char isearch-opoint) + (isearch-done t) + + (isearch-forward-regexp nil 1) + (setq isearch-invisible 'open) ;; isearch-toggle-invisible + (isearch-process-search-string "[0-9]" "[0-9]") + (should (eq (point) 3)) + + (setq isearch-lazy-count-invisible nil isearch-lazy-count-total nil) + (isearch-lazy-highlight-start) + (isearch-lazy-highlight-buffer-update) + (should (eq isearch-lazy-count-invisible 1)) + (should (eq isearch-lazy-count-total 2)) + (should (equal (seq-uniq (mapcar #'overlay-start isearch-lazy-highlight-overlays)) + '(2 11))) + + (let ((isearch-hide-immediately t)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should-not (get-char-property 11 'invisible)) + (isearch-delete-char) + (should (get-char-property 11 'invisible))) + + (let ((isearch-hide-immediately nil)) + (isearch-repeat-forward) + (should (eq (point) 12)) + (should-not (get-char-property 11 'invisible)) + (isearch-delete-char) + (should-not (get-char-property 11 'invisible))) + + (goto-char isearch-opoint) + (isearch-done t) + (isearch-clean-overlays) + (should (get-char-property 11 'invisible))))) + + ;; Search functions. (defun isearch--test-search-within-boundaries (pairs) diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index a595167d130..5c3b694194f 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -103,6 +103,7 @@ (process-get listen-server 'handlers)))))))) (cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body) + (declare (indent 1)) `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body))) (ert-deftest returns-3 () @@ -124,7 +125,7 @@ "Signals an -32603 JSONRPC error." (jsonrpc--with-emacsrpc-fixture (conn) (condition-case err - (progn + (let ((jsonrpc-inhibit-debug-on-error t)) (jsonrpc-request conn '+ ["a" 2]) (ert-fail "A `jsonrpc-error' should have been signaled!")) (jsonrpc-error @@ -151,14 +152,6 @@ [1 2 3 3 4 5] (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]]))))) -(ert-deftest json-el-cant-serialize-this () - "Can't serialize a response that is half-vector/half-list." - (jsonrpc--with-emacsrpc-fixture (conn) - (should-error - ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be - ;; serialized - (jsonrpc-request conn 'append [[1 2 3] [3 4 5]])))) - (cl-defmethod jsonrpc-connection-ready-p ((conn jsonrpc--test-client) what) (and (cl-call-next-method) diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index 8c6262819c4..374028a3d16 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -29,13 +29,6 @@ (require 'ls-lisp) (require 'dired) -(ert-deftest ls-lisp-unload () - "Test for https://debbugs.gnu.org/xxxxx ." - (should (advice-member-p 'ls-lisp--insert-directory 'insert-directory)) - (unload-feature 'ls-lisp 'force) - (should-not (advice-member-p 'ls-lisp--insert-directory 'insert-directory)) - (require 'ls-lisp)) - (ert-deftest ls-lisp-test-bug27762 () "Test for https://debbugs.gnu.org/27762 ." (let* ((dir source-directory) diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh index 5e6b26fd2ec..602d831e28c 100755 --- a/test/lisp/mh-e/test-all-mh-variants.sh +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -81,8 +81,10 @@ for path in "${mh_sys_path[@]}"; do fi echo "** Testing with PATH $path" ((++tests_total)) + # The LD_LIBRARY_PATH setting is needed + # to run locally installed Mailutils. TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ - HOME=/nonexistent \ + LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ "${emacs[@]}" -l ert \ --eval "(setq load-prefer-newer t)" \ --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index a67fc555772..28bca60b189 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -33,14 +33,13 @@ (ert-deftest completion-test1 () (with-temp-buffer - (cl-flet* ((test/completion-table (_string _pred action) - (if (eq action 'lambda) - nil - "test: ")) + (cl-flet* ((test/completion-table (string pred action) + (let ((completion-ignore-case t)) + (complete-with-action action '("test: ") string pred))) (test/completion-at-point () - (list (copy-marker (point-min)) - (copy-marker (point)) - #'test/completion-table))) + (list (copy-marker (point-min)) + (copy-marker (point)) + #'test/completion-table))) (let ((completion-at-point-functions (list #'test/completion-at-point))) (insert "TEST") (completion-at-point) @@ -139,7 +138,7 @@ (defun test-completion-all-sorted-completions (base def history-var history-list) (with-temp-buffer (insert base) - (cl-letf (((symbol-function #'minibufferp) (lambda (&rest _) t))) + (cl-letf (((symbol-function #'minibufferp) #'always)) (let ((completion-styles '(basic)) (completion-category-defaults nil) (completion-category-overrides nil) @@ -190,7 +189,8 @@ (defun completion--pcm-score (comp) "Get `completion-score' from COMP." - (get-text-property 0 'completion-score comp)) + ;; FIXME, uses minibuffer.el implementation details + (completion--flex-score comp completion-pcm--regexp)) (defun completion--pcm-first-difference-pos (comp) "Get `completions-first-difference' from COMP." @@ -298,6 +298,19 @@ "jab" '("dabjabstabby" "many") nil 3))) 6))) +(ert-deftest completion-substring-test-5 () + ;; merge-completions needs to work correctly when + (should (equal + (completion-pcm--merge-completions '("ab" "sab") '(prefix "b")) + '("b" "a" prefix))) + (should (equal + (completion-pcm--merge-completions '("ab" "ab") '(prefix "b")) + '("b" "a"))) + ;; substring completion should successfully complete the entire string + (should (equal + (completion-substring-try-completion "b" '("ab" "ab") nil 0) + '("ab" . 2)))) + (ert-deftest completion-flex-test-1 () ;; Fuzzy match (should (equal @@ -407,6 +420,21 @@ (next-completion 5) (should (equal "ac" (get-text-property (point) 'completion--string))) (previous-completion 5) + (should (equal "aa" (get-text-property (point) 'completion--string))) + + (first-completion) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (next-line-completion 2) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (next-line-completion 5) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (previous-line-completion 5) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (goto-char (point-min)) + (next-line-completion 5) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (goto-char (point-min)) + (previous-line-completion 5) (should (equal "aa" (get-text-property (point) 'completion--string))))) (let ((completion-auto-wrap t)) (completing-read-with-minibuffer-setup @@ -420,6 +448,21 @@ (next-completion 1) (should (equal "aa" (get-text-property (point) 'completion--string))) (previous-completion 1) + (should (equal "ac" (get-text-property (point) 'completion--string))) + + (first-completion) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (next-line-completion 2) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (next-line-completion 1) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (previous-line-completion 1) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (goto-char (point-min)) + (next-line-completion 4) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (goto-char (point-min)) + (previous-line-completion 4) (should (equal "ac" (get-text-property (point) 'completion--string)))))) (ert-deftest completions-header-format-test () @@ -441,6 +484,16 @@ (should (equal "ac" (get-text-property (point) 'completion--string))) (next-completion 1) (should (equal "aa" (get-text-property (point) 'completion--string))) + + (next-line-completion 2) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (previous-line-completion 2) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (previous-line-completion 1) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (next-line-completion 1) + (should (equal "aa" (get-text-property (point) 'completion--string))) + ;; Fixed in bug#55430 (execute-kbd-macro (kbd "C-u RET")) (should (equal (minibuffer-contents) "aa"))) @@ -475,8 +528,58 @@ ;; Fixed in bug#54374 (goto-char (1- (point-max))) (should-not (equal 'highlight (get-text-property (point) 'mouse-face))) + + (first-completion) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (let ((completion-auto-wrap t)) + (next-line-completion 3)) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (let ((completion-auto-wrap nil)) + (next-line-completion 3)) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (execute-kbd-macro (kbd "C-u RET")) (should (equal (minibuffer-contents) "ac"))))) +(ert-deftest completions-group-navigation-test () + (completing-read-with-minibuffer-setup + (lambda (string pred action) + (if (eq action 'metadata) + `(metadata + (group-function + . ,(lambda (name transform) + (if transform + name + (pcase name + (`"aa" "Group 1") + (`"ab" "Group 2") + (`"ac" "Group 3"))))) + (category . unicode-name)) + (complete-with-action action '("aa" "ab" "ac") string pred))) + (insert "a") + (minibuffer-completion-help) + (switch-to-completions) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (let ((completion-auto-wrap t)) + (next-completion 3)) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (let ((completion-auto-wrap nil)) + (next-completion 3)) + (should (equal "ac" (get-text-property (point) 'completion--string))) + + (first-completion) + (let ((completion-auto-wrap t)) + (next-line-completion 1) + (should (equal "ab" (get-text-property (point) 'completion--string))) + (next-line-completion 2) + (should (equal "aa" (get-text-property (point) 'completion--string))) + (previous-line-completion 2) + (should (equal "ab" (get-text-property (point) 'completion--string)))) + (let ((completion-auto-wrap nil)) + (next-line-completion 3) + (should (equal "ac" (get-text-property (point) 'completion--string))) + (previous-line-completion 3) + (should (equal "aa" (get-text-property (point) 'completion--string)))))) + (provide 'minibuffer-tests) ;;; minibuffer-tests.el ends here diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el index 54bb44b7d01..b9bafe4bd11 100644 --- a/test/lisp/misc-tests.el +++ b/test/lisp/misc-tests.el @@ -114,40 +114,70 @@ (require 'rect) (ert-deftest misc--duplicate-dwim () - ;; Duplicate a line. - (with-temp-buffer - (insert "abc\ndefg\nh\n") - (goto-char 7) - (duplicate-dwim 2) - (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\nh\n")) - (should (equal (point) 7))) + (let ((duplicate-line-final-position 0) + (duplicate-region-final-position 0)) + ;; Duplicate a line. + (dolist (final-pos '(0 -1 1)) + (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ") + (with-temp-buffer + (insert "abc\ndefg\nh\n") + (goto-char 7) + (let ((duplicate-line-final-position final-pos)) + (duplicate-dwim 3)) + (should (equal (buffer-string) "abc\ndefg\ndefg\ndefg\ndefg\nh\n")) + (let ((delta (* 5 (if (< final-pos 0) 3 final-pos)))) + (should (equal (point) (+ 7 delta))))))) + + ;; Duplicate a region. + (dolist (final-pos '(0 -1 1)) + (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ") + (with-temp-buffer + (insert "abCDEFghi") + (set-mark 3) + (goto-char 7) + (transient-mark-mode) + (should (use-region-p)) + (let ((duplicate-region-final-position final-pos)) + (duplicate-dwim 3)) + (should (equal (buffer-string) "abCDEFCDEFCDEFCDEFghi")) + (should (region-active-p)) + (let ((delta (* 4 (if (< final-pos 0) 3 final-pos)))) + (should (equal (point) (+ 7 delta))) + (should (equal (mark) (+ 3 delta))))))) + + ;; Duplicate a rectangular region (sparse). + (with-temp-buffer + (insert "x\n>a\n>bcde\n>fg\nyz\n") + (goto-char 4) + (rectangle-mark-mode) + (goto-char 15) + (rectangle-forward-char 1) + (duplicate-dwim) + (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n")) + (should (equal (point) 24)) + (should (region-active-p)) + (should rectangle-mark-mode) + (should (equal (mark) 4))) + + ;; Idem (dense). + (dolist (final-pos '(0 -1 1)) + (ert-info ((prin1-to-string final-pos) :prefix "final-pos: ") + (with-temp-buffer + (insert "aBCd\neFGh\niJKl\n") + (goto-char 2) + (rectangle-mark-mode) + (goto-char 14) + (let ((duplicate-region-final-position final-pos)) + (duplicate-dwim 3)) + (should (equal (buffer-string) + "aBCBCBCBCd\neFGFGFGFGh\niJKJKJKJKl\n")) + (should (region-active-p)) + (should rectangle-mark-mode) + (let ((hdelta (* 2 (if (< final-pos 0) 3 final-pos))) + (vdelta 12)) + (should (equal (point) (+ 14 vdelta hdelta))) + (should (equal (mark) (+ 2 hdelta))))))))) - ;; Duplicate a region. - (with-temp-buffer - (insert "abc\ndef\n") - (set-mark 2) - (goto-char 7) - (transient-mark-mode) - (should (use-region-p)) - (duplicate-dwim) - (should (equal (buffer-string) "abc\ndebc\ndef\n")) - (should (equal (point) 7)) - (should (region-active-p)) - (should (equal (mark) 2))) - - ;; Duplicate a rectangular region. - (with-temp-buffer - (insert "x\n>a\n>bcde\n>fg\nyz\n") - (goto-char 4) - (rectangle-mark-mode) - (goto-char 15) - (rectangle-forward-char 1) - (duplicate-dwim) - (should (equal (buffer-string) "x\n>a a \n>bcdbcde\n>fg fg \nyz\n")) - (should (equal (point) 24)) - (should (region-active-p)) - (should rectangle-mark-mode) - (should (equal (mark) 4)))) (provide 'misc-tests) ;;; misc-tests.el ends here diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el index e47ead98f42..175c3e88da9 100644 --- a/test/lisp/net/mailcap-tests.el +++ b/test/lisp/net/mailcap-tests.el @@ -537,5 +537,29 @@ help to verify the correct addition and merging of an entry." ("minor" . ((viewer . "viewer") (edit . "edit"))))))))) + + +(ert-deftest mailcap-viewer-passes-test-w/o-test-returns-t () + "A VIEWER-INFO without a test should return t with a valid viewer (Bug#65224)." + + (should (equal t + (let ((mailcap-viewer-test-cache) + (viewer-info + (list (cons 'viewer "viewer-w/o-test")))) + (mailcap-viewer-passes-test viewer-info nil)))) + + (should (equal '(t t nil t) + (let ((mailcap-viewer-test-cache) + (viewer-infos + (list + (list (cons 'viewer "viewer-w/o-test")) + (list (cons 'viewer "viewer-w/o-test")) + (list (cons 'viewer "viewer-w/nil-test") + (cons 'test nil)) + (list (cons 'viewer "viewer-w/o-test")) + ))) + (mapcar (lambda (vi) + (mailcap-viewer-passes-test vi nil)) + viewer-infos))))) ;;; mailcap-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 0fd9549c305..8b1ae398930 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -236,7 +236,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect))) + (skip-when (eq (process-status proc) 'connect)) (with-current-buffer (process-buffer proc) (process-send-string proc "echo foo") (sleep-for 0.1) @@ -323,7 +323,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -336,7 +336,7 @@ (ert-deftest connect-to-tls-ipv6-nowait () (skip-unless (executable-find "gnutls-serv")) (skip-unless (gnutls-available-p)) - (skip-unless (not (eq system-type 'windows-nt))) + (skip-when (eq system-type 'windows-nt)) (skip-unless (featurep 'make-network-process '(:family ipv6))) (let ((server (make-tls-server 44333)) (times 0) @@ -368,7 +368,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -403,7 +403,7 @@ (< (setq times (1+ times)) 10)) (sit-for 0.1)) (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -446,7 +446,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -484,7 +484,7 @@ (< (setq times (1+ times)) 10)) (sit-for 0.1)) (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -523,7 +523,7 @@ (< (setq times (1+ times)) 10)) (sit-for 0.1)) (should proc) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -673,7 +673,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) @@ -712,7 +712,7 @@ (while (and (eq (process-status proc) 'connect) (< (setq times (1+ times)) 10)) (sit-for 0.1)) - (skip-unless (not (eq (process-status proc) 'connect)))) + (skip-when (eq (process-status proc) 'connect))) (if (process-live-p server) (delete-process server))) (setq status (gnutls-peer-status proc)) (should (consp status)) diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el index 958e2ff44a8..1a4bac37bf9 100644 --- a/test/lisp/net/socks-tests.el +++ b/test/lisp/net/socks-tests.el @@ -63,21 +63,21 @@ (process-put proc 'socks-state socks-state-waiting) (process-put proc 'socks-server-protocol 4) (ert-info ("Receive initial incomplete segment") - (socks-filter proc (concat [0 90 0 0 93 184 216])) - ;; From example.com: OK status ^ ^ msg start + (socks-filter proc (unibyte-string 0 90 0 0 93 184 216)) + ;; From example.com: OK status ^ ^ msg start (ert-info ("State still set to waiting") (should (eq (process-get proc 'socks-state) socks-state-waiting))) (ert-info ("Response field is nil because processing incomplete") (should-not (process-get proc 'socks-response))) (ert-info ("Scratch field holds stashed partial payload") - (should (string= (concat [0 90 0 0 93 184 216]) + (should (string= (unibyte-string 0 90 0 0 93 184 216) (process-get proc 'socks-scratch))))) (ert-info ("Last part arrives") (socks-filter proc "\42") ; ?\" 34 (ert-info ("State transitions to complete (length check passes)") (should (eq (process-get proc 'socks-state) socks-state-connected))) (ert-info ("Scratch and response fields hold stash w. last chunk") - (should (string= (concat [0 90 0 0 93 184 216 34]) + (should (string= (unibyte-string 0 90 0 0 93 184 216 34) (process-get proc 'socks-response))) (should (string= (process-get proc 'socks-response) (process-get proc 'socks-scratch))))) @@ -133,17 +133,19 @@ Vectors must match verbatim. Strings are considered regex patterns.") (defun socks-tests-canned-server-create () "Create and return a fake SOCKS server." (let* ((port (nth 2 socks-server)) - (name (format "socks-server:%d" port)) + (name (format "socks-server:%s" + (if (numberp port) port (ert-test-name (ert-running-test))))) (pats socks-tests-canned-server-patterns) (filt (lambda (proc line) (pcase-let ((`(,pat . ,resp) (pop pats))) (unless (or (and (vectorp pat) (equal pat (vconcat line))) - (string-match-p pat line)) + (and (stringp pat) (string-match-p pat line))) (error "Unknown request: %s" line)) + (setq resp (apply #'unibyte-string (append resp nil))) (let ((print-escape-control-characters t)) (message "[%s] <- %s" name (prin1-to-string line)) (message "[%s] -> %s" name (prin1-to-string resp))) - (process-send-string proc (concat resp))))) + (process-send-string proc resp)))) (serv (make-network-process :server 1 :buffer (get-buffer-create name) :filter filt @@ -151,8 +153,10 @@ Vectors must match verbatim. Strings are considered regex patterns.") :family 'ipv4 :host 'local :coding 'binary - :service port))) + :service (or port t)))) (set-process-query-on-exit-flag serv nil) + (unless (numberp (nth 2 socks-server)) + (setf (nth 2 socks-server) (process-contact serv :service))) serv)) (defvar socks-tests--hello-world-http-request-pattern @@ -161,9 +165,9 @@ Vectors must match verbatim. Strings are considered regex patterns.") "Content-Length: 13\r\n\r\n" "Hello World!\n"))) -(defun socks-tests-perform-hello-world-http-request () +(defun socks-tests-perform-hello-world-http-request (&optional method) "Start canned server, validate hello-world response, and finalize." - (let* ((url-gateway-method 'socks) + (let* ((url-gateway-method (or method 'socks)) (url (url-generic-parse-url "http://example.com")) (server (socks-tests-canned-server-create)) ;; @@ -191,8 +195,9 @@ Vectors must match verbatim. Strings are considered regex patterns.") (ert-deftest socks-tests-v4-basic () "Show correct preparation of SOCKS4 connect command (Bug#46342)." - (let ((socks-server '("server" "127.0.0.1" 10079 4)) + (let ((socks-server '("server" "127.0.0.1" t 4)) (url-user-agent "Test/4-basic") + (socks-username "foo") (socks-tests-canned-server-patterns `(([4 1 0 80 93 184 216 34 ?f ?o ?o 0] . [0 90 0 0 0 0 0 0]) ,socks-tests--hello-world-http-request-pattern)) @@ -201,11 +206,35 @@ Vectors must match verbatim. Strings are considered regex patterns.") (cl-letf (((symbol-function 'socks-nslookup-host) (lambda (host) (should (equal host "example.com")) - (list 93 184 216 34))) - ((symbol-function 'user-full-name) - (lambda (&optional _) "foo"))) + (list 93 184 216 34)))) (socks-tests-perform-hello-world-http-request))))) +(ert-deftest socks-tests-v4a-basic () + "Show correct preparation of SOCKS4a connect command." + (let ((socks-server '("server" "127.0.0.1" t 4a)) + (socks-username "foo") + (url-user-agent "Test/4a-basic") + (socks-tests-canned-server-patterns + `(([4 1 0 80 0 0 0 1 ?f ?o ?o 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] + . [0 90 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern))) + (ert-info ("Make HTTP request over SOCKS4A") + (socks-tests-perform-hello-world-http-request)))) + +(ert-deftest socks-tests-v4a-error () + "Show error signaled when destination address rejected." + (let ((socks-server '("server" "127.0.0.1" t 4a)) + (url-user-agent "Test/4a-basic") + (socks-username "") + (socks-tests-canned-server-patterns + `(([4 1 0 80 0 0 0 1 0 ?e ?x ?a ?m ?p ?l ?e ?. ?c ?o ?m 0] + . [0 91 0 0 0 0 0 0]) + ,socks-tests--hello-world-http-request-pattern))) + (ert-info ("Make HTTP request over SOCKS4A") + (let ((err (should-error + (socks-tests-perform-hello-world-http-request)))) + (should (equal err '(error "SOCKS: Rejected or failed"))))))) + ;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate ;; against curl 7.71 with the following options: ;; $ curl --verbose -U foo:bar --proxy socks5h://127.0.0.1:10080 example.com @@ -213,7 +242,7 @@ Vectors must match verbatim. Strings are considered regex patterns.") (ert-deftest socks-tests-v5-auth-user-pass () "Verify correct handling of SOCKS5 user/pass authentication." (should (assq 2 socks-authentication-methods)) - (let ((socks-server '("server" "127.0.0.1" 10080 5)) + (let ((socks-server '("server" "127.0.0.1" t 5)) (socks-username "foo") (socks-password "bar") (url-user-agent "Test/auth-user-pass") @@ -247,7 +276,7 @@ Vectors must match verbatim. Strings are considered regex patterns.") (ert-deftest socks-tests-v5-auth-user-pass-blank () "Verify correct SOCKS5 user/pass authentication with empty pass." (should (assq 2 socks-authentication-methods)) - (let ((socks-server '("server" "127.0.0.1" 10081 5)) + (let ((socks-server '("server" "127.0.0.1" t 5)) (socks-username "foo") ; defaults to (user-login-name) (socks-password "") ; simulate user hitting enter when prompted (url-user-agent "Test/auth-user-pass-blank") @@ -264,9 +293,9 @@ Vectors must match verbatim. Strings are considered regex patterns.") ;; against curl 7.71 with the following options: ;; $ curl --verbose --proxy socks5h://127.0.0.1:10082 example.com -(ert-deftest socks-tests-v5-auth-none () +(defun socks-tests-v5-auth-none (method) "Verify correct handling of SOCKS5 when auth method 0 requested." - (let ((socks-server '("server" "127.0.0.1" 10082 5)) + (let ((socks-server '("server" "127.0.0.1" t 5)) (socks-authentication-methods (append socks-authentication-methods nil)) (url-user-agent "Test/auth-none") @@ -278,7 +307,24 @@ Vectors must match verbatim. Strings are considered regex patterns.") (socks-unregister-authentication-method 2) (should-not (assq 2 socks-authentication-methods)) (ert-info ("Make HTTP request over SOCKS5 with no auth method") - (socks-tests-perform-hello-world-http-request))) + (socks-tests-perform-hello-world-http-request method))) (should (assq 2 socks-authentication-methods))) +(ert-deftest socks-tests-v5-auth-none () + (socks-tests-v5-auth-none 'socks)) + +;; This simulates the top-level advice around `open-network-stream' +;; that's applied when loading the library with a non-nil +;; `socks-override-functions'. +(ert-deftest socks-override-functions () + (should-not socks-override-functions) + (should-not (advice-member-p #'socks--open-network-stream + 'open-network-stream)) + (advice-add 'open-network-stream :around #'socks--open-network-stream) + (unwind-protect (let ((socks-override-functions t)) + (socks-tests-v5-auth-none 'native)) + (advice-remove 'open-network-stream #'socks--open-network-stream)) + (should-not (advice-member-p #'socks--open-network-stream + 'open-network-stream))) + ;;; socks-tests.el ends here diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index a23f72635fe..9500ce0efca 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -121,12 +121,6 @@ the origin of the temporary TMPFILE, have no write permissions." (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) (delete-directory tmpfile))) -(defun tramp-archive--test-emacs27-p () - "Check for Emacs version >= 27.1. -Some semantics has been changed for there, without new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 27)) - (defun tramp-archive--test-emacs28-p () "Check for Emacs version >= 28.1. Some semantics has been changed for there, without new functions or @@ -621,16 +615,13 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-directory tramp-archive-test-archive nil) (goto-char (point-min)) - (should - (looking-at-p - (tramp-compat-rx (literal tramp-archive-test-archive))))) + (should (looking-at-p (rx (literal tramp-archive-test-archive))))) (with-temp-buffer (insert-directory tramp-archive-test-archive "-al") (goto-char (point-min)) (should (looking-at-p - (tramp-compat-rx - bol (+ nonl) blank (literal tramp-archive-test-archive) eol)))) + (rx bol (+ nonl) blank (literal tramp-archive-test-archive) eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tramp-archive-test-archive) @@ -886,12 +877,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (ert-deftest tramp-archive-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless tramp-archive-enabled) - ;; Since Emacs 27.1. - (skip-unless (fboundp 'file-system-info)) - ;; `file-system-info' exists since Emacs 27. We don't want to see - ;; compiler warnings for older Emacsen. - (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive)))) + (let ((fsi (file-system-info tramp-archive-test-archive))) (skip-unless fsi) (should (and (consp fsi) (tramp-compat-length= fsi 3) @@ -900,12 +887,29 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test47-auto-load () +;; `file-user-uid' and `file-group-gid' were introduced in Emacs 30.1. +(ert-deftest tramp-archive-test44-user-group-ids () + "Check results of user/group functions. +`file-user-uid' and `file-group-gid' should return proper values." + (skip-unless tramp-archive-enabled) + (skip-unless (and (fboundp 'file-user-uid) + (fboundp 'file-group-gid))) + + ;; `file-user-uid' and `file-group-gid' exist since Emacs 30.1. + ;; We don't want to see compiler warnings for older Emacsen. + (let* ((default-directory tramp-archive-test-archive) + (uid (with-no-warnings (file-user-uid))) + (gid (with-no-warnings (file-group-gid)))) + (should (integerp uid)) + (should (integerp gid)) + (let ((default-directory tramp-archive-test-file-archive)) + (should (equal uid (with-no-warnings (file-user-uid)))) + (should (equal gid (with-no-warnings (file-group-gid))))))) + +(ert-deftest tramp-archive-test48-auto-load () "Check that `tramp-archive' autoloads properly." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) - ;; Autoloading tramp-archive works since Emacs 27.1. - (skip-unless (tramp-archive--test-emacs27-p)) ;; tramp-archive is neither loaded at Emacs startup, nor when ;; loading a file like "/mock::foo" (which loads Tramp). @@ -931,7 +935,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) (should (string-match - (tramp-compat-rx + (rx "tramp-archive loaded: " (literal (symbol-name (tramp-archive-file-name-p default-directory))) @@ -950,12 +954,10 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (format "(setq tramp-archive-enabled %s)" enabled)) (shell-quote-argument (format code file))))))))))) -(ert-deftest tramp-archive-test47-delay-load () +(ert-deftest tramp-archive-test48-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) - ;; Autoloading tramp-archive works since Emacs 27.1. - (skip-unless (tramp-archive--test-emacs27-p)) ;; tramp-archive is neither loaded at Emacs startup, nor when ;; loading a file like "/foo.tar". It is loaded only when @@ -976,7 +978,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (dolist (tae '(t nil)) (should (string-match - (tramp-compat-rx + (rx "tramp-archive loaded: nil" (+ ascii) "tramp-archive loaded: nil" (+ ascii) "tramp-archive loaded: " (literal (symbol-name tae))) @@ -991,6 +993,20 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." code tae tramp-archive-test-file-archive (concat tramp-archive-test-archive "foo")))))))))) +(ert-deftest tramp-archive-test49-without-remote-files () + "Check that Tramp can be suppressed." + (skip-unless tramp-archive-enabled) + + (should (file-exists-p tramp-archive-test-archive)) + (should-not (without-remote-files (file-exists-p tramp-archive-test-archive))) + (should (file-exists-p tramp-archive-test-archive)) + + (inhibit-remote-files) + (should-not (file-exists-p tramp-archive-test-archive)) + (tramp-register-file-name-handlers) + (setq tramp-mode t) + (should (file-exists-p tramp-archive-test-archive))) + (ert-deftest tramp-archive-test99-libarchive-tests () "Run tests of libarchive test files." :tags '(:expensive-test :unstable) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 7854466b819..209eb1a055c 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,7 +33,7 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. -;; For slow remote connections, `tramp-test44-asynchronous-requests' +;; For slow remote connections, `tramp-test45-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -72,17 +72,18 @@ (defvar tramp-persistency-file-name) (defvar tramp-remote-path) (defvar tramp-remote-process-environment) +(defvar tramp-use-connection-share) -;; Needed for Emacs 26. -(declare-function with-connection-local-variables "files-x") ;; Needed for Emacs 27. (defvar lock-file-name-transforms) (defvar process-file-return-signal-string) (defvar remote-file-name-inhibit-locks) -(defvar shell-command-dont-erase-buffer) -;; Needed for Emacs 28. (defvar dired-copy-dereference) +;; Declared in Emacs 30. +(defvar remote-file-name-access-timeout) +(defvar remote-file-name-inhibit-delete-by-moving-to-trash) + ;; `ert-resource-file' was introduced in Emacs 28.1. (unless (macrop 'ert-resource-file) (eval-and-compile @@ -226,7 +227,7 @@ If LOCAL is non-nil, a local file name is returned. If QUOTED is non-nil, the local part of the file name is quoted. The temporary file is not created." (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (make-temp-name "tramp-test") (if local temporary-file-directory ert-remote-temporary-file-directory)))) @@ -262,7 +263,6 @@ is greater than 10. `should-error' is not handled properly. BODY shall not contain a timeout." (declare (indent 1) (debug (natnump body))) `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) - (trace-buffer (tramp-trace-buffer-name tramp-test-vec)) (debug-ignored-errors (append '("^make-symbolic-link not supported$" @@ -297,16 +297,6 @@ is greater than 10. (tramp--test-message "%s %f sec" ,message (float-time (time-subtract nil start)))))) -;; `always' is introduced with Emacs 28.1. -(defalias 'tramp--test-always - (if (fboundp 'always) - #'always - (lambda (&rest _arguments) - "Do nothing and return t. -This function accepts any number of ARGUMENTS, but ignores them. -Also see `ignore'." - t))) - (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -2451,10 +2441,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Check `directory-abbrev-alist' abbreviation. (let ((directory-abbrev-alist - `((,(tramp-compat-rx bos (literal home-dir) "/foo") - . ,(concat home-dir "/f")) - (,(tramp-compat-rx bos (literal remote-host) "/nowhere") - . ,(concat remote-host "/nw"))))) + `((,(rx bos (literal home-dir) "/foo") . ,(concat home-dir "/f")) + (,(rx bos (literal remote-host) "/nowhere") + . ,(concat remote-host "/nw"))))) (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) (concat remote-host-nohop "~/f/bar"))) (should (equal (abbreviate-file-name @@ -2505,7 +2494,24 @@ This checks also `file-name-as-directory', `file-name-directory', (expand-file-name (file-name-nondirectory tmp-name) trash-directory)))) (delete-directory trash-directory 'recursive) - (should-not (file-exists-p trash-directory))))))) + (should-not (file-exists-p trash-directory)))) + + ;; Setting `remote-file-name-inhibit-delete-by-moving-to-trash' + ;; prevents trashing remote files. + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (delete-by-moving-to-trash t) + (remote-file-name-inhibit-delete-by-moving-to-trash t)) + (make-directory trash-directory) + (should-not (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (delete-file tmp-name 'trash) + (should-not (file-exists-p tmp-name)) + (should-not + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name) trash-directory))) + (delete-directory trash-directory 'recursive) + (should-not (file-exists-p trash-directory)))))) (ert-deftest tramp-test08-file-local-copy () "Check `file-local-copy'." @@ -2549,24 +2555,57 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (write-region "foo" nil tmp-name) (let ((point (point))) - (insert-file-contents tmp-name) + (should + (equal + (insert-file-contents tmp-name) + `(,(expand-file-name tmp-name) 3))) (should (string-equal (buffer-string) "foo")) (should (= point (point)))) (goto-char (1+ (point))) (let ((point (point))) - (insert-file-contents tmp-name) + (should + (equal + (insert-file-contents tmp-name) + `(,(expand-file-name tmp-name) 3))) (should (string-equal (buffer-string) "ffoooo")) (should (= point (point)))) ;; Insert partly. (let ((point (point))) - (insert-file-contents tmp-name nil 1 3) + (should + (equal + (insert-file-contents tmp-name nil 1 3) + `(,(expand-file-name tmp-name) 2))) (should (string-equal (buffer-string) "foofoooo")) (should (= point (point)))) + (let ((point (point))) + (should + (equal + (insert-file-contents tmp-name nil 2 5) + `(,(expand-file-name tmp-name) 1))) + (should (string-equal (buffer-string) "fooofoooo")) + (should (= point (point)))) ;; Replace. (let ((point (point))) - (insert-file-contents tmp-name nil nil nil 'replace) + ;; 0 characters replaced, because "foo" is already there. + (should + (equal + (insert-file-contents tmp-name nil nil nil 'replace) + `(,(expand-file-name tmp-name) 0))) (should (string-equal (buffer-string) "foo")) (should (= point (point)))) + ;; Insert another string. + ;; `replace-string-in-region' was introduced in Emacs 28.1. + (when (tramp--test-emacs28-p) + (let ((point (point))) + (with-no-warnings + (replace-string-in-region "foo" "bar" (point-min) (point-max))) + (goto-char point) + (should + (equal + (insert-file-contents tmp-name nil nil nil 'replace) + `(,(expand-file-name tmp-name) 3))) + (should (string-equal (buffer-string) "foo")) + (should (= point (point))))) ;; Error case. (delete-file tmp-name) (should-error @@ -2634,17 +2673,14 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "foo"))) ;; Write empty string. Used for creation of temporary files. - ;; Since Emacs 27.1. - (when (fboundp 'make-empty-file) - (with-no-warnings - (should-error - (make-empty-file tmp-name) - :type 'file-already-exists) - (delete-file tmp-name) - (make-empty-file tmp-name) - (with-temp-buffer - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) ""))))) + (should-error + (make-empty-file tmp-name) + :type 'file-already-exists) + (delete-file tmp-name) + (make-empty-file tmp-name) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) ""))) ;; Write partly. (with-temp-buffer @@ -2666,18 +2702,17 @@ This checks also `file-name-as-directory', `file-name-directory', (string-match-p (if (and (null noninteractive) (or (eq visit t) (null visit) (stringp visit))) - (tramp-compat-rx - bol "Wrote " (literal tmp-name) "\n" eos) + (rx bol "Wrote " (literal tmp-name) "\n" eos) (rx bos)) tramp--test-messages)))))) - ;; We do not test lockname here. See + ;; We do not test the lock file here. See ;; `tramp-test39-make-lock-file-name'. ;; Do not overwrite if excluded. - (cl-letf (((symbol-function #'y-or-n-p) #'tramp--test-always) + (cl-letf (((symbol-function #'y-or-n-p) #'tramp-compat-always) ;; Ange-FTP. - ((symbol-function #'yes-or-no-p) #'tramp--test-always)) + ((symbol-function #'yes-or-no-p) #'tramp-compat-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) (should-error (cl-letf (((symbol-function #'y-or-n-p) #'ignore) @@ -2710,8 +2745,6 @@ This checks also `file-name-as-directory', `file-name-directory', "Check that `file-precious-flag' is respected with Tramp in use." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - ;; The bug is fixed in Emacs 27.1. - (skip-unless (tramp--test-emacs27-p)) (let* ((tmp-name (tramp--test-make-temp-name)) (inhibit-message t) @@ -2794,10 +2827,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `copy-file'." (skip-unless (tramp--test-enabled)) - ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted - (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2906,10 +2936,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `rename-file'." (skip-unless (tramp--test-enabled)) - ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted - (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -3025,6 +3052,7 @@ This checks also `file-name-as-directory', `file-name-directory', This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) + ;; Since Emacs 29.1, `make-directory' has defined return values. (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) @@ -3033,7 +3061,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (unwind-protect (progn (with-file-modes unusual-file-mode-1 - (make-directory tmp-name1)) + (if (tramp--test-emacs29-p) + (should-not (make-directory tmp-name1)) + (make-directory tmp-name1))) (should-error (make-directory tmp-name1) :type 'file-already-exists) @@ -3046,15 +3076,19 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (make-directory tmp-name2) :type 'file-error) (with-file-modes unusual-file-mode-2 - (make-directory tmp-name2 'parents)) + (if (tramp--test-emacs29-p) + (should-not (make-directory tmp-name2 'parents)) + (make-directory tmp-name2 'parents))) (should (file-directory-p tmp-name2)) (should (file-accessible-directory-p tmp-name2)) (when (tramp--test-supports-set-file-modes-p) (should (equal (format "%#o" unusual-file-mode-2) (format "%#o" (file-modes tmp-name2))))) ;; If PARENTS is non-nil, `make-directory' shall not - ;; signal an error when DIR exists already. - (make-directory tmp-name2 'parents)) + ;; signal an error when DIR exists already. It returns t. + (if (tramp--test-emacs29-p) + (should (make-directory tmp-name2 'parents)) + (make-directory tmp-name2 'parents))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3086,13 +3120,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (delete-directory tmp-name1 'recursive) (should-not (file-directory-p tmp-name1)) - ;; Trashing directories works only since Emacs 27.1. It doesn't - ;; work when `system-move-file-to-trash' is defined (on MS - ;; Windows and macOS), for encrypted remote directories and for - ;; ange-ftp. + ;; Trashing directories doesn't work when + ;; `system-move-file-to-trash' is defined (on MS Windows and + ;; macOS), for encrypted remote directories and for ange-ftp. (when (and (not (fboundp 'system-move-file-to-trash)) - (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) - (tramp--test-emacs27-p)) + (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p))) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -3133,7 +3165,23 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "%s/%s/%s/bla" trash-directory (file-name-nondirectory tmp-name1) (file-name-nondirectory tmp-name2)))) (delete-directory trash-directory 'recursive) - (should-not (file-exists-p trash-directory))))))) + (should-not (file-exists-p trash-directory)))) + + ;; Setting `remote-file-name-inhibit-delete-by-moving-to-trash' + ;; prevents trashing remote files. + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (delete-by-moving-to-trash t) + (remote-file-name-inhibit-delete-by-moving-to-trash t)) + (make-directory trash-directory) + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (delete-directory tmp-name1 nil 'trash) + (should-not (file-exists-p tmp-name1)) + (should-not + (file-exists-p + (expand-file-name (file-name-nondirectory tmp-name1) trash-directory))) + (delete-directory trash-directory 'recursive) + (should-not (file-exists-p trash-directory)))))) (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." @@ -3361,9 +3409,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; (this is performed by `dired'). If FULL is nil, it shows just ;; one file. So we refrain from testing. (skip-unless (not (tramp--test-ange-ftp-p))) - ;; `insert-directory' of encrypted remote directories works only - ;; since Emacs 27.1. - (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 @@ -3381,26 +3426,23 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (with-temp-buffer (insert-directory tmp-name1 nil) (goto-char (point-min)) - (should (looking-at-p (tramp-compat-rx (literal tmp-name1))))) + (should (looking-at-p (rx (literal tmp-name1))))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) nil) (goto-char (point-min)) (should - (looking-at-p - (tramp-compat-rx (literal (file-name-as-directory tmp-name1)))))) + (looking-at-p (rx (literal (file-name-as-directory tmp-name1)))))) (with-temp-buffer (insert-directory tmp-name1 "-al") (goto-char (point-min)) (should - (looking-at-p - (tramp-compat-rx bol (+ nonl) blank (literal tmp-name1) eol)))) + (looking-at-p (rx bol (+ nonl) blank (literal tmp-name1) eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) "-al") (goto-char (point-min)) (should (looking-at-p - (tramp-compat-rx - bol (+ nonl) blank (literal tmp-name1) "/" eol)))) + (rx bol (+ nonl) blank (literal tmp-name1) "/" eol)))) (with-temp-buffer (insert-directory (file-name-as-directory tmp-name1) "-al" nil 'full-directory-p) @@ -3410,12 +3452,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (rx-to-string `(: ;; There might be a summary line. - (? "total" (+ nonl) (+ digit) (? blank) + (? (* blank) "total" (+ nonl) (+ digit) (? blank) (? (any "EGKMPTYZk")) (? "i") (? "B") "\n") ;; We don't know in which order ".", ".." and "foo" appear. (= ,(length (directory-files tmp-name1)) (+ nonl) blank - (regexp ,(regexp-opt (directory-files tmp-name1))) + (| . ,(directory-files tmp-name1)) (? " ->" (+ nonl)) "\n")))))) ;; Check error cases. @@ -3461,7 +3503,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (tmp-name4 (expand-file-name "bar" tmp-name2)) (ert-remote-temporary-file-directory (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) ert-remote-temporary-file-directory)) buffer) (unwind-protect @@ -3483,15 +3525,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name1 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name2 ert-remote-temporary-file-directory)))))) @@ -3505,15 +3547,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*/*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name4 @@ -3535,15 +3577,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "tramp-test*/*" ert-remote-temporary-file-directory))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name3 ert-remote-temporary-file-directory))))) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx (literal (file-relative-name tmp-name4 @@ -3636,6 +3678,18 @@ This tests also `access-file', `file-readable-p', attr) (unwind-protect (progn + (write-region "foo" nil tmp-name1) + ;; `access-file' returns nil in case of success. + (should-not (access-file tmp-name1 "error")) + ;; `access-file' could use a timeout. + (let ((remote-file-name-access-timeout 1)) + (cl-letf (((symbol-function #'file-exists-p) + (lambda (_filename) (sleep-for 5)))) + (should-error + (access-file tmp-name1 "error") + :type 'file-error))) + (delete-file tmp-name1) + ;; A sticky bit could damage the `file-ownership-preserved-p' test. (when (and test-file-ownership-preserved-p @@ -3716,7 +3770,7 @@ This tests also `access-file', `file-readable-p', (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (file-attribute-type attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -3757,7 +3811,7 @@ This tests also `access-file', `file-readable-p', (should (eq (file-attribute-type attr) t))) ;; Cleanup. - (ignore-errors (delete-directory tmp-name1)) + (ignore-errors (delete-directory tmp-name1 'recursive)) (ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-file tmp-name2)))))) @@ -3780,9 +3834,6 @@ This tests also `access-file', `file-readable-p', (cons '(nil "perl" nil) tramp-connection-properties))) (progn - ;; `ert-test-result-duration' exists since Emacs 27. It - ;; doesn't hurt to call it unconditionally, because - ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -3811,9 +3862,6 @@ This tests also `access-file', `file-readable-p', (nil "id" nil)) tramp-connection-properties))) (progn - ;; `ert-test-result-duration' exists since Emacs 27. It - ;; doesn't hurt to call it unconditionally, because - ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -3840,9 +3888,6 @@ This tests also `access-file', `file-readable-p', (nil "readlink" nil)) tramp-connection-properties))) (progn - ;; `ert-test-result-duration' exists since Emacs 27. It - ;; doesn't hurt to call it unconditionally, because - ;; `skip-unless' hides the error. (skip-unless (< (ert-test-result-duration result) 300)) (funcall (ert-test-body ert-test))) (ert-skip (format "Test `%s' must run before" ',test))))) @@ -3878,9 +3923,9 @@ They might differ only in time attributes or directory size." ;; few seconds). We use a test start time minus 10 seconds, in ;; order to compensate a possible timestamp resolution higher than ;; a second on the remote machine. - (when (or (tramp-compat-time-equal-p + (when (or (time-equal-p (file-attribute-modification-time attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p + (time-equal-p (file-attribute-modification-time attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) @@ -3891,9 +3936,9 @@ They might differ only in time attributes or directory size." (float-time (file-attribute-modification-time attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Ditto. - (when (or (tramp-compat-time-equal-p + (when (or (time-equal-p (file-attribute-status-change-time attr1) tramp-time-dont-know) - (tramp-compat-time-equal-p + (time-equal-p (file-attribute-status-change-time attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) @@ -4032,7 +4077,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) ;; Both report the modes of `tmp-name1'. @@ -4105,7 +4150,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) (when (tramp--test-expensive-test-p) @@ -4118,19 +4163,19 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always)) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2)))) (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) ;; If we use the local part of `tmp-name1', it shall still work. @@ -4140,7 +4185,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) ;; `tmp-name3' is a local file name. Therefore, the link @@ -4162,7 +4207,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) + (if quoted #'file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name5))) ;; Check, that files in symlinked directories still work. @@ -4198,7 +4243,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always)) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always)) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -4256,16 +4301,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "/[penguin/motd]" "/penguin:motd:"))) (delete-file tmp-name2) (make-symbolic-link - (funcall - (if quoted #'tramp-compat-file-name-unquote #'identity) penguin) + (funcall (if quoted #'file-name-unquote #'identity) penguin) tmp-name2) (should (file-symlink-p tmp-name2)) (should-not (file-regular-p tmp-name2)) (should (string-equal (file-truename tmp-name2) - (tramp-compat-file-name-quote - (concat (file-remote-p tmp-name2) penguin))))) + (file-name-quote (concat (file-remote-p tmp-name2) penguin))))) ;; `tmp-name3' is a local file name. ;; `make-symbolic-link' might not be permitted on w32 systems. (unless (tramp--test-windows-nt-p) @@ -4278,7 +4321,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (file-truename tmp-name1) - (tramp-compat-file-name-unquote (file-truename tmp-name3)))))) + (file-name-unquote (file-truename tmp-name3)))))) ;; Cleanup. (ignore-errors @@ -4365,7 +4408,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (let* ((dir1 (directory-file-name (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) ert-remote-temporary-file-directory))) (dir2 (file-name-as-directory dir1))) (should (string-equal (file-truename dir1) (expand-file-name dir1))) @@ -4394,12 +4437,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (set-file-times tmp-name1 (seconds-to-time 60))) ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". - (unless (tramp-compat-time-equal-p + (unless (time-equal-p (file-attribute-modification-time (file-attributes tmp-name1)) tramp-time-dont-know) (should - (tramp-compat-time-equal-p + (time-equal-p (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 60))) ;; Setting the time for not existing files shall fail. @@ -4418,7 +4461,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-no-warnings (set-file-times tmp-name1 (seconds-to-time 60) 'nofollow) (should - (tramp-compat-time-equal-p + (time-equal-p (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 60))))))) @@ -4464,10 +4507,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (file-acl ert-remote-temporary-file-directory)) (skip-unless (not (tramp--test-crypt-p))) - ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted - (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4544,10 +4584,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." '(nil nil nil nil)))) (skip-unless (not (tramp--test-crypt-p))) - ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted - (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4940,11 +4977,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if (or (not (get-buffer "*Completions*")) (string-match-p (if (string-empty-p tramp-method-regexp) - (tramp-compat-rx + (rx (| (regexp tramp-postfix-user-regexp) (regexp tramp-postfix-host-regexp)) eos) - (tramp-compat-rx + (rx (| (regexp tramp-postfix-method-regexp) (regexp tramp-postfix-user-regexp) (regexp tramp-postfix-host-regexp)) @@ -4967,10 +5004,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We must remove leading `default-directory'. (goto-char (point-min)) (let ((inhibit-read-only t)) - (while (re-search-forward "//" nil 'noerror) + (while (search-forward-regexp "//" nil 'noerror) (delete-region (line-beginning-position) (point)))) (goto-char (point-min)) - (re-search-forward + (search-forward-regexp (rx bol (0+ nonl) (any "Pp") "ossible completions" (0+ nonl) eol)) @@ -5082,7 +5119,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if (bufferp destination) destination (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp + ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal (if destination (format "%s\n" fnnd) "") @@ -5096,7 +5134,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if (bufferp destination) destination (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp + ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal @@ -5241,9 +5280,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unless t (unwind-protect (with-temp-buffer - (setq command '("cat") - proc - (apply #'start-file-process "test4" (current-buffer) command)) + (setq command '("cat") + proc + (apply + #'start-file-process "test4" (current-buffer) command)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5263,12 +5303,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Process connection type. (when (and (tramp--test-sh-p) (not (tramp-direct-async-process-p)) - ;; `executable-find' has changed the number of - ;; parameters in Emacs 27.1, so we use `apply' for - ;; older Emacsen. - (ignore-errors - (with-no-warnings - (apply #'executable-find '("hexdump" remote))))) + (executable-find "hexdump" 'remote)) (dolist (process-connection-type '(nil pipe t pty)) (unwind-protect (with-temp-buffer @@ -5323,33 +5358,29 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Define ert test `TEST-direct-async' for direct async processes. If UNSTABLE is non-nil, the test is tagged as `:unstable'." (declare (indent 1)) - ;; `make-process' supports file name handlers since Emacs 27. We - ;; cannot use `tramp--test-always' during compilation of the macro. - (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t))))) - (ignore-errors (make-process :name "" :command "" :file-handler t))) - `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () - ;; This is the docstring. However, it must be expanded to a - ;; string inside the macro. No idea. - ;; (concat (ert-test-documentation (get ',test 'ert--test)) - ;; "\nUse direct async process.") - :tags (append '(:expensive-test :tramp-asynchronous-processes) - (and ,unstable '(:unstable))) - (skip-unless (tramp--test-enabled)) - (let ((default-directory ert-remote-temporary-file-directory) - (ert-test (ert-get-test ',test)) - (tramp-connection-properties - (cons '(nil "direct-async-process" t) - tramp-connection-properties))) - (skip-unless (tramp-direct-async-process-p)) - ;; We do expect an established connection already, - ;; `file-truename' does it by side-effect. Suppress - ;; `tramp--test-enabled', in order to keep the connection. - ;; Suppress "Process ... finished" messages. - (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp--test-always) - ((symbol-function #'internal-default-process-sentinel) - #'ignore)) - (file-truename ert-remote-temporary-file-directory) - (funcall (ert-test-body ert-test))))))) + `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () + ;; This is the docstring. However, it must be expanded to a + ;; string inside the macro. No idea. + ;; (concat (ert-test-documentation (get ',test 'ert--test)) + ;; "\nUse direct async process.") + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and ,unstable '(:unstable))) + (skip-unless (tramp--test-enabled)) + (let ((default-directory ert-remote-temporary-file-directory) + (ert-test (ert-get-test ',test)) + (tramp-connection-properties + (cons '(nil "direct-async-process" t) + tramp-connection-properties))) + (skip-unless (tramp-direct-async-process-p)) + ;; We do expect an established connection already, + ;; `file-truename' does it by side-effect. Suppress + ;; `tramp--test-enabled', in order to keep the connection. + ;; Suppress "Process ... finished" messages. + (cl-letf (((symbol-function #'tramp--test-enabled) #'tramp-compat-always) + ((symbol-function #'internal-default-process-sentinel) + #'ignore)) + (file-truename ert-remote-temporary-file-directory) + (funcall (ert-test-body ert-test)))))) (tramp--test-deftest-direct-async-process tramp-test29-start-file-process) @@ -5360,8 +5391,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - ;; `make-process' supports file name handlers since Emacs 27. - (skip-unless (tramp--test-emacs27-p)) (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((default-directory ert-remote-temporary-file-directory) @@ -5374,10 +5403,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat") proc - (with-no-warnings - (make-process - :name "test1" :buffer (current-buffer) :command command - :file-handler t))) + (make-process + :name "test1" :buffer (current-buffer) :command command + :file-handler t)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5399,10 +5427,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (should (file-exists-p tmp-name)) (setq command `("cat" ,(file-name-nondirectory tmp-name)) proc - (with-no-warnings - (make-process - :name "test2" :buffer (current-buffer) :command command - :file-handler t))) + (make-process + :name "test2" :buffer (current-buffer) :command command + :file-handler t)) (should (processp proc)) (should (equal (process-get proc 'remote-command) command)) ;; Read output. @@ -5421,13 +5448,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat") proc - (with-no-warnings - (make-process - :name "test3" :buffer (current-buffer) :command command - :filter - (lambda (p s) - (with-current-buffer (process-buffer p) (insert s))) - :file-handler t))) + (make-process + :name "test3" :buffer (current-buffer) :command command + :filter + (lambda (p s) + (with-current-buffer (process-buffer p) (insert s))) + :file-handler t)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5448,11 +5474,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat") proc - (with-no-warnings - (make-process - :name "test4" :buffer (current-buffer) :command command - :filter t - :file-handler t))) + (make-process + :name "test4" :buffer (current-buffer) :command command + :filter t :file-handler t)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5473,13 +5497,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat") proc - (with-no-warnings - (make-process - :name "test5" :buffer (current-buffer) :command command - :sentinel - (lambda (p s) - (with-current-buffer (process-buffer p) (insert s))) - :file-handler t))) + (make-process + :name "test5" :buffer (current-buffer) :command command + :sentinel + (lambda (p s) + (with-current-buffer (process-buffer p) (insert s))) + :file-handler t)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5505,11 +5528,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat" "/does-not-exist") proc - (with-no-warnings - (make-process - :name "test6" :buffer (current-buffer) :command command - :stderr stderr - :file-handler t))) + (make-process + :name "test6" :buffer (current-buffer) :command command + :stderr stderr :file-handler t)) (should (processp proc)) (should (equal (process-get proc 'remote-command) command)) ;; Read output. @@ -5538,11 +5559,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("cat" "/does-not-exist") proc - (with-no-warnings - (make-process - :name "test7" :buffer (current-buffer) :command command - :stderr tmp-name - :file-handler t))) + (make-process + :name "test7" :buffer (current-buffer) :command command + :stderr tmp-name :file-handler t)) (should (processp proc)) (should (equal (process-get proc 'remote-command) command)) ;; Read stderr. @@ -5563,12 +5582,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Process connection type. (when (and (tramp--test-sh-p) (not (tramp-direct-async-process-p)) - ;; `executable-find' has changed the number of - ;; parameters in Emacs 27.1, so we use `apply' for - ;; older Emacsen. - (ignore-errors - (with-no-warnings - (apply #'executable-find '("hexdump" remote))))) + (executable-find "hexdump" 'remote)) (dolist (connection-type '(nil pipe t pty)) ;; `process-connection-type' is taken when ;; `:connection-type' is nil. @@ -5578,15 +5592,14 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (with-temp-buffer (setq command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") proc - (with-no-warnings - (make-process - :name - (format "test8-%s-%s" - connection-type process-connection-type) - :buffer (current-buffer) - :connection-type connection-type - :command command - :file-handler t))) + (make-process + :name + (format "test8-%s-%s" + connection-type process-connection-type) + :buffer (current-buffer) + :connection-type connection-type + :command command + :file-handler t)) (should (processp proc)) (should (equal (process-status proc) 'run)) (should (equal (process-get proc 'remote-command) command)) @@ -5620,8 +5633,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-windows-nt-p))) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 27.1. - (skip-unless (macrop 'with-connection-local-variables)) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous @@ -5663,8 +5674,6 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-windows-nt-p))) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 27.1. - (skip-unless (macrop 'with-connection-local-variables)) ;; Since Emacs 29.1. (skip-unless (boundp 'signal-process-functions)) @@ -5675,55 +5684,69 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (delete-exited-processes t) kill-buffer-query-functions command proc) - (dolist (sigcode '(2 INT)) - (unwind-protect - (with-temp-buffer - (setq command "trap 'echo boom; exit 1' 2; sleep 100" - proc (start-file-process-shell-command - (format "test1%s" sigcode) (current-buffer) command)) - (should (processp proc)) - (should (process-live-p proc)) - (should (equal (process-status proc) 'run)) - (should (numberp (process-get proc 'remote-pid))) - (should (equal (process-get proc 'remote-command) - (with-connection-local-variables - `(,shell-file-name ,shell-command-switch ,command)))) - (should (zerop (signal-process proc sigcode))) - ;; Let the process accept the signal. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc 0 nil t))) - (should-not (process-live-p proc))) + ;; If PROCESS is a string, it must be a process name or a process + ;; number. Check error handling. + (should-error + (signal-process (md5 (current-time-string)) 0) + :type 'wrong-type-argument) + + ;; The PROCESS argument of `signal-process' can be a string. Test + ;; this as well. + (dolist + (func '(identity + (lambda (x) (format "%s" (if (processp x) (process-name x) x))))) + (dolist (sigcode '(2 INT)) + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test1-%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) + (should + (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + (should (zerop (signal-process (funcall func proc) sigcode))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) - ;; Cleanup. - (ignore-errors (kill-process proc)) - (ignore-errors (delete-process proc))) + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc))) - (unwind-protect - (with-temp-buffer - (setq command "trap 'echo boom; exit 1' 2; sleep 100" - proc (start-file-process-shell-command - (format "test2%s" sigcode) (current-buffer) command)) - (should (processp proc)) - (should (process-live-p proc)) - (should (equal (process-status proc) 'run)) - (should (numberp (process-get proc 'remote-pid))) - (should (equal (process-get proc 'remote-command) - (with-connection-local-variables - `(,shell-file-name ,shell-command-switch ,command)))) - ;; `signal-process' has argument REMOTE since Emacs 29. - (with-no-warnings + (unwind-protect + (with-temp-buffer + (setq command "trap 'echo boom; exit 1' 2; sleep 100" + proc (start-file-process-shell-command + (format "test2-%s" sigcode) (current-buffer) command)) + (should (processp proc)) + (should (process-live-p proc)) + (should (equal (process-status proc) 'run)) + (should (numberp (process-get proc 'remote-pid))) (should - (zerop - (signal-process - (process-get proc 'remote-pid) sigcode default-directory)))) - ;; Let the process accept the signal. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc 0 nil t))) - (should-not (process-live-p proc))) + (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) + ;; `signal-process' has argument REMOTE since Emacs 29. + (with-no-warnings + (should + (zerop + (signal-process + (funcall func (process-get proc 'remote-pid)) + sigcode default-directory)))) + ;; Let the process accept the signal. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (should-not (process-live-p proc))) - ;; Cleanup. - (ignore-errors (kill-process proc)) - (ignore-errors (delete-process proc)))))) + ;; Cleanup. + (ignore-errors (kill-process proc)) + (ignore-errors (delete-process proc))))))) (ert-deftest tramp-test31-list-system-processes () "Check `list-system-processes'." @@ -5765,7 +5788,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; (tramp--test-message "%s" attributes) (should (equal (cdr (assq 'comm attributes)) (car command))) (should (equal (cdr (assq 'args attributes)) - (mapconcat #'identity command " "))))) + (string-join command " "))))) ;; Cleanup. (ignore-errors (delete-process proc))))) @@ -5791,11 +5814,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." INPUT, if non-nil, is a string sent to the process." (let ((proc (async-shell-command command output-buffer error-buffer)) (delete-exited-processes t)) - ;; Since Emacs 27.1. - (when (macrop 'with-connection-local-variables) - (should (equal (process-get proc 'remote-command) - (with-connection-local-variables - `(,shell-file-name ,shell-command-switch ,command))))) + (should (equal (process-get proc 'remote-command) + (with-connection-local-variables + `(,shell-file-name ,shell-command-switch ,command)))) (cl-letf (((symbol-function #'shell-command-sentinel) #'ignore)) (when (stringp input) (process-send-string proc input)) @@ -5816,10 +5837,6 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for - ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (when (tramp--test-adb-p) - (skip-unless (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -5847,7 +5864,7 @@ INPUT, if non-nil, is a string sent to the process." (current-buffer)) ;; "ls" could produce colorized output. (goto-char (point-min)) - (while (re-search-forward ansi-color-control-seq-regexp nil t) + (while (search-forward-regexp ansi-color-control-seq-regexp nil t) (replace-match "" nil nil)) (should (string-equal @@ -5886,7 +5903,7 @@ INPUT, if non-nil, is a string sent to the process." (should (string-match-p ;; Some shells echo, for example the "adb" or container methods. - (tramp-compat-rx + (rx bos (** 1 2 (literal (file-name-nondirectory tmp-name)) "\n") eos) (buffer-string)))) @@ -5894,10 +5911,8 @@ INPUT, if non-nil, is a string sent to the process." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) - ;; Test `async-shell-command-width'. It exists since Emacs 26.1, - ;; but seems to work since Emacs 27.1 only. - (when (and (tramp--test-asynchronous-processes-p) - (tramp--test-sh-p) (tramp--test-emacs27-p)) + ;; Test `async-shell-command-width'. + (when (and (tramp--test-asynchronous-processes-p) (tramp--test-sh-p)) (let* ((async-shell-command-width 1024) (default-directory ert-remote-temporary-file-directory) (cols (ignore-errors @@ -5917,8 +5932,6 @@ INPUT, if non-nil, is a string sent to the process." (skip-unless (tramp--test-enabled)) (skip-unless nil) (skip-unless (tramp--test-supports-processes-p)) - ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. - (skip-unless (tramp--test-emacs27-p)) ;; (message " s-c-d-e-b current-buffer buffer-string point") ;; (message "===============================================") @@ -6093,8 +6106,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Variable is set. (should (string-match-p - (tramp-compat-rx (literal envvar)) - (funcall this-shell-command-to-string "set")))) + (rx (literal envvar)) (funcall this-shell-command-to-string "set")))) (unless (tramp-direct-async-process-p) ;; We force a reconnect, in order to have a clean environment. @@ -6122,7 +6134,7 @@ INPUT, if non-nil, is a string sent to the process." ;; Variable is unset. (should-not (string-match-p - (tramp-compat-rx (literal envvar)) + (rx (literal envvar)) ;; We must remove PS1, the output is truncated otherwise. ;; We must suppress "_=VAR...". (funcall @@ -6167,13 +6179,10 @@ INPUT, if non-nil, is a string sent to the process." (dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:")) (tramp-cleanup-connection (tramp-dissect-file-name dir))))) -;; Connection-local variables are enabled per default since Emacs 27.1. (ert-deftest tramp-test34-connection-local-variables () "Check that connection-local variables are enabled." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - ;; Since Emacs 27.1. - (skip-unless (macrop 'with-connection-local-variables)) (let* ((default-directory ert-remote-temporary-file-directory) (tmp-name1 (tramp--test-make-temp-name)) @@ -6183,8 +6192,7 @@ INPUT, if non-nil, is a string sent to the process." (inhibit-message t) kill-buffer-query-functions (clpa connection-local-profile-alist) - (clca connection-local-criteria-alist) - connection-local-profile-alist connection-local-criteria-alist) + (clca connection-local-criteria-alist)) (unwind-protect (progn (make-directory tmp-name1) @@ -6214,22 +6222,42 @@ INPUT, if non-nil, is a string sent to the process." (should (eq local-variable 'connect)) (kill-buffer (current-buffer))) - ;; `local-variable' is dir-local due to existence of .dir-locals.el. + ;; `local-variable' is still connection-local due to Tramp. + ;; `find-file-hook' overrides dir-local settings. (write-region "((nil . ((local-variable . dir))))" nil (expand-file-name ".dir-locals.el" tmp-name1)) (should (file-exists-p (expand-file-name ".dir-locals.el" tmp-name1))) - (with-current-buffer (find-file-noselect tmp-name2) - (should (eq local-variable 'dir)) - (kill-buffer (current-buffer))) - - ;; `local-variable' is file-local due to specifying as file variable. + (when (memq #'tramp-set-connection-local-variables-for-buffer + find-file-hook) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'connect)) + (kill-buffer (current-buffer)))) + ;; `local-variable' is dir-local due to existence of .dir-locals.el. + (let ((find-file-hook + (remq #'tramp-set-connection-local-variables-for-buffer + find-file-hook))) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'dir)) + (kill-buffer (current-buffer)))) + + ;; `local-variable' is still connection-local due to Tramp. + ;; `find-file-hook' overrides dir-local settings. (write-region "-*- mode: comint; local-variable: file; -*-" nil tmp-name2) (should (file-exists-p tmp-name2)) - (with-current-buffer (find-file-noselect tmp-name2) - (should (eq local-variable 'file)) - (kill-buffer (current-buffer)))) + (when (memq #'tramp-set-connection-local-variables-for-buffer + find-file-hook) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'connect)) + (kill-buffer (current-buffer)))) + ;; `local-variable' is file-local due to specifying as file variable. + (let ((find-file-hook + (remq #'tramp-set-connection-local-variables-for-buffer + find-file-hook))) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'file)) + (kill-buffer (current-buffer))))) ;; Cleanup. (custom-set-variables @@ -6242,21 +6270,13 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for - ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (when (tramp--test-adb-p) - (skip-unless (tramp--test-emacs27-p))) (let ((default-directory ert-remote-temporary-file-directory) explicit-shell-file-name kill-buffer-query-functions (clpa connection-local-profile-alist) - (clca connection-local-criteria-alist) - connection-local-profile-alist connection-local-criteria-alist) + (clca connection-local-criteria-alist)) (unwind-protect (progn - ;; `shell-mode' would ruin our test, because it deletes all - ;; buffer local variables. Not needed in Emacs 27.1. - (put 'explicit-shell-file-name 'permanent-local t) (connection-local-set-profile-variables 'remote-sh `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) @@ -6290,29 +6310,24 @@ INPUT, if non-nil, is a string sent to the process." `(connection-local-criteria-alist ',clca now)) (kill-buffer "*shell*")))) -;; `exec-path' was introduced in Emacs 27.1. `executable-find' has -;; changed the number of parameters, so we use `apply' for older -;; Emacsen. (ert-deftest tramp-test35-exec-path () "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) (skip-unless (tramp--test-supports-set-file-modes-p)) - ;; Since Emacs 27.1. - (skip-unless (fboundp 'exec-path)) (let ((tmp-name (tramp--test-make-temp-name)) (default-directory ert-remote-temporary-file-directory)) (unwind-protect (progn - (should (consp (with-no-warnings (exec-path)))) + (should (consp (exec-path))) ;; Last element is the `exec-directory'. (should (string-equal - (car (last (with-no-warnings (exec-path)))) + (car (last (exec-path))) (file-remote-p default-directory 'localname))) ;; The shell "sh" shall always exist. - (should (apply #'executable-find '("sh" remote))) + (should (executable-find "sh" 'remote)) ;; Since the last element in `exec-path' is the current ;; directory, an executable file in that directory will be ;; found. @@ -6323,56 +6338,51 @@ INPUT, if non-nil, is a string sent to the process." (should (file-executable-p tmp-name)) (should (string-equal - (apply - #'executable-find `(,(file-name-nondirectory tmp-name) remote)) + (executable-find (file-name-nondirectory tmp-name) 'remote) (file-remote-p tmp-name 'localname))) (should-not - (apply - #'executable-find - `(,(concat (file-name-nondirectory tmp-name) "foo") remote)))) + (executable-find + (concat (file-name-nondirectory tmp-name) "foo") 'remote))) ;; Cleanup. (ignore-errors (delete-file tmp-name))))) +(tramp--test-deftest-direct-async-process tramp-test35-exec-path) + ;; This test is inspired by Bug#33781. -;; `exec-path' was introduced in Emacs 27.1. `executable-find' has -;; changed the number of parameters, so we use `apply' for older -;; Emacsen. (ert-deftest tramp-test35-remote-path () "Check loooong `tramp-remote-path'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 27.1. - (skip-unless (fboundp 'exec-path)) (let* ((tmp-name (tramp--test-make-temp-name)) (default-directory ert-remote-temporary-file-directory) - (orig-exec-path (with-no-warnings (exec-path))) + (orig-exec-path (exec-path)) (tramp-remote-path tramp-remote-path) (orig-tramp-remote-path tramp-remote-path) path) + ;; The "flatpak" method modifies `tramp-remote-path'. + (skip-unless (not (tramp-compat-connection-local-p tramp-remote-path))) (unwind-protect (progn ;; Non existing directories are removed. (setq tramp-remote-path (cons (file-remote-p tmp-name 'localname) tramp-remote-path)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (should (equal (with-no-warnings (exec-path)) orig-exec-path)) + (should (equal (exec-path) orig-exec-path)) (setq tramp-remote-path orig-tramp-remote-path) ;; Double entries are removed. (setq tramp-remote-path (append '("/" "/") tramp-remote-path)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (should - (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path))) + (should (equal (exec-path) (cons "/" orig-exec-path))) (setq tramp-remote-path orig-tramp-remote-path) ;; We make a super long `tramp-remote-path'. (make-directory tmp-name) (should (file-directory-p tmp-name)) - (while (tramp-compat-length< - (mapconcat #'identity orig-exec-path ":") 5000) + (while (tramp-compat-length< (string-join orig-exec-path ":") 5000) (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) (should (file-directory-p dir)) (setq tramp-remote-path @@ -6384,7 +6394,7 @@ INPUT, if non-nil, is a string sent to the process." `(,(file-remote-p dir 'localname)) (last orig-exec-path))))) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (should (equal (with-no-warnings (exec-path)) orig-exec-path)) + (should (equal (exec-path) orig-exec-path)) ;; Ignore trailing newline. (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) ;; The shell doesn't handle such long strings. @@ -6394,16 +6404,17 @@ INPUT, if non-nil, is a string sent to the process." tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. (should - (string-equal - path (mapconcat #'identity (butlast orig-exec-path) ":")))) + (string-equal path (string-join (butlast orig-exec-path) ":")))) ;; The shell "sh" shall always exist. - (should (apply #'executable-find '("sh" remote)))) + (should (executable-find "sh" 'remote))) ;; Cleanup. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (setq tramp-remote-path orig-tramp-remote-path) (ignore-errors (delete-directory tmp-name 'recursive))))) +(tramp--test-deftest-direct-async-process tramp-test35-remote-path) + (ert-deftest tramp-test36-vc-registered () "Check `vc-registered'." :tags '(:expensive-test) @@ -6517,7 +6528,7 @@ INPUT, if non-nil, is a string sent to the process." (string-equal (make-auto-save-file-name) (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (format "#%s#" (file-name-nondirectory tmp-name1)) ert-remote-temporary-file-directory)))))) @@ -6542,7 +6553,7 @@ INPUT, if non-nil, is a string sent to the process." ("|" . "__") ("[" . "_l") ("]" . "_r")) - (tramp-compat-file-name-unquote tmp-name1))) + (file-name-unquote tmp-name1))) tmp-name2))) (should (file-directory-p tmp-name2))))) @@ -6566,7 +6577,7 @@ INPUT, if non-nil, is a string sent to the process." ("|" . "__") ("[" . "_l") ("]" . "_r")) - (tramp-compat-file-name-unquote tmp-name1))) + (file-name-unquote tmp-name1))) tmp-name2))) (should (file-directory-p tmp-name2))))) @@ -6592,7 +6603,7 @@ INPUT, if non-nil, is a string sent to the process." (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (cl-letf (((symbol-function #'yes-or-no-p) - #'tramp--test-always)) + #'tramp-compat-always)) (should (stringp (make-auto-save-file-name)))))))) ;; Cleanup. @@ -6622,7 +6633,7 @@ INPUT, if non-nil, is a string sent to the process." (find-backup-file-name tmp-name1) (list (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (format "%s~" (file-name-nondirectory tmp-name1)) ert-remote-temporary-file-directory)))))) @@ -6639,7 +6650,7 @@ INPUT, if non-nil, is a string sent to the process." (find-backup-file-name tmp-name1) (list (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (format "%s~" @@ -6668,7 +6679,7 @@ INPUT, if non-nil, is a string sent to the process." (find-backup-file-name tmp-name1) (list (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (format "%s~" @@ -6699,7 +6710,7 @@ INPUT, if non-nil, is a string sent to the process." (find-backup-file-name tmp-name1) (list (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (expand-file-name (format "%s~" @@ -6738,8 +6749,7 @@ INPUT, if non-nil, is a string sent to the process." :type 'file-error)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (cl-letf (((symbol-function #'yes-or-no-p) - #'tramp--test-always)) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always)) (should (stringp (car (find-backup-file-name tmp-name1))))))) ;; Cleanup. @@ -6756,7 +6766,7 @@ INPUT, if non-nil, is a string sent to the process." (skip-unless (and (fboundp 'file-locked-p) (fboundp 'make-lock-file-name))) ;; `lock-file', `unlock-file', `file-locked-p' and - ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to + ;; `make-lock-file-name' exist since Emacs 28.1. We don't want to ;; see compiler warnings for older Emacsen. (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) @@ -6790,11 +6800,33 @@ INPUT, if non-nil, is a string sent to the process." (save-buffer) (should-not (buffer-modified-p))) (should-not (with-no-warnings (file-locked-p tmp-name1))) + + ;; `kill-buffer' removes the lock. (with-no-warnings (lock-file tmp-name1)) (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + (with-temp-buffer + (set-visited-file-name tmp-name1) + (insert "foo") + (should (buffer-modified-p)) + (cl-letf (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) "yes"))) + (kill-buffer))) + (should-not (with-no-warnings (file-locked-p tmp-name1))) + ;; `kill-buffer' should not remove the lock when the + ;; connection is broken. See Bug#61663. + (with-no-warnings (lock-file tmp-name1)) + (should (eq (with-no-warnings (file-locked-p tmp-name1)) t)) + (with-temp-buffer + (set-visited-file-name tmp-name1) + (insert "foo") + (should (buffer-modified-p)) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + (cl-letf (((symbol-function #'read-from-minibuffer) + (lambda (&rest _args) "yes"))) + (kill-buffer))) ;; A new connection changes process id, and also the - ;; lockname contents. + ;; lock file contents. But it still exists. (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (stringp (with-no-warnings (file-locked-p tmp-name1)))) @@ -6872,8 +6904,7 @@ INPUT, if non-nil, is a string sent to the process." :type 'file-error)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) - (cl-letf (((symbol-function #'yes-or-no-p) - #'tramp--test-always)) + (cl-letf (((symbol-function #'yes-or-no-p) #'tramp-compat-always)) (write-region "foo" nil tmp-name1)))) ;; Cleanup. @@ -6944,7 +6975,8 @@ INPUT, if non-nil, is a string sent to the process." (should (file-locked-p tmp-name))))) ;; `save-buffer' removes the file lock. - (cl-letf (((symbol-function #'yes-or-no-p) #'tramp--test-always) + (cl-letf (((symbol-function #'yes-or-no-p) + #'tramp-compat-always) ((symbol-function #'read-char-choice) (lambda (&rest _) ?y))) (should (buffer-modified-p)) @@ -6958,7 +6990,6 @@ INPUT, if non-nil, is a string sent to the process." (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) @@ -6990,12 +7021,6 @@ INPUT, if non-nil, is a string sent to the process." (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--test-emacs27-p () - "Check for Emacs version >= 27.1. -Some semantics has been changed for there, without new functions -or variables, so we check the Emacs version directly." - (>= emacs-major-version 27)) - (defun tramp--test-emacs28-p () "Check for Emacs version >= 28.1. Some semantics has been changed for there, without new functions @@ -7028,9 +7053,9 @@ This is used in tests which we don't want to tag (ert--stats-selector ert--current-run-stats) (list (make-ert-test :name (ert-test-name (ert-running-test)) :body nil :tags '(:tramp-asynchronous-processes)))) - ;; tramp-adb.el cannot apply multi-byte commands. + ;; tramp-adb.el cannot apply multibyte commands. (not (and (tramp--test-adb-p) - (string-match-p (tramp-compat-rx multibyte) default-directory))))) + (string-match-p (rx multibyte) default-directory))))) (defun tramp--test-crypt-p () "Check, whether the remote directory is encrypted." @@ -7104,10 +7129,29 @@ This does not support external Emacs calls." (string-equal "mock" (file-remote-p ert-remote-temporary-file-directory 'method))) +(defun tramp--test-netbsd-p () + "Check, whether the remote host runs NetBSD." + ;; We must refill the cache. `file-truename' does it. + (file-truename ert-remote-temporary-file-directory) + (ignore-errors (tramp-check-remote-uname tramp-test-vec "NetBSD"))) + +(defun tramp--test-openbsd-p () + "Check, whether the remote host runs OpenBSD." + ;; We must refill the cache. `file-truename' does it. + (file-truename ert-remote-temporary-file-directory) + (ignore-errors (tramp-check-remote-uname tramp-test-vec "OpenBSD"))) + (defun tramp--test-out-of-band-p () "Check, whether an out-of-band method is used." (tramp-method-out-of-band-p tramp-test-vec 1)) +(defun tramp--test-putty-p () + "Check, whether the method method usaes PuTTY. +This does not support connection share for more than two connections." + (member + (file-remote-p ert-remote-temporary-file-directory 'method) + '("plink" "plinkx" "pscp" "psftp"))) + (defun tramp--test-rclone-p () "Check, whether the remote host is offered by rclone. This requires restrictions of file name syntax." @@ -7195,10 +7239,7 @@ This requires restrictions of file name syntax." (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." - ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted - (if (and (tramp--test-expensive-test-p) (tramp--test-emacs27-p)) - '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -7248,7 +7289,7 @@ This requires restrictions of file name syntax." (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (file-attribute-type (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. @@ -7331,22 +7372,24 @@ This requires restrictions of file name syntax." ;; Check symlink in `directory-files-and-attributes'. ;; It does not work in the "smb" case, only relative - ;; symlinks to existing files are shown there. + ;; symlinks to existing files are shown there. On + ;; NetBSD, there are problems with loooong file names, + ;; see Bug#65324. (tramp--test-ignore-make-symbolic-link-error - (unless (tramp--test-smb-p) + (unless (or (tramp--test-netbsd-p) (tramp--test-smb-p)) (make-symbolic-link file2 file3) (should (file-symlink-p file3)) (should (string-equal (caar (directory-files-and-attributes - file1 nil (tramp-compat-rx (literal elt1)))) + file1 nil (rx (literal elt1)))) elt1)) (should (string-equal (funcall - (if quoted #'tramp-compat-file-name-quote #'identity) + (if quoted #'file-name-quote #'identity) (cadr (car (directory-files-and-attributes - file1 nil (tramp-compat-rx (literal elt1)))))) + file1 nil (rx (literal elt1)))))) (file-remote-p (file-truename file2) 'localname))) (delete-file file3) (should-not (file-exists-p file3)))) @@ -7355,15 +7398,7 @@ This requires restrictions of file name syntax." ;; `default-directory' with special characters. See ;; Bug#53846. (when (and (tramp--test-expensive-test-p) - (tramp--test-supports-processes-p) - ;; Prior Emacs 27, `shell-file-name' was - ;; hard coded as "/bin/sh" for remote - ;; processes in Emacs. That doesn't work - ;; for tramp-adb.el. tramp-sshfs.el times - ;; out for older Emacsen, reason unknown. - (or (and (not (tramp--test-adb-p)) - (not (tramp--test-sshfs-p))) - (tramp--test-emacs27-p))) + (tramp--test-supports-processes-p)) (let ((default-directory file1)) (dolist (this-shell-command (append @@ -7400,8 +7435,8 @@ This requires restrictions of file name syntax." (when (zerop (process-file "printenv" nil t nil)) (goto-char (point-min)) (should - (re-search-forward - (tramp-compat-rx + (search-forward-regexp + (rx bol (literal envvar) "=" (literal (getenv envvar)) eol))))))))) @@ -7429,6 +7464,7 @@ This requires restrictions of file name syntax." (cond ((or (tramp--test-ange-ftp-p) (tramp--test-container-p) (tramp--test-gvfs-p) + (tramp--test-openbsd-p) (tramp--test-rclone-p) (tramp--test-sudoedit-p) (tramp--test-windows-nt-or-smb-p)) @@ -7473,7 +7509,7 @@ This requires restrictions of file name syntax." ;; Simplify test in order to speed up. (apply #'tramp--test-check-files (if (tramp--test-expensive-test-p) - files (list (mapconcat #'identity files "")))))) + files (list (string-join files "")))))) (tramp--test-deftest-with-stat tramp-test41-special-characters) @@ -7509,7 +7545,8 @@ This requires restrictions of file name syntax." "Автостопом по гала́ктике" ;; Use codepoints without a name. See Bug#31272. ;; Works on some Android systems only. - (unless (tramp--test-adb-p) "bung") + (unless (or (tramp--test-adb-p) (tramp--test-openbsd-p)) + "bung") ;; Use codepoints from Supplementary Multilingual Plane (U+10000 ;; to U+1FFFF). "🌈🍒👋") @@ -7549,23 +7586,51 @@ This requires restrictions of file name syntax." (ert-deftest tramp-test43-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) - ;; Since Emacs 27.1. - (skip-unless (fboundp 'file-system-info)) - ;; `file-system-info' exists since Emacs 27.1. We don't want to see - ;; compiler warnings for older Emacsen. - (when-let ((fsi (with-no-warnings - (file-system-info ert-remote-temporary-file-directory)))) + (when-let ((fsi (file-system-info ert-remote-temporary-file-directory))) (should (consp fsi)) (should (tramp-compat-length= fsi 3)) (dotimes (i (length fsi)) (should (natnump (or (nth i fsi) 0)))))) -;; `tramp-test44-asynchronous-requests' could be blocked. So we set a +;; `file-user-uid' and `file-group-gid' were introduced in Emacs 30.1. +(ert-deftest tramp-test44-file-user-group-ids () + "Check results of user/group functions. +`file-user-uid', `file-group-gid', and `tramp-get-remote-*' +should all return proper values." + (skip-unless (tramp--test-enabled)) + + (let ((default-directory ert-remote-temporary-file-directory)) + ;; `file-user-uid' and `file-group-gid' exist since Emacs 30.1. + ;; We don't want to see compiler warnings for older Emacsen. + (when (fboundp 'file-user-uid) + (should (integerp (with-no-warnings (file-user-uid))))) + (when (fboundp 'file-group-gid) + (should (integerp (with-no-warnings (file-group-gid))))) + + (with-parsed-tramp-file-name default-directory nil + (should (or (integerp (tramp-get-remote-uid v 'integer)) + (null (tramp-get-remote-uid v 'integer)))) + (should (or (stringp (tramp-get-remote-uid v 'string)) + (null (tramp-get-remote-uid v 'string)))) + + (should (or (integerp (tramp-get-remote-gid v 'integer)) + (null (tramp-get-remote-gid v 'integer)))) + (should (or (stringp (tramp-get-remote-gid v 'string)) + (null (tramp-get-remote-gid v 'string)))) + + (when-let ((groups (tramp-get-remote-groups v 'integer))) + (should (consp groups)) + (dolist (group groups) (should (integerp group)))) + (when-let ((groups (tramp-get-remote-groups v 'string))) + (should (consp groups)) + (dolist (group groups) (should (stringp group))))))) + +;; `tramp-test45-asynchronous-requests' could be blocked. So we set a ;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300 ;; seconds. Similar check is performed in the timer function. (defconst tramp--test-asynchronous-requests-timeout 300 - "Timeout for `tramp-test44-asynchronous-requests'.") + "Timeout for `tramp-test45-asynchronous-requests'.") (defmacro tramp--test-with-proper-process-name-and-buffer (proc &rest body) "Set \"process-name\" and \"process-buffer\" connection properties. @@ -7601,17 +7666,13 @@ This is needed in timer functions as well as process filters and sentinels." (tramp-flush-connection-property v "process-buffer"))))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test44-asynchronous-requests () +(ert-deftest tramp-test45-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags '(:expensive-test :tramp-asynchronous-processes :unstable) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for - ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (when (tramp--test-adb-p) - (skip-unless (tramp--test-emacs27-p))) (skip-unless (not (tramp--test-container-p))) (skip-unless (not (tramp--test-telnet-p))) (skip-unless (not (tramp--test-sshfs-p))) @@ -7647,6 +7708,10 @@ process sentinels. They shall not disturb each other." (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES")))) ((getenv "EMACS_HYDRA_CI") 5) (t 10))) + ;; PuTTY-based methods can only share up to 10 connections. + (tramp-use-connection-share + (if (and (tramp--test-putty-p) (>= number-proc 10)) + 'suppress (bound-and-true-p tramp-use-connection-share))) ;; On hydra, timings are bad. (timer-repeat (cond @@ -7677,14 +7742,12 @@ process sentinels. They shall not disturb each other." (when buffers (let ((time (float-time)) (default-directory tmp-name) - (file (buffer-name (seq-random-elt buffers))) - ;; A remote operation in a timer could - ;; confuse Tramp heavily. So we ignore this - ;; error here. - (debug-ignored-errors - (cons 'remote-file-error debug-ignored-errors))) + (file (buffer-name (seq-random-elt buffers)))) (tramp--test-message "Start timer %s %s" file (current-time-string)) + (dired-uncache file) + (tramp--test-message + "Continue timer %s %s" file (file-attributes file)) (vc-registered file) (tramp--test-message "Stop timer %s %s" file (current-time-string)) @@ -7772,7 +7835,7 @@ process sentinels. They shall not disturb each other." (setq buffers (delq buf buffers)))) (setq buffers (delq buf buffers))))) - ;; Checks. All process output shall exists in the + ;; Checks. All process output shall exist in the ;; respective buffers. All created files shall be ;; deleted. (tramp--test-message "Check %s" (current-time-string)) @@ -7798,10 +7861,10 @@ process sentinels. They shall not disturb each other." (ignore-errors (cancel-timer timer)) (ignore-errors (delete-directory tmp-name 'recursive)))))) -;; (tramp--test-deftest-direct-async-process tramp-test44-asynchronous-requests +;; (tramp--test-deftest-direct-async-process tramp-test45-asynchronous-requests ;; 'unstable) -(ert-deftest tramp-test45-dired-compress-file () +(ert-deftest tramp-test46-dired-compress-file () "Check that Tramp (un)compresses normal files." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) @@ -7822,7 +7885,7 @@ process sentinels. They shall not disturb each other." (should (string= tmp-name (dired-get-filename))) (delete-file tmp-name))) -(ert-deftest tramp-test45-dired-compress-dir () +(ert-deftest tramp-test46-dired-compress-dir () "Check that Tramp (un)compresses directories." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) @@ -7844,7 +7907,7 @@ process sentinels. They shall not disturb each other." (delete-directory tmp-name) (delete-file (concat tmp-name ".tar.gz")))) -(ert-deftest tramp-test46-read-password () +(ert-deftest tramp-test47-read-password () "Check Tramp password handling." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) @@ -7903,7 +7966,7 @@ process sentinels. They shall not disturb each other." (let ((auth-sources `(,netrc-file))) (should (file-exists-p ert-remote-temporary-file-directory))))))))) -(ert-deftest tramp-test46-read-otp-password () +(ert-deftest tramp-test47-read-otp-password () "Check Tramp one-time password handling." :tags '(:expensive-test) (skip-unless (tramp--test-mock-p)) @@ -7963,7 +8026,7 @@ process sentinels. They shall not disturb each other." (file-exists-p ert-remote-temporary-file-directory))))))))) ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test47-auto-load () +(ert-deftest tramp-test48-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -7988,7 +8051,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test47-delay-load () +(ert-deftest tramp-test48-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file @@ -8006,7 +8069,7 @@ process sentinels. They shall not disturb each other." (dolist (tm '(t nil)) (should (string-match-p - (tramp-compat-rx + (rx "Tramp loaded: nil" (+ (any "\r\n")) "Tramp loaded: nil" (+ (any "\r\n")) "Tramp loaded: " (literal (symbol-name tm)) (+ (any "\r\n"))) @@ -8018,7 +8081,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test47-recursive-load () +(ert-deftest tramp-test48-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -8042,7 +8105,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test47-remote-load-path () +(ert-deftest tramp-test48-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the @@ -8054,7 +8117,7 @@ process sentinels. They shall not disturb each other." (tramp-cleanup-all-connections))")) (should (string-match-p - (tramp-compat-rx + (rx "Loading " (literal (expand-file-name @@ -8067,7 +8130,22 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test48-unload () +(ert-deftest tramp-test49-without-remote-files () + "Check that Tramp can be suppressed." + (skip-unless (tramp--test-enabled)) + + (should (file-remote-p ert-remote-temporary-file-directory)) + (should-not + (without-remote-files (file-remote-p ert-remote-temporary-file-directory))) + (should (file-remote-p ert-remote-temporary-file-directory)) + + (inhibit-remote-files) + (should-not (file-remote-p ert-remote-temporary-file-directory)) + (tramp-register-file-name-handlers) + (setq tramp-mode t) + (should (file-remote-p ert-remote-temporary-file-directory))) + +(ert-deftest tramp-test50-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -8106,6 +8184,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; `tramp-register-archive-file-name-handler' is autoloaded ;; in Emacs < 29.1. (not (eq 'tramp-register-archive-file-name-handler x)) + ;; `tramp-compat-rx' is autoloaded in Emacs 29.1. + (not (eq 'tramp-compat-rx x)) (not (string-match-p (rx bol "tramp" (? "-archive") (** 1 2 "-") "test") (symbol-name x))) @@ -8167,12 +8247,10 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-name-case-insensitive-p ;; * memory-info ;; * tramp-get-home-directory -;; * tramp-get-remote-gid -;; * tramp-get-remote-groups -;; * tramp-get-remote-uid ;; * tramp-set-file-uid-gid ;; * Work on skipped tests. Make a comment, when it is impossible. +;; * Use `skip-when' starting with Emacs 30.1. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * Fix `tramp-test06-directory-file-name' for "ftp". ;; * Check, why a process filter t doesn't work in @@ -8182,7 +8260,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; `tramp-test31-signal-process' for "adb", "sshfs" and for direct ;; async processes. Check, why they don't run stable. ;; * Check, why direct async processes do not work for -;; `tramp-test44-asynchronous-requests'. +;; `tramp-test45-asynchronous-requests'. (provide 'tramp-tests) diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el index 42fa346a869..ffdebf2bb6f 100644 --- a/test/lisp/net/webjump-tests.el +++ b/test/lisp/net/webjump-tests.el @@ -58,7 +58,7 @@ (ert-deftest webjump-tests-url-fix () (should (equal (webjump-url-fix nil) "")) (should (equal (webjump-url-fix "/tmp/") "file:///tmp/")) - (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/")) + (should (equal (webjump-url-fix "gnu.org") "https://gnu.org/")) (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/")) (should (equal (webjump-url-fix "https://gnu.org") "https://gnu.org/"))) diff --git a/test/lisp/proced-tests.el b/test/lisp/proced-tests.el new file mode 100644 index 00000000000..58d97f46c4f --- /dev/null +++ b/test/lisp/proced-tests.el @@ -0,0 +1,136 @@ +;;; proced-tests.el --- Test suite for proced.el -*- lexical-binding: t -*- + +;; Copyright (C) 2022-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/>. + +;;; Code: + +(require 'ert) +(require 'proced) +(require 'thingatpt) + +(cl-defmacro proced--within-buffer (format filter &body body) + "Execute BODY within a proced buffer using format FORMAT and filter FILTER." + `(let ((proced-format ,format) + (proced-filter ,filter) + (proced-auto-update-flag nil) + (inhibit-message t)) + (proced) + (unwind-protect + (with-current-buffer "*Proced*" + ,@body) + (kill-buffer "*Proced*")))) + +(defun proced--assert-emacs-pid-in-buffer () + "Fail unless the process ID of the current Emacs process exists in buffer." + (should (string-match-p + (number-to-string (emacs-pid)) + (buffer-substring-no-properties (point-min) (point-max))))) + +(defun proced--move-to-column (attribute) + "Move to the column under ATTRIBUTE in the current proced buffer." + (move-to-column (string-match attribute proced-header-line))) + +(defun proced--assert-process-valid-pid-refinement (pid) + "Fail unless the process at point could be present after a refinement using PID." + (proced--move-to-column "PID") + (let ((pid-equal (string= pid (word-at-point)))) + (should + (or pid-equal + ;; Guard against the unlikely event a platform doesn't support PPID + (when (string-match "PPID" proced-header-line) + (proced--move-to-column "PPID") + (string= pid (word-at-point))))))) + +(ert-deftest proced-format-test () + (dolist (format '(short medium long verbose)) + (proced--within-buffer + format + 'user + (proced--assert-emacs-pid-in-buffer)))) + +(ert-deftest proced-update-test () + (proced--within-buffer + 'short + 'user + (proced-update) + (proced--assert-emacs-pid-in-buffer))) + +(ert-deftest proced-revert-test () + (proced--within-buffer + 'short + 'user + (proced-revert) + (proced--assert-emacs-pid-in-buffer))) + +(ert-deftest proced-color-test () + (let ((proced-enable-color-flag t)) + (proced--within-buffer + 'short + 'user + (proced--assert-emacs-pid-in-buffer)))) + +(ert-deftest proced-refine-test () + ;;(skip-unless (memq system-type '(gnu/linux gnu/kfreebsd darwin))) + (proced--within-buffer + 'verbose + 'user + ;; When refining on PID for process A, a process is kept if and only + ;; if its PID is the same as process A, or its parent process is + ;; process A. + (proced--move-to-column "PID") + (let ((pid (word-at-point))) + (proced-refine) + (while (not (eobp)) + (proced--assert-process-valid-pid-refinement pid) + (forward-line))))) + +(ert-deftest proced-refine-with-update-test () + (proced--within-buffer + 'verbose + 'user + (proced--move-to-column "PID") + (let ((pid (word-at-point))) + (proced-refine) + ;; Don't use (proced-update t) since this will reset `proced-process-alist' + ;; and it's possible the process refined on would have exited by that + ;; point. In this case proced will skip the refinement and show all + ;; processes again, causing the test to fail. + (proced-update) + (while (not (eobp)) + (proced--assert-process-valid-pid-refinement pid) + (forward-line))))) + +(ert-deftest proced-update-preserves-pid-at-point-test () + (proced--within-buffer + 'medium + 'user + (goto-char (point-min)) + (search-forward (number-to-string (emacs-pid))) + (proced--move-to-column "PID") + (save-window-excursion + (let ((pid (proced-pid-at-point)) + (new-window (split-window)) + (old-window (get-buffer-window))) + (select-window new-window) + (with-current-buffer "*Proced*" + (proced-update t t)) + (select-window old-window) + (should (= pid (proced-pid-at-point))))))) + +(provide 'proced-tests) +;;; proced-tests.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el index 790582aed4c..e5b207748bf 100644 --- a/test/lisp/progmodes/bug-reference-tests.el +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -25,6 +25,7 @@ (require 'bug-reference) (require 'ert) +(require 'ert-x) (defun test--get-github-entry (url) (and (string-match @@ -125,4 +126,18 @@ (test--get-gitea-entry "https://gitea.com/magit/magit/") "magit/magit"))) +(ert-deftest test-thing-at-point () + "Ensure that (thing-at-point 'url) returns the bug URL." + (ert-with-test-buffer (:name "thingatpt") + (setq-local bug-reference-url-format "https://debbugs.gnu.org/%s") + (insert "bug#1234") + (bug-reference-mode) + (jit-lock-fontify-now (point-min) (point-max)) + (goto-char (point-min)) + ;; Make sure we get the URL when `bug-reference-mode' is active... + (should (equal (thing-at-point 'url) "https://debbugs.gnu.org/1234")) + (bug-reference-mode -1) + ;; ... and get nil when `bug-reference-mode' is inactive. + (should-not (thing-at-point 'url)))) + ;;; bug-reference-tests.el ends here diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 078eef36774..d497644c389 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -121,9 +121,7 @@ ;; cucumber (cucumber "Scenario: undefined step # features/cucumber.feature:3" 29 nil 3 "features/cucumber.feature") - ;; This rule is actually handled by the `cucumber' pattern but when - ;; `omake' is included, then `gnu' matches it first. - (gnu " /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" + (cucumber " /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" 1 nil 500 "/home/gusev/.rvm/foo/bar.rb") ;; edg-1 edg-2 (edg-1 "build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" @@ -312,10 +310,6 @@ 1 nil 109 "..\\src\\ctrl\\lister.c") (watcom "..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" 1 nil 120 "..\\src\\ctrl\\lister.c") - ;; omake - ;; FIXME: This doesn't actually test the omake rule. - (gnu " alpha.c:5:15: error: expected ';' after expression" - 1 15 5 "alpha.c") ;; oracle (oracle "Semantic error at line 528, column 5, file erosacqdb.pc:" 1 5 528 "erosacqdb.pc") @@ -497,8 +491,22 @@ The test data is in `compile-tests--test-regexps-data'." (font-lock-mode -1) (let ((compilation-num-errors-found 0) (compilation-num-warnings-found 0) - (compilation-num-infos-found 0)) - (mapc #'compile--test-error-line compile-tests--test-regexps-data) + (compilation-num-infos-found 0) + (all-rules (mapcar #'car compilation-error-regexp-alist-alist))) + + ;; Test all built-in rules except `omake' to avoid interference. + (let ((compilation-error-regexp-alist (remq 'omake all-rules))) + (mapc #'compile--test-error-line compile-tests--test-regexps-data)) + + ;; Test the `omake' rule separately. + ;; This doesn't actually test the `omake' rule itself but its + ;; indirect effects. + (let ((compilation-error-regexp-alist all-rules) + (test + '(gnu " alpha.c:5:15: error: expected ';' after expression" + 1 15 5 "alpha.c"))) + (compile--test-error-line test)) + (should (eq compilation-num-errors-found 100)) (should (eq compilation-num-warnings-found 35)) (should (eq compilation-num-infos-found 28))))) diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl new file mode 100644 index 00000000000..a474e431222 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-11733.pl @@ -0,0 +1,50 @@ +# This resource file can be run with cperl--run-testcases from +# cperl-tests.el and works with both perl-mode and cperl-mode. + +# -------- Multiline declaration: input ------- +#!/usr/bin/env perl +# -*- mode: cperl -*- + +sub foo + { + } + +sub bar + { + } +# -------- Multiline declaration: expected output ------- +#!/usr/bin/env perl +# -*- mode: cperl -*- + +sub foo +{ +} + +sub bar +{ +} +# -------- Multiline declaration: end ------- + +# -------- Fred Colon at work: input -------- +#!/usr/bin/env perl +# -*- mode: cperl -*- + +while (<>) +{ +m:^ \d+ p: +or die; +m:^ \d+ : +or die; +} +# -------- Fred Colon at work: expected output -------- +#!/usr/bin/env perl +# -*- mode: cperl -*- + +while (<>) + { + m:^ \d+ p: + or die; + m:^ \d+ : + or die; + } +# -------- Fred Colon at work: end -------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl new file mode 100644 index 00000000000..e3f96241ab7 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-35925.pl @@ -0,0 +1,36 @@ +# This resource file can be run with cperl--run-testcases from +# cperl-tests.el and works with both perl-mode and cperl-mode. + +# -------- Bug#35925: input ------- +format FH = +@### @.### @### +42, 3.1415, 0 +. +write FH; + +# -------- Bug#35925: expected output ------- +format FH = +@### @.### @### +42, 3.1415, 0 +. +write FH; + +# -------- Bug#35925: end ------- + +# -------- format not as top-level: input ------- +foo: { + format STDOUT = +^<<<< +$foo +. +write; +} +# -------- format not as top-level: expected output ------- +foo: { + format STDOUT = +^<<<< +$foo +. + write; +} +# -------- format not as top-level: end ------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl new file mode 100644 index 00000000000..c7621e1c47b --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64190.pl @@ -0,0 +1,24 @@ +# Example 1 + +my ($var1, + $var2, + $var3); + +# Example 2 + +package Foo + 0.1; + +# Example 3 (intentionally incomplete, body is inserted by test) + +sub do_stuff + +# Example 4 + +sub do_more_stuff ($param1, +$param2) +{ + ...; +} + +sub oops { ...; } diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl new file mode 100644 index 00000000000..62ef6982f38 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-64364.pl @@ -0,0 +1,55 @@ +# This resource file can be run with cperl--run-testcases from +# cperl-tests.el and works with both perl-mode and cperl-mode. + +# -------- Bug#64364: input ------- +package P { +sub way { ...; } +# +sub bus +:lvalue +($sig,$na,@ture) +{ +...; +} +} +# -------- Bug#64364: expected output ------- +package P { + sub way { ...; } + # + sub bus + :lvalue + ($sig,$na,@ture) + { + ...; + } +} +# -------- Bug#64364: end ------- + +# Now do this with multiline initializers +# -------- signature with init: input ------- +package P { +sub way { ...; } +# perl 5.38 or newer +sub bus +:lvalue +($sig, +$na //= 42, +@ture) +{ +...; +} +} +# -------- signature with init: expected output ------- +package P { + sub way { ...; } + # perl 5.38 or newer + sub bus + :lvalue + ($sig, + $na //= 42, + @ture) + { + ...; + } +} +# -------- signature with init: end ------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl new file mode 100644 index 00000000000..775a113ac17 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-65834.pl @@ -0,0 +1,5 @@ +# -*- mode: cperl -*- +if ($t->[3]<<5) { + return 0; +} +# comment diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl new file mode 100644 index 00000000000..70f12346ded --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66145.pl @@ -0,0 +1,62 @@ +# The original code, from the bug report, with variables renamed + +sub foo { + # Here we do something like + # this: $array_comment [ num_things ]->{key_comment} +} + +# -------------------------------------------------- +# Comments containing hash and array sigils + +# This is an @array, and this is a %hash +# $array_comment[$index] = $hash_comment{key_comment} +# The last element has the index $#array_comment +# my @a_slice = @array_comment[1,2,3]; +# my @h_slice = @hash_comment{qw(a b c)}; +# my %a_set = %array_comment[1,2,3]; +# my %h_set = %hash_comment{qw(a b c)}; + +# -------------------------------------------------- +# in POD + +=head1 NAME + +cperl-bug-66145 - don't fontify arrays and hashes in POD + +=head1 SYNOPSIS + + $array_comment[$index] = $hash_comment{key_comment}; + @array_comment = qw(in pod); + %hash_comment = key_comment => q(pod); + @array_comment = @array_comment[1,2,3]; + @array_comment = @hash_comment{qw(a b c)}; + %hash_comment = %array_comment[1,2,3]; + %hash_comment = %hash_comment{qw(a b c)}; + +=cut + +# -------------------------------------------------- +# in strings + +my @strings = ( + q/$array_string[$index] = $hash_string{key_string};/, + q/my @array_string = qw(in unquoted string);/, + q/my %hash_string = (key_string => q(pod);)/, + q/@array_string = @array_string[1,2,3];/, + q/@array_string = @hash_string{qw(a b c)};/, + q/%hash_string = %array_string[1,2,3];/, + q/%hash_string = %hash_string{qw(a b c)};/, +); + +# -------------------------------------------------- +# in a HERE-document (perl-mode has an extra face for that) + +my $here = <<DONE; + $array_here[$index_here] = $hash_here{key_here}; + @array_here = qw(in a hrere-document); + %hash_here = key_here => q(pod); + @array_here = @array_here[1,2,3]; + @array_here = @hash_here{qw(a b c)}; + %hash_here = %array_here[1,2,3]; + %hash_here = %hash_here{qw(a b c)}; +DONE diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl new file mode 100644 index 00000000000..e39cfdd3b24 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-66161.pl @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +print("Hello World\n"); + +__END__ + +TODO: +What's happening? + +It's all messed up. diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts index 6b874ffaa1f..ba35b1d0690 100644 --- a/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-indents.erts @@ -24,3 +24,58 @@ Name: cperl-indents1 ""; } =-=-= + +Name: cperl-try-catch-finally + +=-= +{ + try { + call_a_function(); + } + catch ($e) { + warn "Unable to call; $e"; + } + finally { + print "Finished\n"; + } +} +=-=-= + +Name: cperl-defer + +=-= +use feature 'defer'; + +{ + say "This happens first"; + defer { + say "This happens last"; + } + + say "And this happens inbetween"; +} +=-=-= + +Name: cperl-feature-class + +=-= +use 5.038; +use feature "class"; +no warnings "experimental"; + +class A { +} + +class C + : isa(A) +{ + method with_sig_and_attr + : lvalue + ($top,$down) + { + return $top-$down; + } +} + +say "done!"; +=-=-= diff --git a/test/lisp/progmodes/cperl-mode-resources/grammar.pl b/test/lisp/progmodes/cperl-mode-resources/grammar.pl index 96a86993082..9420c0d1fa8 100644 --- a/test/lisp/progmodes/cperl-mode-resources/grammar.pl +++ b/test/lisp/progmodes/cperl-mode-resources/grammar.pl @@ -169,4 +169,29 @@ sub erdős_number { } } +=head1 And now, for something completely different + +Perl 5.38 supports classes with the same scope weirdness as packages. +As long as this is experimental, CPAN tools don't play well with this, +so some weird constructs are recommended to authors of CPAN modules. + +=cut + +package Class::Class; + +our $VERSION = 0.01; + +class Class::Class 0.01 { + method init ($with,$signature) { + ...; + } + + class Class::Inner :isa(Class::Class); + # This class comes without a block, so takes over until the rest + # of the containing block. + method init_again (@with_parameters) { + ...; + } +} + 1; diff --git a/test/lisp/progmodes/cperl-mode-resources/perl-class.pl b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl new file mode 100644 index 00000000000..032690d20a5 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/perl-class.pl @@ -0,0 +1,19 @@ +use 5.038; +use feature 'class'; +no warnings 'experimental'; + +class A { +} + +class C + : isa(A) +{ + method with_sig_and_attr + : lvalue + ($top,$down) + { + return $top-$down; + } +} + +say "done!"; diff --git a/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl b/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl index 7138bf631df..1f898250252 100644 --- a/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl +++ b/test/lisp/progmodes/cperl-mode-resources/proto-and-attrs.pl @@ -12,12 +12,10 @@ no warnings 'experimental::signatures'; # are somewhat frowned upon most of the times, but they are required # for some Perl magic -# FIXME: 2022-02-02 CPerl mode does not handle subroutine signatures. -# In simple cases it mistakes them as prototypes, when attributes are -# present, it doesn't handle them at all. Variables in signatures -# SHOULD be fontified like variable declarations. - # Part 1: Named subroutines +# A plain named subroutine without any optional stuff +sub sub_0 { ...; } + # A prototype and a trivial subroutine attribute { no feature 'signatures'; # that's a prototype, not a signature @@ -30,10 +28,24 @@ sub sub_2 :prototype($) { ...; } # A signature (these will soon-ish leave the experimental state) sub sub_3 ($foo,$bar) { ...; } -# Attribute plus signature FIXME: Not yet supported -sub bad_sub_4 :prototype($$$) ($foo,$bar,$baz) { ...; } +# Attribute plus signature +sub sub_4 :prototype($$$) ($foo,$bar,$baz) { ...; } + +# A signature with a trailing comma (weird, but legal) +sub sub_5 ($foo,$bar,) { ...; } + +# Perl 5.38-style initializer +sub sub_6 + ($foo, + $bar //= "baz") +{ +} + # Part 2: Same constructs for anonymous subs +# A plain named subroutine without any optional stuff +my $subref_0 = sub { ...; }; + # A prototype and a trivial subroutine attribute { no feature 'signatures'; # that's a prototype, not a signature diff --git a/test/lisp/progmodes/cperl-mode-resources/sub-names.pl b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl new file mode 100644 index 00000000000..46d05b4dbd2 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/sub-names.pl @@ -0,0 +1,25 @@ +use 5.038; +use feature 'class'; +use warnings; +no warnings 'experimental'; + +class C { + # "method" is not yet understood by perl-mode, but it isn't + # relevant here: We can use "sub" because what matters is the + # name, which collides with a builtin. + sub m { + "m called" + } +} + +say C->new->m; + +# This comment has a method name in it, and we don't want "method" +# to be fontified as a keyword, nor "name" fontified as a name. + +__END__ + +=head1 Test using the keywords POD + +This piece of POD has a method name in it, and we don't want "method" +to be fontified as a keyword, nor "name" fontified as a name. diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index 9bd250a38b5..0af44c8e08d 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -25,6 +25,10 @@ ;;; Commentary: ;; This is a collection of tests for CPerl-mode. +;; The maintainer would like to use this test file with cperl-mode.el +;; also in older Emacs versions (currently: Emacs 26.1): Please don't +;; use Emacs features which are not available in that version (unless +;; they're already used in existing tests). ;;; Code: @@ -177,14 +181,19 @@ attributes, prototypes and signatures." (should (equal (get-text-property (1+ (match-beginning 0)) 'face) 'font-lock-string-face))) (goto-char start-of-sub) + ;; Attributes with their optional parameters (when (search-forward-regexp "\\(:[a-z]+\\)\\((.*?)\\)?" end-of-sub t) (should (equal (get-text-property (match-beginning 1) 'face) 'font-lock-constant-face)) (when (match-beginning 2) (should (equal (get-text-property (match-beginning 2) 'face) 'font-lock-string-face)))) + ;; Subroutine signatures + (goto-char start-of-sub) + (when (search-forward "$bar" end-of-sub t) + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face))) (goto-char end-of-sub))) - ;; Anonymous subroutines (while (search-forward-regexp "= sub" nil t) (let ((start-of-sub (match-beginning 0)) @@ -201,8 +210,40 @@ attributes, prototypes and signatures." (when (match-beginning 2) (should (equal (get-text-property (match-beginning 2) 'face) 'font-lock-string-face)))) + ;; Subroutine signatures + (goto-char start-of-sub) + (when (search-forward "$bar" end-of-sub t) + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face))) (goto-char end-of-sub)))))) +(ert-deftest cperl-test-fontify-class () + "Test fontification of the various elements in a Perl class." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "perl-class.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + + ;; The class name + (while (search-forward-regexp "class " nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face))) + ;; The attributes (class and method) + (while (search-forward-regexp " : " nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-constant-face))) + ;; The signature + (goto-char (point-min)) + (search-forward-regexp "\\(\\$top\\),\\(\\$down\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-variable-name-face)) +))) + (ert-deftest cperl-test-fontify-special-variables () "Test fontification of variables like $^T or ${^ENCODING}. These can occur as \"local\" aliases." @@ -219,6 +260,39 @@ These can occur as \"local\" aliases." (should (equal (get-text-property (point) 'face) 'font-lock-variable-name-face)))) +(ert-deftest cperl-test-fontify-sub-names () + "Test fontification of subroutines named like builtins. +On declaration, they should look like other used defined +functions. When called, they should not be fontified. In +comments and POD they should be fontified as POD." + (let ((file (ert-resource-file "sub-names.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + ;; The declaration + (search-forward-regexp "sub \\(m\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-function-name-face)) + ;; calling as a method + (search-forward-regexp "C->new->\\(m\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + (if (equal cperl-test-mode 'perl-mode) nil + 'cperl-method-call))) + ;; POD + (search-forward-regexp "\\(method\\) \\(name\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-comment-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-comment-face)) + ;; comment + (search-forward-regexp "\\(method\\) \\(name\\)") + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-comment-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-comment-face))))) + (ert-deftest cperl-test-identify-heredoc () "Test whether a construct containing \"<<\" followed by a bareword is properly identified for a here-document if @@ -306,6 +380,7 @@ issued by CPerl mode." (defvar perl-continued-statement-offset) (defvar perl-indent-level) +(defvar perl-indent-parens-as-block) (defconst cperl--tests-heredoc-face (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc @@ -397,7 +472,7 @@ the whole string." valid invalid))) (ert-deftest cperl-test-package-regexp () - "Tests the regular expression of Perl package names with versions. + "Tests the regular expression of Perl package and class names with versions. Also includes valid cases with whitespace in strange places." (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid @@ -405,13 +480,13 @@ Also includes valid cases with whitespace in strange places." "package Foo::Bar" "package Foo::Bar v1.2.3" "package Foo::Bar::Baz 1.1" + "class O3D::Sphere" ; since Perl 5.38 "package \nFoo::Bar\n 1.00")) (invalid '("package Foo;" ; semicolon must not be included "package Foo 1.1 {" ; nor the opening brace "packageFoo" ; not a package declaration - "package Foo1.1" ; invalid package name - "class O3D::Sphere"))) ; class not yet supported + "package Foo1.1"))) ; invalid package name (cperl-test--validate-regexp (rx (eval cperl--package-rx)) valid invalid))) @@ -428,6 +503,66 @@ Also includes valid cases with whitespace in strange places." (cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx)) valid invalid))) +(ert-deftest cperl-test-attribute-rx () + "Test attributes and attribute lists" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("foo" "bar()" "baz(quux)")) + (invalid + '("+foo" ; not an identifier + "foo::bar" ; no package qualifiers allowed + "(no-identifier)" ; no attribute name + "baz (quux)"))) ; no space allowed before "(" + (cperl-test--validate-regexp (rx (eval cperl--single-attribute-rx)) + valid invalid))) + +(ert-deftest cperl-test-attribute-list-rx () + "Test attributes and attribute lists" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '(":" ":foo" ": bar()" ":baz(quux):" + ":_" ":_foo" + ":isa(Foo) does(Bar)" ":isa(Foo):does(Bar)" + ":isa(Foo):does(Bar):" + ": isa(Foo::Bar) : does(Bar)")) + (invalid + '(":foo + bar" ; not an identifier + "::foo" ; not an attribute list + ": foo(bar : : baz" ; too many colons + ": foo(bar)baz" ; need a separator + ": baz (quux)"))) ; no space allowed before "(" + (cperl-test--validate-regexp (rx (eval cperl--attribute-list-rx)) + valid invalid))) + +(ert-deftest cperl-test-prototype-rx () + "Test subroutine prototypes" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + ;; Examples from perldoc perlsub + '("($$)" "($$$)" "($$;$)" "($$$;$)" "(@)" "($@)" "(\\@)" "(\\@$$@)" + "(\\[%@])" "(*;$)" "(**)" "(&@)" "(;$)" "()")) + (invalid + '("$" ; missing paren + "($self)" ; a variable, -> subroutine signature + "(!$)" ; not all punctuation is permitted + "{$$}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--prototype-rx)) + valid invalid))) + +(ert-deftest cperl-test-signature-rx () + "Test subroutine signatures." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("()" "( )" "($self, %params)" "(@params)")) + (invalid + '("$self" ; missing paren + "($)" ; a subroutine signature + "($!)" ; globals not permitted in a signature + "(@par,%options)" ; two slurpy parameters + "{$self}"))) ; wrong type of paren + (cperl-test--validate-regexp (rx (eval cperl--signature-rx)) + valid invalid))) + ;;; Test unicode identifier in various places (defun cperl--test-unicode-setup (code string) @@ -717,7 +852,9 @@ created by CPerl mode, so skip it for Perl mode." "lexical" "Versioned::Block::signatured" "Package::in_package_again" - "Erdős::Number::erdős_number"))) + "Erdős::Number::erdős_number" + "Class::Class::init" + "Class::Inner::init_again"))) (dolist (sub expected) (should (assoc-string sub index))))))) @@ -788,6 +925,17 @@ under timeout control." (should (string-match "poop ('foo', \n 'bar')" (buffer-string)))))) +(ert-deftest cperl-test-bug-11733 () + "Verify indentation of braces after newline and non-labels." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (cperl--run-test-cases + (ert-resource-file "cperl-bug-11733.pl") + (goto-char (point-min)) + (while (null (eobp)) + (cperl-indent-command) + (forward-line 1)))) + + (ert-deftest cperl-test-bug-11996 () "Verify that we give the right syntax property to a backslash operator." (with-temp-buffer @@ -995,6 +1143,20 @@ Perl is not Lisp: An open paren in column 0 does not start a function." (cperl-indent-command) (forward-line 1)))) +(ert-deftest cperl-test-bug-35925 () + "Check that indentation is correct after a terminating format declaration." + (cperl-set-style "PBP") ; Make cperl-mode use the same settings as perl-mode. + (cperl--run-test-cases + (ert-resource-file "cperl-bug-35925.pl") + (let ((tab-function + (if (equal cperl-test-mode 'perl-mode) + #'indent-for-tab-command + #'cperl-indent-command))) + (goto-char (point-max)) + (forward-line -2) + (funcall tab-function))) + (cperl-set-style-back)) + (ert-deftest cperl-test-bug-37127 () "Verify that closing a paren in a regex goes without a message. Also check that the message is issued if the regex terminator is @@ -1145,6 +1307,132 @@ as a regex." (funcall cperl-test-mode) (should-not (nth 3 (syntax-ppss 3))))) +(ert-deftest cperl-test-bug-64190 () + "Verify correct fontification of multiline declarations" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "cperl-bug-64190.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (cperl-mode) + (font-lock-ensure) + ;; Example 1 + (while (search-forward "var" nil t) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face))) + ;; Example 2 + (search-forward "package F") + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + + ;; Example 3 and 4 can't be directly tested because jit-lock and + ;; batch tests don't play together well. But we can approximate + ;; the behavior by calling the the fontification for the same + ;; region which would be used by jit-lock. + ;; Example 3 + (search-forward "sub do_stuff") + (let ((start-change (point))) + (insert "\n{") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1- start-change)) ; between the "ff" in "stuff" + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + (search-forward "{") + (insert "}")) ; make it legal again + + ;; Example 4 + (search-forward "$param2") + (beginning-of-line) + (let ((start-change (point))) + (insert " ") + (cperl-font-lock-fontify-region-function start-change + (point-max) + nil) ; silent + (font-lock-ensure start-change (point-max)) + (goto-char (1+ start-change)) + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (re-search-forward (rx (group "sub") " " (group "oops"))) + (should (equal (get-text-property (match-beginning 1) 'face) + 'font-lock-keyword-face)) + (should (equal (get-text-property (match-beginning 2) 'face) + 'font-lock-function-name-face)))))) + +(ert-deftest cperl-test-bug-64364 () + "Check that multi-line subroutine declarations indent correctly." + (cperl-set-style "PBP") ; make cperl-mode use the same settings as perl-mode + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (indent-region (point-min) (point-max))) + (cperl--run-test-cases + (ert-resource-file "cperl-bug-64364.pl") + (let ((tab-function + (if (equal cperl-test-mode 'perl-mode) + #'indent-for-tab-command + #'cperl-indent-command))) + (goto-char (point-min)) + (while (null (eobp)) + (funcall tab-function) + (forward-line 1)))) + (cperl-set-style-back)) + +(ert-deftest cperl-test-bug-65834 () + "Verify that CPerl mode identifies a left-shift operator. +Left-shift and here-documents both use the \"<<\" operator. +In the code provided by this bug report, it needs to be +detected as left-shift operator." + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-65834.pl")) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "retur") ; leaves point before the "n" + (should (equal (get-text-property (point) 'face) + font-lock-keyword-face)) + (search-forward "# comm") ; leaves point before "ent" + (should (equal (get-text-property (point) 'face) + font-lock-comment-face)))) + +(ert-deftest cperl-test-bug-66145 () + "Verify that hashes and arrays are only fontified in code. +In strings, comments and POD the syntaxified faces should +prevail. The tests exercise all combinations of sigils $@% and +parenthesess [{ for comments, POD, strings and HERE-documents. +Fontification in code for `cperl-mode' is done in the tests +beginning with `cperl-test-unicode`." + (let ((types '("array" "hash" "key")) + (faces `(("string" . font-lock-string-face) + ("comment" . font-lock-comment-face) + ("here" . ,(if (equal cperl-test-mode 'perl-mode) + 'perl-heredoc + font-lock-string-face))))) + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-66145.pl")) + (funcall cperl-test-mode) + (font-lock-ensure) + (dolist (type types) + (goto-char (point-min)) + (while (re-search-forward (concat type "_\\([a-z]+\\)") nil t) + (should (equal (get-text-property (match-beginning 1) 'face) + (cdr (assoc (match-string-no-properties 1) + faces))))))))) + +(ert-deftest cperl-test-bug-66161 () + "Verify that text after \"__END__\" is fontified as comment. +For `cperl-mode', this needs the custom variable +`cperl-fontify-trailer' to be set to `comment'. Per default, +cperl-mode fontifies text after the delimiter as Perl code." + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-66161.pl")) + (setq cperl-fontify-trailer 'comment) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "TODO") ; leaves point before the colon + (should (equal (get-text-property (point) 'face) + font-lock-comment-face)))) + (ert-deftest test-indentation () (ert-test-erts-file (ert-resource-file "cperl-indents.erts"))) diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 7ce0116636d..f2da3295b49 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -31,23 +31,20 @@ ;; Some of these tests rely on the GNU ELPA package company.el and ;; yasnippet.el being available. -;; Some of the tests require access to a remote host files. Since -;; this could be problematic, a mock-up connection method "mock" is -;; used. Emulating a remote connection, it simply calls "sh -i". -;; Tramp's file name handlers still run, so this test is sufficient -;; except for connection establishing. - -;; If you want to test a real Tramp connection, set -;; $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable value in order to -;; overwrite the default value. If you want to skip tests accessing a -;; remote host, set this environment variable to "/dev/null" or -;; whatever is appropriate on your system. +;; Some of the tests require access to a remote host files, which is +;; mocked in the simplest case. If you want to test a real Tramp +;; connection, override $REMOTE_TEMPORARY_FILE_DIRECTORY to a suitable +;; value (FIXME: like what?) in order to overwrite the default value. +;; +;; IMPORTANT: Since Eglot is a :core ELPA package, these tests are +;; supposed to run on Emacsen down to 26.3. Do not use bleeding-edge +;; functionality not compatible with that Emacs version. ;;; Code: (require 'eglot) (require 'cl-lib) (require 'ert) -(require 'tramp) ; must be prior ert-x +(require 'tramp) (require 'ert-x) ; ert-simulate-command (require 'edebug) (require 'cc-mode) ; c-mode-hook @@ -58,73 +55,66 @@ ;;; Helpers +(defun eglot--test-message (format &rest args) + "Message out with FORMAT with ARGS." + (message "[eglot-tests] %s" + (apply #'format format args))) + (defmacro eglot--with-fixture (fixture &rest body) - "Setup FIXTURE, call BODY, teardown FIXTURE. + "Set up FIXTURE, call BODY, tear down FIXTURE. FIXTURE is a list. Its elements are of the form (FILE . CONTENT) to create a readable FILE with CONTENT. FILE may be a directory name and CONTENT another (FILE . CONTENT) list to specify a -directory hierarchy. FIXTURE's elements can also be (SYMBOL -VALUE) meaning SYMBOL should be bound to VALUE during BODY and -then restored." +directory hierarchy." (declare (indent 1) (debug t)) - `(eglot--call-with-fixture - ,fixture #'(lambda () ,@body))) + `(eglot--call-with-fixture ,fixture (lambda () ,@body))) (defun eglot--make-file-or-dir (ass) - (let ((file-or-dir-name (car ass)) + (let ((file-or-dir-name (expand-file-name (car ass))) (content (cdr ass))) (cond ((listp content) (make-directory file-or-dir-name 'parents) - (let ((default-directory (concat default-directory "/" file-or-dir-name))) + (let ((default-directory (file-name-as-directory file-or-dir-name))) (mapcan #'eglot--make-file-or-dir content))) ((stringp content) - (with-temp-buffer - (insert content) - (write-region nil nil file-or-dir-name nil 'nomessage)) - (list (expand-file-name file-or-dir-name))) + (with-temp-file file-or-dir-name + (insert content)) + (list file-or-dir-name)) (t (eglot--error "Expected a string or a directory spec"))))) (defun eglot--call-with-fixture (fixture fn) "Helper for `eglot--with-fixture'. Run FN under FIXTURE." - (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture" t)) - (default-directory fixture-directory) - file-specs created-files - syms-to-restore + (let* ((fixture-directory (make-nearby-temp-file "eglot--fixture-" t)) + (default-directory (file-name-as-directory fixture-directory)) + created-files new-servers test-body-successful-p) - (dolist (spec fixture) - (cond ((symbolp spec) - (push (cons spec (symbol-value spec)) syms-to-restore) - (set spec nil)) - ((symbolp (car spec)) - (push (cons (car spec) (symbol-value (car spec))) syms-to-restore) - (set (car spec) (cadr spec))) - ((stringp (car spec)) (push spec file-specs)))) + (eglot--test-message "[%s]: test start" (ert-test-name (ert-running-test))) (unwind-protect - (let* ((process-environment - (append - `(;; Set XDF_CONFIG_HOME to /dev/null to prevent - ;; user-configuration to have an influence on - ;; language servers. (See github#441) - "XDG_CONFIG_HOME=/dev/null" - ;; ... on the flip-side, a similar technique by - ;; Emacs's test makefiles means that HOME is - ;; spoofed to /nonexistent, or sometimes /tmp. - ;; This breaks some common installations for LSP - ;; servers like pylsp, rust-analyzer making these - ;; tests mostly useless, so we hack around it here - ;; with a great big hack. - ,(format "HOME=%s" - (expand-file-name (format "~%s" (user-login-name))))) - process-environment)) - (eglot-server-initialized-hook - (lambda (server) (push server new-servers)))) - (setq created-files (mapcan #'eglot--make-file-or-dir file-specs)) + (let ((process-environment + `(;; Set XDG_CONFIG_HOME to /dev/null to prevent + ;; user-configuration influencing language servers + ;; (see github#441). + ,(format "XDG_CONFIG_HOME=%s" null-device) + ;; ... on the flip-side, a similar technique in + ;; Emacs's `test/Makefile' spoofs HOME as + ;; /nonexistent (and as `temporary-file-directory' in + ;; `ert-remote-temporary-file-directory'). + ;; This breaks some common installations for LSP + ;; servers like rust-analyzer, making these tests + ;; mostly useless, so we hack around it here with a + ;; great big hack. + ,(format "HOME=%s" + (expand-file-name (format "~%s" (user-login-name)))) + ,@process-environment)) + (eglot-server-initialized-hook + (lambda (server) (push server new-servers)))) + (setq created-files (mapcan #'eglot--make-file-or-dir fixture)) (prog1 (funcall fn) (setq test-body-successful-p t))) - (eglot--message - "Test body was %s" (if test-body-successful-p "OK" "A FAILURE")) + (eglot--test-message "[%s]: %s" (ert-test-name (ert-running-test)) + (if test-body-successful-p "OK" "FAILED")) (unwind-protect (let ((eglot-autoreconnect nil)) (dolist (server new-servers) @@ -133,8 +123,7 @@ then restored." (eglot-shutdown server nil 3 (not test-body-successful-p)) (error - (eglot--message "Non-critical shutdown error after test: %S" - oops)))) + (eglot--test-message "Non-critical cleanup error: %S" oops)))) (when (not test-body-successful-p) ;; We want to do this after the sockets have ;; shut down such that any pending data has been @@ -147,24 +136,21 @@ then restored." (jsonrpc-events-buffer server))))) (cond (noninteractive (dolist (buffer buffers) - (eglot--message "%s:" (buffer-name buffer)) + (eglot--test-message "contents of `%s':" (buffer-name buffer)) (princ (with-current-buffer buffer (buffer-string)) 'external-debugging-output))) (t - (eglot--message "Preserved for inspection: %s" - (mapconcat #'buffer-name buffers ", ")))))))) - (eglot--cleanup-after-test fixture-directory created-files syms-to-restore))))) + (eglot--test-message "Preserved for inspection: %s" + (mapconcat #'buffer-name buffers ", ")))))))) + (eglot--cleanup-after-test fixture-directory created-files))))) -(defun eglot--cleanup-after-test (fixture-directory created-files syms-to-restore) +(defun eglot--cleanup-after-test (fixture-directory created-files) (let ((buffers-to-delete - (delete nil (mapcar #'find-buffer-visiting created-files)))) - (eglot--message "Killing %s, wiping %s, restoring %s" - buffers-to-delete - fixture-directory - (mapcar #'car syms-to-restore)) - (cl-loop for (sym . val) in syms-to-restore - do (set sym val)) - (dolist (buf buffers-to-delete) ;; have to save otherwise will get prompted + (delq nil (mapcar #'find-buffer-visiting created-files)))) + (eglot--test-message "Killing %s, wiping %s" + buffers-to-delete + fixture-directory) + (dolist (buf buffers-to-delete) ;; Have to save otherwise will get prompted. (with-current-buffer buf (save-buffer) (kill-buffer))) (delete-directory fixture-directory 'recursive) ;; Delete Tramp buffers if needed. @@ -213,48 +199,48 @@ then restored." &rest body) "Run BODY saving LSP JSON messages in variables, most recent first." (declare (indent 1) (debug (sexp &rest form))) - (let ((log-event-ad-sym (make-symbol "eglot--event-sniff"))) - `(unwind-protect - (let ,(delq nil (list server-requests - server-notifications - server-replies - client-requests - client-notifications - client-replies)) - (advice-add - #'jsonrpc--log-event :before - (lambda (_proc message &optional type) - (cl-destructuring-bind (&key method id _error &allow-other-keys) - message - (let ((req-p (and method id)) - (notif-p method) - (reply-p id)) - (cond - ((eq type 'server) - (cond (req-p ,(when server-requests - `(push message ,server-requests))) - (notif-p ,(when server-notifications - `(push message ,server-notifications))) - (reply-p ,(when server-replies - `(push message ,server-replies))))) - ((eq type 'client) - (cond (req-p ,(when client-requests - `(push message ,client-requests))) - (notif-p ,(when client-notifications - `(push message ,client-notifications))) - (reply-p ,(when client-replies - `(push message ,client-replies))))))))) - '((name . ,log-event-ad-sym))) - ,@body) - (advice-remove #'jsonrpc--log-event ',log-event-ad-sym)))) + (let ((log-event-hook-sym (make-symbol "eglot--event-sniff"))) + `(let* (,@(delq nil (list server-requests + server-notifications + server-replies + client-requests + client-notifications + client-replies))) + (cl-flet ((,log-event-hook-sym (_connection + origin + &key _json kind message _foreign-message + &allow-other-keys) + (let ((req-p (eq kind 'request)) + (notif-p (eq kind 'notification)) + (reply-p (eql kind 'reply))) + (cond + ((eq origin 'server) + (cond (req-p ,(when server-requests + `(push message ,server-requests))) + (notif-p ,(when server-notifications + `(push message ,server-notifications))) + (reply-p ,(when server-replies + `(push message ,server-replies))))) + ((eq origin 'client) + (cond (req-p ,(when client-requests + `(push message ,client-requests))) + (notif-p ,(when client-notifications + `(push message ,client-notifications))) + (reply-p ,(when client-replies + `(push message ,client-replies))))))))) + (unwind-protect + (progn + (add-hook 'jsonrpc-event-hook #',log-event-hook-sym) + ,@body) + (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym)))))) (cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) args &body body) - "Spin until FN match in EVENTS-SYM, flush events after it. -Pass TIMEOUT to `eglot--with-timeout'." (declare (indent 2) (debug (sexp sexp sexp &rest form))) `(eglot--with-timeout '(,timeout ,(or message (format "waiting for:\n%s" (pp-to-string body)))) - (let ((event + (eglot--test-message "waiting for `%s'" (with-output-to-string + (mapc #'princ ',body))) + (let ((events (cl-loop thereis (cl-loop for json in ,events-sym for method = (plist-get json :method) when (keywordp method) @@ -268,16 +254,21 @@ Pass TIMEOUT to `eglot--with-timeout'." collect json into before) for i from 0 when (zerop (mod i 5)) - ;; do (eglot--message "still struggling to find in %s" - ;; ,events-sym) + ;; do (eglot--test-message "still struggling to find in %s" + ;; ,events-sym) do ;; `read-event' is essential to have the file ;; watchers come through. - (read-event "[eglot] Waiting a bit..." nil 0.1) + (cond ((fboundp 'flush-standard-output) + (read-event nil nil 0.1) (princ ".") + (flush-standard-output)) + (t + (read-event "." nil 0.1))) (accept-process-output nil 0.1)))) - (setq ,events-sym (cdr event)) - (eglot--message "Event detected:\n%s" - (pp-to-string (car event)))))) + (setq ,events-sym (cdr events)) + (cl-destructuring-bind (&key method id &allow-other-keys) (car events) + (eglot--test-message "detected: %s" + (or method (and id (format "id=%s" id)))))))) ;; `rust-mode' is not a part of Emacs, so we define these two shims ;; which should be more than enough for testing. @@ -304,6 +295,13 @@ Pass TIMEOUT to `eglot--with-timeout'." (setq last-command-event char) (call-interactively (key-binding (vector char)))) +(defun eglot--clangd-version () + "Report on the clangd version used in various tests." + (let ((version (shell-command-to-string "clangd --version"))) + (when (string-match "version[[:space:]]+\\([0-9.]*\\)" + version) + (match-string 1 version)))) + ;;; Unit tests @@ -311,8 +309,7 @@ Pass TIMEOUT to `eglot--with-timeout'." "Connect to eclipse.jdt.ls server." (skip-unless (executable-find "jdtls")) (eglot--with-fixture - '(("project/src/main/java/foo" . (("Main.java" . ""))) - ("project/.git/" . nil)) + '(("project/src/main/java/foo" . (("Main.java" . "")))) (with-current-buffer (eglot--find-file-noselect "project/src/main/java/foo/Main.java") (eglot--sniffing (:server-notifications s-notifs) @@ -418,7 +415,7 @@ Pass TIMEOUT to `eglot--with-timeout'." (and (string= method "workspace/didChangeWatchedFiles") (cl-destructuring-bind (&key uri type) (elt (plist-get params :changes) 0) - (and (string= (eglot--path-to-uri "Cargo.toml") uri) + (and (string= (eglot-path-to-uri "Cargo.toml") uri) (= type 3)))))))))) (ert-deftest eglot-test-basic-diagnostics () @@ -431,7 +428,7 @@ Pass TIMEOUT to `eglot--with-timeout'." (eglot--find-file-noselect "diag-project/main.c") (eglot--sniffing (:server-notifications s-notifs) (eglot--tests-connect) - (eglot--wait-for (s-notifs 2) + (eglot--wait-for (s-notifs 10) (&key _id method &allow-other-keys) (string= method "textDocument/publishDiagnostics")) (flymake-start) @@ -441,16 +438,20 @@ Pass TIMEOUT to `eglot--with-timeout'." (ert-deftest eglot-test-diagnostic-tags-unnecessary-code () "Test rendering of diagnostics tagged \"unnecessary\"." - (skip-unless (executable-find "rust-analyzer")) - (skip-unless (executable-find "cargo")) + (skip-unless (executable-find "clangd")) + (skip-unless (version<= "14" (eglot--clangd-version))) (eglot--with-fixture - '(("diagnostic-tag-project" . - (("main.rs" . - "fn main() -> () { let test=3; }")))) + `(("diag-project" . + (("main.cpp" . "int main(){float a = 42.2; return 0;}")))) (with-current-buffer - (eglot--find-file-noselect "diagnostic-tag-project/main.rs") - (let ((eglot-server-programs '((rust-mode . ("rust-analyzer"))))) - (should (zerop (shell-command "cargo init"))) + (eglot--find-file-noselect "diag-project/main.cpp") + (eglot--make-file-or-dir '(".git")) + (eglot--make-file-or-dir + `("compile_commands.json" . + ,(jsonrpc--json-encode + `[(:directory ,default-directory :command "/usr/bin/c++ -Wall -c main.cpp" + :file ,(expand-file-name "main.cpp"))]))) + (let ((eglot-server-programs '((c++-mode . ("clangd"))))) (eglot--sniffing (:server-notifications s-notifs) (eglot--tests-connect) (eglot--wait-for (s-notifs 10) @@ -462,11 +463,11 @@ Pass TIMEOUT to `eglot--with-timeout'." (should (eq 'eglot-diagnostic-tag-unnecessary-face (face-at-point)))))))) (defun eglot--eldoc-on-demand () - ;; Trick Eldoc 1.1.0 into accepting on-demand calls. + ;; Trick ElDoc 1.1.0 into accepting on-demand calls. (eldoc t)) (defun eglot--tests-force-full-eldoc () - ;; FIXME: This uses some Eldoc implementation defatils. + ;; FIXME: This uses some ElDoc implementation details. (when (buffer-live-p eldoc--doc-buffer) (with-current-buffer eldoc--doc-buffer (let ((inhibit-read-only t)) @@ -543,10 +544,7 @@ Pass TIMEOUT to `eglot--with-timeout'." `(("project" . (("coiso.c" . "#include <stdio.h>\nint main () {fprin")))) (with-current-buffer (eglot--find-file-noselect "project/coiso.c") - (eglot--sniffing (:server-notifications s-notifs) - (eglot--wait-for-clangd) - (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys) - (string= method "textDocument/publishDiagnostics"))) + (eglot--wait-for-clangd) (goto-char (point-max)) (completion-at-point) (message (buffer-string)) @@ -652,7 +650,7 @@ int main() { (should (string-match "^fprintf" (eglot--tests-force-full-eldoc)))))) (ert-deftest eglot-test-multiline-eldoc () - "Test Eldoc documentation from multiple osurces." + "Test ElDoc documentation from multiple osurces." (skip-unless (executable-find "clangd")) (eglot--with-fixture `(("project" . (("coiso.c" . @@ -704,8 +702,8 @@ int main() { (should (zerop (shell-command "cargo init"))) (eglot--sniffing (:server-notifications s-notifs) (should (eglot--tests-connect)) - (eglot--wait-for (s-notifs 10) (&key method &allow-other-keys) - (string= method "textDocument/publishDiagnostics"))) + (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys) + (string= method "textDocument/publishDiagnostics"))) (goto-char (point-max)) (eglot--simulate-key-event ?.) (should (looking-back "^ \\.")))))) @@ -770,33 +768,35 @@ int main() { (should (= 4 (length (flymake--project-diagnostics)))))))))) (ert-deftest eglot-test-project-wide-diagnostics-rust-analyzer () - "Test diagnostics through multiple files in a TypeScript LSP." + "Test diagnostics through multiple files in rust-analyzer." (skip-unless (executable-find "rust-analyzer")) (skip-unless (executable-find "cargo")) + (skip-unless (executable-find "git")) (eglot--with-fixture '(("project" . (("main.rs" . - "fn main() -> () { let test=3; }") + "fn main() -> i32 { return 42.2;}") ("other-file.rs" . "fn foo() -> () { let hi=3; }")))) - (eglot--make-file-or-dir '(".git")) (let ((eglot-server-programs '((rust-mode . ("rust-analyzer"))))) - ;; Open other-file, and see diagnostics arrive for main.rs + ;; Open other-file.rs, and see diagnostics arrive for main.rs, + ;; which we didn't open. (with-current-buffer (eglot--find-file-noselect "project/other-file.rs") + (should (zerop (shell-command "git init"))) (should (zerop (shell-command "cargo init"))) (eglot--sniffing (:server-notifications s-notifs) (eglot--tests-connect) (flymake-start) - (eglot--wait-for (s-notifs 10) - (&key _id method &allow-other-keys) - (string= method "textDocument/publishDiagnostics")) - (let ((diags (flymake--project-diagnostics))) - (should (= 2 (length diags))) - ;; Check that we really get a diagnostic from main.rs, and - ;; not from other-file.rs - (should (string-suffix-p - "main.rs" - (flymake-diagnostic-buffer (car diags)))))))))) + (eglot--wait-for (s-notifs 20) + (&key _id method params &allow-other-keys) + (and (string= method "textDocument/publishDiagnostics") + (string-suffix-p "main.rs" (plist-get params :uri)))) + (let* ((diags (flymake--project-diagnostics))) + (should (cl-some (lambda (diag) + (let ((locus (flymake-diagnostic-buffer diag))) + (and (stringp (flymake-diagnostic-buffer diag)) + (string-suffix-p "main.rs" locus)))) + diags)))))))) (ert-deftest eglot-test-json-basic () "Test basic autocompletion in vscode-json-languageserver." @@ -853,9 +853,9 @@ int main() { (skip-unless (executable-find "clangd")) (eglot--with-fixture `(("project" . (("foo.c" . "int foo() {return 42;}") - ("bar.c" . "int bar() {return 42;}"))) - (c-mode-hook (eglot-ensure))) - (let (server) + ("bar.c" . "int bar() {return 42;}")))) + (let ((c-mode-hook '(eglot-ensure)) + server) ;; need `ert-simulate-command' because `eglot-ensure' ;; relies on `post-command-hook'. (with-current-buffer @@ -924,7 +924,7 @@ int main() { (should-error (apply #'eglot--connect (eglot--guess-contact))))))) (ert-deftest eglot-test-capabilities () - "Unit test for `eglot--server-capable'." + "Unit test for `eglot-server-capable'." (cl-letf (((symbol-function 'eglot--capabilities) (lambda (_dummy) ;; test data lifted from Golangserver example at @@ -939,11 +939,11 @@ int main() { :xdefinitionProvider t :xworkspaceSymbolByProperties t))) ((symbol-function 'eglot--current-server-or-lose) (lambda () nil))) - (should (eql 2 (eglot--server-capable :textDocumentSync))) - (should (eglot--server-capable :completionProvider :triggerCharacters)) - (should (equal '(:triggerCharacters ["."]) (eglot--server-capable :completionProvider))) - (should-not (eglot--server-capable :foobarbaz)) - (should-not (eglot--server-capable :textDocumentSync :foobarbaz)))) + (should (eql 2 (eglot-server-capable :textDocumentSync))) + (should (eglot-server-capable :completionProvider :triggerCharacters)) + (should (equal '(:triggerCharacters ["."]) (eglot-server-capable :completionProvider))) + (should-not (eglot-server-capable :foobarbaz)) + (should-not (eglot-server-capable :textDocumentSync :foobarbaz)))) (defmacro eglot--without-interface-warnings (&rest body) (let ((eglot-strict-mode nil)) @@ -1039,7 +1039,8 @@ int main() { (cl-defmacro eglot--guessing-contact ((interactive-sym prompt-args-sym guessed-class-sym guessed-contact-sym - &optional guessed-lang-id-sym) + &optional guessed-major-modes-sym + guessed-lang-ids-sym) &body body) "Guess LSP contact with `eglot--guessing-contact', evaluate BODY. @@ -1049,10 +1050,10 @@ BODY is evaluated twice, with INTERACTIVE bound to the boolean passed to If the user would have been prompted, PROMPT-ARGS-SYM is bound to the list of arguments that would have been passed to `read-shell-command', else nil. GUESSED-CLASS-SYM, -GUESSED-CONTACT-SYM and GUESSED-LANG-ID-SYM are bound to the -useful return values of `eglot--guess-contact'. Unless the -server program evaluates to \"a-missing-executable.exe\", this -macro will assume it exists." +GUESSED-CONTACT-SYM, GUESSED-LANG-IDS-SYM and +GUESSED-MAJOR-MODES-SYM are bound to the useful return values of +`eglot--guess-contact'. Unless the server program evaluates to +\"a-missing-executable.exe\", this macro will assume it exists." (declare (indent 1) (debug t)) (let ((i-sym (cl-gensym))) `(dolist (,i-sym '(nil t)) @@ -1068,8 +1069,9 @@ macro will assume it exists." `(lambda (&rest args) (setq ,prompt-args-sym args) "") `(lambda (&rest _dummy) "")))) (cl-destructuring-bind - (_ _ ,guessed-class-sym ,guessed-contact-sym - ,(or guessed-lang-id-sym '_)) + (,(or guessed-major-modes-sym '_) + _ ,guessed-class-sym ,guessed-contact-sym + ,(or guessed-lang-ids-sym '_)) (eglot--guess-contact ,i-sym) ,@body)))))) @@ -1164,16 +1166,17 @@ macro will assume it exists." (ert-deftest eglot-test-server-programs-guess-lang () (let ((major-mode 'foo-mode)) (let ((eglot-server-programs '((foo-mode . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "foo")))) + (eglot--guessing-contact (_ nil _ _ _ guessed-langs) + (should (equal guessed-langs '("foo"))))) (let ((eglot-server-programs '(((foo-mode :language-id "bar") . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "bar")))) + (eglot--guessing-contact (_ nil _ _ _ guessed-langs) + (should (equal guessed-langs '("bar"))))) (let ((eglot-server-programs '(((baz-mode (foo-mode :language-id "bar")) . ("prog-executable"))))) - (eglot--guessing-contact (_ nil _ _ guessed-lang) - (should (equal guessed-lang "bar")))))) + (eglot--guessing-contact (_ nil _ _ modes guessed-langs) + (should (equal guessed-langs '("bar" "baz"))) + (should (equal modes '(foo-mode baz-mode))))))) (defun eglot--glob-match (glob str) (funcall (eglot--glob-compile glob t t) str)) @@ -1233,14 +1236,27 @@ macro will assume it exists." (defun eglot--call-with-tramp-test (fn) ;; Set up a Tramp method that’s just a shell so the remote host is ;; really just the local host. - (let* ((tramp-remote-path (cons 'tramp-own-remote-path tramp-remote-path)) + (let* ((tramp-remote-path (cons 'tramp-own-remote-path + tramp-remote-path)) (tramp-histfile-override t) (tramp-allow-unsafe-temporary-files t) (tramp-verbose 1) - (temporary-file-directory ert-remote-temporary-file-directory) + (temporary-file-directory + (or (bound-and-true-p ert-remote-temporary-file-directory) + (prog1 (format "/mock::%s" temporary-file-directory) + (add-to-list + 'tramp-methods + '("mock" + (tramp-login-program "sh") (tramp-login-args (("-i"))) + (tramp-direct-async ("-c")) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) + (add-to-list 'tramp-default-host-alist + `("\\`mock\\'" nil ,(system-name))) + (when (and noninteractive (not (file-directory-p "~/"))) + (setenv "HOME" temporary-file-directory))))) (default-directory temporary-file-directory)) ;; We must check the remote LSP server. So far, just "clangd" is used. - (unless (executable-find "clangd" 'remote) + (unless (ignore-errors (executable-find "clangd" 'remote)) (ert-skip "Remote clangd not found")) (funcall fn))) @@ -1257,9 +1273,9 @@ macro will assume it exists." (ert-deftest eglot-test-path-to-uri-windows () (skip-unless (eq system-type 'windows-nt)) (should (string-prefix-p "file:///" - (eglot--path-to-uri "c:/Users/Foo/bar.lisp"))) + (eglot-path-to-uri "c:/Users/Foo/bar.lisp"))) (should (string-suffix-p "c%3A/Users/Foo/bar.lisp" - (eglot--path-to-uri "c:/Users/Foo/bar.lisp")))) + (eglot-path-to-uri "c:/Users/Foo/bar.lisp")))) (ert-deftest eglot-test-same-server-multi-mode () "Check single LSP instance manages multiple modes in same project." @@ -1287,8 +1303,9 @@ macro will assume it exists." (should (eq (eglot-current-server) server)))))) (provide 'eglot-tests) -;;; eglot-tests.el ends here ;; Local Variables: ;; checkdoc-force-docstrings-flag: nil ;; End: + +;;; eglot-tests.el ends here diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 57b39a49801..4fa869c773f 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -128,7 +128,7 @@ (ert-deftest eval-last-sexp-print-format-sym-echo () ;; We can only check the echo area when running interactive. - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (let ((current-prefix-arg nil)) (erase-buffer) (insert "t") (message nil) @@ -147,7 +147,7 @@ (should (equal (buffer-string) "?A65 (#o101, #x41, ?A)"))))) (ert-deftest eval-last-sexp-print-format-small-int-echo () - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (let ((current-prefix-arg nil)) (erase-buffer) (insert "?A") (message nil) @@ -171,7 +171,7 @@ (should (equal (buffer-string) "?B66 (#o102, #x42, ?B)")))))) (ert-deftest eval-last-sexp-print-format-large-int-echo () - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (let ((eval-expression-print-maximum-character ?A)) (let ((current-prefix-arg nil)) @@ -186,7 +186,7 @@ ;;; eval-defun (ert-deftest eval-defun-prints-edebug-when-instrumented () - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (let ((current-prefix-arg '(4))) (erase-buffer) (insert "(defun foo ())") (message nil) @@ -1004,6 +1004,11 @@ evaluation of BODY." (should (equal (elisp--xref-infer-namespace p6) 'function))) (elisp-mode-test--with-buffer + (concat "(defclass child-class ({p1}parent-1 {p2}parent-2))\n") + (should (equal (elisp--xref-infer-namespace p1) 'function)) + (should (equal (elisp--xref-infer-namespace p2) 'function))) + + (elisp-mode-test--with-buffer (concat "(require '{p1}alpha)\n" "(fboundp '{p2}beta)\n" "(boundp '{p3}gamma)\n" diff --git a/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..fe09a37a32b --- /dev/null +++ b/test/lisp/progmodes/elixir-ts-mode-resources/indent.erts @@ -0,0 +1,390 @@ +Code: + (lambda () + (elixir-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: $ + +Name: Basic modules + +=-= + defmodule Foobar do +def bar() do +"one" + end + end +=-= +defmodule Foobar do + def bar() do + "one" + end +end +=-=-= + +Name: Map + +=-= +map = %{ + "a" => 1, + "b" => 2 +} +=-=-= + +Name: Map in function def + +=-= +def foobar() do + %{ + one: "one", + two: "two", + three: "three", + four: "four" + } +end +=-=-= + +Name: Map in tuple + +=-= +def foo() do + {:ok, + %{ + state + | extra_arguments: extra_arguments, + max_children: max_children, + max_restarts: max_restarts, + max_seconds: max_seconds, + strategy: strategy + }} +end +=-=-= + +Name: Nested maps + +=-= +%{ + foo: "bar", + bar: %{ + foo: "bar" + } +} + +def foo() do + %{ + foo: "bar", + bar: %{ + foo: "bar" + } + } +end +=-=-= + +Name: Bitstring mulitline + +=-= +<<12, 22, +22, 32 + >> +=-= +<<12, 22, + 22, 32 +>> +=-=-= + +Name: Block assignments + +=-= +foo = + if true do + "yes" + else + "no" + end +=-=-= + +Name: Function rescue + +=-= +def foo do + "bar" +rescue + e -> + "bar" +end +=-=-= + +Name: With statement +=-= +with one <- one(), + two <- two(), + {:ok, value} <- get_value(one, two) do + {:ok, value} +else + {:error, %{"Message" => message}} -> + {:error, message} +end +=-=-= + +Name: Pipe statements with fn + +=-= +[1, 2] +|> Enum.map(fn num -> + num + 1 +end) +=-=-= + +Name: Pipe statements stab clases + +=-= +[1, 2] +|> Enum.map(fn + x when x < 10 -> x * 2 + x -> x * 3 +end) +=-=-= + +Name: Pipe statements params + +=-= +[1, 2] +|> foobar( + :one, + :two, + :three, + :four +) +=-=-= + +Name: Parameter maps + +=-= +def something(%{ + one: :one, + two: :two + }) do + {:ok, "done"} +end +=-=-= + +Name: Binary operator in else block + +=-= +defp foobar() do + if false do + :foo + else + :bar |> foo + end +end +=-=-= + +Name: Tuple indentation + +=-= +tuple = { + :one, + :two +} + +{ + :one, + :two +} +=-=-= + +Name: Call with keywords + +=-= +def foo() do + bar(:one, + :two, + one: 1, + two: 2 + ) +end +=-=-= + +Name: Call with @spec + +=-= +@spec foobar( + t, + acc, + (one, something -> :bar | far), + (two -> :bar | far) + ) :: any() + when chunk: any +def foobar(enumerable, acc, chunk_fun, after_fun) do + {_, {res, acc}} = + case after_fun.(acc) do + {:one, "one"} -> + "one" + + {:two, "two"} -> + "two" + end +end +=-=-= + +Name: Spec with multi-line result + +=-= +@type result :: + {:done, term} + | {:two} + | {:one} + +@type result :: + { + :done, + term + } + | {:two} + | {:one} + +@type boo_bar :: + (foo :: pos_integer, bar :: pos_integer -> any()) + +@spec foo_bar( + t, + (foo -> any), + (() -> any) | (foo, foo -> boolean) | module() + ) :: any + when foo: any +def foo(one, fun, other) +=-=-= + +Name: String concatenation in call + +=-= +IO.warn( + "one" <> + "two" <> + "bar" +) + +IO.warn( + "foo" <> + "bar" +) +=-=-= + +Name: Incomplete tuple + +=-= +map = { +:foo + +=-= +map = { + :foo + +=-=-= + +Name: Incomplete map + +=-= +map = %{ + "a" => "a", +=-=-= + +Name: Incomplete list + +=-= +map = [ +:foo + +=-= +map = [ + :foo + +=-=-= + +Name: String concatenation + +=-= +"one" <> + "two" <> + "three" <> + "four" +=-=-= + +Name: Tuple with same line first node + +=-= +{:one, + :two} + +{:ok, + fn one -> + one + |> String.upcase(one) + end} +=-=-= + +Name: Long tuple + +=-= +{"January", "February", "March", "April", "May", "June", "July", "August", "September", + "October", "November", "December"} +=-=-= + +Name: Doc + +=-= +defmodule Foo do +""" + bar + """ +end +=-= +defmodule Foo do + """ + bar + """ +end +=-=-= + +Name: Embedded HEEx + +=-= + defmodule Foo do + def foo(assigns) do +~H""" +<span> +text +</span> +""" + end + end +=-= +defmodule Foo do + def foo(assigns) do + ~H""" + <span> + text + </span> + """ + end +end +=-=-= + +Code: + (lambda () + (elixir-ts-mode) + (newline) + (indent-for-tab-command)) + +Name: New list item + +=-= +[ + :foo,$ +] +=-= +[ + :foo, + $ +] +=-=-= diff --git a/test/lisp/progmodes/elixir-ts-mode-tests.el b/test/lisp/progmodes/elixir-ts-mode-tests.el new file mode 100644 index 00000000000..488fc1b646f --- /dev/null +++ b/test/lisp/progmodes/elixir-ts-mode-tests.el @@ -0,0 +1,31 @@ +;;; elixir-ts-mode-tests.el --- Tests for elixir-ts-mode -*- 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/>. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'treesit) + +(ert-deftest elixir-ts-mode-test-indentation () + (skip-unless (and (treesit-ready-p 'elixir) (treesit-ready-p 'heex))) + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'elixir-ts-mode-tests) +;;; elixir-ts-mode-tests.el ends here diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index f6608dffca2..c3ef4827ef2 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -213,6 +213,7 @@ SEVERITY-PREDICATE is used to setup (ert-deftest dummy-backends () "Test many different kinds of backends." + (let ((debug-on-error nil)) (with-temp-buffer (cl-letf (((symbol-function 'error-backend) @@ -291,7 +292,7 @@ SEVERITY-PREDICATE is used to setup (should (eq 'flymake-warning (face-at-point))) ; dolor (flymake-goto-next-error) (should (eq 'flymake-error (face-at-point))) ; prognata - (should-error (flymake-goto-next-error nil nil t)))))) + (should-error (flymake-goto-next-error nil nil t))))))) (ert-deftest recurrent-backend () "Test a backend that calls REPORT-FN multiple times." diff --git a/test/lisp/progmodes/grep-tests.el b/test/lisp/progmodes/grep-tests.el index 39307999d6d..9b7f83086bf 100644 --- a/test/lisp/progmodes/grep-tests.el +++ b/test/lisp/progmodes/grep-tests.el @@ -66,4 +66,18 @@ (cl-letf (((symbol-function 'w32-shell-dos-semantics) #'ignore)) (grep-tests--check-rgrep-abbreviation)))) +(ert-deftest grep-tests--grep-heading-regexp-without-null () + (dolist (sep '(?: ?- ?=)) + (let ((string (format "filename%c123%ctext" sep sep))) + (should (string-match grep-heading-regexp string)) + (should (equal (match-string 1 string) "filename")) + (should (equal (match-string 2 string) (format "filename%c" sep)))))) + +(ert-deftest grep-tests--grep-heading-regexp-with-null () + (dolist (sep '(?: ?- ?=)) + (let ((string (format "funny:0:filename%c123%ctext" 0 sep))) + (should (string-match grep-heading-regexp string)) + (should (equal (match-string 1 string) "funny:0:filename")) + (should (equal (match-string 2 string) "funny:0:filename\0"))))) + ;;; grep-tests.el ends here diff --git a/test/lisp/progmodes/heex-ts-mode-resources/indent.erts b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..500ddb2b536 --- /dev/null +++ b/test/lisp/progmodes/heex-ts-mode-resources/indent.erts @@ -0,0 +1,47 @@ +Code: + (lambda () + (setq indent-tabs-mode nil) + (heex-ts-mode) + (indent-region (point-min) (point-max))) + +Point-Char: $ + +Name: Tag + +=-= + <div> + div + </div> +=-= +<div> + div +</div> +=-=-= + +Name: Component + +=-= + <Foo> + foobar + </Foo> +=-= +<Foo> + foobar +</Foo> +=-=-= + +Name: Slots + +=-= + <Foo> + <:bar> + foobar + </:bar> + </Foo> +=-= +<Foo> + <:bar> + foobar + </:bar> +</Foo> +=-=-= diff --git a/test/lisp/progmodes/heex-ts-mode-tests.el b/test/lisp/progmodes/heex-ts-mode-tests.el new file mode 100644 index 00000000000..def6d845de9 --- /dev/null +++ b/test/lisp/progmodes/heex-ts-mode-tests.el @@ -0,0 +1,31 @@ +;;; heex-ts-mode-tests.el --- Tests for heex-ts-mode -*- 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/>. + +;;; Code: + +(require 'ert) +(require 'ert-x) +(require 'treesit) + +(ert-deftest heex-ts-mode-test-indentation () + (skip-unless (treesit-ready-p 'heex)) + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(provide 'heex-ts-mode-tests) +;;; heex-ts-mode-tests.el ends here diff --git a/test/lisp/progmodes/java-ts-mode-tests.el b/test/lisp/progmodes/java-ts-mode-tests.el index 03c13b9700d..4fd8fc3019f 100644 --- a/test/lisp/progmodes/java-ts-mode-tests.el +++ b/test/lisp/progmodes/java-ts-mode-tests.el @@ -28,8 +28,6 @@ (ert-test-erts-file (ert-resource-file "indent.erts"))) (ert-deftest java-ts-mode-test-movement () - :expected-result :failed ;in emacs-29 no sexp - ;navigation (skip-unless (treesit-ready-p 'java)) (ert-test-erts-file (ert-resource-file "movement.erts"))) diff --git a/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua b/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua new file mode 100644 index 00000000000..93d589e3825 --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-resources/font-lock.lua @@ -0,0 +1,339 @@ +#!/usr/bin/env lua +-- ^ font-lock-comment-face +-- Comment +-- <- font-lock-comment-delimiter-face +-- ^ font-lock-comment-face +--[[ +-- ^ font-lock-comment-face +Multi-line comment +-- ^ font-lock-comment-face +]] +-- <- font-lock-comment-face +local line_comment = "comment" -- comment +-- ^ font-lock-comment-face + +-- Definition +local function f1() end +-- ^ font-lock-function-name-face +local f2 = function() end +-- ^ font-lock-function-name-face +local tb = { f1 = function() end } +-- ^ font-lock-function-name-face +function tb.f2() end +-- ^ font-lock-function-name-face +function tb:f3() end +-- ^ font-lock-function-name-face +tbl.f4 = function() end +-- ^ font-lock-function-name-face +function x.y:z() end +-- ^ font-lock-function-name-face + +-- Keyword +if true then +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +elseif true then +-- <- font-lock-keyword-face +else end +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +local p = {} +-- ^ font-lock-keyword-face +for k,v in pairs({}) do end +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +repeat if true then break end until false +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +-- ^ font-lock-keyword-face +while true do end +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +function fn() return true end +-- <- font-lock-keyword-face +-- ^ font-lock-keyword-face +goto label1 +-- ^ font-lock-keyword-face +::label1:: +if true and not false or nil then +-- ^ font-lock-keyword-face +-- ^ font-lock-keyword-face +-- ^ font-lock-keyword-face +end + +-- String +local _ +_ = "x" +-- ^ font-lock-string-face +_ = 'x' +-- ^ font-lock-string-face +_ = "x\ty" +-- ^ font-lock-string-face +-- ^ font-lock-string-face +_ = "x\"y" +-- ^ font-lock-string-face +-- ^ font-lock-string-face +_ = 'x\'y' +-- ^ font-lock-string-face +-- ^ font-lock-string-face +_ = "x\z + y" +-- ^ font-lock-string-face +_ = "x\0900y" +-- ^ font-lock-string-face +_ = "x\09y" +-- ^ font-lock-string-face +_ = "x\0y" +-- ^ font-lock-string-face +_ = "x\u{1f602}y" +-- ^ font-lock-string-face +_ = [[x]] +-- ^ font-lock-string-face +_ = [=[x]=] +-- ^ font-lock-string-face + +-- Assignment +local n = 0 +-- ^ font-lock-variable-name-face +o, p, q = 1, 2, 3 +-- <- font-lock-variable-name-face +-- ^ font-lock-variable-name-face +-- ^ font-lock-variable-name-face +tbl[k] = "A" +-- ^ font-lock-variable-name-face +tbl.x = 1 +-- ^ font-lock-variable-name-face +for i=0,9 do end +-- ^ font-lock-variable-name-face + +-- Constant +local x <const> = 1 +-- ^ font-lock-constant-face +local f <close> = io.open('/file') +-- ^ font-lock-constant-face +local a, b, c = true, false, nil +-- ^ font-lock-constant-face +-- ^ font-lock-constant-face +-- ^ font-lock-constant-face +::label2:: +-- ^ font-lock-constant-face +goto label2 +-- ^ font-lock-constant-face + +-- Number +n = 123 +-- ^ font-lock-number-face +print(99) +-- ^ font-lock-number-face +print(tbl[1]) +-- ^ font-lock-number-face + +-- Bracket +local t = {} +-- ^ font-lock-bracket-face +-- ^ font-lock-bracket-face +print(t[1]) +-- ^ font-lock-bracket-face +-- ^ font-lock-bracket-face +-- ^ font-lock-bracket-face +-- ^ font-lock-bracket-face + +-- Builtin +assert() +-- <- font-lock-builtin-face +bit32() +-- <- font-lock-builtin-face +collectgarbage() +-- <- font-lock-builtin-face +coroutine() +-- <- font-lock-builtin-face +debug() +-- <- font-lock-builtin-face +dofile() +-- <- font-lock-builtin-face +error() +-- <- font-lock-builtin-face +getmetatable() +-- <- font-lock-builtin-face +io() +-- <- font-lock-builtin-face +ipairs() +-- <- font-lock-builtin-face +load() +-- <- font-lock-builtin-face +loadfile() +-- <- font-lock-builtin-face +math() +-- <- font-lock-builtin-face +next() +-- <- font-lock-builtin-face +os() +-- <- font-lock-builtin-face +package() +-- <- font-lock-builtin-face +pairs() +-- <- font-lock-builtin-face +pcall() +-- <- font-lock-builtin-face +print() +-- <- font-lock-builtin-face +rawequal() +-- <- font-lock-builtin-face +rawget() +-- <- font-lock-builtin-face +rawlen() +-- <- font-lock-builtin-face +rawset() +-- <- font-lock-builtin-face +require() +-- <- font-lock-builtin-face +select() +-- <- font-lock-builtin-face +setmetatable() +-- <- font-lock-builtin-face +string() +-- <- font-lock-builtin-face +table() +-- <- font-lock-builtin-face +tonumber() +-- <- font-lock-builtin-face +tostring() +-- <- font-lock-builtin-face +type() +-- <- font-lock-builtin-face +utf8() +-- <- font-lock-builtin-face +warn() +-- <- font-lock-builtin-face +xpcall() +-- <- font-lock-builtin-face +print(_G) +-- ^ font-lock-builtin-face +print(_VERSION) +-- ^ font-lock-builtin-face +f.close() +-- ^ font-lock-builtin-face +f.flush() +-- ^ font-lock-builtin-face +f.lines() +-- ^ font-lock-builtin-face +f.read() +-- ^ font-lock-builtin-face +f.seek() +-- ^ font-lock-builtin-face +f.setvbuf() +-- ^ font-lock-builtin-face +f.write() +-- ^ font-lock-builtin-face + +-- Delimiter +t = { 1, 2 }; +-- ^ font-lock-delimiter-face +-- ^ font-lock-delimiter-face + +-- Escape +_ = "x\ty" +-- ^ font-lock-escape-face +-- ^ font-lock-escape-face +_ = "x\"y" +-- ^ font-lock-escape-face +-- ^ font-lock-escape-face +_ = 'x\'y' +-- ^ font-lock-escape-face +-- ^ font-lock-escape-face +_ = "x\z + y" +-- <- font-lock-escape-face +_ = "x\x5Ay" +-- ^ font-lock-escape-face +-- ^ font-lock-escape-face +_ = "x\0900y" +-- ^ font-lock-escape-face +_ = "x\09y" +-- ^ font-lock-escape-face +_ = "x\0y" +-- ^ font-lock-escape-face +_ = "x\u{1f602}y" +-- ^ font-lock-escape-face +-- ^ font-lock-escape-face + +-- Function +func_one() +-- ^ font-lock-function-call-face +tbl.func_two() +-- ^ font-lock-function-call-face +tbl:func_three() +-- ^ font-lock-function-call-face +tbl.f = f4() +-- ^ font-lock-function-call-face + +-- Operator +local a, b = 1, 2 +-- ^ font-lock-operator-face +print(a & b) +-- ^ font-lock-operator-face +print(a | b) +-- ^ font-lock-operator-face +print(a ~ b) +-- ^ font-lock-operator-face +print(a << 1) +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +print(a >> 1) +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +print(a+b-a*b/a%b^a//b) +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +-- ^ font-lock-operator-face +print(#t) +-- ^ font-lock-operator-face +print("h".."at") +-- ^ font-lock-operator-face +print(a==b) +-- ^ font-lock-operator-face +print(a~=b) +-- ^ font-lock-operator-face +print(a<=b) +-- ^ font-lock-operator-face +print(a>=b) +-- ^ font-lock-operator-face +print(a<b) +-- ^ font-lock-operator-face +print(a>b) +-- ^ font-lock-operator-face +function ff(...) end +-- ^ font-lock-operator-face + +-- Property +t = { a=1 } +-- ^ font-lock-property-name-face +print(t.a) +-- ^ font-lock-property-use-face + +-- Punctuation +tbl.f2() +-- ^ font-lock-punctuation-face +tbl:f3() +-- ^ font-lock-punctuation-face + +-- Variable +function fn(x, y) end +-- ^ font-lock-variable-name-face +-- ^ font-lock-variable-name-face +fn(a, b) +-- ^ font-lock-variable-use-face +-- ^ font-lock-variable-use-face +print(a + b) +-- ^ font-lock-variable-use-face +-- ^ font-lock-variable-use-face +print(t[a]) +-- ^ font-lock-variable-use-face +tbl.f1(p) +-- ^ font-lock-variable-use-face +tbl:f2(q) +-- ^ font-lock-variable-use-face diff --git a/test/lisp/progmodes/lua-ts-mode-resources/indent.erts b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts new file mode 100644 index 00000000000..9797467bbe5 --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-resources/indent.erts @@ -0,0 +1,679 @@ +Code: + (lambda () + (setq indent-tabs-mode nil) + (setq lua-ts-indent-offset 2) + (lua-ts-mode) + (indent-region (point-min) (point-max))) + +Name: Chunk Indent + +=-= + print(1) + print(2) +=-= +print(1) +print(2) +=-=-= + +Name: Function Indent + +=-= +function f1(n) +print(n) +return n + 1 +end + +local function f2(n) +print(n) +return n * 2 +end + +local f3 = function(n) +print(n) +return n / 3 +end + +function f4(...) +local f = function (...) +if ok +then print(1) +else print(0) +end +end +return f +end + +function f5(...) +local f = function (...) +if ok +then +print(1) +else +print(0) +end +end +return f +end + +function f6(...) +local f = function (...) +if ok then +print(1) +else +print(0) +end +end +return f +end + +;(function () + return true + end)() +=-= +function f1(n) + print(n) + return n + 1 +end + +local function f2(n) + print(n) + return n * 2 +end + +local f3 = function(n) + print(n) + return n / 3 +end + +function f4(...) + local f = function (...) + if ok + then print(1) + else print(0) + end + end + return f +end + +function f5(...) + local f = function (...) + if ok + then + print(1) + else + print(0) + end + end + return f +end + +function f6(...) + local f = function (...) + if ok then + print(1) + else + print(0) + end + end + return f +end + +;(function () + return true +end)() +=-=-= + +Name: Conditional Indent + +=-= +if true then +print(true) +return 1 +elseif false then +print(false) +return -1 +else +print(nil) +return 0 +end + +if true + then + print(true) + return 1 + elseif false + then + print(false) + return -1 + else + print(nil) + return 0 +end + +if true + then return 1 + elseif false + then return -1 + else return 0 +end +=-= +if true then + print(true) + return 1 +elseif false then + print(false) + return -1 +else + print(nil) + return 0 +end + +if true +then + print(true) + return 1 +elseif false +then + print(false) + return -1 +else + print(nil) + return 0 +end + +if true +then return 1 +elseif false +then return -1 +else return 0 +end +=-=-= + +Name: Loop Indent + +=-= +for k,v in pairs({}) do + print(k) + print(v) +end + +for i=1,10 + do print(i) +end + +while n < 10 do + n = n + 1 + print(n) +end + +while n < 10 + do + n = n + 1 + print(n) +end + +for i=0,9 do +repeat n = n+1 + until n > 99 +end + +repeat +z = z * 2 +print(z) +until z > 12 + + for i,x in ipairs(t) do + while i < 9 + do + local n = t[x] + repeat n = n + 1 + until n > #t + while n < 99 + do + print(n) + end + end + print(t[i]) + end + +do +local a = b +print(a + 1) +end +=-= +for k,v in pairs({}) do + print(k) + print(v) +end + +for i=1,10 +do print(i) +end + +while n < 10 do + n = n + 1 + print(n) +end + +while n < 10 +do + n = n + 1 + print(n) +end + +for i=0,9 do + repeat n = n+1 + until n > 99 +end + +repeat + z = z * 2 + print(z) +until z > 12 + +for i,x in ipairs(t) do + while i < 9 + do + local n = t[x] + repeat n = n + 1 + until n > #t + while n < 99 + do + print(n) + end + end + print(t[i]) +end + +do + local a = b + print(a + 1) +end +=-=-= + +Name: Bracket Indent + +=-= +fn( + ) + +tb={ + } +=-= +fn( +) + +tb={ +} +=-=-= + +Name: Multi-line String Indent + +=-= +local s = [[ + Multi-line + string content + ]] + +function f() + local str = [[ + multi-line + string + ]] +return true +end +=-= +local s = [[ + Multi-line + string content + ]] + +function f() + local str = [[ + multi-line + string + ]] + return true +end +=-=-= + +Name: Multi-line Comment Indent + +=-= +--[[ + Multi-line + comment content + ]] + +function f() +--[[ +multi-line + comment + ]] + return true +end +=-= +--[[ + Multi-line + comment content + ]] + +function f() +--[[ +multi-line + comment + ]] + return true +end +=-=-= + +Name: Argument Indent + +=-= + h( + "string", + 1000 + ) + +local p = h( +"string", + 1000 +) + +fn(1, +2, + 3) + +fn( 1, 2, +3, 4 ) + +f({ +x = 1, +y = 2, +z = 3, +}) + +f({ x = 1, +y = 2, +z = 3, }) + +Test({ +a=1 +}) + +Test({ +a = 1, +b = 2, +}, +nil) +=-= +h( + "string", + 1000 +) + +local p = h( + "string", + 1000 +) + +fn(1, + 2, + 3) + +fn( 1, 2, + 3, 4 ) + +f({ + x = 1, + y = 2, + z = 3, +}) + +f({ x = 1, + y = 2, + z = 3, }) + +Test({ + a=1 +}) + +Test({ + a = 1, + b = 2, + }, + nil) +=-=-= + +Name: Parameter Indent + +=-= +function f1( +a, +b +) +print(a,b) +end + +local function f2(a, + b) +print(a,b) +end + +local f3 = function( a, b, + c, d ) +print(a,b,c,d) +end +=-= +function f1( + a, + b +) + print(a,b) +end + +local function f2(a, + b) + print(a,b) +end + +local f3 = function( a, b, + c, d ) + print(a,b,c,d) +end +=-=-= + +Name: Table Indent + +=-= +local Other = { + First={up={Step=true,Jump=true}, + down={Step=true,Jump=true}, + left={Step=true,Jump=true}, + right={Step=true,Jump=true}}, + Second={up={Step=true,Jump=true}, + down={Step=true,Jump=true}, + left={Step=true,Jump=true}, + right={Step=true,Jump=true}}, + Third={up={Goto=true}, + down={Goto=true}, + left={Goto=true}, + right={Goto=true}} +} + +local Other = { +a = 1, + b = 2, + c = 3, +} +=-= +local Other = { + First={up={Step=true,Jump=true}, + down={Step=true,Jump=true}, + left={Step=true,Jump=true}, + right={Step=true,Jump=true}}, + Second={up={Step=true,Jump=true}, + down={Step=true,Jump=true}, + left={Step=true,Jump=true}, + right={Step=true,Jump=true}}, + Third={up={Goto=true}, + down={Goto=true}, + left={Goto=true}, + right={Goto=true}} +} + +local Other = { + a = 1, + b = 2, + c = 3, +} +=-=-= + +Code: + (lambda () + (setq indent-tabs-mode nil) + (setq lua-ts-indent-offset 4) + (lua-ts-mode) + (indent-region (point-min) (point-max))) + +Name: End Indent + +=-= +function f(x) + for y=1,x.y do + for x=1,x.z do + if x.y and x.z then + if y <= x then + y = y + 1 + end end end end + return {x,y} or {math.random(),math.random()} + end + +for y=1,x.y do + for x=1,x.z do + if x.y and x.z then + if y <= x then + y = y + 1 + end + end end end +=-= +function f(x) + for y=1,x.y do + for x=1,x.z do + if x.y and x.z then + if y <= x then + y = y + 1 + end end end end + return {x,y} or {math.random(),math.random()} +end + +for y=1,x.y do + for x=1,x.z do + if x.y and x.z then + if y <= x then + y = y + 1 + end +end end end +=-=-= + +Name: Nested Function Indent + +=-= +function a(...) + return (function (x) + return x + end)(foo(...)) +end + +function b(n) + local x = 1 + return function (i) + return function (...) + return (function (n, ...) + return function (f, ...) + return (function (...) + if ... and x < 9 then + x = x + 1 + return ... + end end)(n(f, ...)) + end, ... + end)(i(...)) +end end end + +function c(f) + local f1 = function (...) + if nil ~= ... then + return f(...) + end + end + return function (i) + return function (...) + local fn = function (n, ...) + local x = function (f, ...) + return f1(n(f, ...)) + end + return x + end + return fn(i(...)) + end + end +end + +function d(f) + local f1 = function (c, f, ...) + if ... then + if f(...) then + return ... + else + return c(f, ...) + end end end + return function (i) + return function (...) + return (function (n, ...) + local function j (f, ...) + return f1(j, f, n(f, ...)) + end + return j, ... + end)(i(...)) +end end end + +function e (n, t) + return function (i) + return function (...) + return ( + function (n, ...) + local x, y, z = 0, {} + return (function (f, ...) + return (function (i, ...) return i(i, ...) end)( + function (i, ...) + return f(function (x, ...) + return i(i, ...)(x, ...) + end, ...) + end) + end)(function (j) + return function(f, ...) + return (function (c, f, ...) + if ... then + if n+1 == x then + local y1, x1 = y, x + y, x = {}, 0 + return (function (...) + z = ... + return ... + end)(t(y1-1, x1-1, ...)) + else + x = x - 1 + return c(f, + (function (...) + z = ... + return ... + end)(t(y, x, ...))) + end + elseif x ~= 0 then + x = 0 + return z, y + end end)(j, f, n(f, ...)) + end end), ... + end)(i(...)) +end end end +=-=-= diff --git a/test/lisp/progmodes/lua-ts-mode-resources/movement.erts b/test/lisp/progmodes/lua-ts-mode-resources/movement.erts new file mode 100644 index 00000000000..11e86f12926 --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-resources/movement.erts @@ -0,0 +1,603 @@ +Code: + (lambda () + (lua-ts-mode) + (beginning-of-defun 1)) + +Point-Char: | + +Name: beginning-of-defun moves to start of function declaration + +=-= +local function Test() + if true then + print(1) + else + print(0) + end| +end +=-= +|local function Test() + if true then + print(1) + else + print(0) + end +end +=-=-= + +Name: beginning-of-defun moves to start of function definition + +=-= +local t = { + f = function() + return true + end, +}| +=-= +local t = { +| f = function() + return true + end, +} +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (end-of-defun 1)) + +Point-Char: | + +Name: end-of-defun moves to end of function declaration + +=-= +local function Test() + if true then + pr|int(1) + else + print(0) + end +end + +local t = Test() +=-= +local function Test() + if true then + print(1) + else + print(0) + end +end +| +local t = Test() +=-=-= + +Name: end-of-defun moves to end of function definition + +=-= +local t = { + f = function() + re|turn true + end, +} +=-= +local t = { + f = function() + return true + end|, +} +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (forward-sentence 1)) + +Point-Char: | + +Name: forward-sentence moves over if statements + +=-= +function f() + |if true then + print(1) + elseif false then + print(0) + else + print(2) + end +end +=-= +function f() + if true then + print(1) + elseif false then + print(0) + else + print(2) + end| +end +=-=-= + +Name: forward-sentence moves over variable declaration + +=-= +|local n = 1 + +print(n) +=-= +local n = 1| + +print(n) +=-=-= + +Name: forward-sentence moves over for statements + +=-= +|for k, v in pairs({}) do + print(k, v) +end + +print(1) +=-= +for k, v in pairs({}) do + print(k, v) +end| + +print(1) +=-=-= + +Name: forward-sentence moves over do statements + +=-= +|do + local x = 1 + local y = 2 + + print(x, y) +end + +print(1) +=-= +do + local x = 1 + local y = 2 + + print(x, y) +end| + +print(1) +=-=-= + +Name: forward-sentence moves over while statements + +=-= +local i = 0 +|while i < 9 do + print(i) + i = i + 1 +end + +print(1) +=-= +local i = 0 +while i < 9 do + print(i) + i = i + 1 +end| + +print(1) +=-=-= + +Name: forward-sentence moves over repeat statements + +=-= +local i = 0 +|repeat + print(i) + i = i + 1 +until i > 9 + +print(1) +=-= +local i = 0 +repeat + print(i) + i = i + 1 +until i > 9| + +print(1) +=-=-= + +Name: forward-sentence moves over function calls + +=-= +|print(1) +=-= +print(1)| +=-=-= + +Name: forward-sentence moves over return statements + +=-= +function f() + |return math.random() +end +=-= +function f() + return math.random()| +end +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (forward-sentence 2)) + +Name: forward-sentence moves over table fields + +=-= +local t = { + |a = 1, + b = 2, +} +=-= +local t = { + a = 1, + b = 2|, +} +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (backward-sentence 1)) + +Point-Char: | + +Name: backward-sentence moves over if statements + +=-= +function f() + if true then + print(1) + elseif false then + print(0) + else + print(2) + end| +end +=-= +function f() + |if true then + print(1) + elseif false then + print(0) + else + print(2) + end +end +=-=-= + +Name: backward-sentence moves over variable declaration + +=-= +local n = 1| + +print(n) +=-= +|local n = 1 + +print(n) +=-=-= + +Name: backward-sentence moves over for statements + +=-= +for k, v in pairs({}) do + print(k, v) +end| + +print(1) +=-= +|for k, v in pairs({}) do + print(k, v) +end + +print(1) +=-=-= + +Name: backward-sentence moves over for statements + +=-= +do + local x = 1 + local y = 2 + + print(x, y) +end| + +print(1) +=-= +|do + local x = 1 + local y = 2 + + print(x, y) +end + +print(1) +=-=-= + +Name: backward-sentence moves over while statements + +=-= +local i = 0 +while i < 9 do + print(i) + i = i + 1 +end| + +print(1) +=-= +local i = 0 +|while i < 9 do + print(i) + i = i + 1 +end + +print(1) +=-=-= + +Name: backward-sentence moves over repeat statements + +=-= +local i = 0 +repeat + print(i) + i = i + 1 +until i > 9| + +print(1) +=-= +local i = 0 +|repeat + print(i) + i = i + 1 +until i > 9 + +print(1) +=-=-= + +Name: backward-sentence moves over function calls + +=-= +print(1)| +=-= +|print(1) +=-=-= + +Name: backward-sentence moves over return statements + +=-= +function f() + return math.random()| +end +=-= +function f() + |return math.random() +end +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (backward-sentence 2)) + +Point-Char: | + +Name: backward-sentence moves over table fields + +=-= +local t = { + a = 1, + b = 2|, +} +=-= +local t = { + |a = 1, + b = 2, +} +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (forward-sexp 1)) + +Point-Char: | + +Name: forward-sexp moves over arguments + +=-= +print|(1, 2, 3) +=-= +print(1, 2, 3)| +=-=-= + +Name: forward-sexp moves over parameters + +=-= +function f|(a, b) end +=-= +function f(a, b)| end +=-=-= + +Name: forward-sexp moves over strings + +=-= +print("|1, 2, 3") +=-= +print("1, 2, 3|") +=-=-= + +Name: forward-sexp moves over tables + +=-= +local t = |{ 1, + 2, + 3 } +=-= +local t = { 1, + 2, + 3 }| +=-=-= + +Name: forward-sexp moves over parenthesized expressions + +=-= +|(function (x) return x + 1 end)(41) +=-= +(function (x) return x + 1 end)|(41) +=-=-= + +Name: forward-sexp moves over function declarations + +=-= +|function foo (x) + if false then + print "foo" + elseif true then + print "bar" + end +end +=-= +function foo (x) + if false then + print "foo" + elseif true then + print "bar" + end +end| +=-=-= + +Name: forward-sexp moves over do statements + +=-= +|do + print(a + 1) +end +=-= +do + print(a + 1) +end| +=-=-= + +Name: forward-sexp moves over for statements + +=-= +|for k,v in pairs({}) do + print(k, v) +end +=-= +for k,v in pairs({}) do + print(k, v) +end| +=-=-= + +Name: forward-sexp moves over repeat statements + +=-= +|repeat + n = n + 1 +until n > 10 +=-= +repeat + n = n + 1 +until n > 10| +=-=-= + +Name: forward-sexp moves over while statements + +=-= +|while n < 99 +do + n = n+1 +end +=-= +while n < 99 +do + n = n+1 +end| +=-=-= + +Code: + (lambda () + (lua-ts-mode) + (backward-sexp 1)) + +Point-Char: | + +Name: backward-sexp moves over arguments + +=-= +print(1, 2, 3)| +=-= +print|(1, 2, 3) +=-=-= + +Name: backward-sexp moves over parameters + +=-= +function f(a, b)| end +=-= +function f|(a, b) end +=-=-= + +Name: backward-sexp moves over strings + +=-= +print("1, 2, 3|") +=-= +print("|1, 2, 3") +=-=-= + +Name: backward-sexp moves over tables + +=-= +local t = { 1, + 2, + 3 }| +=-= +local t = |{ 1, + 2, + 3 } +=-=-= + +Name: backward-sexp moves over parenthesized expressions + +=-= +(function (x) return x + 1 end)|(41) +=-= +|(function (x) return x + 1 end)(41) +=-=-= + +Name: backward-sexp moves over function declarations + +=-= +function foo (x) + if false then + print "foo" + elseif true then + print "bar" + end +end| +=-= +|function foo (x) + if false then + print "foo" + elseif true then + print "bar" + end +end +=-=-= diff --git a/test/lisp/progmodes/lua-ts-mode-tests.el b/test/lisp/progmodes/lua-ts-mode-tests.el new file mode 100644 index 00000000000..8a566d777e3 --- /dev/null +++ b/test/lisp/progmodes/lua-ts-mode-tests.el @@ -0,0 +1,42 @@ +;;; lua-ts-mode-tests.el --- Tests for lua-ts-mode -*- 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/>. + +;;; Code: + +(require 'ert) +(require 'ert-font-lock) +(require 'ert-x) +(require 'treesit) + +(ert-deftest lua-ts-test-indentation () + (skip-unless (treesit-ready-p 'lua)) + (ert-test-erts-file (ert-resource-file "indent.erts"))) + +(ert-deftest lua-ts-test-movement () + (skip-unless (treesit-ready-p 'lua)) + (ert-test-erts-file (ert-resource-file "movement.erts"))) + +(ert-deftest lua-ts-test-font-lock () + (skip-unless (treesit-ready-p 'lua)) + (let ((treesit-font-lock-level 4)) + (ert-font-lock-test-file (ert-resource-file "font-lock.lua") 'lua-ts-mode))) + +(provide 'lua-ts-mode-tests) + +;;; lua-ts-mode-tests.el ends here diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el index 3b22c5d8750..e72bdf30711 100644 --- a/test/lisp/progmodes/perl-mode-tests.el +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -28,6 +28,23 @@ (font-lock-ensure (point-min) (point-max)) (should (equal (get-text-property 4 'face) 'font-lock-variable-name-face)))) +(ert-deftest perl-test-bug-34245 () + "Test correct indentation after a hanging paren, with and without comments." + (with-temp-buffer + (perl-mode) + (insert "my @foo = (\n\"bar\",\n\"baz\",\n);") + (insert "\n\n") + (insert "my @ofoo = (\t\t# A comment.\n\"obar\",\n\"obaz\",\n);") + (indent-region (point-min) (point-max)) + (goto-char (point-min)) + (forward-line) + (skip-chars-forward " \t") + (should (equal (current-column) perl-indent-level)) + (search-forward "# A comment.") + (forward-line) + (skip-chars-forward " \t") + (should (equal (current-column) perl-indent-level)))) + ;;;; Reuse cperl-mode tests (defvar cperl-test-mode) diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 5a206b67db1..d335864ca2e 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -137,6 +137,7 @@ When `project-ignores' includes a name matching project dir." (project-vc-extra-root-markers '("files-x-tests.*")) (project (project-current nil dir))) (should-not (null project)) + (should (nth 1 project)) (should (string-match-p "/test/lisp/\\'" (project-root project))))) (ert-deftest project-vc-supports-project-in-different-dir () diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 59287970ca0..3ba720061ab 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -683,7 +683,7 @@ def long_function_name( (should (= (python-indent-calculate-indentation) 8)) (python-tests-look-at "var_four):") (should (eq (car (python-indent-context)) - :inside-paren-newline-start-from-block)) + :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 8)) (python-tests-look-at "print (var_one)") (should (eq (car (python-indent-context)) @@ -707,8 +707,8 @@ foo = long_function_name( (should (eq (car (python-indent-context)) :inside-paren-newline-start)) (should (= (python-indent-calculate-indentation) 4)) (python-tests-look-at "var_three, var_four)") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) - (should (= (python-indent-calculate-indentation) 4)))) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) + (should (= (python-indent-calculate-indentation) 2)))) (ert-deftest python-indent-hanging-close-paren () "Like first pep8 case, but with hanging close paren." ;; See Bug#20742. @@ -864,7 +864,7 @@ data = { (should (eq (car (python-indent-context)) :inside-paren-newline-start)) (should (= (python-indent-calculate-indentation) 4)) (python-tests-look-at "{") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 4)) (python-tests-look-at "'objlist': [") (should (eq (car (python-indent-context)) :inside-paren-newline-start)) @@ -876,20 +876,20 @@ data = { (should (eq (car (python-indent-context)) :inside-paren-newline-start)) (should (= (python-indent-calculate-indentation) 16)) (python-tests-look-at "'name': 'first',") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 16)) (python-tests-look-at "},") (should (eq (car (python-indent-context)) :inside-paren-at-closing-nested-paren)) (should (= (python-indent-calculate-indentation) 12)) (python-tests-look-at "{") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 12)) (python-tests-look-at "'pk': 2,") (should (eq (car (python-indent-context)) :inside-paren-newline-start)) (should (= (python-indent-calculate-indentation) 16)) (python-tests-look-at "'name': 'second',") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 16)) (python-tests-look-at "}") (should (eq (car (python-indent-context)) @@ -933,7 +933,7 @@ data = {'key': { (should (eq (car (python-indent-context)) :inside-paren)) (should (= (python-indent-calculate-indentation) 9)) (python-tests-look-at "{'pk': 2,") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 8)) (python-tests-look-at "'name': 'second'}") (should (eq (car (python-indent-context)) :inside-paren)) @@ -966,10 +966,10 @@ data = ('these', (should (eq (car (python-indent-context)) :inside-paren)) (should (= (python-indent-calculate-indentation) 8)) (forward-line 1) - (should (eq (car (python-indent-context)) :inside-paren)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 8)) (forward-line 1) - (should (eq (car (python-indent-context)) :inside-paren)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 8)))) (ert-deftest python-indent-inside-paren-4 () @@ -999,7 +999,7 @@ while ((not some_condition) and (should (eq (car (python-indent-context)) :no-indent)) (should (= (python-indent-calculate-indentation) 0)) (forward-line 1) - (should (eq (car (python-indent-context)) :inside-paren)) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) (should (= (python-indent-calculate-indentation) 7)) (forward-line 1) (should (eq (car (python-indent-context)) :after-block-start)) @@ -1023,7 +1023,7 @@ CHOICES = (('some', 'choice'), (should (eq (car (python-indent-context)) :inside-paren)) (should (= (python-indent-calculate-indentation) 11)) (forward-line 1) - (should (eq (car (python-indent-context)) :inside-paren)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 11)))) (ert-deftest python-indent-inside-paren-7 () @@ -1034,6 +1034,183 @@ CHOICES = (('some', 'choice'), ;; This signals an error if the test fails (should (eq (car (python-indent-context)) :inside-paren-newline-start)))) +(ert-deftest python-indent-inside-paren-8 () + "Test for Bug#63959." + (python-tests-with-temp-buffer + " +for a in [ # comment + 'some', # Manually indented. + 'thing']: # Respect indentation of the previous line. +" + (python-tests-look-at "for a in [ # comment") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) + :inside-paren-newline-start-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) + (should (= (python-indent-calculate-indentation) 10)))) + +(ert-deftest python-indent-inside-paren-9 () + "Test `:inside-paren-continuation-line'." + (python-tests-with-temp-buffer + " +a = ((( + 1, 2), + 3), # Do not respect the indentation of the previous line + 4) # Do not respect the indentation of the previous line +b = (( + 1, 2), # Manually indented + 3, # Do not respect the indentation of the previous line + 4, # Respect the indentation of the previous line + 5, # Manually indented + 6) # Respect the indentation of the previous line +" + (python-tests-look-at "a = (((") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 6)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 5)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-line)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren)) + (should (= (python-indent-calculate-indentation) 5)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) + (should (= (python-indent-calculate-indentation) 5)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) + (should (= (python-indent-calculate-indentation) 5)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) + (should (= (python-indent-calculate-indentation) 8)))) + +(ert-deftest python-indent-inside-paren-block-1 () + "`python-indent-block-paren-deeper' set to nil (default). +See Bug#62696." + (python-tests-with-temp-buffer + " +if ('VALUE' in my_unnecessarily_long_dictionary and + some_other_long_condition_case): + do_something() +elif (some_case or + another_case): + do_another() +" + (python-tests-look-at "if") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 6)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-paren-block-2 () + "`python-indent-block-paren-deeper' set to t. +See Bug#62696." + (python-tests-with-temp-buffer + " +if ('VALUE' in my_unnecessarily_long_dictionary and + some_other_long_condition_case): + do_something() +elif (some_case or + another_case): + do_another() +" + (let ((python-indent-block-paren-deeper t)) + (python-tests-look-at "if") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :at-dedenter-block-start)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 6)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4))))) + +(ert-deftest python-indent-inside-paren-block-3 () + "With backslash. `python-indent-block-paren-deeper' set to nil (default). +See Bug#62696." + (python-tests-with-temp-buffer + " +if 'VALUE' in my_uncessarily_long_dictionary and\\ + (some_other_long_condition_case or + another_case): + do_something() +" + (python-tests-look-at "if") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) + :after-backslash-block-continuation)) + (should (= (python-indent-calculate-indentation) 3)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 4)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4)))) + +(ert-deftest python-indent-inside-paren-block-4 () + "With backslash. `python-indent-block-paren-deeper' set to t. +See Bug#62696." + (python-tests-with-temp-buffer + " +if 'VALUE' in my_uncessarily_long_dictionary and\\ + (some_other_long_condition_case or + another_case): + do_something() +" + (let ((python-indent-block-paren-deeper t)) + (python-tests-look-at "if") + (should (eq (car (python-indent-context)) :no-indent)) + (should (= (python-indent-calculate-indentation) 0)) + (forward-line 1) + (should (eq (car (python-indent-context)) + :after-backslash-block-continuation)) + (should (= (python-indent-calculate-indentation) 3)) + (forward-line 1) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) + (should (= (python-indent-calculate-indentation) 8)) + (forward-line 1) + (should (eq (car (python-indent-context)) :after-block-start)) + (should (= (python-indent-calculate-indentation) 4))))) + (ert-deftest python-indent-after-block-1 () "The most simple after-block case that shouldn't fail." (python-tests-with-temp-buffer @@ -1159,7 +1336,7 @@ objects = Thing.objects.all() \\ (should (eq (car (python-indent-context)) :inside-paren-newline-start)) (should (= (python-indent-calculate-indentation) 27)) (python-tests-look-at "status='bought'") - (should (eq (car (python-indent-context)) :inside-paren-newline-start)) + (should (eq (car (python-indent-context)) :inside-paren-continuation-line)) (should (= (python-indent-calculate-indentation) 27)) (python-tests-look-at ") \\") (should (eq (car (python-indent-context)) :inside-paren-at-closing-paren)) @@ -1530,7 +1707,7 @@ a == 4): (should (= (python-indent-calculate-indentation) 0)) (should (= (python-indent-calculate-indentation t) 0)) (python-tests-look-at "a == 4):\n") - (should (eq (car (python-indent-context)) :inside-paren)) + (should (eq (car (python-indent-context)) :inside-paren-from-block)) (should (= (python-indent-calculate-indentation) 6)) (python-indent-line) (should (= (python-indent-calculate-indentation t) 4)) @@ -4741,7 +4918,7 @@ import abc ;; Skip the test on macOS, since the standard Python installation uses ;; libedit rather than readline which confuses the running of an inferior ;; interpreter in this case (see bug#59477 and bug#25753). - (skip-unless (not (eq system-type 'darwin))) + (skip-when (eq system-type 'darwin)) (trace-function 'python-shell-output-filter) (python-tests-with-temp-buffer-with-shell " @@ -5796,9 +5973,9 @@ def func(): else " (python-tests-look-at "else\n") - (should - (equal (list (python-tests-look-at "if (" -1 t)) - (python-info-dedenter-opening-block-positions))))) + (should + (equal (list (python-tests-look-at "if (" -1 t)) + (python-info-dedenter-opening-block-positions))))) (ert-deftest python-info-dedenter-opening-block-positions-7 () "Test case blocks." @@ -5816,9 +5993,9 @@ match a: (python-tests-look-at "case 2:") (should-not (python-info-dedenter-opening-block-positions)) (python-tests-look-at "case 3:") - (equal (list (python-tests-look-at "case 2:" -1) - (python-tests-look-at "case 1:" -1 t)) - (python-info-dedenter-opening-block-positions)))) + (should (equal (list (python-tests-look-at "case 2:" -1 t) + (python-tests-look-at "case 1:" -1 t)) + (python-info-dedenter-opening-block-positions))))) (ert-deftest python-info-dedenter-opening-block-message-1 () "Test dedenters inside strings are ignored." diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb index 81d0dfd75c9..a411b39a8fc 100644 --- a/test/lisp/progmodes/ruby-mode-resources/ruby.rb +++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb @@ -34,11 +34,11 @@ x = # "tot %q/to"; = # Regexp after whitelisted method. "abc".sub /b/, 'd' -# Don't mismatch "sub" at the end of words. -a = asub / aslb + bsub / bslb; +# Don't mistake division for regexp. +a = sub / aslb + bsub / bslb; # Highlight the regexp after "if". -x = toto / foo if /do bar/ =~ "dobar" +x = toto / foo if / do bar/ =~ "dobar" # Regexp options are highlighted. diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index a931541ba35..fea5f58b92e 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -164,7 +164,7 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby-assert-state "x = index/3" 3 nil)) (ert-deftest ruby-regexp-not-division-when-only-space-before () - (ruby-assert-state "x = index /3" 3 ?/)) + (ruby-assert-state "x = foo_index /3" 3 ?/)) (ert-deftest ruby-slash-not-regexp-when-only-space-after () (ruby-assert-state "x = index/ 3" 3 nil)) diff --git a/test/lisp/progmodes/sh-script-resources/sh-indents.erts b/test/lisp/progmodes/sh-script-resources/sh-indents.erts index 1f92610b3aa..36f4e4c22ab 100644 --- a/test/lisp/progmodes/sh-script-resources/sh-indents.erts +++ b/test/lisp/progmodes/sh-script-resources/sh-indents.erts @@ -38,3 +38,10 @@ if test ;then fi other =-=-= + +Name: sh-indents5 + +=-= +for i do echo 1; done +for i; do echo 1; done +=-=-= diff --git a/test/lisp/progmodes/sh-script-tests.el b/test/lisp/progmodes/sh-script-tests.el index c850a5d8af7..135d7afe3fe 100644 --- a/test/lisp/progmodes/sh-script-tests.el +++ b/test/lisp/progmodes/sh-script-tests.el @@ -52,6 +52,24 @@ (ert-deftest test-indentation () (ert-test-erts-file (ert-resource-file "sh-indents.erts"))) +(ert-deftest test-indent-after-continuation () + (with-temp-buffer + (insert "for f \\\nin a; do \\\ntoto; \\\ndone\n") + (shell-script-mode) + (let ((sh-indent-for-continuation '++)) + (let ((sh-indent-after-continuation t)) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "for f \\\n\tin a; do \\\n toto; \\\n done\n"))) + (let ((sh-indent-after-continuation 'always)) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "for f \\\n\tin a; do \\\n\ttoto; \\\n\tdone\n"))) + (let ((sh-indent-after-continuation nil)) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "for f \\\nin a; do \\\n toto; \\\ndone\n")))))) + (defun test-sh-back (string &optional pos) (with-temp-buffer (shell-script-mode) @@ -69,4 +87,15 @@ (should-not (test-sh-back "foo;bar")) (should (test-sh-back "foo#zot"))) +(ert-deftest sh-script-test-do-fontification () + "Test that \"do\" gets fontified correctly, even with no \";\"." + (with-temp-buffer + (shell-script-mode) + (insert "for i do echo 1; done") + (font-lock-ensure) + (goto-char (point-min)) + (search-forward "do") + (forward-char -1) + (should (equal (get-text-property (point) 'face) 'font-lock-keyword-face)))) + ;;; sh-script-tests.el ends here diff --git a/test/lisp/progmodes/which-func-tests.el b/test/lisp/progmodes/which-func-tests.el new file mode 100644 index 00000000000..73709f1c5e5 --- /dev/null +++ b/test/lisp/progmodes/which-func-tests.el @@ -0,0 +1,58 @@ +;;; which-func-tests.el --- tests for which-func -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Spencer Baugh <sbaugh@catern.com> + +;; This file is part of GNU Emacs. + +;; This program 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. + +;; This program 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: + +;;; Code: +(require 'ert) +(require 'which-func) + +(ert-deftest which-func-tests-toggle () + (let ((which-func-display 'mode-and-header) buf-code buf-not) + (setq buf-code (find-file-noselect "which-func-tests.el")) + (setq buf-not (get-buffer-create "fundamental")) + (with-current-buffer buf-code + (should-not which-func-mode) (should-not header-line-format)) + (with-current-buffer buf-not + (should-not which-func-mode) (should-not header-line-format)) + (which-function-mode 1) + (with-current-buffer buf-code + (should which-func-mode) (should header-line-format)) + (with-current-buffer buf-not + (should-not which-func-mode) (should-not header-line-format)) + (which-function-mode -1) + ;; which-func-mode stays set even when which-function-mode is off. + (with-current-buffer buf-code + (should which-func-mode) (should-not header-line-format)) + (with-current-buffer buf-not + (should-not which-func-mode) (should-not header-line-format)) + (kill-buffer buf-code) + (kill-buffer buf-not) + (which-function-mode 1) + (setq buf-code (find-file-noselect "which-func-tests.el")) + (setq buf-not (get-buffer-create "fundamental")) + (with-current-buffer buf-code + (should which-func-mode) (should header-line-format)) + (with-current-buffer buf-not + (should-not which-func-mode) (should-not header-line-format)))) + +(provide 'which-func-tests) +;;; which-func-tests.el ends here diff --git a/test/lisp/register-tests.el b/test/lisp/register-tests.el deleted file mode 100644 index 6283d1c31e0..00000000000 --- a/test/lisp/register-tests.el +++ /dev/null @@ -1,43 +0,0 @@ -;;; register-tests.el --- tests for register.el -*- lexical-binding: t-*- - -;; Copyright (C) 2017-2023 Free Software Foundation, Inc. - -;; Author: Tino Calancha <tino.calancha@gmail.com> -;; Keywords: - -;; 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: - - -;;; Code: -(require 'ert) -(require 'cl-lib) - -(ert-deftest register-test-bug27634 () - "Test for https://debbugs.gnu.org/27634 ." - (dolist (event (list ?\C-g 'escape ?\C-\[)) - (cl-letf (((symbol-function 'read-key) #'ignore) - (last-input-event event) - (register-alist nil)) - (should (equal 'quit - (condition-case err - (call-interactively 'point-to-register) - (quit (car err))))) - (should-not register-alist)))) - -(provide 'register-tests) -;;; register-tests.el ends here diff --git a/test/lisp/server-tests.el b/test/lisp/server-tests.el index ffafa74925f..de1aa80c272 100644 --- a/test/lisp/server-tests.el +++ b/test/lisp/server-tests.el @@ -25,12 +25,18 @@ (defconst server-tests/can-create-frames-p (and (not (memq system-type '(windows-nt ms-dos))) - (not (member (getenv "TERM") '("dumb" "" nil)))) + (not (member (getenv "TERM") '("dumb" "" nil))) + (or (not (eq system-type 'cygwin)) + (featurep 'gfilenotify) + (featurep 'dbus) + (featurep 'threads))) "Non-nil if we can create a new frame in the tests. Some tests below need to create new frames for the emacsclient. However, this doesn't work on all platforms. In particular, -MS-Windows fails to create frames from a batch Emacs session. In -cases like that, we just skip the test.") +MS-Windows fails to create frames from a batch Emacs session. +The same is true on Cygwin unless Emacs has at least one of the +features gfilenotify, dbus, or threads (bug#65325). In cases +like that, we just skip the test.") (defconst server-tests/max-wait-time 5 "The maximum time to wait in `server-tests/wait-until', in seconds.") diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index a941605a4d8..265b448226f 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -1,4 +1,4 @@ -;;; ses-tests.el --- Tests for ses.el -*- lexical-binding: t; -*- +;;; SES-tests.el --- Tests for ses.el -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2023 Free Software Foundation, Inc. @@ -241,6 +241,28 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to (ses-command-hook) (should (eq (ses--cell-at-pos (point)) 'ses--toto))))) +(ert-deftest ses-set-formula-write-cells-with-changed-references () + "Test fix of bug#5852. +When setting a formula has some cell with changed references, this +cell has to be rewritten to data area." + (let ((ses-initial-size '(4 . 3)) + ses-after-entry-functions beg) + (with-temp-buffer + (ses-mode) + (dolist (c '((0 1 1); B1 + (1 0 2) (1 1 (+ B1 A2)); A2 B2 + (2 0 4); A3 + (3 0 3) (3 1 (+ B2 A4))));A4 B4 + (apply 'ses-cell-set-formula c) + (apply 'ses-calculate-cell (list (car c) (cadr c) nil))) + (ses-cell-set-formula 2 1 '(+ B2 A3)); B3 + (ses-command-hook) + (ses-cell-set-formula 3 1 (+ B3 A4)); B4 + (ses-command-hook) + (should (equal (ses-cell-references 1 1) '(B3))) + (ses-mode) + (should (equal (ses-cell-references 1 1) '(B3)))))) + (provide 'ses-tests) ;;; ses-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 5edba039032..b1c06ad2d05 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -101,7 +101,7 @@ Per definition, all files are identical on the different hosts of a cluster (or site). This is not tested here; it must be guaranteed by the originator of a cluster definition." :tags '(:expensive-test) - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((text-quoting-style 'grave) ;; We inspect the *Messages* buffer! @@ -219,7 +219,7 @@ guaranteed by the originator of a cluster definition." Per definition, all files are identical on the different hosts of a cluster (or site). This is not tested here; it must be guaranteed by the originator of a cluster definition." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -320,7 +320,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test02-files () "Check file manipulation functions." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -391,7 +391,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test03-expand-cluster-in-file-name () "Check canonical file name of a cluster or site." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -456,7 +456,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test04-contract-file-name () "Check canonical file name of a cluster or site." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -511,7 +511,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test05-file-match () "Check `shadow-same-site' and `shadow-file-match'." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -563,7 +563,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test06-literal-groups () "Check literal group definitions." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -648,7 +648,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test07-regexp-groups () "Check regexp group definitions." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (let ((shadow-info-file shadow-test-info-file) @@ -710,7 +710,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test08-shadow-todo () "Check that needed shadows are added to todo." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (skip-unless (file-writable-p ert-remote-temporary-file-directory)) @@ -855,7 +855,7 @@ guaranteed by the originator of a cluster definition." (ert-deftest shadow-test09-shadow-copy-files () "Check that needed shadow files are copied." :tags '(:expensive-test) - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (skip-unless (file-remote-p ert-remote-temporary-file-directory)) (skip-unless (file-writable-p ert-remote-temporary-file-directory)) diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el index db9124e2435..ddddfdb2e0f 100644 --- a/test/lisp/shell-tests.el +++ b/test/lisp/shell-tests.el @@ -64,4 +64,35 @@ (should (equal (split-string-shell-command "ls /tmp/foo\\ bar") '("ls" "/tmp/foo bar"))))) +(ert-deftest shell-dirtrack-on-by-default () + (with-temp-buffer + (shell-mode) + (should shell-dirtrack-mode))) + +(ert-deftest shell-dirtrack-should-not-be-on-in-unrelated-modes () + (with-temp-buffer + (should (not shell-dirtrack-mode)))) + +(ert-deftest shell-dirtrack-sets-list-buffers-directory () + (let ((start-dir default-directory)) + (with-temp-buffer + (should-not list-buffers-directory) + (shell-mode) + (shell-cd "..") + (should list-buffers-directory) + (should (not (equal start-dir list-buffers-directory))) + (should (string-prefix-p list-buffers-directory start-dir))))) + +(ert-deftest shell-directory-tracker-cd () + (let ((start-dir default-directory)) + (with-temp-buffer + (should-not list-buffers-directory) + (shell-mode) + (cl-letf (((symbol-function 'shell-unquote-argument) + (lambda (x) x))) + (shell-directory-tracker "cd ..")) + (should list-buffers-directory) + (should (not (equal start-dir list-buffers-directory))) + (should (string-prefix-p list-buffers-directory start-dir))))) + ;;; shell-tests.el ends here diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 28d8120f143..b632c908443 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -742,7 +742,7 @@ See Bug#21722." (ert-deftest eval-expression-print-format-sym-echo () ;; We can only check the echo area when running interactive. - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (cl-letf (((symbol-function 'read--expression) (lambda (&rest _) t))) (let ((current-prefix-arg nil)) @@ -763,7 +763,7 @@ See Bug#21722." (should (equal (buffer-string) "65 (#o101, #x41, ?A)")))))) (ert-deftest eval-expression-print-format-small-int-echo () - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?A))) (let ((current-prefix-arg nil)) @@ -789,7 +789,7 @@ See Bug#21722." (should (equal (buffer-string) "66 (#o102, #x42, ?B)")))))) (ert-deftest eval-expression-print-format-large-int-echo () - (skip-unless (not noninteractive)) + (skip-when noninteractive) (with-temp-buffer (cl-letf (((symbol-function 'read--expression) (lambda (&rest _) ?B)) (eval-expression-print-maximum-character ?A)) @@ -839,7 +839,7 @@ See Bug#21722." (forward-line 2) (narrow-to-region (pos-bol) (pos-eol)) (should (equal (line-number-at-pos) 1)) - (line-number-at-pos nil t) + (should (equal (line-number-at-pos nil t) 3)) (should (equal (line-number-at-pos) 1)))) (ert-deftest line-number-at-pos-keeps-point () @@ -849,8 +849,8 @@ See Bug#21722." (goto-char (point-min)) (forward-line 2) (setq pos (point)) - (line-number-at-pos) - (line-number-at-pos nil t) + (should (equal (line-number-at-pos) 3)) + (should (equal (line-number-at-pos nil t) 3)) (should (equal pos (point)))))) (ert-deftest line-number-at-pos-when-passing-point () diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 1abd3be4ea1..f485328aa7a 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -345,18 +345,54 @@ ;;;; Mode hooks. -(defalias 'subr-tests--parent-mode - (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode)) +(defalias 'subr-tests--parent-mode #'prog-mode) +(define-derived-mode subr-tests--derived-mode-1 prog-mode "test") +(define-derived-mode subr-tests--derived-mode-2 subr-tests--parent-mode "test") (ert-deftest provided-mode-derived-p () ;; base case: `derived-mode' directly derives `prog-mode' - (should (progn - (define-derived-mode derived-mode prog-mode "test") - (provided-mode-derived-p 'derived-mode 'prog-mode))) - ;; edge case: `derived-mode' derives an alias of `prog-mode' - (should (progn - (define-derived-mode derived-mode subr-tests--parent-mode "test") - (provided-mode-derived-p 'derived-mode 'prog-mode)))) + (should (provided-mode-derived-p 'subr-tests--derived-mode-1 'prog-mode)) + ;; Edge cases: aliases along the derivation. + (should (provided-mode-derived-p 'subr-tests--parent-mode + 'subr-tests--parent-mode)) + (should (provided-mode-derived-p 'subr-tests--derived-mode-2 + 'subr-tests--parent-mode)) + (should (provided-mode-derived-p 'subr-tests--derived-mode-2 'prog-mode))) + + +(define-derived-mode subr-tests--mode-A subr-tests--derived-mode-1 "t") +(define-derived-mode subr-tests--mode-B subr-tests--mode-A "t") +(defalias 'subr-tests--mode-C #'subr-tests--mode-B) +(derived-mode-add-parents 'subr-tests--mode-A '(subr-tests--mode-C)) + +(ert-deftest subr-tests--derived-mode-add-parents () + ;; The Right Answer is somewhat unclear in the presence of cycles, + ;; but let's make sure we get tolerable answers. + ;; FIXME: Currently `prog-mode' doesn't always end up at the end :-( + (let ((set-equal (lambda (a b) + (not (or (cl-set-difference a b) + (cl-set-difference b a)))))) + (dolist (mode '(subr-tests--mode-A subr-tests--mode-B subr-tests--mode-C)) + (should (eq (derived-mode-all-parents mode) + (derived-mode-all-parents mode))) + (should (eq mode (car (derived-mode-all-parents mode)))) + (should (funcall set-equal + (derived-mode-all-parents mode) + '(subr-tests--mode-A subr-tests--mode-B prog-mode + subr-tests--mode-C subr-tests--derived-mode-1)))))) + +(ert-deftest subr-tests--merge-ordered-lists () + (should (equal (merge-ordered-lists + '((B A) (C A) (D B) (E D C)) + (lambda (_) (error "cycle"))) + '(E D B C A))) + (should (equal (merge-ordered-lists + '((E D C) (B A) (C A) (D B)) + (lambda (_) (error "cycle"))) + '(E D C B A))) + (should-error (merge-ordered-lists + '((E C D) (B A) (A C) (D B)) + (lambda (_) (error "cycle"))))) (ert-deftest number-sequence-test () (should (= (length @@ -579,7 +615,8 @@ (cons (mapcar (pcase-lambda (`(,evald ,func ,args ,_)) `(,evald ,func ,@args)) (backtrace-frames base)) - (subr-test--backtrace-frames-with-backtrace-frame base)))))) + (subr-test--backtrace-frames-with-backtrace-frame base)) + (sit-for 0))))) ; dummy unwind form (defun subr-test--frames-1 (base) (subr-test--frames-2 base)) @@ -1058,10 +1095,12 @@ final or penultimate step during initialization.")) '(subr-tests--b subr-tests--c))) (defalias 'subr-tests--d 'subr-tests--e) - (defalias 'subr-tests--e 'subr-tests--d) - (should-error (function-alias-p 'subr-tests--d)) - (should (equal (function-alias-p 'subr-tests--d t) - '(subr-tests--e)))) + (should (equal (function-alias-p 'subr-tests--d) + '(subr-tests--e))) + + (fset 'subr-tests--f 'subr-tests--a) + (should (equal (function-alias-p 'subr-tests--f) + '(subr-tests--a subr-tests--b subr-tests--c)))) (ert-deftest test-readablep () (should (readablep "foo")) @@ -1169,5 +1208,120 @@ final or penultimate step during initialization.")) (should-not (list-of-strings-p '("a" nil "b"))) (should-not (list-of-strings-p '("a" "b" . "c")))) +(ert-deftest subr--delete-dups () + (should (equal (delete-dups nil) nil)) + (let* ((a (list "a" "b" "c")) + (a-dedup (delete-dups a))) + (should (equal a-dedup '("a" "b" "c"))) + (should (eq a a-dedup))) + (let* ((a (list "a" "a" "b" "b" "a" "c" "b" "c" "a")) + (a-b (cddr a)) ; link of first "b" + (a-dedup (delete-dups a))) + (should (equal a-dedup '("a" "b" "c"))) + (should (eq a a-dedup)) + (should (eq (cdr a-dedup) a-b)))) + +(ert-deftest subr--delete-consecutive-dups () + (should (equal (delete-consecutive-dups nil) nil)) + (let* ((a (list "a" "b" "c")) + (a-dedup (delete-consecutive-dups a))) + (should (equal a-dedup '("a" "b" "c"))) + (should (eq a a-dedup))) + (let* ((a (list "a" "a" "b" "a" "a" "b" "b" "b" "c" "c" "a" "a")) + (a-b (nthcdr 3 a)) ; link of third "a" + (a-dedup (delete-consecutive-dups a))) + (should (equal a-dedup '("a" "b" "a" "b" "c" "a"))) + (should (eq a a-dedup)) + (should (equal (nthcdr 2 a-dedup) a-b))) + (let* ((a (list "a" "b" "a")) + (a-dedup (delete-consecutive-dups a t))) + (should (equal a-dedup '("a" "b"))) + (should (eq a a-dedup))) + (let* ((a (list "a" "a" "b" "a" "a" "b" "b" "b" "c" "c" "a" "a")) + (a-dedup (delete-consecutive-dups a t))) + (should (equal a-dedup '("a" "b" "a" "b" "c"))) + (should (eq a a-dedup)))) + +(ert-deftest subr--copy-tree () + ;; Check that values other than conses, vectors and records are + ;; neither copied nor traversed. + (let ((s (propertize "abc" 'prop (list 11 12))) + (h (make-hash-table :test #'equal))) + (puthash (list 1 2) (list 3 4) h) + (dolist (x (list nil 'a "abc" s h)) + (should (eq (copy-tree x) x)) + (should (eq (copy-tree x t) x)))) + + ;; Use the printer to detect common parts of Lisp values. + (let ((print-circle t)) + (cl-labels ((prn3 (x y z) (prin1-to-string (list x y z))) + (cat3 (x y z) (concat "(" x " " y " " z ")"))) + (let ((x '(a (b ((c) . d) e) (f)))) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "(a (b ((c) . d) e) (f))" + "(a (b ((c) . d) e) (f))" + "(a (b ((c) . d) e) (f))")))) + (let ((x '(a [b (c d)] #s(e (f [g]))))) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "(a #1=[b (c d)] #2=#s(e (f [g])))" + "(a #1# #2#)" + "(a [b (c d)] #s(e (f [g])))")))) + (let ((x [a (b #s(c d))])) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "#1=[a (b #s(c d))]" + "#1#" + "[a (b #s(c d))]")))) + (let ((x #s(a (b [c d])))) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "#1=#s(a (b [c d]))" + "#1#" + "#s(a (b [c d]))")))) + ;; Check cdr recursion. + (let ((x '(a b . [(c . #s(d))]))) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "(a b . #1=[(c . #s(d))])" + "(a b . #1#)" + "(a b . [(c . #s(d))])")))) + ;; Check that we can copy DAGs (the result is a tree). + (let ((x (list '(a b) nil [c d] nil #s(e f) nil))) + (setf (nth 1 x) (nth 0 x)) + (setf (nth 3 x) (nth 2 x)) + (setf (nth 5 x) (nth 4 x)) + (should (equal (prn3 x (copy-tree x) (copy-tree x t)) + (cat3 "(#1=(a b) #1# #2=[c d] #2# #3=#s(e f) #3#)" + "((a b) (a b) #2# #2# #3# #3#)" + "((a b) (a b) [c d] [c d] #s(e f) #s(e f))"))))))) + +(ert-deftest condition-case-unless-debug () + "Test `condition-case-unless-debug'." + (let ((debug-on-error nil)) + (with-suppressed-warnings ((suspicious condition-case)) + (should (= 0 (condition-case-unless-debug nil 0)))) + (should (= 0 (condition-case-unless-debug nil 0 (t 1)))) + (should (= 0 (condition-case-unless-debug x 0 (t (1+ x))))) + (should (= 1 (condition-case-unless-debug nil (error "") (t 1)))) + (should (equal (condition-case-unless-debug x (error "") (t x)) + '(error ""))))) + +(ert-deftest condition-case-unless-debug-success () + "Test `condition-case-unless-debug' with :success (bug#64404)." + (let ((debug-on-error nil)) + (should (= 1 (condition-case-unless-debug nil 0 (:success 1)))) + (should (= 1 (condition-case-unless-debug nil 0 (:success 1) (t 2)))) + (should (= 1 (condition-case-unless-debug nil 0 (t 2) (:success 1)))) + (should (= 1 (condition-case-unless-debug x 0 (:success (1+ x))))) + (should (= 1 (condition-case-unless-debug x 0 (:success (1+ x)) (t x)))) + (should (= 1 (condition-case-unless-debug x 0 (t x) (:success (1+ x))))) + (should (= 2 (condition-case-unless-debug nil (error "") + (:success 1) (t 2)))) + (should (= 2 (condition-case-unless-debug nil (error "") + (t 2) (:success 1)))) + (should (equal (condition-case-unless-debug x (error "") + (:success (1+ x)) (t x)) + '(error ""))) + (should (equal (condition-case-unless-debug x (error "") + (t x) (:success (1+ x))) + '(error ""))))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index ee2bb6574ae..911d03d5628 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -110,7 +110,7 @@ (buffer-substring (point-min) (point-max)))))) (ert-deftest term-simple-lines () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let ((str "\ first line\r next line\r\n")) @@ -118,14 +118,14 @@ next line\r\n")) (string-replace "\r" "" str))))) (ert-deftest term-carriage-return () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let ((str "\ first line\r_next line\r\n")) (should (equal (term-test-screen-from-input 40 12 str) "_next line\n")))) (ert-deftest term-line-wrap () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (should (string-match-p ;; Don't be strict about trailing whitespace. "\\`a\\{40\\}\na\\{20\\} *\\'" @@ -137,7 +137,7 @@ first line\r_next line\r\n")) (list str str)))))) (ert-deftest term-colors () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (pcase-dolist (`(,str ,expected) ansi-test-strings) (let ((result (term-test-screen-from-input 40 12 str))) (should (equal result expected)) @@ -145,7 +145,7 @@ first line\r_next line\r\n")) (text-properties-at 0 expected)))))) (ert-deftest term-colors-bold-is-bright () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let ((ansi-color-bold-is-bright t)) (pcase-dolist (`(,str ,expected ,bright-expected) ansi-test-strings) (let ((expected (or bright-expected expected)) @@ -155,7 +155,7 @@ first line\r_next line\r\n")) (text-properties-at 0 expected))))))) (ert-deftest term-cursor-movement () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) ;; Absolute positioning. (should (equal "ab\ncd" (term-test-screen-from-input @@ -186,7 +186,7 @@ first line\r_next line\r\n")) "\e[D\e[Da"))))) (ert-deftest term-scrolling-region () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (should (equal "\ line3 line4 @@ -338,7 +338,7 @@ line6\r line7"))))) (ert-deftest term-set-directory () - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let ((term-ansi-at-user (user-real-login-name))) (should (equal (term-test-screen-from-input 40 12 "\eAnSiTc /foo/\n" 'default-directory) @@ -354,7 +354,7 @@ A real-life example is the default zsh prompt which writes spaces to the end of line (triggering line-wrapping state), and then sends a carriage return followed by another space to overwrite the first character of the line." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let* ((width 10) (strs (list "x" (make-string (1- width) ?_) "\r_"))) @@ -364,7 +364,7 @@ the first character of the line." (ert-deftest term-to-margin () "Test cursor movement at the scroll margin. This is a reduced example from GNU nano's initial screen." - (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (skip-when (memq system-type '(windows-nt ms-dos))) (let* ((width 10) (x (make-string width ?x)) (y (make-string width ?y))) diff --git a/test/lisp/textmodes/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el index 5e21d2cfacb..677a6d35d66 100644 --- a/test/lisp/textmodes/conf-mode-tests.el +++ b/test/lisp/textmodes/conf-mode-tests.el @@ -93,12 +93,13 @@ x.2.y.1.z.2.zz =") (should (equal (face-at-point) 'font-lock-variable-name-face)) (search-forward "val") (should-not (face-at-point))) - (while (re-search-forward "a-z" nil t) + (while (re-search-forward "[xyz]" nil t) (backward-char) (should (equal (face-at-point) 'font-lock-variable-name-face)) - (re-search-forward "[0-0]" nil t) - (backward-char) - (should (equal (face-at-point) 'font-lock-constant-face))))) + (forward-char) + (when (re-search-forward "[0-9]" nil t) + (backward-char) + (should (equal (face-at-point) 'font-lock-constant-face)))))) (ert-deftest conf-test-space-mode () ;; From `conf-space-mode' docstring. @@ -157,7 +158,6 @@ image/tiff tiff tif (should-not (face-at-point)))) (ert-deftest conf-test-toml-mode () - ;; From `conf-toml-mode' docstring. (with-temp-buffer (insert "[entry] value = \"some string\"") @@ -173,6 +173,22 @@ value = \"some string\"") (search-forward "som") (should (equal (face-at-point) 'font-lock-string-face)))) +(ert-deftest conf-test-toml-mode/boolean () + ;; https://toml.io/en/v1.0.0#boolean + (with-temp-buffer + (insert "[entry] +a = true +b = True") + (goto-char (point-min)) + (conf-toml-mode) + (font-lock-mode) + (font-lock-ensure) + (search-forward "tru") + (should (equal (face-at-point) 'font-lock-keyword-face)) + ;; Do not fontify upper-case "True". + (search-forward "Tru") + (should (equal (face-at-point) nil)))) + (ert-deftest conf-test-desktop-mode () ;; From `conf-desktop-mode' dostring. (with-temp-buffer diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el index ef822ba805b..4ad31481054 100644 --- a/test/lisp/textmodes/fill-tests.el +++ b/test/lisp/textmodes/fill-tests.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2017-2023 Free Software Foundation, Inc. ;; Author: Marcin Borkowski <mbork@mbork.pl> -;; Keywords: text, wp +;; Keywords: text ;; This file is part of GNU Emacs. diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index 5a137ba8a67..6aa12bc3b58 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -294,7 +294,8 @@ And this should be % \\cite{ignored}. (find-file tex-file) (setq keys (reftex-all-used-citation-keys)) (should (equal (sort keys #'string<) - (sort '(;; Standard commands: + (sort (list + ;; Standard commands: "cite:2022" "Cite:2022" "parencite:2022" "Parencite:2022" "footcite:2022" "footcitetext:2022" diff --git a/test/lisp/textmodes/tildify-tests.el b/test/lisp/textmodes/tildify-tests.el index 962aeb4747c..695dac008e9 100644 --- a/test/lisp/textmodes/tildify-tests.el +++ b/test/lisp/textmodes/tildify-tests.el @@ -4,7 +4,7 @@ ;; Author: Michal Nazarewicz <mina86@mina86.com> ;; Version: 4.5 -;; Keywords: text, TeX, SGML, wp +;; Keywords: text, TeX, SGML ;; This file is part of GNU Emacs. diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 0daf27f32ec..98ebf771717 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -72,7 +72,38 @@ ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/") ;; UUID, only hex is allowed ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789") - ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)) + ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil) + ;; email addresses + ("foo@example.com" 1 email "foo@example.com") + ("f@example.com" 1 email "f@example.com") + ("foo@example.com" 4 email "foo@example.com") + ("foo@example.com" 5 email "foo@example.com") + ("foo@example.com" 15 email "foo@example.com") + ("foo@example.com" 16 email "foo@example.com") + ("<foo@example.com>" 1 email "<foo@example.com>") + ("<foo@example.com>" 4 email "<foo@example.com>") + ("<foo@example.com>" 5 email "<foo@example.com>") + ("<foo@example.com>" 16 email "<foo@example.com>") + ("<foo@example.com>" 17 email "<foo@example.com>") + ;; email addresses containing numbers + ("foo1@example.com" 1 email "foo1@example.com") + ("1foo@example.com" 1 email "1foo@example.com") + ("11@example.com" 1 email "11@example.com") + ("1@example.com" 1 email "1@example.com") + ;; email addresses user portion containing dots + ("foo.bar@example.com" 1 email "foo.bar@example.com") + (".foobar@example.com" 1 email nil) + (".foobar@example.com" 2 email "foobar@example.com") + ;; email addresses domain portion containing dots and dashes + ("foobar@.example.com" 1 email nil) + ("foobar@-example.com" 1 email "foobar@-example.com") + ;; These are illegal, but thingatpt doesn't yet handle them + ;; ("foo..bar@example.com" 1 email nil) + ;; ("foobar@.example.com" 1 email nil) + ;; ("foobar@example..com" 1 email nil) + ;; ("foobar.@example.com" 1 email nil) + + ) "List of `thing-at-point' tests. Each list element should have the form diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el index 4ba7b99719c..5d684a96a18 100644 --- a/test/lisp/thread-tests.el +++ b/test/lisp/thread-tests.el @@ -88,7 +88,7 @@ (ert-deftest thread-tests-list-threads-error-when-not-configured () "Signal an error running `list-threads' if threads are not configured." - (skip-unless (not (featurep 'threads))) + (skip-when (featurep 'threads)) (should-error (list-threads))) (provide 'thread-tests) diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 341c40b617b..c1036f636e5 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -89,12 +89,12 @@ (iter-defun time-stamp-test-pattern-sequential () "Iterate through each possibility for a part of `time-stamp-pattern'." (let ((pattern-value-parts - '(("4/" "10/" "-9/" "0/" "") ;0: line limit - ("stamp<" "") ;1: start - ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%" "") ;2: format part 1 - (" " "x" ":" "\n" "") ;3: format part 2 - ("%-d" "%_H" "%^a" "%#Z" "%:A" "%09z" "%%") ;4: format part 3 - (">end" "")))) ;5: end + '(("4/" "10/" "-9/" "0/" "") ;0: line limit + ("stamp:" "") ;1: start + ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%" "") ;2: format part 1 + (" " "x" ":" "\n" "") ;3: format part 2 + ("%-d" "%_H" "%^a" "%#Z" "%:A" "%019z" "%%") ;4: format part 3 + ("end" "")))) ;5: end (dotimes (cur (length pattern-value-parts)) (dotimes (cur-index (length (nth cur pattern-value-parts))) (cl-flet ((extract-part @@ -118,15 +118,21 @@ (iter-defun time-stamp-test-pattern-multiply () "Iterate through every combination of parts of `time-stamp-pattern'." (let ((line-limit-values '("" "4/")) - (start-values '("" "/stamp/")) - (format-values '("%%" "%m")) + (start-values '("" "/stamp1/")) + (format-values '("" "%%" "%m")) (end-values '("" ">end"))) ;; yield all combinations of the above (dolist (line-limit line-limit-values) (dolist (start start-values) (dolist (format format-values) (dolist (end end-values) - (iter-yield (list line-limit start format end)))))))) + ;; If the format is not supplied, the end cannot be either, + ;; so not all generated combinations are valid. + ;; (This is why the format can be supplied as "%%" to + ;; preserve the default format.) + (if (or (not (equal format "")) + (equal end "")) + (iter-yield (list line-limit start format end))))))))) (iter-defun time-stamp-test-pattern-all () (iter-yield-from (time-stamp-test-pattern-sequential)) @@ -156,7 +162,8 @@ (if (equal start1 "") (should (equal ts-start time-stamp-start)) (should (equal ts-start start1))) - (if (equal whole-format "%%") + (if (or (equal whole-format "") + (equal whole-format "%%")) (should (equal ts-format time-stamp-format)) (should (equal ts-format whole-format))) (if (equal end1 "") @@ -165,7 +172,8 @@ ;; return nil to stop time-stamp from calling us again nil))) (let ((time-stamp-pattern (concat - line-limit1 start1 whole-format end1))) + line-limit1 start1 whole-format end1)) + (case-fold-search nil)) (with-temp-buffer ;; prep the buffer with more than the ;; largest line-limit1 number of lines @@ -758,12 +766,14 @@ and is called by some low-level `time-stamp' \"%z\" unit tests." (defun fz-make+zone (h &optional m s) "Creates a non-negative offset." + (declare (pure t)) (let ((m (or m 0)) (s (or s 0))) (+ (* 3600 h) (* 60 m) s))) (defun fz-make-zone (h &optional m s) "Creates a negative offset. The arguments are all non-negative." + (declare (pure t)) (- (fz-make+zone h m s))) (defmacro formatz-should-equal (zone expect) diff --git a/test/lisp/uniquify-tests.el b/test/lisp/uniquify-tests.el new file mode 100644 index 00000000000..38510c3bd77 --- /dev/null +++ b/test/lisp/uniquify-tests.el @@ -0,0 +1,150 @@ +;;; uniquify-tests.el --- Tests for uniquify -*- lexical-binding: t; -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Spencer Baugh <sbaugh@janestreet.com> + +;; This program 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. + +;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(ert-deftest uniquify-basic () + (let (bufs old-names) + (cl-flet ((names-are (current-names &optional nosave) + (should (equal (mapcar #'buffer-name bufs) current-names)) + (unless nosave (push current-names old-names)))) + (should (eq (get-buffer "z") nil)) + (push (find-file-noselect "a/b/z") bufs) + (names-are '("z")) + (push (find-file-noselect "a/b/c/z") bufs) + (names-are '("z<c>" "z<b>")) + (push (find-file-noselect "a/b/d/z") bufs) + (names-are '("z<d>" "z<c>" "z<b>")) + (push (find-file-noselect "e/b/z") bufs) + (names-are '("z<e/b>" "z<d>" "z<c>" "z<a/b>")) + ;; buffers without a buffer-file-name don't get uniquified by uniquify + (push (generate-new-buffer "z") bufs) + (names-are '("z" "z<e/b>" "z<d>" "z<c>" "z<a/b>")) + ;; but they do get uniquified by the C code which uses <n> + (push (generate-new-buffer "z") bufs) + (names-are '("z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>")) + (save-excursion + ;; uniquify will happily work with file-visiting buffers whose names don't match buffer-file-name + (find-file "f/y") + (push (current-buffer) bufs) + (rename-buffer "z" t) + (names-are '("z<f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave) + ;; somewhat confusing behavior results if a buffer is renamed to match an already-uniquified buffer + (rename-buffer "z<a/b>" t) + (names-are '("z<a/b><f>" "z<2>" "z" "z<e/b>" "z<d>" "z<c>" "z<a/b>") 'nosave)) + (while bufs + (kill-buffer (pop bufs)) + (names-are (pop old-names) 'nosave))))) + +(ert-deftest uniquify-dirs () + "Check strip-common-suffix and trailing-separator-p work together; bug#47132" + (ert-with-temp-directory root + (let ((a-path (file-name-concat root "a/x/y/dir")) + (b-path (file-name-concat root "b/x/y/dir"))) + (make-directory a-path 'parents) + (make-directory b-path 'parents) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix t) + (uniquify-trailing-separator-p nil)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/dir" "b/dir"))) + (mapc #'kill-buffer bufs))) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix nil) + (uniquify-trailing-separator-p t)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/x/y/dir/" "b/x/y/dir/"))) + (mapc #'kill-buffer bufs))) + (let ((uniquify-buffer-name-style 'forward) + (uniquify-strip-common-suffix t) + (uniquify-trailing-separator-p t)) + (let ((bufs (list (find-file-noselect a-path) + (find-file-noselect b-path)))) + (should (equal (mapcar #'buffer-name bufs) + '("a/dir/" "b/dir/"))) + (mapc #'kill-buffer bufs)))))) + +(ert-deftest uniquify-rename-to-dir () + "Giving a buffer a name which matches a directory doesn't rename the buffer" + (let ((uniquify-buffer-name-style 'forward) + (uniquify-trailing-separator-p t)) + (save-excursion + (find-file "../README") + (rename-buffer "lisp" t) + (should (equal (buffer-name) "lisp")) + (kill-buffer)))) + +(ert-deftest uniquify-separator-style-reverse () + (let ((uniquify-buffer-name-style 'reverse) + (uniquify-trailing-separator-p t)) + (save-excursion + (should (file-directory-p "../lib-src")) + (find-file "../lib-src") + (should (equal (buffer-name) "\\lib-src")) + (kill-buffer)))) + +(ert-deftest uniquify-separator-ignored () + "If uniquify-buffer-name-style isn't forward or reverse, +uniquify-trailing-separator-p is ignored" + (let ((uniquify-buffer-name-style 'post-forward-angle-brackets) + (uniquify-trailing-separator-p t)) + (save-excursion + (should (file-directory-p "../lib-src")) + (find-file "../lib-src") + (should (equal (buffer-name) "lib-src")) + (kill-buffer)))) + +(ert-deftest uniquify-space-prefix () + "If a buffer starts with a space, | is added at the start" + (save-excursion + (find-file " foo") + (should (equal (buffer-name) "| foo")) + (kill-buffer))) + +(require 'project) +(ert-deftest uniquify-project-transform () + "`project-uniquify-dirname-transform' works" + (let ((uniquify-dirname-transform #'project-uniquify-dirname-transform) + (project-vc-name "foo1/bar") + bufs) + (save-excursion + (let ((default-directory (expand-file-name "test/" source-directory))) + (should (file-exists-p "../README")) + (push (find-file-noselect "../README") bufs) + (push (find-file-noselect "other/README") bufs) + (should (equal (mapcar #'buffer-name bufs) + '("README<other>" "README<bar>"))) + (push (find-file-noselect "foo2/bar/README") bufs) + (should (equal (mapcar #'buffer-name bufs) + '("README<foo2/bar>" "README<other>" + "README<foo1/bar>"))) + (while bufs + (kill-buffer (pop bufs))))))) + +(provide 'uniquify-tests) +;;; uniquify-tests.el ends here diff --git a/test/lisp/url/url-domsuf-tests.el b/test/lisp/url/url-domsuf-tests.el index 09fd6240065..8dbf65dae44 100644 --- a/test/lisp/url/url-domsuf-tests.el +++ b/test/lisp/url/url-domsuf-tests.el @@ -24,6 +24,10 @@ (require 'url-domsuf) (require 'ert) +(ert-deftest url-domsuf--public-suffix-file () + ;; We should always have a file, since it ships with Emacs. + (should (file-readable-p (url-domsuf--public-suffix-file)))) + (defun url-domsuf-tests--run () (should-not (url-domsuf-cookie-allowed-p "com")) (should (url-domsuf-cookie-allowed-p "foo.bar.bd")) diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el index 651bd690811..392e949465c 100644 --- a/test/lisp/url/url-expand-tests.el +++ b/test/lisp/url/url-expand-tests.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2012-2023 Free Software Foundation, Inc. ;; Author: Alain Schneble <a.s@realize.ch> -;; Version: 1.0 ;; This file is part of GNU Emacs. diff --git a/test/lisp/url/url-future-tests.el b/test/lisp/url/url-future-tests.el index 5c5802ef3e4..18e6e31c8ce 100644 --- a/test/lisp/url/url-future-tests.el +++ b/test/lisp/url/url-future-tests.el @@ -52,7 +52,7 @@ (should (equal (url-future-cancel tocancel) tocancel)) (should-error (url-future-call tocancel)) (should (null url-future-tests--saver)) - (should (url-future-cancelled-p tocancel)))) + (should (url-future-canceled-p tocancel)))) (provide 'url-future-tests) diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el index cf75738d00a..eb6df17daeb 100644 --- a/test/lisp/url/url-parse-tests.el +++ b/test/lisp/url/url-parse-tests.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2012-2023 Free Software Foundation, Inc. ;; Author: Alain Schneble <a.s@realize.ch> -;; Version: 1.0 ;; This file is part of GNU Emacs. diff --git a/test/lisp/use-package/use-package-tests.el b/test/lisp/use-package/use-package-tests.el index 6374a0d1037..9181a8171a7 100644 --- a/test/lisp/use-package/use-package-tests.el +++ b/test/lisp/use-package/use-package-tests.el @@ -1951,6 +1951,71 @@ (should (eq (nth 1 binding) 'ignore)) (should (eq (nth 2 binding) nil)))) +(ert-deftest use-package-test/:vc-1 () + (match-expansion + (use-package foo :vc (:url "bar")) + '(progn (use-package-vc-install '(foo (:url "bar") :last-release) nil) + (require 'foo nil nil)))) + +(ert-deftest use-package-test/:vc-2 () + (match-expansion + (use-package foo + :vc (baz . (:url "baz" :vc-backend "Git" + :main-file qux.el :rev "rev-string"))) + '(progn (use-package-vc-install '(baz + (:url "baz" :vc-backend Git :main-file "qux.el") + "rev-string") + nil) + (require 'foo nil nil)))) + +(ert-deftest use-package-test/:vc-3 () + (match-expansion + (use-package foo :vc (bar . "baz")) + '(progn (use-package-vc-install '(bar "baz") nil) + (require 'foo nil nil)))) + +(ert-deftest use-package-test/:vc-4 () + (match-expansion + (use-package foo :vc (bar . (:url "baz" :rev :newest))) + '(progn (use-package-vc-install '(bar (:url "baz") nil) nil) + (require 'foo nil nil)))) + +(ert-deftest use-package-test/:vc-5 () + (let ((load-path? '(pred (apply-partially + #'string= + (expand-file-name "bar" user-emacs-directory))))) + (match-expansion + (use-package foo :vc other-name :load-path "bar") + `(progn (eval-and-compile + (add-to-list 'load-path ,load-path?)) + (use-package-vc-install '(other-name) ,load-path?) + (require 'foo nil nil))))) + +(ert-deftest use-package-test-handler/:vc-6 () + (let ((byte-compile-current-file "use-package-core.el") + tried-to-install) + (cl-letf (((symbol-function #'use-package-vc-install) + (lambda (arg &optional local-path) + (setq tried-to-install arg)))) + (should (equal + (use-package-handler/:vc 'foo nil 'some-pkg '(:init (foo)) nil) + '(foo))) + (should (eq tried-to-install 'some-pkg))))) + +(ert-deftest use-package-test-normalize/:vc () + (should (equal '(foo "version-string") + (use-package-normalize/:vc 'foo :vc '("version-string")))) + (should (equal '(bar "version-string") + (use-package-normalize/:vc 'foo :vc '((bar . "version-string"))))) + (should (equal '(foo (:url "bar") "baz") + (use-package-normalize/:vc 'foo :vc '((:url "bar" :rev "baz"))))) + (should (equal '(foo) + (use-package-normalize/:vc 'foo :vc '(t)))) + (should (equal '(foo) + (use-package-normalize/:vc 'foo :vc nil))) + (should (equal '(bar) + (use-package-normalize/:vc 'foo :vc '(bar))))) + ;; Local Variables: ;; no-byte-compile: t ;; no-update-autoloads: t diff --git a/test/lisp/vc/vc-cvs-tests.el b/test/lisp/vc/vc-cvs-tests.el new file mode 100644 index 00000000000..473ac69e24c --- /dev/null +++ b/test/lisp/vc/vc-cvs-tests.el @@ -0,0 +1,107 @@ +;;; vc-cvs-tests.el --- tests for vc/vc-cvs.el -*- lexical-binding:t -*- + +;; Copyright (C) 2023 Free Software Foundation, Inc. + +;; Author: Olivier Certner <olce.emacs@certner.fr> +;; Maintainer: emacs-devel@gnu.org + +;; 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: + +;;; Code: + +(require 'vc-cvs) + +(ert-deftest vc-cvs-test-parse-root--local-no-method () + (vc-cvs-test--check-parse-root + "/home/joe/repo" + '("local" nil nil "/home/joe/repo"))) + +(ert-deftest vc-cvs-test-parse-root--local-windows-drive-letter () + (vc-cvs-test--check-parse-root + ":local:c:/users/joe/repo" + '("local" nil nil "c:/users/joe/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-host-no-port-colon () + (vc-cvs-test--check-parse-root + "host/home/serv/repo" + '("ext" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-host-no-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:host/home/serv/repo" + '("pserver" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-host-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:host:/home/serv/repo" + '("pserver" nil "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-no-port-colon () + (vc-cvs-test--check-parse-root + "usr@host/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--ext-no-method-user-host-port-colon () + (vc-cvs-test--check-parse-root + "usr@host:/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-no-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port-colon () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host:/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +(ert-deftest vc-cvs-test-parse-root--pserver-user-password-host-port () + (vc-cvs-test--check-parse-root + ":pserver:usr:passwd@host:28/home/serv/repo" + '("pserver" "usr" "host" "/home/serv/repo"))) + +;; Next 3 tests are just to err on the side of caution. It doesn't +;; seem that CVS 1.12 can ever produce such lines. + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-no-port-colon + () + (vc-cvs-test--check-parse-root + "usr:passwd@host/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-port-colon + () + (vc-cvs-test--check-parse-root + "usr:passwd@host:/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + +(ert-deftest + vc-cvs-test-parse-root--ext-no-method-user-password-host-port + () + (vc-cvs-test--check-parse-root + "usr:passwd@host:28/home/serv/repo" + '("ext" "usr" "host" "/home/serv/repo"))) + + +(defun vc-cvs-test--check-parse-root (input expected-output) + (should (equal (vc-cvs-parse-root input) expected-output))) + +;;; vc-cvs-tests.el ends here diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el index f12c5d3434b..b331b77cf01 100644 --- a/test/lisp/vc/vc-git-tests.el +++ b/test/lisp/vc/vc-git-tests.el @@ -64,4 +64,21 @@ (actual-output (vc-git--program-version))) (should (equal actual-output expected-output)))) +(ert-deftest vc-git-test-annotate-time () + "Test `vc-git-annotate-time'." + (require 'vc-annotate) + (with-temp-buffer + (insert "\ +00000000 (Foo Bar 2023-06-14 1) a +00000001 (Foo Bar 2023-06-14 00:00:00 -0130 2) b +00000002 (Foo Bar 2023-06-14 00:00:00 +0145 3) c +00000003 (Foo Bar 2023-06-14 00:00:00 4) d +00000004 (Foo Bar 0-0-0 5) \n") + (goto-char (point-min)) + (should (floatp (vc-git-annotate-time))) + (should (> (vc-git-annotate-time) + (vc-git-annotate-time))) + (should-not (vc-git-annotate-time)) + (should-not (vc-git-annotate-time)))) + ;;; vc-git-tests.el ends here diff --git a/test/lisp/vc/vc-hg-tests.el b/test/lisp/vc/vc-hg-tests.el index 89d518b2a91..43bb922d567 100644 --- a/test/lisp/vc/vc-hg-tests.el +++ b/test/lisp/vc/vc-hg-tests.el @@ -53,6 +53,8 @@ (ert-deftest vc-hg-annotate-time () (with-temp-buffer (save-excursion (insert "philringnalda 218075 2014-11-28 CLOBBER:")) - (should (floatp (vc-hg-annotate-time))))) + (should (equal (vc-hg-annotate-time) + (vc-annotate-convert-time + (encode-time 0 0 0 28 11 2014)))))) ;;; vc-hg-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 0a26e25e32a..f40cee8cc5b 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -781,7 +781,7 @@ This checks also `vc-backend' and `vc-responsible-backend'." ;; CVS calls vc-delete-file, which insists on prompting ;; "Really want to delete ...?", and `vc-mtn.el' does not implement ;; `delete-file' at all. - (skip-unless (not (memq ',backend '(CVS Mtn)))) + (skip-when (memq ',backend '(CVS Mtn))) (vc-test--rename-file ',backend)) (ert-deftest @@ -796,7 +796,7 @@ This checks also `vc-backend' and `vc-responsible-backend'." (format "vc-test-%s01-register" backend-string)))))) ;; `vc-mtn.el' gives me: ;; "Failed (status 1): mtn commit -m Testing vc-version-diff\n\n foo" - (skip-unless (not (memq ',backend '(Mtn)))) + (skip-when (memq ',backend '(Mtn))) (vc-test--version-diff ',backend)) )))) diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 7b76ac87129..f059104cdb9 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -57,6 +57,24 @@ buffer's content." (whitespace-cleanup) (buffer-string))) +(ert-deftest whitespace-tests--global () + (let ((backup global-whitespace-mode) + (noninteractive nil) + (whitespace-enable-predicate (lambda () t))) + (unwind-protect + (progn + (global-whitespace-mode 1) + (ert-with-test-buffer-selected () + (normal-mode) + (should whitespace-mode) + (global-whitespace-mode -1) + (should (null whitespace-mode)) + (whitespace-mode 1) + (should whitespace-mode) + (global-whitespace-mode 1) + (should whitespace-mode))) + (global-whitespace-mode (if backup 1 -1))))) + (ert-deftest whitespace-cleanup-eob () (let ((whitespace-style '(empty))) (should (equal (whitespace-tests--cleanup-string "a\n") diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index b379c7c91a8..66bff4ad2e3 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -349,4 +349,46 @@ return nil, even with a non-nil bubblep argument." (should-not (widget-apply widget :match "someundefinedcolorihope")) (should-not (widget-apply widget :match "#11223")))) +(ert-deftest widget-test-alist-default-value-1 () + "Test getting the default value for an alist widget with options." + (with-temp-buffer + (let ((w (widget-create '(alist :key-type string + :value-type integer + :options (("0" (integer))))))) + (should (equal '(("0" . 0)) (widget-default-get w)))))) + +(ert-deftest widget-test-alist-default-value-2 () + "Test getting the default value for an alist widget without :value." + (with-temp-buffer + (let ((w (widget-create '(alist :key-type string + :value-type integer)))) + (should-not (widget-default-get w))))) + +(ert-deftest widget-test-alist-default-value-3 () + "Test getting the default value for an alist widget with nil :value." + (with-temp-buffer + (let ((w (widget-create '(alist :key-type string + :value-type integer + :value nil)))) + (should-not (widget-default-get w))))) + +(ert-deftest widget-test-alist-default-value-4 () + "Test getting the default value for an alist widget with non-nil :value." + (with-temp-buffer + (let ((w (widget-create '(alist :key-type string + :value-type integer + :value (("1" . 1) ("2" . 2)))))) + (should (equal '(("1" . 1) ("2" . 2)) (widget-default-get w)))))) + +(ert-deftest widget-test-restricted-sexp-empty-val () + "Test that we handle an empty restricted-sexp widget just fine." + (with-temp-buffer + (let ((w (widget-create '(restricted-sexp + :value 3 + :match-alternatives (integerp))))) + (widget-setup) + (widget-backward 1) + (delete-char 1) + (should (string= (widget-value w) ""))))) + ;;; wid-edit-tests.el ends here |