diff options
Diffstat (limited to 'test/lisp')
480 files changed, 17599 insertions, 3094 deletions
diff --git a/test/lisp/allout-tests.el b/test/lisp/allout-tests.el new file mode 100644 index 00000000000..f7cd6db9cd4 --- /dev/null +++ b/test/lisp/allout-tests.el @@ -0,0 +1,148 @@ +;;; allout-tests.el --- Tests for allout.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'allout) + +(require 'cl-lib) + +(defun allout-tests-obliterate-variable (name) + "Completely unbind variable with NAME." + (if (local-variable-p name (current-buffer)) (kill-local-variable name)) + (while (boundp name) (makunbound name))) + +(defvar allout-tests-globally-unbound nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-globally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") +(defvar allout-tests-locally-true nil + "Fodder for allout resumptions tests -- defvar just for byte compiler.") + +;; For each resumption case, we also test that the right local/global +;; scopes are affected during resumption effects. + +(ert-deftest allout-test-resumption-unbound-return-to-unbound () + "Previously unbound variables return to the unbound state." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-add-resumptions '(allout-tests-globally-unbound t)) + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (boundp 'allout-tests-globally-unbound)) + (should (equal allout-tests-globally-unbound t)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))))) + +(ert-deftest allout-test-resumption-variable-resumed () + "Ensure that variable with prior global value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-add-resumptions '(allout-tests-globally-true nil)) + (should (equal (default-value 'allout-tests-globally-true) t)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true nil)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)))) + +(ert-deftest allout-test-resumption-prior-value-resumed () + "Ensure that prior local value is resumed." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (cl-assert (not (default-boundp 'allout-tests-locally-true)) + nil (concat "Test setup mistake -- variable supposed to" + " not have global binding, but it does.")) + (cl-assert (local-variable-p 'allout-tests-locally-true (current-buffer)) + nil (concat "Test setup mistake -- variable supposed to have" + " local binding, but it lacks one.")) + (allout-add-resumptions '(allout-tests-locally-true nil)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true nil)) + (allout-do-resumptions) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-multiple-holds () + "Ensure that last of multiple resumptions holds, for various scopes." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-add-resumptions '(allout-tests-globally-unbound 2) + '(allout-tests-globally-true 3) + '(allout-tests-locally-true 4)) + ;; reestablish many of the basic conditions are maintained after re-add: + (should (not (default-boundp 'allout-tests-globally-unbound))) + (should (local-variable-p 'allout-tests-globally-unbound (current-buffer))) + (should (equal allout-tests-globally-unbound 2)) + (should (default-boundp 'allout-tests-globally-true)) + (should (local-variable-p 'allout-tests-globally-true (current-buffer))) + (should (equal allout-tests-globally-true 3)) + (should (not (default-boundp 'allout-tests-locally-true))) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true 4)) + (allout-do-resumptions) + (should (not (local-variable-p 'allout-tests-globally-unbound + (current-buffer)))) + (should (not (boundp 'allout-tests-globally-unbound))) + (should (not (local-variable-p 'allout-tests-globally-true + (current-buffer)))) + (should (boundp 'allout-tests-globally-true)) + (should (equal allout-tests-globally-true t)) + (should (boundp 'allout-tests-locally-true)) + (should (local-variable-p 'allout-tests-locally-true (current-buffer))) + (should (equal allout-tests-locally-true t)) + (should (not (default-boundp 'allout-tests-locally-true))))) + +(ert-deftest allout-test-resumption-unbinding () + "Ensure that deliberately unbinding registered variables doesn't foul things." + (with-temp-buffer + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (setq allout-tests-globally-true t) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (set (make-local-variable 'allout-tests-locally-true) t) + (allout-add-resumptions '(allout-tests-globally-unbound t) + '(allout-tests-globally-true nil) + '(allout-tests-locally-true nil)) + (allout-tests-obliterate-variable 'allout-tests-globally-unbound) + (allout-tests-obliterate-variable 'allout-tests-globally-true) + (allout-tests-obliterate-variable 'allout-tests-locally-true) + (allout-do-resumptions))) + +(provide 'allout-tests) +;;; allout-tests.el ends here diff --git a/test/lisp/allout-widgets-tests.el b/test/lisp/allout-widgets-tests.el new file mode 100644 index 00000000000..2b1bcaa6de3 --- /dev/null +++ b/test/lisp/allout-widgets-tests.el @@ -0,0 +1,87 @@ +;;; allout-widgets-tests.el --- Tests for allout-widgets.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'allout-widgets) + +(require 'cl-lib) + +(ert-deftest allout-test-range-overlaps () + "`allout-range-overlaps' unit tests." + (let* (ranges + got + (try (lambda (from to) + (setq got (allout-range-overlaps from to ranges)) + (setq ranges (cadr got)) + got))) +;; ;; biggie: +;; (setq ranges nil) +;; ;; ~ .02 to .1 seconds for just repeated listing args instead of funcall +;; ;; ~ 13 seconds for doing repeated funcall +;; (message "time-trial: %s, resulting size %s" +;; (time-trial +;; '(let ((size 10000) +;; doing) +;; (dotimes (count size) +;; (setq doing (random size)) +;; (funcall try doing (+ doing (random 5))) +;; ;;(list doing (+ doing (random 5))) +;; ))) +;; (length ranges)) +;; (sit-for 2) + + ;; fresh: + (setq ranges nil) + (should (equal (funcall try 3 5) '(nil ((3 5))))) + ;; add range at end: + (should (equal (funcall try 10 12) '(nil ((3 5) (10 12))))) + ;; add range at beginning: + (should (equal (funcall try 1 2) '(nil ((1 2) (3 5) (10 12))))) + ;; insert range somewhere in the middle: + (should (equal (funcall try 7 9) '(nil ((1 2) (3 5) (7 9) (10 12))))) + ;; consolidate some: + (should (equal (funcall try 5 8) '(t ((1 2) (3 9) (10 12))))) + ;; add more: + (should (equal (funcall try 15 17) '(nil ((1 2) (3 9) (10 12) (15 17))))) + ;; add more: + (should (equal (funcall try 20 22) + '(nil ((1 2) (3 9) (10 12) (15 17) (20 22))))) + ;; encompass more: + (should (equal (funcall try 4 11) '(t ((1 2) (3 12) (15 17) (20 22))))) + ;; encompass all: + (should (equal (funcall try 2 25) '(t ((1 25))))) + + ;; fresh slate: + (setq ranges nil) + (should (equal (funcall try 20 25) '(nil ((20 25))))) + (should (equal (funcall try 30 35) '(nil ((20 25) (30 35))))) + (should (equal (funcall try 26 28) '(nil ((20 25) (26 28) (30 35))))) + (should (equal (funcall try 15 20) '(t ((15 25) (26 28) (30 35))))) + (should (equal (funcall try 10 30) '(t ((10 35))))) + (should (equal (funcall try 5 6) '(nil ((5 6) (10 35))))) + (should (equal (funcall try 2 100) '(t ((2 100))))) + + (setq ranges nil))) + +(provide 'allout-widgets-tests) +;;; allout-widgets-tests.el ends here diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el new file mode 100644 index 00000000000..5c3da875f8c --- /dev/null +++ b/test/lisp/ansi-color-tests.el @@ -0,0 +1,49 @@ +;;; ansi-color-tests.el --- Test suite for ansi-color -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Pablo Barbáchano <pablob@amazon.com> +;; Keywords: ansi + +;; 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 'ansi-color) + +(defvar test-strings '(("\e[33mHello World\e[0m" . "Hello World") + ("\e[1m\e[3m\e[5mbold italics blink\e[0m" . "bold italics blink"))) + +(ert-deftest ansi-color-apply-on-region-test () + (dolist (pair test-strings) + (with-temp-buffer + (insert (car pair)) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (equal (buffer-string) (cdr pair))) + (should (not (equal (overlays-at (point-min)) nil)))))) + +(ert-deftest ansi-color-apply-on-region-preserving-test () + (dolist (pair test-strings) + (with-temp-buffer + (insert (car pair)) + (ansi-color-apply-on-region (point-min) (point-max) t) + (should (equal (buffer-string) (car pair)))))) + +(provide 'ansi-color-tests) + +;;; ansi-color-tests.el ends here diff --git a/test/lisp/apropos-tests.el b/test/lisp/apropos-tests.el new file mode 100644 index 00000000000..4c5522d14c2 --- /dev/null +++ b/test/lisp/apropos-tests.el @@ -0,0 +1,133 @@ +;;; apropos-tests.el --- Tests for apropos.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'apropos) +(require 'ert) + +(ert-deftest apropos-tests-words-to-regexp-1 () + (let ((re (apropos-words-to-regexp '("foo" "bar") "baz"))) + (should (string-match-p re "foobazbar")) + (should (string-match-p re "barbazfoo")) + (should-not (string-match-p re "foo-bar")) + (should-not (string-match-p re "foobazbazbar")))) + +(ert-deftest apropos-tests-words-to-regexp-2 () + (let ((re (apropos-words-to-regexp '("foo" "bar" "baz") "-"))) + (should-not (string-match-p re "foo")) + (should-not (string-match-p re "foobar")) + (should (string-match-p re "foo-bar")) + (should (string-match-p re "foo-baz")))) + +(ert-deftest apropos-tests-parse-pattern-1 () + (apropos-parse-pattern '("foo")) + (should (string-match-p apropos-regexp "foo")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "bar-foo")) + (should (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar"))) + +(ert-deftest apropos-tests-parse-pattern-2 () + (apropos-parse-pattern '("foo" "bar")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "bar-foo")) + (should-not (string-match-p apropos-regexp "foo")) + (should-not (string-match-p apropos-regexp "bar")) + (should-not (string-match-p apropos-regexp "baz")) + (should-not (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar-bar"))) + +(ert-deftest apropos-tests-parse-pattern-3 () + (apropos-parse-pattern '("foo" "bar" "baz")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "foo-baz")) + (should (string-match-p apropos-regexp "bar-foo")) + (should (string-match-p apropos-regexp "bar-baz")) + (should (string-match-p apropos-regexp "baz-foo")) + (should (string-match-p apropos-regexp "baz-bar")) + (should-not (string-match-p apropos-regexp "foo")) + (should-not (string-match-p apropos-regexp "bar")) + (should-not (string-match-p apropos-regexp "baz")) + (should-not (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar-bar")) + (should-not (string-match-p apropos-regexp "baz-baz"))) + +(ert-deftest apropos-tests-parse-pattern-single-regexp () + (apropos-parse-pattern "foo+bar") + (should-not (string-match-p apropos-regexp "fobar")) + (should (string-match-p apropos-regexp "foobar")) + (should (string-match-p apropos-regexp "fooobar"))) + +(ert-deftest apropos-tests-parse-pattern-synonyms () + (let ((apropos-synonyms '(("find" "open" "edit")))) + (apropos-parse-pattern '("open")) + (should (string-match-p apropos-regexp "find-file")) + (should (string-match-p apropos-regexp "open-file")) + (should (string-match-p apropos-regexp "edit-file")))) + +(ert-deftest apropos-tests-calc-scores () + (let ((str "Return apropos score for string STR.")) + (should (equal (apropos-calc-scores str '("apr")) '(7))) + (should (equal (apropos-calc-scores str '("apr" "str")) '(25 7))) + (should (equal (apropos-calc-scores str '("appr" "str")) '(25))) + (should-not (apropos-calc-scores str '("appr" "strr"))))) + +(ert-deftest apropos-tests-score-str () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-str "baz") + (apropos-score-str "foo baz") + (apropos-score-str "foo bar baz")))) + +(ert-deftest apropos-tests-score-doc () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-doc "baz") + (apropos-score-doc "foo baz") + (apropos-score-doc "foo bar baz")))) + +(ert-deftest apropos-tests-score-symbol () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-symbol 'baz) + (apropos-score-symbol 'foo-baz) + (apropos-score-symbol 'foo-bar-baz)))) + +(ert-deftest apropos-tests-true-hit () + (should-not (apropos-true-hit "foo" '("foo" "bar"))) + (should (apropos-true-hit "foo bar" '("foo" "bar"))) + (should (apropos-true-hit "foo bar baz" '("foo" "bar")))) + +(ert-deftest apropos-tests-format-plist () + (setplist 'foo '(a 1 b (2 3) c nil)) + (apropos-parse-pattern '("b")) + (should (equal (apropos-format-plist 'foo ", ") + "a 1, b (2 3), c nil")) + (should (equal (apropos-format-plist 'foo ", " t) + "b (2 3)")) + (apropos-parse-pattern '("d")) + (should-not (apropos-format-plist 'foo ", " t))) + +(provide 'apropos-tests) +;;; apropos-tests.el ends here diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index df658b98139..e92a4d28c6f 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -28,11 +28,11 @@ (let ((alist (list (cons 448 "-rwx------") (cons 420 "-rw-r--r--") (cons 292 "-r--r--r--") - (cons 512 "----------") + (cons 512 "---------T") (cons 1024 "------S---") ; Bug#28092 (cons 2048 "---S------")))) (dolist (x alist) - (should (equal (cdr x) (archive-int-to-mode (car x))))))) + (should (equal (cdr x) (file-modes-number-to-symbolic (car x))))))) (ert-deftest arc-mode-test-zip-extract-gz () (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract)))) diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 10ed9c39fbb..677abb33cc9 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -353,6 +353,10 @@ HOSTNAME, USER and PORT are passed unchanged to (auth-source-pass--with-store '(("bar.com:8080")) (should (auth-source-pass-match-entry-p "bar.com:8080" "bar.com" nil "8080")))) +(ert-deftest auth-source-pass--matching-entries-find-entries-with-a-port-when-passed-multiple-ports () + (auth-source-pass--with-store '(("bar.com:8080")) + (should (auth-source-pass-match-entry-p "bar.com:8080" "bar.com" nil '("http" "https" "80" "8080"))))) + (ert-deftest auth-source-pass--matching-entries-find-entries-with-slash () ;; match if entry filename matches user (auth-source-pass--with-store '(("foo.com/user")) diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 574763c4b3d..eafa9c6c02c 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -79,10 +79,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-before () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar"))) + (lambda () (insert "bar"))) (with-temp-buffer (text-mode) (auto-insert) @@ -90,10 +90,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-after () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar")) + (lambda () (insert "bar")) t) (with-temp-buffer (text-mode) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index f7c5580b111..9ebf137f87c 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -59,11 +61,11 @@ auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" auto-revert-stop-on-user-input nil file-notify-debug nil - tramp-verbose 0 - tramp-message-show-message nil) + tramp-verbose 0) -(defconst auto-revert--timeout (1+ auto-revert-interval) - "Time to wait for a message.") +(defun auto-revert--timeout () + "Time to wait for a message." + (+ auto-revert-interval 0.1)) (defvar auto-revert--messages nil "Used to collect messages issued during a section of a test.") @@ -126,14 +128,14 @@ This expects `auto-revert--messages' to be bound by ;; Remote files do not cooperate well with timers. So we count ourselves. (let ((ct (current-time))) (while (and (< (float-time (time-subtract (current-time) ct)) - auto-revert--timeout) + (auto-revert--timeout)) (null (string-match (format-message "Reverting buffer `%s'\\." (buffer-name buffer)) auto-revert--messages))) (if (with-current-buffer buffer auto-revert-use-notify) - (read-event nil nil 0.1) - (sleep-for 0.1))))) + (read-event nil nil 0.05) + (sleep-for 0.05))))) (defmacro auto-revert--deftest-remote (test docstring) "Define ert `TEST-remote' for remote files." @@ -153,50 +155,59 @@ This expects `auto-revert--messages' to be bound by (funcall (ert-test-body ert-test)) (error (message "%s" err) (signal (car err) (cdr err))))))) +(defmacro with-auto-revert-test (&rest body) + `(let ((auto-revert-interval-orig auto-revert-interval)) + (unwind-protect + (progn + (customize-set-variable 'auto-revert-interval 0.1) + ,@body) + (customize-set-variable 'auto-revert-interval auto-revert-interval-orig)))) + +(defun auto-revert-tests--write-file (text file time-delta &optional append) + (write-region text nil file append 'no-message) + (set-file-times file (time-subtract (current-time) time-delta))) + (ert-deftest auto-revert-test00-auto-revert-mode () "Check autorevert for a file." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let ((tmpfile (make-temp-file "auto-revert-test")) - buf) - (unwind-protect - (progn - (write-region "any text" nil tmpfile nil 'no-message) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (ert-with-message-capture auto-revert--messages - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (sleep-for 1) - (auto-revert-mode 1) - (should auto-revert-mode) - - ;; Modify file. We wait for a second, in order to have - ;; another timestamp. - (sleep-for 1) - (write-region "another text" nil tmpfile nil 'no-message) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf)) - (should (string-match "another text" (buffer-string))) - - ;; When the buffer is modified, it shall not be reverted. - (ert-with-message-capture auto-revert--messages - (set-buffer-modified-p t) - (sleep-for 1) - (write-region "any text" nil tmpfile nil 'no-message) - - ;; Check, that the buffer hasn't been reverted. - (auto-revert--wait-for-revert buf)) - (should-not (string-match "any text" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (with-auto-revert-test + (let ((tmpfile (make-temp-file "auto-revert-test")) + (times '(60 30 15)) + buf) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (ert-with-message-capture auto-revert--messages + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf)) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (ert-with-message-capture auto-revert--messages + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf)) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile)))))) (auto-revert--deftest-remote auto-revert-test00-auto-revert-mode "Check autorevert for a remote file.") @@ -204,66 +215,65 @@ This expects `auto-revert--messages' to be bound by ;; This is inspired by Bug#21841. (ert-deftest auto-revert-test01-auto-revert-several-files () "Check autorevert for several files at once." - :tags '(:expensive-test) (skip-unless (executable-find "cp" (file-remote-p temporary-file-directory))) - (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) - (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) - (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) - (tmpfile1 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (tmpfile2 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - buf1 buf2) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (write-region "any text" nil tmpfile1 nil 'no-message) - (setq buf1 (find-file-noselect tmpfile1)) - (write-region "any text" nil tmpfile2 nil 'no-message) - (setq buf2 (find-file-noselect tmpfile2)) - - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (sleep-for 1) - (auto-revert-mode 1) - (should auto-revert-mode))) - - ;; Modify files. We wait for a second, in order to have - ;; another timestamp. - (sleep-for 1) - (write-region - "another text" nil - (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) - nil 'no-message) - (write-region - "another text" nil - (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) - nil 'no-message) - ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) - ;; Strange, that `copy-directory' does not work as expected. - ;; The following shell command is not portable on all - ;; platforms, unfortunately. - (shell-command - (format "%s -f %s/* %s" - cp (file-local-name tmpdir2) (file-local-name tmpdir1))) - - ;; Check, that the buffers have been reverted. - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (auto-revert--wait-for-revert buf) - (should (string-match "another text" (buffer-string)))))) - - ;; Exit. - (ignore-errors - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-directory tmpdir1 'recursive)) - (ignore-errors (delete-directory tmpdir2 'recursive))))) + (with-auto-revert-test + (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) + (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) + (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) + (tmpfile1 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + (tmpfile2 + (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) + (times '(120 60 30 15)) + buf1 buf2) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) + (setq buf1 (find-file-noselect tmpfile1)) + (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + (pop times)) + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + (pop times)) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command + (format "%s -f %s/* %s" + cp (file-local-name tmpdir2) (file-local-name tmpdir1))) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (ignore-errors (delete-directory tmpdir1 'recursive)) + (ignore-errors (delete-directory tmpdir2 'recursive)))))) (auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files "Check autorevert for several remote files at once.") @@ -271,84 +281,81 @@ This expects `auto-revert--messages' to be bound by ;; This is inspired by Bug#23276. (ert-deftest auto-revert-test02-auto-revert-deleted-file () "Check autorevert for a deleted file." - :tags '(:expensive-test) ;; Repeated unpredictable failures, bug#32645. ;; Unlikely to be hydra-specific? ; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - (let ((tmpfile (make-temp-file "auto-revert-test")) - ;; Try to catch bug#32645. - (auto-revert-debug (getenv "EMACS_HYDRA_CI")) - (file-notify-debug (getenv "EMACS_HYDRA_CI")) - buf desc) - (unwind-protect - (progn - (write-region "any text" nil tmpfile nil 'no-message) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor)) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (sleep-for 1) - (auto-revert-mode 1) - (should auto-revert-mode) - (setq desc auto-revert-notify-watch-descriptor) - - ;; Remove file while reverting. We simulate this by - ;; modifying `before-revert-hook'. - (add-hook - 'before-revert-hook - (lambda () - (when auto-revert-debug - (message "%s deleted" buffer-file-name)) - (delete-file buffer-file-name)) - nil t) - - (ert-with-message-capture auto-revert--messages - (sleep-for 1) - (write-region "another text" nil tmpfile nil 'no-message) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer hasn't been reverted. File - ;; notification should be disabled, falling back to - ;; polling. - (should (string-match "any text" (buffer-string))) - ;; With w32notify, and on emba, the `stopped' events are not sent. - (or (eq file-notify--library 'w32notify) - (getenv "EMACS_EMBA_CI") - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor))) - - ;; Once the file has been recreated, the buffer shall be - ;; reverted. - (kill-local-variable 'before-revert-hook) - (ert-with-message-capture auto-revert--messages - (sleep-for 1) - (write-region "another text" nil tmpfile nil 'no-message) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-match "another text" (buffer-string))) - ;; When file notification is used, it must be reenabled - ;; after recreation of the file. We cannot expect that - ;; the descriptor is the same, so we just check the - ;; existence. - (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) - - ;; An empty file shall still be reverted. - (ert-with-message-capture auto-revert--messages - (sleep-for 1) - (write-region "" nil tmpfile nil 'no-message) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-equal "" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (with-auto-revert-test + (let ((tmpfile (make-temp-file "auto-revert-test")) + ;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) + (times '(120 60 30 15)) + buf desc) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () + (when auto-revert-debug + (message "%s deleted" buffer-file-name)) + (delete-file buffer-file-name)) + nil t) + + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (should (string-match "any text" (buffer-string))) + ;; With w32notify, and on emba, the `stopped' events are not sent. + (or (eq file-notify--library 'w32notify) + (getenv "EMACS_EMBA_CI") + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) + + ;; An empty file shall still be reverted. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile)))))) (auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file "Check autorevert for a deleted remote file.") @@ -358,26 +365,24 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (let ((tmpfile (make-temp-file "auto-revert-test")) + (times '(30 15)) buf) (unwind-protect (ert-with-message-capture auto-revert--messages - (write-region "any text" nil tmpfile nil 'no-message) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) (setq buf (find-file-noselect tmpfile)) (with-current-buffer buf ;; `buffer-stale--default-function' checks for ;; `verify-visited-file-modtime'. We must ensure that it ;; returns nil. - (sleep-for 1) (auto-revert-tail-mode 1) (should auto-revert-tail-mode) (erase-buffer) (insert "modified text\n") (set-buffer-modified-p nil) - ;; Modify file. We wait for a second, in order to have - ;; another timestamp. - (sleep-for 1) - (write-region "another text" nil tmpfile 'append 'no-message) + ;; Modify file. + (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) ;; Check, that the buffer has been reverted. (auto-revert--wait-for-revert buf) @@ -395,49 +400,47 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for dired." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let* ((tmpfile (make-temp-file "auto-revert-test")) - (name (file-name-nondirectory tmpfile)) - buf) - (unwind-protect - (progn - (setq buf (dired-noselect temporary-file-directory)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (sleep-for 1) - (auto-revert-mode 1) - (should auto-revert-mode) - (should - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Delete file. We wait for a second, in order to have - ;; another timestamp. - (sleep-for 1) - (delete-file tmpfile) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should-not - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Make dired buffer modified. Check, that the buffer has - ;; been still reverted. - (set-buffer-modified-p t) - (sleep-for 1) - (write-region "any text" nil tmpfile nil 'no-message) - - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should - (string-match name (substring-no-properties (buffer-string)))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (with-auto-revert-test + (let* ((tmpfile (make-temp-file "auto-revert-test")) + (name (file-name-nondirectory tmpfile)) + (times '(30)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Delete file. + (delete-file tmpfile) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmpfile)))))) (auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired "Check remote autorevert for dired.") @@ -466,117 +469,116 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test05-global-notify () "Test `global-auto-revert-mode' without polling." - :tags '(:expensive-test) (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) - (let* ((auto-revert-use-notify t) - (auto-revert-avoid-polling t) - (was-in-global-auto-revert-mode global-auto-revert-mode) - (file-1 (make-temp-file "global-auto-revert-test-1")) - (file-2 (make-temp-file "global-auto-revert-test-2")) - (file-3 (make-temp-file "global-auto-revert-test-3")) - (file-2b (concat file-2 "-b")) - require-final-newline buf-1 buf-2 buf-3) - (unwind-protect - (progn - (setq buf-1 (find-file-noselect file-1)) - (setq buf-2 (find-file-noselect file-2)) - (auto-revert-test--write-file "1-a" file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "")) - - (global-auto-revert-mode 1) ; Turn it on. - - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2)) - - ;; buf-1 should have been reverted immediately when the mode - ;; was enabled. - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - - ;; Alter a file. - (auto-revert-test--write-file "2-a" file-2) - ;; Allow for some time to handle notification events. - (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - - ;; Visit a file, and modify it on disk. - (setq buf-3 (find-file-noselect file-3)) - ;; Newly opened buffers won't be use notification until the - ;; first poll cycle; wait for it. - (auto-revert-test--wait-for - (lambda () (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - auto-revert--timeout) - (should (buffer-local-value + (with-auto-revert-test + (let* ((auto-revert-use-notify t) + (auto-revert-avoid-polling t) + (was-in-global-auto-revert-mode global-auto-revert-mode) + (file-1 (make-temp-file "global-auto-revert-test-1")) + (file-2 (make-temp-file "global-auto-revert-test-2")) + (file-3 (make-temp-file "global-auto-revert-test-3")) + (file-2b (concat file-2 "-b")) + require-final-newline buf-1 buf-2 buf-3) + (unwind-protect + (progn + (setq buf-1 (find-file-noselect file-1)) + (setq buf-2 (find-file-noselect file-2)) + (auto-revert-test--write-file "1-a" file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "")) + + (global-auto-revert-mode 1) ; Turn it on. + + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2)) + + ;; buf-1 should have been reverted immediately when the mode + ;; was enabled. + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + + ;; Alter a file. + (auto-revert-test--write-file "2-a" file-2) + ;; Allow for some time to handle notification events. + (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + + ;; Visit a file, and modify it on disk. + (setq buf-3 (find-file-noselect file-3)) + ;; Newly opened buffers won't be use notification until the + ;; first poll cycle; wait for it. + (auto-revert-test--wait-for + (lambda () (buffer-local-value 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert-test--write-file "3-a" file-3) - (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) - (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) - - ;; Delete a visited file, and re-create it with new contents. - (delete-file file-1) - (sleep-for 0.5) - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - (auto-revert-test--write-file "1-b" file-1) - (auto-revert-test--wait-for-buffer-text - buf-1 "1-b" auto-revert--timeout) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - - ;; Write a buffer to a new file, then modify the new file on disk. - (with-current-buffer buf-2 - (write-file file-2b)) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - (auto-revert-test--write-file "2-b" file-2b) - (auto-revert-test--wait-for-buffer-text - buf-2 "2-b" auto-revert--timeout) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2))) - - ;; Clean up. - (unless was-in-global-auto-revert-mode - (global-auto-revert-mode 0)) ; Turn it off. - (dolist (buf (list buf-1 buf-2 buf-3)) - (ignore-errors (kill-buffer buf))) - (dolist (file (list file-1 file-2 file-2b file-3)) - (ignore-errors (delete-file file))) - ))) + (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert-test--write-file "3-a" file-3) + (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) + (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) + + ;; Delete a visited file, and re-create it with new contents. + (delete-file file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + (auto-revert-test--write-file "1-b" file-1) + (auto-revert-test--wait-for-buffer-text + buf-1 "1-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + + ;; Write a buffer to a new file, then modify the new file on disk. + (with-current-buffer buf-2 + (write-file file-2b)) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + (auto-revert-test--write-file "2-b" file-2b) + (auto-revert-test--wait-for-buffer-text + buf-2 "2-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2))) + + ;; Clean up. + (unless was-in-global-auto-revert-mode + (global-auto-revert-mode 0)) ; Turn it off. + (dolist (buf (list buf-1 buf-2 buf-3)) + (ignore-errors (kill-buffer buf))) + (dolist (file (list file-1 file-2 file-2b file-3)) + (ignore-errors (delete-file file))) + )))) (auto-revert--deftest-remote auto-revert-test05-global-notify "Test `global-auto-revert-mode' without polling for remote buffers.") (ert-deftest auto-revert-test06-write-file () "Verify that notification follows `write-file' correctly." - :tags '(:expensive-test) (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) - (let* ((auto-revert-use-notify t) - (file-1 (make-temp-file "auto-revert-test")) - (file-2 (concat file-1 "-2")) - require-final-newline buf) - (unwind-protect - (progn - (setq buf (find-file-noselect file-1)) - (with-current-buffer buf - (insert "A") - (save-buffer) - - (auto-revert-mode 1) - - (insert "B") - (write-file file-2) - - (auto-revert-test--write-file "C" file-2) - (auto-revert-test--wait-for-buffer-text - buf "C" auto-revert--timeout) - (should (equal (buffer-string) "C")))) - - ;; Clean up. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file file-1)) - (ignore-errors (delete-file file-2))))) + (with-auto-revert-test + (let* ((auto-revert-use-notify t) + (file-1 (make-temp-file "auto-revert-test")) + (file-2 (concat file-1 "-2")) + require-final-newline buf) + (unwind-protect + (progn + (setq buf (find-file-noselect file-1)) + (with-current-buffer buf + (insert "A") + (save-buffer) + + (auto-revert-mode 1) + + (insert "B") + (write-file file-2) + + (auto-revert-test--write-file "C" file-2) + (auto-revert-test--wait-for-buffer-text + buf "C" (auto-revert--timeout)) + (should (equal (buffer-string) "C")))) + + ;; Clean up. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-1)) + (ignore-errors (delete-file file-2)))))) (auto-revert--deftest-remote auto-revert-test06-write-file "Test `write-file' in `auto-revert-mode' for remote buffers.") diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el index 052ae49a800..8d7cc7fccf3 100644 --- a/test/lisp/battery-tests.el +++ b/test/lisp/battery-tests.el @@ -22,9 +22,9 @@ (require 'battery) (ert-deftest battery-linux-proc-apm-regexp () - "Test `battery-linux-proc-apm-regexp'." + "Test `rx' definition `battery--linux-proc-apm'." (let ((str "1.16 1.2 0x07 0x01 0xff 0x80 -1% -1 ?")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -36,7 +36,7 @@ (should (equal (match-string 8 str) "-1")) (should (equal (match-string 9 str) "?"))) (let ((str "1.16 1.2 0x03 0x00 0x00 0x01 99% 1792 min")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -48,11 +48,107 @@ (should (equal (match-string 8 str) "1792")) (should (equal (match-string 9 str) "min")))) +(ert-deftest battery-acpi-rate-regexp () + "Test `rx' definition `battery--acpi-rate'." + (let ((str "01 mA")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mA"))) + (let ((str "23 mW")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (let ((str "23 mWh")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) "23 mW")) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (should-not (string-match (rx (battery--acpi-rate) eos) "45 mWh"))) + +(ert-deftest battery-acpi-capacity-regexp () + "Test `rx' definition `battery--acpi-capacity'." + (let ((str "01 mAh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mAh"))) + (let ((str "23 mWh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mWh"))) + (should-not (string-match (rx battery--acpi-capacity eos) "45 mW"))) + +(ert-deftest battery-upower-state () + "Test `battery--upower-state'." + ;; Charging. + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 1)) total) 'charging))) + (dolist (state '(nil 0 1 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'charging) + 'charging))) + ;; Discharging. + (dolist (total '(nil discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 2)) total) 'discharging))) + (dolist (state '(nil 0 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'discharging) + 'discharging))) + ;; Pending charge. + (dolist (total '(nil empty fully-charged pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 5)) total) + 'pending-charge))) + (dolist (state '(nil 0 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-charge) + 'pending-charge))) + ;; Pending discharge. + (dolist (total '(nil empty fully-charged pending-discharge)) + (should (eq (battery--upower-state '(("State" . 6)) total) + 'pending-discharge))) + (dolist (state '(nil 0 3 4 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-discharge) + 'pending-discharge))) + ;; Empty. + (dolist (total '(nil empty)) + (should (eq (battery--upower-state '(("State" . 3)) total) 'empty))) + (dolist (state '(nil 0 3)) + (should (eq (battery--upower-state `(("State" . ,state)) 'empty) 'empty))) + ;; Fully charged. + (dolist (total '(nil fully-charged)) + (should (eq (battery--upower-state '(("State" . 4)) total) 'fully-charged))) + (dolist (state '(nil 0 4)) + (should (eq (battery--upower-state `(("State" . ,state)) 'fully-charged) + 'fully-charged)))) + +(ert-deftest battery-upower-state-unknown () + "Test `battery--upower-state' with unknown states." + ;; Unknown running total retains new state. + (should-not (battery--upower-state () nil)) + (should-not (battery--upower-state '(("State" . state)) nil)) + (should-not (battery--upower-state '(("State" . 0)) nil)) + (should (eq (battery--upower-state '(("State" . 1)) nil) 'charging)) + (should (eq (battery--upower-state '(("State" . 2)) nil) 'discharging)) + (should (eq (battery--upower-state '(("State" . 3)) nil) 'empty)) + (should (eq (battery--upower-state '(("State" . 4)) nil) 'fully-charged)) + (should (eq (battery--upower-state '(("State" . 5)) nil) 'pending-charge)) + (should (eq (battery--upower-state '(("State" . 6)) nil) 'pending-discharge)) + ;; Unknown new state retains running total. + (dolist (props '(() (("State" . state)) (("State" . 0)))) + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state props total) total)))) + ;; Conflicting empty and fully-charged. + (should-not (battery--upower-state '(("State" . 3)) 'fully-charged)) + (should-not (battery--upower-state '(("State" . 4)) 'empty))) + (ert-deftest battery-format () "Test `battery-format'." (should (equal (battery-format "" ()) "")) (should (equal (battery-format "" '((?b . "-"))) "")) - (should (equal (battery-format "%a%b%p%%" '((?b . "-") (?p . "99"))) - "-99%"))) + (should (equal (battery-format "%2a%-3b%.1p%%" '((?b . "-") (?p . "99"))) + "- 9%"))) ;;; battery-tests.el ends here diff --git a/test/lisp/bookmark-resources/test-list.bmk b/test/lisp/bookmark-resources/test-list.bmk new file mode 100644 index 00000000000..696d64979b8 --- /dev/null +++ b/test/lisp/bookmark-resources/test-list.bmk @@ -0,0 +1,20 @@ +;;;; Emacs Bookmark Format Version 1 ;;;; -*- coding: utf-8-emacs -*- +;;; This format is meant to be slightly human-readable; +;;; nevertheless, you probably don't want to edit it. +;;; -*- End Of Bookmark File Format Version Stamp -*- +(("name-0" + (filename . "/some/file-0") + (front-context-string . "abc") + (rear-context-string . "def") + (position . 3)) +("name-1" + (filename . "/some/file-1") + (front-context-string . "abc") + (rear-context-string . "def") + (position . 3)) +("name-2" + (filename . "/some/file-2") + (front-context-string . "abc") + (rear-context-string . "def") + (position . 3)) +) diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 7e0384b7241..6745e4c1d8a 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -24,23 +24,17 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'bookmark) +(require 'cl-lib) -(defvar bookmark-tests-data-dir - (file-truename - (expand-file-name "bookmark-resources/" - (file-name-directory (or load-file-name - buffer-file-name)))) - "Base directory of bookmark-tests.el data files.") - -(defvar bookmark-tests-bookmark-file - (expand-file-name "test.bmk" bookmark-tests-data-dir) +(defvar bookmark-tests-bookmark-file (ert-resource-file "test.bmk") "Bookmark file used for testing.") (defvar bookmark-tests-example-file ;; We use abbreviate-file-name here to match the behavior of ;; `bookmark-buffer-file-name'. - (abbreviate-file-name (expand-file-name "example.txt" bookmark-tests-data-dir)) + (abbreviate-file-name (ert-resource-file "example.txt")) "Example file used for testing.") ;; The values below should match `bookmark-tests-bookmark-file'. We cache @@ -82,6 +76,69 @@ the lexically-bound variable `buffer'." ,@body) (kill-buffer buffer)))) +(defvar bookmark-tests-bookmark-file-list (ert-resource-file "test-list.bmk") + "Bookmark file used for testing a list of bookmarks.") + +;; The values below should match `bookmark-tests-bookmark-file-list' +;; content. We cache these values to speed up tests. +(eval-and-compile ; needed by `with-bookmark-test-list' macro + (defvar bookmark-tests-bookmark-list-0 '("name-0" + (filename . "/some/file-0") + (front-context-string . "ghi") + (rear-context-string . "jkl") + (position . 4)) + "Cached value used in bookmark-tests.el.")) + +;; The values below should match `bookmark-tests-bookmark-file-list' +;; content. We cache these values to speed up tests. +(eval-and-compile ; needed by `with-bookmark-test-list' macro + (defvar bookmark-tests-bookmark-list-1 '("name-1" + (filename . "/some/file-1") + (front-context-string . "mno") + (rear-context-string . "pqr") + (position . 5)) + "Cached value used in bookmark-tests.el.")) + +;; The values below should match `bookmark-tests-bookmark-file-list' +;; content. We cache these values to speed up tests. +(eval-and-compile ; needed by `with-bookmark-test-list' macro + (defvar bookmark-tests-bookmark-list-2 '("name-2" + (filename . "/some/file-2") + (front-context-string . "stu") + (rear-context-string . "vwx") + (position . 6)) + "Cached value used in bookmark-tests.el.")) + +(defvar bookmark-tests-cache-timestamp-list + (cons bookmark-tests-bookmark-file-list + (nth 5 (file-attributes + bookmark-tests-bookmark-file-list))) + "Cached value used in bookmark-tests.el.") + +(defmacro with-bookmark-test-list (&rest body) + "Create environment for testing bookmark.el and evaluate BODY. +Ensure a clean environment for testing, and do not change user +data when running tests interactively." + `(with-temp-buffer + (let ((bookmark-alist (quote (,(copy-sequence bookmark-tests-bookmark-list-0) + ,(copy-sequence bookmark-tests-bookmark-list-1) + ,(copy-sequence bookmark-tests-bookmark-list-2)))) + (bookmark-default-file bookmark-tests-bookmark-file-list) + (bookmark-bookmarks-timestamp bookmark-tests-cache-timestamp-list) + bookmark-save-flag) + ,@body))) + +(defmacro with-bookmark-test-file-list (&rest body) + "Create environment for testing bookmark.el and evaluate BODY. +Same as `with-bookmark-test-list' but also opens the resource file +example.txt in a buffer, which can be accessed by callers through +the lexically-bound variable `buffer'." + `(let ((buffer (find-file-noselect bookmark-tests-example-file))) + (unwind-protect + (with-bookmark-test-list + ,@body) + (kill-buffer buffer)))) + (ert-deftest bookmark-tests-all-names () (with-bookmark-test (should (equal (bookmark-all-names) '("name"))))) @@ -94,6 +151,30 @@ the lexically-bound variable `buffer'." (with-bookmark-test (should (equal (bookmark-get-bookmark-record "name") (cdr bookmark-tests-bookmark))))) +(ert-deftest bookmark-tests-all-names-list () + (with-bookmark-test-list + (should (equal (bookmark-all-names) '("name-0" + "name-1" + "name-2"))))) + +(ert-deftest bookmark-tests-get-bookmark-list () + (with-bookmark-test-list + (should (equal (bookmark-get-bookmark "name-0") + bookmark-tests-bookmark-list-0)) + (should (equal (bookmark-get-bookmark "name-1") + bookmark-tests-bookmark-list-1)) + (should (equal (bookmark-get-bookmark "name-2") + bookmark-tests-bookmark-list-2)))) + +(ert-deftest bookmark-tests-get-bookmark-record-list () + (with-bookmark-test-list + (should (equal (bookmark-get-bookmark-record "name-0") + (cdr bookmark-tests-bookmark-list-0))) + (should (equal (bookmark-get-bookmark-record "name-1") + (cdr bookmark-tests-bookmark-list-1))) + (should (equal (bookmark-get-bookmark-record "name-2") + (cdr bookmark-tests-bookmark-list-2))))) + (ert-deftest bookmark-tests-record-getters-and-setters-new () (with-temp-buffer (let* ((buffer-file-name "test") @@ -129,6 +210,19 @@ the lexically-bound variable `buffer'." ;; calling twice gives same record (should (equal (bookmark-make-record) record)))))) +(ert-deftest bookmark-tests-make-record-list () + (with-bookmark-test-file-list + (let* ((record `("example.txt" (filename . ,bookmark-tests-example-file) + (front-context-string . "is text file is ") + (rear-context-string) + (position . 3) + (defaults "example.txt")))) + (with-current-buffer buffer + (goto-char 3) + (should (equal (bookmark-make-record) record)) + ;; calling twice gives same record + (should (equal (bookmark-make-record) record)))))) + (ert-deftest bookmark-tests-make-record-function () (with-bookmark-test (let ((buffer-file-name "test")) @@ -218,7 +312,7 @@ the lexically-bound variable `buffer'." (with-bookmark-test (should-error (bookmark-insert-annotation "a missing bookmark")) (bookmark-insert-annotation "name") - (should (equal (buffer-string) (bookmark-default-annotation-text "name")))) + (should (string-match "Type the annotation" (buffer-string)))) (with-bookmark-test (bookmark-set-annotation "name" "some stuff") (bookmark-insert-annotation "name") @@ -266,6 +360,11 @@ the lexically-bound variable `buffer'." (bookmark-delete "name") (should (equal bookmark-alist nil)))) +(ert-deftest bookmark-tests-delete-all () + (with-bookmark-test-list + (bookmark-delete-all t) + (should (equal bookmark-alist nil)))) + (defmacro with-bookmark-test-save-load (&rest body) "Create environment for testing bookmark.el and evaluate BODY. Same as `with-bookmark-test' but also sets a temporary @@ -339,28 +438,209 @@ testing `bookmark-bmenu-list'." ,@body) (kill-buffer bookmark-bmenu-buffer))))) -(ert-deftest bookmark-bmenu.enu-edit-annotation/show-annotation () +(defmacro with-bookmark-bmenu-test-list (&rest body) + "Create environment for testing `bookmark-bmenu-list' and evaluate BODY. +Same as `with-bookmark-test-list' but with additions suitable for +testing `bookmark-bmenu-list'." + `(with-bookmark-test-list + (let ((bookmark-bmenu-buffer "*Bookmark List - Testing*")) + (unwind-protect + (save-window-excursion + (bookmark-bmenu-list) + ,@body) + (kill-buffer bookmark-bmenu-buffer))))) + +(ert-deftest bookmark-test-bmenu-edit-annotation/show-annotation () (with-bookmark-bmenu-test (bookmark-set-annotation "name" "foo") (bookmark-bmenu-edit-annotation) (should (string-match "foo" (buffer-string))) (kill-buffer (current-buffer)))) -(ert-deftest bookmark-bmenu-send-edited-annotation () +(ert-deftest bookmark-test-bmenu-send-edited-annotation () (with-bookmark-bmenu-test (bookmark-bmenu-edit-annotation) (insert "foo") (bookmark-send-edited-annotation) (should (equal (bookmark-get-annotation "name") "foo")))) -(ert-deftest bookmark-bmenu-send-edited-annotation/restore-focus () +(ert-deftest bookmark-test-bmenu-send-edited-annotation/restore-focus () "Test for https://debbugs.gnu.org/20150 ." (with-bookmark-bmenu-test (bookmark-bmenu-edit-annotation) (insert "foo") (bookmark-send-edited-annotation) (should (equal (buffer-name (current-buffer)) bookmark-bmenu-buffer)) + (beginning-of-line) + (forward-char 4) (should (looking-at "name")))) +(ert-deftest bookmark-test-bmenu-toggle-filenames () + (with-bookmark-bmenu-test + (should (re-search-forward "/some/file" nil t)) + (bookmark-bmenu-toggle-filenames) + (goto-char (point-min)) + (should-not (re-search-forward "/some/file" nil t)))) + +(ert-deftest bookmark-test-bmenu-toggle-filenames/show () + (with-bookmark-bmenu-test + (bookmark-bmenu-toggle-filenames t) + (should (re-search-forward "/some/file")))) + +(ert-deftest bookmark-test-bmenu-show-filenames () + (with-bookmark-bmenu-test + (bookmark-bmenu-show-filenames) + (should (re-search-forward "/some/file")))) + +(ert-deftest bookmark-test-bmenu-hide-filenames () + (with-bookmark-bmenu-test + (bookmark-bmenu-hide-filenames) + (goto-char (point-min)) + (should-not (re-search-forward "/some/file" nil t)))) + +(ert-deftest bookmark-test-bmenu-bookmark () + (with-bookmark-bmenu-test + (should (equal (bookmark-bmenu-bookmark) "name")))) + +(ert-deftest bookmark-test-bmenu-mark () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (forward-line -1) + (beginning-of-line) + (should (looking-at "^>")))) + +(ert-deftest bookmark-test-bmenu-any-marks () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (beginning-of-line) + (should (bookmark-bmenu-any-marks)))) + +(ert-deftest bookmark-test-bmenu-mark-all () + (with-bookmark-bmenu-test-list + (let ((here (point-max))) + ;; Expect to not move the point + (goto-char here) + (bookmark-bmenu-mark-all) + (should (equal here (point))) + ;; Verify that all bookmarks are marked + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (should (looking-at "^> ")) + (should (equal bookmark-tests-bookmark-list-0 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^> ")) + (should (equal bookmark-tests-bookmark-list-1 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^> ")) + (should (equal bookmark-tests-bookmark-list-2 + (bookmark-get-bookmark (bookmark-bmenu-bookmark))))))) + +(ert-deftest bookmark-test-bmenu-any-marks-list () + (with-bookmark-bmenu-test-list + ;; Mark just the second item + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (forward-line 1) + (bookmark-bmenu-mark) + ;; Verify that only the second item is marked + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (should (looking-at "^ ")) + (should (equal bookmark-tests-bookmark-list-0 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^> ")) + (should (equal bookmark-tests-bookmark-list-1 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^ ")) + (should (equal bookmark-tests-bookmark-list-2 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + ;; There should be at least one mark + (should (bookmark-bmenu-any-marks)))) + +(ert-deftest bookmark-test-bmenu-unmark () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (goto-char (point-min)) + (bookmark-bmenu-unmark) + (forward-line -1) + (beginning-of-line) + (should (looking-at "^ ")))) + +(ert-deftest bookmark-test-bmenu-unmark-all () + (with-bookmark-bmenu-test-list + (bookmark-bmenu-mark-all) + (let ((here (point-max))) + ;; Expect to not move the point + (goto-char here) + (bookmark-bmenu-unmark-all) + (should (equal here (point))) + ;; Verify that all bookmarks are unmarked + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (should (looking-at "^ ")) + (should (equal bookmark-tests-bookmark-list-0 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^ ")) + (should (equal bookmark-tests-bookmark-list-1 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^ ")) + (should (equal bookmark-tests-bookmark-list-2 + (bookmark-get-bookmark (bookmark-bmenu-bookmark))))))) + +(ert-deftest bookmark-test-bmenu-delete () + (with-bookmark-bmenu-test + (bookmark-bmenu-delete) + (bookmark-bmenu-execute-deletions) + (should (equal (length bookmark-alist) 0)))) + +(ert-deftest bookmark-test-bmenu-delete-all () + (with-bookmark-bmenu-test-list + ;; Verify that unmarked bookmarks aren't deleted + (bookmark-bmenu-execute-deletions) + (should-not (eq bookmark-alist nil)) + (let ((here (point-max))) + ;; Expect to not move the point + (goto-char here) + (bookmark-bmenu-delete-all) + (should (equal here (point))) + ;; Verify that all bookmarks are marked for deletion + (goto-char (point-min)) + (bookmark-bmenu-ensure-position) + (should (looking-at "^D ")) + (should (equal bookmark-tests-bookmark-list-0 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^D ")) + (should (equal bookmark-tests-bookmark-list-1 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + (forward-line 1) + (should (looking-at "^D ")) + (should (equal bookmark-tests-bookmark-list-2 + (bookmark-get-bookmark (bookmark-bmenu-bookmark)))) + ;; Verify that all bookmarks are deleted + (bookmark-bmenu-execute-deletions) + (should (eq bookmark-alist nil))))) + +(ert-deftest bookmark-test-bmenu-locate () + (let (msg) + (cl-letf (((symbol-function 'message) + (lambda (&rest args) + (setq msg (apply #'format args))))) + (with-bookmark-bmenu-test + (bookmark-bmenu-locate) + (should (equal msg "/some/file")))))) + +(ert-deftest bookmark-test-bmenu-filter-alist-by-regexp () + (with-bookmark-bmenu-test + (bookmark-bmenu-filter-alist-by-regexp regexp-unmatchable) + (goto-char (point-min)) + (should (looking-at "^$")))) + (provide 'bookmark-tests) ;;; bookmark-tests.el ends here diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el index 11cc14042c6..b463366c33b 100644 --- a/test/lisp/button-tests.el +++ b/test/lisp/button-tests.el @@ -21,6 +21,12 @@ (require 'ert) +(defvar button-tests--map + (let ((map (make-sparse-keymap))) + (define-key map "x" #'ignore) + map) + "Keymap for testing command substitution.") + (ert-deftest button-at () "Test `button-at' behavior." (with-temp-buffer @@ -41,11 +47,13 @@ "Test `button--help-echo' with strings." (with-temp-buffer ;; Text property buttons. - (let ((button (insert-text-button "text" 'help-echo "text help"))) - (should (equal (button--help-echo button) "text help"))) + (let ((button (insert-text-button + "text" 'help-echo "text: \\<button-tests--map>\\[ignore]"))) + (should (equal (button--help-echo button) "text: x"))) ;; Overlay buttons. - (let ((button (insert-button "overlay" 'help-echo "overlay help"))) - (should (equal (button--help-echo button) "overlay help"))))) + (let ((button (insert-button "overlay" 'help-echo + "overlay: \\<button-tests--map>\\[ignore]"))) + (should (equal (button--help-echo button) "overlay: x"))))) (ert-deftest button--help-echo-form () "Test `button--help-echo' with forms." @@ -55,16 +63,17 @@ (form `(funcall (let ((,help "lexical form")) (lambda () ,help)))) (button (insert-text-button "text" 'help-echo form))) - (set help "dynamic form") - (should (equal (button--help-echo button) "dynamic form"))) + (set help "dynamic: \\<button-tests--map>\\[ignore]") + (should (equal (button--help-echo button) "dynamic: x"))) ;; Test overlay buttons with lexical scoping. (setq lexical-binding t) (let* ((help (make-symbol "help")) - (form `(funcall (let ((,help "lexical form")) - (lambda () ,help)))) + (form `(funcall + (let ((,help "lexical: \\<button-tests--map>\\[ignore]")) + (lambda () ,help)))) (button (insert-button "overlay" 'help-echo form))) (set help "dynamic form") - (should (equal (button--help-echo button) "lexical form"))))) + (should (equal (button--help-echo button) "lexical: x"))))) (ert-deftest button--help-echo-function () "Test `button--help-echo' with functions." @@ -77,9 +86,9 @@ (should (eq win owin)) (should (eq obj obuf)) (should (= pos opos)) - "text function")) + "text: \\<button-tests--map>\\[ignore]")) (button (insert-text-button "text" 'help-echo help))) - (should (equal (button--help-echo button) "text function")) + (should (equal (button--help-echo button) "text: x")) ;; Overlay buttons. (setq help (lambda (win obj pos) (should (eq win owin)) @@ -88,9 +97,9 @@ (should (eq (overlay-buffer obj) obuf)) (should (= (overlay-start obj) opos)) (should (= pos opos)) - "overlay function")) + "overlay: \\<button-tests--map>\\[ignore]")) (setq opos (point)) (setq button (insert-button "overlay" 'help-echo help)) - (should (equal (button--help-echo button) "overlay function"))))) + (should (equal (button--help-echo button) "overlay: x"))))) ;;; button-tests.el ends here diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 6db5426ff6d..b59f4dc988f 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -63,29 +63,26 @@ An existing calc stack is reused, otherwise a new one is created." (calc-top-n 1)) (calc-pop 0))) -;; (ert-deftest test-math-bignum () -;; ;; bug#17556 -;; (let ((n (math-bignum most-negative-fixnum))) -;; (should (math-negp n)) -;; (should (cl-notany #'cl-minusp (cdr n))))) - -(ert-deftest test-calc-remove-units () +(ert-deftest calc-remove-units () (should (calc-tests-equal (calc-tests-simple #'calc-remove-units "-1 m") -1))) -(ert-deftest test-calc-extract-units () - (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m") - '(var m var-m))) - (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m*cm") - '(* (float 1 -2) (^ (var m var-m) 2))))) - -(ert-deftest test-calc-convert-units () - ;; Used to ask for `(The expression is unitless when simplified) Old Units: '. - (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" nil "cm") - '(* -100 (var cm var-cm)))) - ;; Gave wrong result. - (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" - (math-read-expr "1m") "cm") - '(* -100 (var cm var-cm))))) +(ert-deftest calc-extract-units () + (let ((calc-display-working-message nil)) + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m") + '(var m var-m))) + (should (calc-tests-equal (calc-tests-simple #'calc-extract-units "-1 m*cm") + '(* (float 1 -2) (^ (var m var-m) 2)))))) + +(ert-deftest calc-convert-units () + (let ((calc-display-working-message nil)) + ;; Used to ask `(The expression is unitless when simplified) Old Units: '. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" + nil "cm") + '(* -100 (var cm var-cm)))) + ;; Gave wrong result. + (should (calc-tests-equal (calc-tests-simple #'calc-convert-units "-1 m" + (math-read-expr "1m") "cm") + '(* -100 (var cm var-cm)))))) (ert-deftest calc-imaginary-i () "Test `math-imaginary-i' for non-special-const values." @@ -94,7 +91,7 @@ An existing calc stack is reused, otherwise a new one is created." (let ((var-i (calcFunc-sqrt -1))) (should (math-imaginary-i)))) -(ert-deftest test-calc-23889 () +(ert-deftest calc-bug-23889 () "Test for https://debbugs.gnu.org/23889 and 25652." (skip-unless t) ;; (>= math-bignum-digit-length 9)) (dolist (mode '(deg rad)) @@ -139,7 +136,7 @@ An existing calc stack is reused, otherwise a new one is created." (nth 1 (calcFunc-cos 1))) 0 4)))))) -(ert-deftest calc-test-trig () +(ert-deftest calc-trig () "Trigonometric simplification; bug#33052." (let ((calc-angle-mode 'rad)) (let ((calc-symbolic-mode t)) @@ -169,7 +166,7 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (math-simplify '(calcFunc-cot (/ (var pi var-pi) 3))) '(calcFunc-cot (/ (var pi var-pi) 3))))))) -(ert-deftest calc-test-format-radix () +(ert-deftest calc-format-radix () "Test integer formatting (bug#36689)." (let ((calc-group-digits nil)) (let ((calc-number-radix 10)) @@ -194,7 +191,7 @@ An existing calc stack is reused, otherwise a new one is created." (let ((calc-number-radix 36)) (should (equal (math-format-number 12345678901) "36#5,O6A,QT1"))))) -(ert-deftest calc-test-calendar () +(ert-deftest calc-calendar () "Test calendar conversions (bug#36822)." (should (equal (calcFunc-julian (math-parse-date "2019-07-27")) 2458692)) (should (equal (math-parse-date "2019-07-27") '(date 737267))) @@ -216,7 +213,7 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (math-absolute-from-julian-dt -101 3 1) -36832)) (should (equal (math-absolute-from-julian-dt -4713 1 1) -1721425))) -(ert-deftest calc-test-solve-linear-system () +(ert-deftest calc-solve-linear-system () "Test linear system solving (bug#35374)." ;; x + y = 3 ;; 2x - 3y = -4 @@ -345,6 +342,371 @@ An existing calc stack is reused, otherwise a new one is created." (should (Math-num-integerp '(float 1 0))) (should-not (Math-num-integerp nil))) +(ert-deftest calc-matrix-determinant () + (let ((calc-display-working-message nil)) + (should (equal (calcFunc-det '(vec (vec 3))) + 3)) + (should (equal (calcFunc-det '(vec (vec 2 3) (vec 6 7))) + -4)) + (should (equal (calcFunc-det '(vec (vec 1 2 3) (vec 4 5 7) (vec 9 6 2))) + 15)) + (should (equal (calcFunc-det '(vec (vec 0 5 7 3) + (vec 0 0 2 0) + (vec 1 2 3 4) + (vec 0 0 0 3))) + 30)) + (should (equal (calcFunc-det '(vec (vec (var a var-a)))) + '(var a var-a))) + (should (equal (calcFunc-det '(vec (vec 2 (var a var-a)) + (vec 7 (var a var-a)))) + '(* -5 (var a var-a)))) + (should (equal (calcFunc-det '(vec (vec 1 0 0 0) + (vec 0 1 0 0) + (vec 0 0 0 1) + (vec 0 0 (var a var-a) 0))) + '(neg (var a var-a)))))) + +(ert-deftest calc-gcd () + (should (equal (calcFunc-gcd 3 4) 1)) + (should (equal (calcFunc-gcd 12 15) 3)) + (should (equal (calcFunc-gcd -12 15) 3)) + (should (equal (calcFunc-gcd 12 -15) 3)) + (should (equal (calcFunc-gcd -12 -15) 3)) + (should (equal (calcFunc-gcd 0 5) 5)) + (should (equal (calcFunc-gcd 5 0) 5)) + (should (equal (calcFunc-gcd 0 -5) 5)) + (should (equal (calcFunc-gcd -5 0) 5)) + (should (equal (calcFunc-gcd 0 0) 0)) + (should (equal (calcFunc-gcd 0 '(var x var-x)) + '(calcFunc-abs (var x var-x)))) + (should (equal (calcFunc-gcd '(var x var-x) 0) + '(calcFunc-abs (var x var-x))))) + +(ert-deftest calc-sum-gcd () + ;; sum(gcd(0,n),n,-1,-1) + (should (equal (math-simplify '(calcFunc-sum (calcFunc-gcd 0 (var n var-n)) + (var n var-n) -1 -1)) + 1)) + ;; sum(sum(gcd(n,k),k,-1,1),n,-1,1) + (should (equal (math-simplify + '(calcFunc-sum + (calcFunc-sum (calcFunc-gcd (var n var-n) (var k var-k)) + (var k var-k) -1 1) + (var n var-n) -1 1)) + 8))) + +(defun calc-tests--fac (n) + (apply #'* (number-sequence 1 n))) + +(defun calc-tests--choose (n k) + "N choose K, reference implementation." + (cond + ((and (integerp n) (integerp k)) + (if (<= 0 n) + (if (<= 0 k n) + (/ (calc-tests--fac n) + (* (calc-tests--fac k) (calc-tests--fac (- n k)))) + 0) ; 0≤n<k + ;; n<0, n and k integers: use extension from M. J. Kronenburg + (cond + ((<= 0 k) + (* (expt -1 k) + (calc-tests--choose (+ (- n) k -1) k))) + ((<= k n) + (* (expt -1 (- n k)) + (calc-tests--choose (+ (- k) -1) (- n k)))) + (t ; n<k<0 + 0)))) + ((natnump k) + ;; Generalisation for any n, integral k≥0: use falling product + (/ (apply '* (number-sequence n (- n (1- k)) -1)) + (calc-tests--fac k))) + (t (error "case not covered")))) + +(defun calc-tests--calc-to-number (x) + "Convert a Calc object to a Lisp number." + (pcase x + ((pred numberp) x) + (`(frac ,p ,q) (/ (float p) q)) + (`(float ,m ,e) (* m (expt 10 e))) + (_ (error "calc object not converted: %S" x)))) + +(ert-deftest calc-choose () + "Test computation of binomial coefficients (bug#16999)." + (let ((calc-display-working-message nil)) + ;; Integral arguments + (dolist (n (number-sequence -6 6)) + (dolist (k (number-sequence -6 6)) + (should (equal (calcFunc-choose n k) + (calc-tests--choose n k))))) + + ;; Fractional n, natural k + (should (equal (calc-tests--calc-to-number + (calcFunc-choose '(frac 15 2) 3)) + (calc-tests--choose 7.5 3))) + + (should (equal (calc-tests--calc-to-number + (calcFunc-choose '(frac 1 2) 2)) + (calc-tests--choose 0.5 2))) + + (should (equal (calc-tests--calc-to-number + (calcFunc-choose '(frac -15 2) 3)) + (calc-tests--choose -7.5 3))))) + +(ert-deftest calc-business-days () + (cl-flet ((m (s) (math-parse-date s)) + (b+ (a b) (calcFunc-badd a b)) + (b- (a b) (calcFunc-bsub a b))) + ;; Sanity check. + (should (equal (m "2020-09-07") '(date 737675))) + + ;; Test with standard business days (Mon-Fri): + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-09"))) ; Tue->Wed + (should (equal (b+ (m "2020-09-09") 1) (m "2020-09-10"))) ; Wed->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-14"))) ; Fri->Mon + + (should (equal (b+ (m "2020-09-07") 4) (m "2020-09-11"))) ; Mon->Fri + (should (equal (b+ (m "2020-09-07") 6) (m "2020-09-15"))) ; Mon->Tue + + (should (equal (b+ (m "2020-09-12") 1) (m "2020-09-14"))) ; Sat->Mon + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-09"))) ; Thu->Wed + (should (equal (b- (m "2020-09-09") 1) (m "2020-09-08"))) ; Wed->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + (should (equal (b- (m "2020-09-07") 1) (m "2020-09-04"))) ; Mon->Fri + + (should (equal (b- (m "2020-09-11") 4) (m "2020-09-07"))) ; Fri->Mon + (should (equal (b- (m "2020-09-15") 6) (m "2020-09-07"))) ; Tue->Mon + + (should (equal (b- (m "2020-09-12") 1) (m "2020-09-11"))) ; Sat->Fri + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + + ;; Stepping fractional days + (should (equal (b+ (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-09 09:00"))) + (should (equal (b+ (m "2020-09-11 21:00") '(frac 1 2)) + (m "2020-09-14 09:00"))) + (should (equal (b- (m "2020-09-08 21:00") '(frac 1 2)) + (m "2020-09-08 09:00"))) + (should (equal (b- (m "2020-09-14 06:00") '(frac 1 2)) + (m "2020-09-11 18:00"))) + + ;; Test with a couple of extra days off: + (let ((var-Holidays (list 'vec + '(var sat var-sat) '(var sun var-sun) + (m "2020-09-09") (m "2020-09-11")))) + + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-08"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-08") 1) (m "2020-09-10"))) ; Tue->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-14"))) ; Thu->Mon + (should (equal (b+ (m "2020-09-14") 1) (m "2020-09-15"))) ; Mon->Tue + (should (equal (b+ (m "2020-09-15") 1) (m "2020-09-16"))) ; Tue->Wed + + (should (equal (b- (m "2020-09-16") 1) (m "2020-09-15"))) ; Wed->Tue + (should (equal (b- (m "2020-09-15") 1) (m "2020-09-14"))) ; Tue->Mon + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-08"))) ; Thu->Tue + (should (equal (b- (m "2020-09-08") 1) (m "2020-09-07"))) ; Tue->Mon + ) + + ;; Test with odd non-business weekdays (Tue, Wed, Sat): + (let ((var-Holidays '(vec (var tue var-tue) + (var wed var-wed) + (var sat var-sat)))) + (should (equal (b+ (m "2020-09-07") 1) (m "2020-09-10"))) ; Mon->Thu + (should (equal (b+ (m "2020-09-10") 1) (m "2020-09-11"))) ; Thu->Fri + (should (equal (b+ (m "2020-09-11") 1) (m "2020-09-13"))) ; Fri->Sun + (should (equal (b+ (m "2020-09-13") 1) (m "2020-09-14"))) ; Sun->Mon + + (should (equal (b- (m "2020-09-14") 1) (m "2020-09-13"))) ; Mon->Sun + (should (equal (b- (m "2020-09-13") 1) (m "2020-09-11"))) ; Sun->Fri + (should (equal (b- (m "2020-09-11") 1) (m "2020-09-10"))) ; Fri->Thu + (should (equal (b- (m "2020-09-10") 1) (m "2020-09-07"))) ; Thu->Mon + ) + )) + +(ert-deftest calc-unix-date () + (let* ((d-1970-01-01 (math-parse-date "1970-01-01")) + (d-2020-09-07 (math-parse-date "2020-09-07")) + (d-1991-01-09-0600 (math-parse-date "1991-01-09 06:00"))) + ;; calcFunc-unixtime (command "t U") converts a date value to Unix time, + ;; and a number to a date. + (should (equal d-1970-01-01 '(date 719163))) + (should (equal (calcFunc-unixtime d-1970-01-01 0) 0)) + (should (equal (calc-tests--calc-to-number (cadr (calcFunc-unixtime 0 0))) + (cadr d-1970-01-01))) + (should (equal (calcFunc-unixtime d-2020-09-07 0) + (* (- (cadr d-2020-09-07) + (cadr d-1970-01-01)) + 86400))) + (should (equal (calcFunc-unixtime d-1991-01-09-0600 0) + 663400800)) + (should (equal (calc-tests--calc-to-number + (cadr (calcFunc-unixtime 663400800 0))) + 726841.25)) + + (let ((calc-date-format '(U))) + ;; Test parsing Unix time. + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "0"))) + 719163)) + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "469324800"))) + (+ 719163 (/ 469324800 86400)))) + (should (equal (calc-tests--calc-to-number + (cadr (math-parse-date "663400800"))) + 726841.25)) + + ;; Test formatting Unix time. + (should (equal (math-format-date d-1970-01-01) "0")) + (should (equal (math-format-date d-2020-09-07) + (number-to-string (* (- (cadr d-2020-09-07) + (cadr d-1970-01-01)) + 86400)))) + (should (equal (math-format-date d-1991-01-09-0600) "663400800"))))) + +;; Reference implementations of bit operations: + +(defun calc-tests--clip (x w) + "Clip X to W bits, signed if W is negative, otherwise unsigned." + (cond ((zerop w) x) + ((> w 0) (logand x (- (ash 1 w) 1))) + (t (let ((y (calc-tests--clip x (- w))) + (msb (ash 1 (- (- w) 1)))) + (- y (ash (logand y msb) 1)))))) + +(defun calc-tests--not (x w) + "Bitwise complement of X, word size W." + (calc-tests--clip (lognot x) w)) + +(defun calc-tests--and (x y w) + "Bitwise AND of X and W, word size W." + (calc-tests--clip (logand x y) w)) + +(defun calc-tests--or (x y w) + "Bitwise OR of X and Y, word size W." + (calc-tests--clip (logior x y) w)) + +(defun calc-tests--xor (x y w) + "Bitwise XOR of X and Y, word size W." + (calc-tests--clip (logxor x y) w)) + +(defun calc-tests--diff (x y w) + "Bitwise AND of X and NOT Y, word size W." + (calc-tests--clip (logand x (lognot y)) w)) + +(defun calc-tests--lsh (x n w) + "Logical shift left X by N steps, word size W." + (if (< n 0) + (calc-tests--rsh x (- n) w) + (calc-tests--clip (ash x n) w))) + +(defun calc-tests--rsh (x n w) + "Logical shift right X by N steps, word size W." + (if (< n 0) + (calc-tests--lsh x (- n) w) + ;; First zero-extend, then shift. + (calc-tests--clip + (ash (calc-tests--clip x (abs w)) (- n)) + w))) + +(defun calc-tests--ash (x n w) + "Arithmetic shift left X by N steps, word size W." + (if (< n 0) + (calc-tests--rash x (- n) w) + (calc-tests--clip (ash x n) w))) + +(defun calc-tests--rash (x n w) + "Arithmetic shift right X by N steps, word size W." + (if (< n 0) + (calc-tests--ash x (- n) w) + ;; First sign-extend, then shift. + (calc-tests--clip + (ash (calc-tests--clip x (- (abs w))) (- n)) + w))) + +(defun calc-tests--rot (x n w) + "Rotate X left by N steps, word size W." + (when (zerop w) + (error "Undefined")) + (let* ((aw (abs w)) + (y (calc-tests--clip x aw)) + (steps (mod n aw))) + (calc-tests--clip (logior (ash y steps) (ash y (- steps aw))) + w))) + +(ert-deftest calc-shift-binary () + (dolist (w '(16 32 -16 -32 0)) + (dolist (x '(0 1 #x1234 #x8000 #xabcd #xffff + #x12345678 #xabcdef12 #x80000000 #xffffffff + #x1234567890ab #x1234967890ab + -1 -14 #x-8000 #x-ffff #x-8001 #x-10000 + #x-80000000 #x-ffffffff #x-80000001 #x-100000000)) + (dolist (n '(0 1 4 16 32 -1 -4 -16 -32)) + (should (equal (calcFunc-lsh x n w) + (calc-tests--lsh x n w))) + (should (equal (calcFunc-rsh x n w) + (calc-tests--rsh x n w))) + (should (equal (calcFunc-ash x n w) + (calc-tests--ash x n w))) + (should (equal (calcFunc-rash x n w) + (calc-tests--rash x n w))) + (unless (zerop w) + (should (equal (calcFunc-rot x n w) + (calc-tests--rot x n w))))))) + (should-error (calcFunc-rot 1 1 0))) + +(ert-deftest calc-bit-ops () + (dolist (w '(16 32 -16 -32 0)) + (dolist (x '(0 1 #x1234 #x8000 #xabcd #xffff + #x12345678 #xabcdef12 #x80000000 #xffffffff + #x1234567890ab #x1234967890ab + -1 -14 #x-8000 #x-ffff #x-8001 #x-10000 + #x-80000000 #x-ffffffff #x-80000001 #x-100000000)) + (should (equal (calcFunc-not x w) + (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))) + + (dolist (y '(0 1 #x1234 #x8000 #xabcd #xffff + #x12345678 #xabcdef12 #x80000000 #xffffffff + #x1234567890ab #x1234967890ab + -1 -14 #x-8000 #x-ffff #x-8001 #x-10000 + #x-80000000 #x-ffffffff #x-80000001 #x-100000000)) + (should (equal (calcFunc-and x y w) + (calc-tests--and x y w))) + (should (equal (calcFunc-or x y w) + (calc-tests--or x y w))) + (should (equal (calcFunc-xor x y w) + (calc-tests--xor x y w))) + (should (equal (calcFunc-diff x y w) + (calc-tests--diff x y w))))))) + +(ert-deftest calc-latex-input () + ;; Check precedence of "/" in LaTeX input mode. + (should (equal (math-read-exprs "a+b/c*d") + '((+ (var a var-a) (/ (var b var-b) + (* (var c var-c) (var d var-d))))))) + (unwind-protect + (progn + (calc-set-language 'latex) + (should (equal (math-read-exprs "a+b/c*d") + '((+ (var a var-a) (/ (var b var-b) + (* (var c var-c) (var d var-d))))))) + (should (equal (math-read-exprs "a+b\\over c*d") + '((/ (+ (var a var-a) (var b var-b)) + (* (var c var-c) (var d var-d)))))) + (should (equal (math-read-exprs "a/b/c") + '((/ (/ (var a var-a) (var b var-b)) + (var c var-c)))))) + (calc-set-language nil))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calendar/cal-julian-tests.el b/test/lisp/calendar/cal-julian-tests.el new file mode 100644 index 00000000000..76118b3d7f5 --- /dev/null +++ b/test/lisp/calendar/cal-julian-tests.el @@ -0,0 +1,72 @@ +;;; cal-julian-tests.el --- tests for calendar/cal-julian.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'cal-julian) + +(ert-deftest cal-julian-test-to-absolute () + (should (equal (calendar-gregorian-from-absolute + (calendar-julian-to-absolute + '(10 25 1917))) + '(11 7 1917)))) + +(ert-deftest cal-julian-test-from-absolute () + (should (equal (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + '(11 7 1917))) + '(10 25 1917)))) + +(ert-deftest cal-julian-test-date-string () + (should (equal (let ((calendar-date-display-form calendar-iso-date-display-form)) + (calendar-julian-date-string '(11 7 1917))) + "1917-10-25"))) + +(defmacro with-cal-julian-test (&rest body) + `(save-window-excursion + (unwind-protect + (progn + (calendar) + ,@body) + (kill-buffer "*Calendar*")))) + +(ert-deftest cal-julian-test-goto-date () + (with-cal-julian-test + (calendar-julian-goto-date '(10 25 1917)) + (should (looking-at "7")))) + +(ert-deftest cal-julian-test-astro-to-and-from-absolute () + (should (= (+ (calendar-astro-to-absolute 0.0) + (calendar-astro-from-absolute 0.0)) + 0.0))) + +(ert-deftest cal-julian-calendar-astro-date-string () + (should (equal (calendar-astro-date-string '(10 25 1917)) "2421527"))) + +(ert-deftest calendar-astro-goto-day-number () + (with-cal-julian-test + (calendar-astro-goto-day-number 2421527) + (backward-char) + (should (looking-at "25")))) + +(provide 'cal-julian-tests) +;;; cal-julian-tests.el ends here diff --git a/test/lisp/calendar/icalendar-resources/import-bug-11473.diary-european b/test/lisp/calendar/icalendar-resources/import-bug-11473.diary-european new file mode 100644 index 00000000000..97348ae0498 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-11473.diary-european @@ -0,0 +1,10 @@ +&15/5/2012 15:00-15:30 Query + Desc: + Whassup? + + + Location: phone + Organizer: MAILTO:a.luser@foo.com + Status: CONFIRMED + Class: PUBLIC + UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-11473.ics b/test/lisp/calendar/icalendar-resources/import-bug-11473.ics new file mode 100644 index 00000000000..bc3a6c69fb7 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-11473.ics @@ -0,0 +1,54 @@ +BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft Exchange Server 2007 +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna +BEGIN:STANDARD +DTSTART:16010101T030000 +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +ORGANIZER;CN="A. Luser":MAILTO:a.luser@foo.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN="Luser, Oth + er":MAILTO:other.luser@foo.com +DESCRIPTION;LANGUAGE=en-US:\nWhassup?\n\n +SUMMARY;LANGUAGE=en-US:Query +DTSTART;TZID="(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna" + :20120515T150000 +DTEND;TZID="(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna":2 + 0120515T153000 +UID:040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000 + 010000000575268034ECDB649A15349B1BF240F15 +RECURRENCE-ID;TZID="(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, V + ienna":20120515T170000 +CLASS:PUBLIC +PRIORITY:5 +DTSTAMP:20120514T153645Z +TRANSP:OPAQUE +STATUS:CONFIRMED +SEQUENCE:15 +LOCATION;LANGUAGE=en-US:phone +X-MICROSOFT-CDO-APPT-SEQUENCE:15 +X-MICROSOFT-CDO-OWNERAPPTID:1907632092 +X-MICROSOFT-CDO-BUSYSTATUS:TENTATIVE +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-INSTTYPE:3 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT15M +END:VALARM +END:VEVENT +END:VCALENDAR
\ No newline at end of file diff --git a/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-american b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-american new file mode 100644 index 00000000000..392345fe0a2 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-american @@ -0,0 +1,6 @@ +&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-european b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-european new file mode 100644 index 00000000000..6a64cf6a8e9 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-european @@ -0,0 +1,6 @@ +&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-iso b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-iso new file mode 100644 index 00000000000..e0fadbf94dc --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-22092.diary-iso @@ -0,0 +1,6 @@ +&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - + Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 + Location: Stavanger-Sola + Organizer: noreply@norwegian.no + Class: PUBLIC + UID: RFCALITEM1 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-22092.ics b/test/lisp/calendar/icalendar-resources/import-bug-22092.ics new file mode 100644 index 00000000000..4a4c679da9c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-22092.ics @@ -0,0 +1,30 @@ +BEGIN:VCALENDAR
+PRODID:-//www.norwegian.no//iCalendar MIMEDIR//EN
+VERSION:2.0
+METHOD:REQUEST
+BEGIN:VEVENT
+UID:RFCALITEM1
+SEQUENCE:1512040950
+DTSTAMP:20141204T095043Z
+ORGANIZER:noreply@norwegian.no
+DTSTART:20141208T173000Z
+ +DTEND:20141208T215500Z
+ +LOCATION:Stavanger-Sola
+ +DESCRIPTION:Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390
+ +X-ALT-DESC;FMTTYPE=text/html:<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"><html><head><META NAME="Generator" CONTENT="MS Exchange Server version 08.00.0681.000"><title></title></head><body><b><font face="Calibri" size="3">Reisereferanse</p></body></html> +SUMMARY:Norwegian til Tromsoe-Langnes -
+ +CATEGORIES:Appointment
+ + +PRIORITY:5
+ +CLASS:PUBLIC
+ +TRANSP:OPAQUE
+END:VEVENT
+END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-american b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-american new file mode 100644 index 00000000000..b3308f1fcfa --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-american @@ -0,0 +1,5 @@ +&%%(and (not (diary-date 1 6 2016)) (not (diary-date 2 3 2016)) (not (diary-date 3 2 2016)) (not (diary-date 5 4 2016)) (not (diary-date 6 1 2016)) (diary-float t 3 1) (diary-block 12 2 2015 1 1 9999)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a diff --git a/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-european b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-european new file mode 100644 index 00000000000..acba714b527 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-european @@ -0,0 +1,5 @@ +&%%(and (not (diary-date 6 1 2016)) (not (diary-date 3 2 2016)) (not (diary-date 2 3 2016)) (not (diary-date 4 5 2016)) (not (diary-date 1 6 2016)) (diary-float t 3 1) (diary-block 2 12 2015 1 1 9999)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a diff --git a/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-iso b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-iso new file mode 100644 index 00000000000..2c18395dea8 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-24199.diary-iso @@ -0,0 +1,5 @@ +&%%(and (not (diary-date 2016 1 6)) (not (diary-date 2016 2 3)) (not (diary-date 2016 3 2)) (not (diary-date 2016 5 4)) (not (diary-date 2016 6 1)) (diary-float t 3 1) (diary-block 2015 12 2 9999 1 1)) 12:46-16:00 Summary + Desc: Desc + Location: Loc + Class: DEFAULT + UID: 9188710a-08a7-4061-bae3-d4cf4972599a diff --git a/test/lisp/calendar/icalendar-resources/import-bug-24199.ics b/test/lisp/calendar/icalendar-resources/import-bug-24199.ics new file mode 100644 index 00000000000..a307c2da3ca --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-24199.ics @@ -0,0 +1,25 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:Summary +DESCRIPTION:Desc +LOCATION:Loc +DTSTART:20151202T124600 +DTEND:20151202T160000 +RRULE:FREQ=MONTHLY;BYDAY=1WE;INTERVAL=1 +EXDATE:20160106T114600Z +EXDATE:20160203T114600Z +EXDATE:20160302T114600Z +EXDATE:20160504T104600Z +EXDATE:20160601T104600Z +CLASS:DEFAULT +TRANSP:OPAQUE +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER;VALUE=DURATION:-PT3H +END:VALARM +LAST-MODIFIED:20160805T191040Z +UID:9188710a-08a7-4061-bae3-d4cf4972599a +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-american b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-american new file mode 100644 index 00000000000..c546fa9a97c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-american @@ -0,0 +1 @@ +&11/5/2018 21:00 event with same start/end time diff --git a/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-european b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-european new file mode 100644 index 00000000000..28e53960536 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-european @@ -0,0 +1 @@ +&5/11/2018 21:00 event with same start/end time diff --git a/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-iso b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-iso new file mode 100644 index 00000000000..faa7aeafeb5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-33277.diary-iso @@ -0,0 +1 @@ +&2018/11/5 21:00 event with same start/end time diff --git a/test/lisp/calendar/icalendar-resources/import-bug-33277.ics b/test/lisp/calendar/icalendar-resources/import-bug-33277.ics new file mode 100644 index 00000000000..a4122a28007 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-33277.ics @@ -0,0 +1,15 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART:20181105T200000Z +DTSTAMP:20181105T181652Z +DESCRIPTION: +LAST-MODIFIED:20181105T181646Z +LOCATION: +SEQUENCE:0 +SUMMARY:event with same start/end time +TRANSP:OPAQUE +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-american b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-american new file mode 100644 index 00000000000..30deea9911a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-american @@ -0,0 +1,7 @@ +&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-european b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-european new file mode 100644 index 00000000000..ba16c02305a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-european @@ -0,0 +1,7 @@ +&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-iso b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-iso new file mode 100644 index 00000000000..7794e586f37 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-6766.diary-iso @@ -0,0 +1,7 @@ +&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum + Status: CONFIRMED + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1262 +&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking + Class: PUBLIC + UID: 8814e3f9-7482-408f-996c-3bfe486a1263 diff --git a/test/lisp/calendar/icalendar-resources/import-bug-6766.ics b/test/lisp/calendar/icalendar-resources/import-bug-6766.ics new file mode 100644 index 00000000000..451391be025 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-bug-6766.ics @@ -0,0 +1,28 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +CLASS:PUBLIC +DTEND;TZID=America/New_York:20100421T120000 +DTSTAMP:20100525T141214Z +DTSTART;TZID=America/New_York:20100421T113000 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR +SEQUENCE:1 +STATUS:CONFIRMED +SUMMARY:Scrum +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1262 +END:VEVENT +BEGIN:VEVENT +CLASS:PUBLIC +DTSTAMP:20100525T141214Z +DTSTART;VALUE=DATE:20100422 +DTEND;VALUE=DATE:20100423 +RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH +SEQUENCE:1 +SUMMARY:Tues + Thurs thinking +TRANSP:OPAQUE +UID:8814e3f9-7482-408f-996c-3bfe486a1263 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-duration-2.diary-american b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-american new file mode 100644 index 00000000000..56f41d6ad9e --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-american @@ -0,0 +1,3 @@ +&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda diff --git a/test/lisp/calendar/icalendar-resources/import-duration-2.diary-european b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-european new file mode 100644 index 00000000000..999102ab6b4 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-european @@ -0,0 +1,3 @@ +&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda diff --git a/test/lisp/calendar/icalendar-resources/import-duration-2.diary-iso b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-iso new file mode 100644 index 00000000000..393937e6cd9 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration-2.diary-iso @@ -0,0 +1,3 @@ +&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub + Class: PUBLIC + UID: 20041127T183329Z-18215-1001-4536-49109@andromeda diff --git a/test/lisp/calendar/icalendar-resources/import-duration-2.ics b/test/lisp/calendar/icalendar-resources/import-duration-2.ics new file mode 100644 index 00000000000..eb8a03ba36f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration-2.ics @@ -0,0 +1,17 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:20041127T183329Z-18215-1001-4536-49109@andromeda +DTSTAMP:20041127T183315Z +LAST-MODIFIED:20041127T183329 +SUMMARY:Urlaub +DTSTART;VALUE=DATE:20011221 +DTEND;VALUE=DATE:20011221 +RRULE:FREQ=DAILY;UNTIL=20011229;INTERVAL=1;WKST=SU +CLASS:PUBLIC +SEQUENCE:1 +CREATED:20041127T183329 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-duration.diary-american b/test/lisp/calendar/icalendar-resources/import-duration.diary-american new file mode 100644 index 00000000000..268736a8cd0 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration.diary-american @@ -0,0 +1 @@ +&%%(and (diary-block 2 17 2005 2 23 2005)) duration diff --git a/test/lisp/calendar/icalendar-resources/import-duration.diary-european b/test/lisp/calendar/icalendar-resources/import-duration.diary-european new file mode 100644 index 00000000000..7d852ddcd3c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration.diary-european @@ -0,0 +1 @@ +&%%(and (diary-block 17 2 2005 23 2 2005)) duration diff --git a/test/lisp/calendar/icalendar-resources/import-duration.diary-iso b/test/lisp/calendar/icalendar-resources/import-duration.diary-iso new file mode 100644 index 00000000000..5d3a714284e --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-block 2005 2 17 2005 2 23)) duration diff --git a/test/lisp/calendar/icalendar-resources/import-duration.ics b/test/lisp/calendar/icalendar-resources/import-duration.ics new file mode 100644 index 00000000000..67f5c73571b --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-duration.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20050217 +SUMMARY:duration +DURATION:P7D +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-american b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-american new file mode 100644 index 00000000000..d1b1992a022 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-american @@ -0,0 +1,4 @@ +&7/23/2011 event-1 +&7/24/2011 event-2 +&7/25/2011 event-3a +&7/25/2011 event-3b diff --git a/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-european b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-european new file mode 100644 index 00000000000..f068354220c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-european @@ -0,0 +1,4 @@ +&23/7/2011 event-1 +&24/7/2011 event-2 +&25/7/2011 event-3a +&25/7/2011 event-3b diff --git a/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-iso b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-iso new file mode 100644 index 00000000000..5685e4708a7 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.diary-iso @@ -0,0 +1,4 @@ +&2011/7/23 event-1 +&2011/7/24 event-2 +&2011/7/25 event-3a +&2011/7/25 event-3b diff --git a/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.ics b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.ics new file mode 100644 index 00000000000..69a02c09b1b --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-multiple-vcalendars.ics @@ -0,0 +1,21 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110723 +SUMMARY:event-1 +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110724 +SUMMARY:event-2 +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3a +END:VEVENT +BEGIN:VEVENT +DTSTART;VALUE=DATE:20110725 +SUMMARY:event-3b +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-american new file mode 100644 index 00000000000..780e3a8ce64 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-american @@ -0,0 +1 @@ +&9/19/2003 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-european new file mode 100644 index 00000000000..7e0cd21b784 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-european @@ -0,0 +1 @@ +&19/9/2003 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-iso new file mode 100644 index 00000000000..c7311286619 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.diary-iso @@ -0,0 +1 @@ +&2003/9/19 09:00-11:30 non-recurring diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-1.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.ics new file mode 100644 index 00000000000..cd471efc861 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-1.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-american new file mode 100644 index 00000000000..1d4bb6a337e --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-american @@ -0,0 +1 @@ +&9/19/2003 non-recurring allday diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-european new file mode 100644 index 00000000000..b56c7f4e17f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-european @@ -0,0 +1 @@ +&19/9/2003 non-recurring allday diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-iso new file mode 100644 index 00000000000..f1c70ab34c3 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.diary-iso @@ -0,0 +1 @@ +&2003/9/19 non-recurring allday diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics new file mode 100644 index 00000000000..4efa8ffa133 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-all-day.ics @@ -0,0 +1,9 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:non-recurring allday +DTSTART;VALUE=DATE-TIME:20030919 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-american new file mode 100644 index 00000000000..2eb8c0ab686 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-american @@ -0,0 +1,4 @@ +&11/23/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-european new file mode 100644 index 00000000000..394eae8bb77 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-european @@ -0,0 +1,4 @@ +&23/11/2004 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-iso new file mode 100644 index 00000000000..5e8bdf417d5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.diary-iso @@ -0,0 +1,4 @@ +&2004/11/23 14:45-15:45 another example + Status: TENTATIVE + Class: PRIVATE + UID: 6161a312-3902-11d9-b512-f764153bb28b diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.ics new file mode 100644 index 00000000000..b145e418791 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-another-example.ics @@ -0,0 +1,23 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID + :6161a312-3902-11d9-b512-f764153bb28b +SUMMARY + :another example +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-american new file mode 100644 index 00000000000..b22234229cf --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-american @@ -0,0 +1,4 @@ +&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-european new file mode 100644 index 00000000000..8043482442f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-european @@ -0,0 +1,4 @@ +&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-iso new file mode 100644 index 00000000000..e0f1896114f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.diary-iso @@ -0,0 +1,4 @@ +&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien + Status: TENTATIVE + Class: PRIVATE + UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-block.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.ics new file mode 100644 index 00000000000..0c52ba3d66a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-block.ics @@ -0,0 +1,16 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:748f2da0-0d9b-11d8-97af-b4ec8686ea61 +SUMMARY:Sommerferien +STATUS:TENTATIVE +CLASS:PRIVATE +X-MOZILLA-ALARM-DEFAULT-UNITS:Minuten +X-MOZILLA-RECUR-DEFAULT-INTERVAL:0 +DTSTART;VALUE=DATE:20040719 +DTEND;VALUE=DATE:20040828 +DTSTAMP:20031103T011641Z +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-american new file mode 100644 index 00000000000..2954d0c4fd1 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-american @@ -0,0 +1,4 @@ +&11/23/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-european new file mode 100644 index 00000000000..7745fc811b4 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-european @@ -0,0 +1,4 @@ +&23/11/2004 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-iso new file mode 100644 index 00000000000..8c19a95ed2d --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.diary-iso @@ -0,0 +1,4 @@ +&2004/11/23 14:00-14:30 folded summary + Status: TENTATIVE + Class: PRIVATE + UID: 04979712-3902-11d9-93dd-8f9f4afe08da diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.ics new file mode 100644 index 00000000000..e3ecee9dae8 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-folded-summary.ics @@ -0,0 +1,25 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID + :04979712-3902-11d9-93dd-8f9f4afe08da +SUMMARY + :folded summary +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-american b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-american new file mode 100644 index 00000000000..84cd464c568 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-american @@ -0,0 +1 @@ +&9/19/2003 long summary diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-european b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-european new file mode 100644 index 00000000000..5d6524202c3 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-european @@ -0,0 +1 @@ +&19/9/2003 long summary diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-iso b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-iso new file mode 100644 index 00000000000..d2300522d9a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.diary-iso @@ -0,0 +1 @@ +&2003/9/19 long summary diff --git a/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.ics b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.ics new file mode 100644 index 00000000000..39ae02f10ca --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-non-recurring-long-summary.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:long + summary +DTSTART;VALUE=DATE:20030919 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-american new file mode 100644 index 00000000000..e6c8712d254 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-american @@ -0,0 +1,6 @@ +&5/9/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-european new file mode 100644 index 00000000000..cecca070a51 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.diary-european @@ -0,0 +1,6 @@ +&9/5/2003 07:00-12:00 On-Site Interview + Desc: 10:30am - Blah + Location: Cccc + Organizer: MAILTO:aaaaaaa@aaaaaaa.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.ics new file mode 100644 index 00000000000..decc8df5451 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-05-29.ics @@ -0,0 +1,54 @@ +BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Kolkata, Chennai, Mumbai, New Delhi +X-MICROSOFT-CDO-TZID:23 +BEGIN:STANDARD +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T000000 +TZOFFSETFROM:+0530 +TZOFFSETTO:+0530 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030509T043439Z +DTSTART;TZID="Kolkata, Chennai, Mumbai, New Delhi":20030509T103000 +SUMMARY:On-Site Interview +UID:040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000 + 010000000DB823520692542408ED02D7023F9DFF9 +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN="Xxxxx + xxx Xxxxxxxxxxxx":MAILTO:xxxxxxxx@xxxxxxx.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN="Yyyyyyy Y + yyyy":MAILTO:yyyyyyy@yyyyyyy.com +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN="Zzzz Zzzz + zz":MAILTO:zzzzzz@zzzzzzz.com +ORGANIZER;CN="Aaaaaa Aaaaa":MAILTO:aaaaaaa@aaaaaaa.com +LOCATION:Cccc +DTEND;TZID="Kolkata, Chennai, Mumbai, New Delhi":20030509T153000 +DESCRIPTION:10:30am - Blah +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030509T043439Z +LAST-MODIFIED:20030509T043459Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:126441427 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-american new file mode 100644 index 00000000000..f2c914184e7 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-american @@ -0,0 +1,6 @@ +&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-european new file mode 100644 index 00000000000..89cff58af42 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.diary-european @@ -0,0 +1,6 @@ +&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX + Desc: 753 Zeichen hier radiert + Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) + Organizer: MAILTO:xxx@xxxxx.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.ics new file mode 100644 index 00000000000..6bb5b05af17 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18a.ics @@ -0,0 +1,36 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTAMP:20030618T195512Z +DTSTART;TZID="Mountain Time (US & Canada)":20030623T110000 +SUMMARY:Dress Rehearsal for XXXX-XXXX +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN="AAAAA,AAA + AA (A-AAAAAAA,ex1)":MAILTO:aaaaa_aaaaa@aaaaa.com +ORGANIZER;CN="ABCD,TECHTRAINING + (A-Americas,exgen1)":MAILTO:xxx@xxxxx.com +LOCATION:555 or TN 555-5555 ID 5555 & NochWas (see below) +DTEND;TZID="Mountain Time (US & Canada)":20030623T120000 +DESCRIPTION:753 Zeichen hier radiert +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T195518Z +LAST-MODIFIED:20030618T195527Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-american new file mode 100644 index 00000000000..2c0774cdd83 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-american @@ -0,0 +1,6 @@ +&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-european new file mode 100644 index 00000000000..95aac168699 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.diary-european @@ -0,0 +1,6 @@ +&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 + Desc: Viele Zeichen standen hier früher + Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) + Organizer: MAILTO:bbb@bbbbb.com + Status: CONFIRMED + UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.ics new file mode 100644 index 00000000000..1523135adf3 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2003-06-18b.ics @@ -0,0 +1,55 @@ +BEGIN:VCALENDAR +METHOD:REQUEST +PRODID:Microsoft CDO for Microsoft Exchange +VERSION:2.0 +BEGIN:VTIMEZONE +TZID:Mountain Time (US & Canada) +X-MICROSOFT-CDO-TZID:12 +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETFROM:-0600 +TZOFFSETTO:-0700 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=10;BYDAY=-1SU +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETFROM:-0700 +TZOFFSETTO:-0600 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=4;BYDAY=1SU +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20030618T230323Z +DTSTART;TZID="Mountain Time (US & Canada)":20030623T090000 +SUMMARY:Updated: Dress Rehearsal for ABC01-15 +UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 + 0100000007C3A6D65EE726E40B7F3D69A23BD567E +ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;X-REPLYTIME=20030618T20 + 0700Z;RSVP=TRUE;CN="AAAAA,AAAAAA +\(A-AAAAAAA,ex1)":MAILTO:aaaaaa_aaaaa@aaaaa + .com +ORGANIZER;CN="ABCD,TECHTRAINING +\(A-Americas,exgen1)":MAILTO:bbb@bbbbb.com +LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) +DTEND;TZID="Mountain Time (US & Canada)":20030623T100000 +DESCRIPTION:Viele Zeichen standen hier früher +SEQUENCE:0 +PRIORITY:5 +CLASS: +CREATED:20030618T230326Z +LAST-MODIFIED:20030618T230335Z +STATUS:CONFIRMED +TRANSP:OPAQUE +X-MICROSOFT-CDO-BUSYSTATUS:BUSY +X-MICROSOFT-CDO-INSTTYPE:0 +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +X-MICROSOFT-CDO-ALLDAYEVENT:FALSE +X-MICROSOFT-CDO-IMPORTANCE:1 +X-MICROSOFT-CDO-OWNERAPPTID:1022519251 +BEGIN:VALARM +ACTION:DISPLAY +DESCRIPTION:REMINDER +TRIGGER;RELATED=START:-PT00H15M00S +END:VALARM +END:VEVENT +END:VCALENDAR
\ No newline at end of file diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-american new file mode 100644 index 00000000000..a986f700ba2 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-american @@ -0,0 +1,19 @@ +&11/23/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&11/23/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 11 12 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 11 19 2004 11 19 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 11 1 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-european new file mode 100644 index 00000000000..cbfe99eb8e3 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.diary-european @@ -0,0 +1,19 @@ +&23/11/2004 14:00-14:30 Jjjjj & Wwwww + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb + Status: TENTATIVE + Class: PRIVATE +&23/11/2004 11:00-12:00 Hhhhhhhh + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 14 12 11 2004)) 14:00-18:30 MMM Aaaaaaaaa + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-block 19 11 2004 19 11 2004)) Rrrr/Cccccc ii Aaaaaaaa + Desc: Vvvvv Rrrr aaa Cccccc + Status: TENTATIVE + Class: PRIVATE +&%%(and (diary-cyclic 7 1 11 2004)) Wwww aa hhhh + Status: TENTATIVE + Class: PRIVATE diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.ics new file mode 100644 index 00000000000..9edb682fcad --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2004-11-19.ics @@ -0,0 +1,120 @@ +BEGIN:VCALENDAR +VERSION + :2.0 +PRODID + :-//Mozilla.org/NONSGML Mozilla Calendar V1.0//EN +BEGIN:VEVENT +SUMMARY + :Jjjjj & Wwwww +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T140000 +DTEND + :20041123T143000 +DTSTAMP + :20041118T013430Z +LAST-MODIFIED + :20041118T013640Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :BB Aaaaaaaa Bbbbb +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T144500 +DTEND + :20041123T154500 +DTSTAMP + :20041118T013641Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Hhhhhhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + :20041123T110000 +DTEND + :20041123T120000 +DTSTAMP + :20041118T013831Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :MMM Aaaaaaaaa +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +X-MOZILLA-RECUR-DEFAULT-INTERVAL + :2 +RRULE + :FREQ=WEEKLY;INTERVAL=2;BYDAY=FR +DTSTART + :20041112T140000 +DTEND + :20041112T183000 +DTSTAMP + :20041118T014117Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Rrrr/Cccccc ii Aaaaaaaa +DESCRIPTION + :Vvvvv Rrrr aaa Cccccc +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +DTSTART + ;VALUE=DATE + :20041119 +DTEND + ;VALUE=DATE + :20041120 +DTSTAMP + :20041118T013107Z +LAST-MODIFIED + :20041118T014203Z +END:VEVENT +BEGIN:VEVENT +SUMMARY + :Wwww aa hhhh +STATUS + :TENTATIVE +CLASS + :PRIVATE +X-MOZILLA-ALARM-DEFAULT-LENGTH + :0 +RRULE + :FREQ=WEEKLY;INTERVAL=1;BYDAY=MO +DTSTART + ;VALUE=DATE + :20041101 +DTEND + ;VALUE=DATE + :20041102 +DTSTAMP + :20041118T014045Z +LAST-MODIFIED + :20041118T023846Z +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-american new file mode 100644 index 00000000000..ce7d835d96b --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-american @@ -0,0 +1,5 @@ +&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-european new file mode 100644 index 00000000000..3a52b0ab271 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.diary-european @@ -0,0 +1,5 @@ +&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day + Desc: abcdef + Status: CONFIRMED + Class: PRIVATE + UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.ics new file mode 100644 index 00000000000..9eec71fe751 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-02-07.ics @@ -0,0 +1,26 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID + :b60d398e-1dd1-11b2-a159-cf8cb05139f4 +SUMMARY + :Waitangi Day +DESCRIPTION + :abcdef +CATEGORIES + :Public Holiday +STATUS + :CONFIRMED +CLASS + :PRIVATE +DTSTART + ;VALUE=DATE + :20050206 +DTEND + ;VALUE=DATE + :20050207 +DTSTAMP + :20050128T011209Z +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-american new file mode 100644 index 00000000000..23c93d45d9a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-american @@ -0,0 +1,2 @@ +&%%(and (diary-block 2 17 2005 2 23 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-european new file mode 100644 index 00000000000..106e9f3cdd0 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.diary-european @@ -0,0 +1,2 @@ +&%%(and (diary-block 17 2 2005 23 2 2005)) Hhhhhh Aaaaa ii Aaaaaaaa + UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.ics b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.ics new file mode 100644 index 00000000000..ed9faa9b0bd --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-2005-03-01.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20050217 +SUMMARY:Hhhhhh Aaaaa ii Aaaaaaaa +UID:6AFA7558-6994-11D9-8A3A-000A95A0E830-RID +DTSTAMP:20050118T210335Z +DURATION:P7D +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-american b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-american new file mode 100644 index 00000000000..290edb88760 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-american @@ -0,0 +1,4 @@ +&11/16/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-european b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-european new file mode 100644 index 00000000000..c56b7a6547a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.diary-european @@ -0,0 +1,4 @@ +&16/11/2014 04:30-05:30 NoDST + Desc: Test event from timezone without DST + Location: Everywhere + UID: 20141116T171439Z-678877132@marudot.com diff --git a/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.ics b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.ics new file mode 100644 index 00000000000..5f147af4f37 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-real-world-no-dst.ics @@ -0,0 +1,26 @@ +BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//www.marudot.com//iCal Event Maker +X-WR-CALNAME:Test +CALSCALE:GREGORIAN +BEGIN:VTIMEZONE +TZID:Asia/Tehran +TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tehran +X-LIC-LOCATION:Asia/Tehran +BEGIN:STANDARD +TZOFFSETFROM:+0330 +TZOFFSETTO:+0330 +TZNAME:IRST +DTSTART:19700101T000000 +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTAMP:20141116T171439Z +UID:20141116T171439Z-678877132@marudot.com +DTSTART;TZID="Asia/Tehran":20141116T070000 +DTEND;TZID="Asia/Tehran":20141116T080000 +SUMMARY:NoDST +DESCRIPTION:Test event from timezone without DST +LOCATION:Everywhere +END:VEVENT +END:VCALENDAR
\ No newline at end of file diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-american new file mode 100644 index 00000000000..7b86b554dd4 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-american @@ -0,0 +1 @@ +&%%(and (diary-anniversary 8 15 2004)) Maria Himmelfahrt diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-european new file mode 100644 index 00000000000..3b82ec09fd5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-european @@ -0,0 +1 @@ +&%%(and (diary-anniversary 15 8 2004)) Maria Himmelfahrt diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-iso new file mode 100644 index 00000000000..7fc99478d4e --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-anniversary 2004 8 15)) Maria Himmelfahrt diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics new file mode 100644 index 00000000000..2996f494167 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-anniversary.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +DTSTART;VALUE=DATE:20040815 +DTEND;VALUE=DATE:20040816 +SUMMARY:Maria Himmelfahrt +RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-american new file mode 100644 index 00000000000..84b6d109953 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 14 9 19 2003) (diary-block 9 19 2003 10 31 2003)) 09:00-11:30 rrule count bi-weekly 3 times diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-european new file mode 100644 index 00000000000..0bebdf8872f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 14 19 9 2003) (diary-block 19 9 2003 31 10 2003)) 09:00-11:30 rrule count bi-weekly 3 times diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-iso new file mode 100644 index 00000000000..11429081abe --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 14 2003 9 19) (diary-block 2003 9 19 2003 10 31)) 09:00-11:30 rrule count bi-weekly 3 times diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.ics new file mode 100644 index 00000000000..888b85bb331 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-bi-weekly.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count bi-weekly 3 times +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY;COUNT=3;INTERVAL=2 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-american new file mode 100644 index 00000000000..23fe9fcaf32 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 10 2 2003)) 09:00-11:30 rrule count daily long diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-european new file mode 100644 index 00000000000..0d4ab669058 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 2 10 2003)) 09:00-11:30 rrule count daily long diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-iso new file mode 100644 index 00000000000..8cecda5c879 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 10 2)) 09:00-11:30 rrule count daily long diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.ics new file mode 100644 index 00000000000..73df19a8196 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-long.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count daily long +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=14;INTERVAL=1 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-american new file mode 100644 index 00000000000..d69bb08c318 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 9 19 2003)) 09:00-11:30 rrule count daily short diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-european new file mode 100644 index 00000000000..33a1ce4cf51 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 19 9 2003)) 09:00-11:30 rrule count daily short diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-iso new file mode 100644 index 00000000000..a06bcba0dc1 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 9 19)) 09:00-11:30 rrule count daily short diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.ics new file mode 100644 index 00000000000..92ffe8be654 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-daily-short.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count daily short +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;COUNT=1;INTERVAL=1 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-american new file mode 100644 index 00000000000..4ce8ef842f8 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date t 19 t) (diary-block 9 19 2003 5 19 2004)) 09:00-11:30 rrule count every second month diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-european new file mode 100644 index 00000000000..09ec3756295 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 5 2004)) 09:00-11:30 rrule count every second month diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-iso new file mode 100644 index 00000000000..ae6feb70d4c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 5 19)) 09:00-11:30 rrule count every second month diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.ics new file mode 100644 index 00000000000..3b27b665498 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-month.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count every second month +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=5 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-american new file mode 100644 index 00000000000..99543aa9596 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2011)) 09:00-11:30 rrule count every second year diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-european new file mode 100644 index 00000000000..3b330886ce0 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2011)) 09:00-11:30 rrule count every second year diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-iso new file mode 100644 index 00000000000..16af52ea91c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2011 9 19)) 09:00-11:30 rrule count every second year diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.ics new file mode 100644 index 00000000000..ce21c34d09a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-every-second-year.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count every second year +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=5 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-american new file mode 100644 index 00000000000..ad5ca0b0ed4 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 19 2004)) 09:00-11:30 rrule count monthly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-european new file mode 100644 index 00000000000..709de3a3fd5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 1 2004)) 09:00-11:30 rrule count monthly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-iso new file mode 100644 index 00000000000..9fc2a2def94 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 1 19)) 09:00-11:30 rrule count monthly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.ics new file mode 100644 index 00000000000..3391ca24252 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-monthly.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count monthly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;INTERVAL=1;COUNT=5 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-american new file mode 100644 index 00000000000..8c1f95b0c05 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2007)) 09:00-11:30 rrule count yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-european new file mode 100644 index 00000000000..e216e224eae --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2007)) 09:00-11:30 rrule count yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-iso new file mode 100644 index 00000000000..3801192ee60 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2007 9 19)) 09:00-11:30 rrule count yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.ics new file mode 100644 index 00000000000..d8569933e0c --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-count-yearly.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule count yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=1;COUNT=5 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-american new file mode 100644 index 00000000000..495fca5f8df --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-european new file mode 100644 index 00000000000..61db14ab24a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-iso new file mode 100644 index 00000000000..0e0a4b19781 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.ics b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.ics new file mode 100644 index 00000000000..8c9cb3b2845 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-two-day.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-american new file mode 100644 index 00000000000..83e5f582d5f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-american @@ -0,0 +1 @@ +&%%(and (not (diary-date 9 25 2003)) (not (diary-date 9 21 2003)) (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily with exceptions diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-european new file mode 100644 index 00000000000..a3c7fdd4177 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-european @@ -0,0 +1 @@ +&%%(and (not (diary-date 25 9 2003)) (not (diary-date 21 9 2003)) (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily with exceptions diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-iso new file mode 100644 index 00000000000..88b4c892d16 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.diary-iso @@ -0,0 +1 @@ +&%%(and (not (diary-date 2003 9 25)) (not (diary-date 2003 9 21)) (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily with exceptions diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics new file mode 100644 index 00000000000..5284bf42d8b --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily-with-exceptions.ics @@ -0,0 +1,12 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule daily with exceptions +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY;INTERVAL=2 +EXDATE:20030921,20030925 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-american new file mode 100644 index 00000000000..9213270fa41 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 9 19 2003)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-european new file mode 100644 index 00000000000..2c70cd7da55 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 19 9 2003)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-iso new file mode 100644 index 00000000000..b201cb44308 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 1 2003 9 19)) 09:00-11:30 rrule daily diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics b/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics new file mode 100644 index 00000000000..6d013b0b4f6 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-daily.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule daily +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=DAILY; +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-american new file mode 100644 index 00000000000..bc5453fe425 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 1 9999)) 09:00-11:30 rrule monthly no end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-european new file mode 100644 index 00000000000..f071519701d --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 t t) (diary-block 19 9 2003 1 1 9999)) 09:00-11:30 rrule monthly no end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-iso new file mode 100644 index 00000000000..3709e933337 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t t 19) (diary-block 2003 9 19 9999 1 1)) 09:00-11:30 rrule monthly no end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics new file mode 100644 index 00000000000..b871658600a --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-no-end.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule monthly no end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY; +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-american new file mode 100644 index 00000000000..638ab8b2327 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-american @@ -0,0 +1 @@ +&%%(and (diary-date t 19 t) (diary-block 9 19 2003 8 19 2005)) 09:00-11:30 rrule monthly with end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-european new file mode 100644 index 00000000000..c70cde25f32 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-european @@ -0,0 +1 @@ +&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 8 2005)) 09:00-11:30 rrule monthly with end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-iso new file mode 100644 index 00000000000..ee51a2142a4 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-date t t 19) (diary-block 2003 9 19 2005 8 19)) 09:00-11:30 rrule monthly with end diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics new file mode 100644 index 00000000000..d8a1fe2e5af --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-monthly-with-end.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule monthly with end +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=MONTHLY;UNTIL=20050819; +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-american new file mode 100644 index 00000000000..d8bf2eba104 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-american @@ -0,0 +1 @@ +&%%(and (diary-cyclic 7 9 19 2003)) 09:00-11:30 rrule weekly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-european new file mode 100644 index 00000000000..e368fde9709 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-european @@ -0,0 +1 @@ +&%%(and (diary-cyclic 7 19 9 2003)) 09:00-11:30 rrule weekly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-iso new file mode 100644 index 00000000000..49cd9d8ace6 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-cyclic 7 2003 9 19)) 09:00-11:30 rrule weekly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics new file mode 100644 index 00000000000..c3f0b8ae933 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-weekly.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule weekly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=WEEKLY; +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-american b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-american new file mode 100644 index 00000000000..a54780b9699 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-american @@ -0,0 +1 @@ +&%%(and (diary-anniversary 9 19 2003)) 09:00-11:30 rrule yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-european b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-european new file mode 100644 index 00000000000..a4bd81d6f2b --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-european @@ -0,0 +1 @@ +&%%(and (diary-anniversary 19 9 2003)) 09:00-11:30 rrule yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-iso b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-iso new file mode 100644 index 00000000000..65a7abe0344 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.diary-iso @@ -0,0 +1 @@ +&%%(and (diary-anniversary 2003 9 19)) 09:00-11:30 rrule yearly diff --git a/test/lisp/calendar/icalendar-resources/import-rrule-yearly.ics b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.ics new file mode 100644 index 00000000000..21cca097f7e --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-rrule-yearly.ics @@ -0,0 +1,11 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +SUMMARY:rrule yearly +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +RRULE:FREQ=YEARLY;INTERVAL=2 +END:VEVENT +END:VCALENDAR + diff --git a/test/lisp/calendar/icalendar-resources/import-with-timezone.diary-iso b/test/lisp/calendar/icalendar-resources/import-with-timezone.diary-iso new file mode 100644 index 00000000000..f99b59213e5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-timezone.diary-iso @@ -0,0 +1,2 @@ +&2012/1/15 15:00-15:30 standardtime +&2012/12/15 11:00-11:30 daylightsavingtime diff --git a/test/lisp/calendar/icalendar-resources/import-with-timezone.ics b/test/lisp/calendar/icalendar-resources/import-with-timezone.ics new file mode 100644 index 00000000000..110a9835e41 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-timezone.ics @@ -0,0 +1,27 @@ +BEGIN:VCALENDAR +BEGIN:VTIMEZONE +TZID:fictional, nonexistent, arbitrary +BEGIN:STANDARD +DTSTART:20100101T000000 +TZOFFSETFROM:+0200 +TZOFFSETTO:-0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:20101201T000000 +TZOFFSETFROM:-0200 +TZOFFSETTO:+0200 +RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +SUMMARY:standardtime +DTSTART;TZID="fictional, nonexistent, arbitrary":20120115T120000 +DTEND;TZID="fictional, nonexistent, arbitrary":20120115T123000 +END:VEVENT +BEGIN:VEVENT +SUMMARY:daylightsavingtime +DTSTART;TZID="fictional, nonexistent, arbitrary":20121215T120000 +DTEND;TZID="fictional, nonexistent, arbitrary":20121215T123000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-resources/import-with-uid.diary-american b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-american new file mode 100644 index 00000000000..9b2f06afc26 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-american @@ -0,0 +1,2 @@ +&9/19/2003 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/icalendar-resources/import-with-uid.diary-european b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-european new file mode 100644 index 00000000000..95db4d40151 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-european @@ -0,0 +1,2 @@ +&19/9/2003 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/icalendar-resources/import-with-uid.diary-iso b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-iso new file mode 100644 index 00000000000..d372e5a3d1f --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-uid.diary-iso @@ -0,0 +1,2 @@ +&2003/9/19 09:00-11:30 non-recurring + UID: 1234567890uid diff --git a/test/lisp/calendar/icalendar-resources/import-with-uid.ics b/test/lisp/calendar/icalendar-resources/import-with-uid.ics new file mode 100644 index 00000000000..db412d9d9f5 --- /dev/null +++ b/test/lisp/calendar/icalendar-resources/import-with-uid.ics @@ -0,0 +1,10 @@ +BEGIN:VCALENDAR +PRODID:-//Emacs//NONSGML icalendar.el//EN +VERSION:2.0 +BEGIN:VEVENT +UID:1234567890uid +SUMMARY:non-recurring +DTSTART;VALUE=DATE-TIME:20030919T090000 +DTEND;VALUE=DATE-TIME:20030919T113000 +END:VEVENT +END:VCALENDAR diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 986255250dc..8b44f639475 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -1,4 +1,4 @@ -;; icalendar-tests.el --- Test suite for icalendar.el +;; icalendar-tests.el --- Test suite for icalendar.el -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008-2020 Free Software Foundation, Inc. @@ -32,6 +32,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'icalendar) ;; ====================================================================== @@ -51,6 +52,15 @@ (replace-regexp-in-string "[ \t\n]+\\'" "" (replace-regexp-in-string "\\`[ \t\n]+" "" string))) +(defun icalendar-tests--get-file-contents (filename) + "Return contents of file in test data directory named FILENAME." + (with-temp-buffer + (let ((coding-system-for-read 'raw-text) + (inhibit-eol-conversion t)) + (insert-file-contents-literally + (ert-resource-file filename)) + (buffer-string)))) + ;; ====================================================================== ;; Tests of functions ;; ====================================================================== @@ -183,6 +193,7 @@ (ert-deftest icalendar--parse-vtimezone () "Test method for `icalendar--parse-vtimezone'." (let (vtimezone result) + ;; testcase: valid timezone with rrule (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE TZID:thename BEGIN:STANDARD @@ -204,6 +215,8 @@ END:VTIMEZONE (message (cdr result)) (should (string= "STD-02:00DST-03:00,M3.5.0/03:00:00,M10.5.0/04:00:00" (cdr result))) + + ;; testcase: name of tz contains comma (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE TZID:anothername, with a comma BEGIN:STANDARD @@ -225,7 +238,8 @@ END:VTIMEZONE (message (cdr result)) (should (string= "STD-02:00DST-03:00,M3.2.1/03:00:00,M10.2.1/04:00:00" (cdr result))) - ;; offsetfrom = offsetto + + ;; testcase: offsetfrom = offsetto (setq vtimezone (icalendar-tests--get-ical-event "BEGIN:VTIMEZONE TZID:Kolkata, Chennai, Mumbai, New Delhi X-MICROSOFT-CDO-TZID:23 @@ -245,7 +259,10 @@ END:VTIMEZONE (should (string= "Kolkata, Chennai, Mumbai, New Delhi" (car result))) (message (cdr result)) (should (string= "STD-05:30DST-05:30,M1.1.1/00:00:00,M1.1.1/00:00:00" - (cdr result))))) + (cdr result))) + + ;; FIXME: add testcase that covers changes for fix of bug#34315 + )) (ert-deftest icalendar--convert-ordinary-to-ical () "Test method for `icalendar--convert-ordinary-to-ical'." @@ -419,11 +436,11 @@ END:VEVENT "))) (should (string= "SUM sum DES des LOC loc ORG org" (icalendar--format-ical-event event))) - (setq icalendar-import-format (lambda (&rest ignore) + (setq icalendar-import-format (lambda (&rest _ignore) "helloworld")) (should (string= "helloworld" (icalendar--format-ical-event event))) (setq icalendar-import-format - (lambda (e) + (lambda (event) (format "-%s-%s-%s-%s-%s-%s-%s-" (icalendar--get-event-property event 'SUMMARY) (icalendar--get-event-property event 'DESCRIPTION) @@ -465,8 +482,7 @@ END:VEVENT (ert-deftest icalendar--decode-isodatetime () "Test `icalendar--decode-isodatetime'." - (let ((tz (getenv "TZ")) - result) + (let ((tz (getenv "TZ"))) (unwind-protect (progn ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) @@ -483,17 +499,132 @@ END:VEVENT (should (equal '(0 0 10 1 8 2013 4 t 10800) (icalendar--decode-isodatetime "20130801T100000"))) + ;; testcase: no time zone in input, shift by -1 days + ;; 1 Jan 2013 10:00 -> 31 Dec 2012 + (should (equal '(0 0 10 31 12 2012 1 nil 7200) + (icalendar--decode-isodatetime "20130101T100000" -1))) + ;; 1 Aug 2013 10:00 (DST) -> 31 Jul 2012 (DST) + (should (equal '(0 0 10 31 7 2013 3 t 10800) + (icalendar--decode-isodatetime "20130801T100000" -1))) + + ;; testcase: UTC time zone specifier in input -> convert to local time - ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2013 01:00 EET + ;; 31 Dec 2013 23:00 UTC -> 1 Jan 2014 01:00 EET (should (equal '(0 0 1 1 1 2014 3 nil 7200) (icalendar--decode-isodatetime "20131231T230000Z"))) ;; 1 Aug 2013 10:00 UTC -> 1 Aug 2013 13:00 EEST (should (equal '(0 0 13 1 8 2013 4 t 10800) (icalendar--decode-isodatetime "20130801T100000Z"))) + ;; testcase: override timezone with Central European Time, 1 Jan 2013 10:00 -> 1 Jan 2013 11:00 + (should (equal '(0 0 11 1 1 2013 2 nil 7200) + (icalendar--decode-isodatetime "20130101T100000" nil + '(3600 "CET")))) + ;; testcase: override timezone (UTC-02:00), 1 Jan 2013 10:00 -> 1 Jan 2013 14:00 + (should (equal '(0 0 14 1 1 2013 2 nil 7200) + (icalendar--decode-isodatetime "20130101T100000" nil -7200))) + + ;; FIXME: add testcase that covers changes for fix of bug#34315 + ) ;; restore time-zone even if something went terribly wrong - (setenv "TZ" tz))) ) + (setenv "TZ" tz)))) + +(ert-deftest icalendar--convert-tz-offset () + "Test `icalendar--convert-tz-offset'." + (let ((tz (getenv "TZ"))) + (unwind-protect + (progn + ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) + (setenv "TZ" "EET-2EEST,M3.5.0/3,M10.5.0/4") + + ;; testcase: artificial input + (should (equal '("DST-03:00" . "M5.1.1/01:23:45") + (icalendar--convert-tz-offset + '((DTSTART nil "________T012345") ; + (TZOFFSETFROM nil "+0200") + (TZOFFSETTO nil "+0300") + (RRULE nil "FREQ=YEARLY;INTERVAL=1;BYDAY=1MO;BYMONTH=5")) + t))) + + ;; testcase: Europe/Berlin Standard + (should (equal '("STD-01:00" . "M10.5.0/03:00:00") + (icalendar--convert-tz-offset + '((TZOFFSETFROM nil "+0200") + (TZOFFSETTO nil "+0100") + (TZNAME nil CET) + (DTSTART nil "19701025T030000") + (RRULE nil "FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU")) + nil))) + + ;; testcase: Europe/Berlin DST + (should (equal '("DST-02:00" . "M3.5.0/02:00:00") + (icalendar--convert-tz-offset + '((TZOFFSETFROM nil "+0100") + (TZOFFSETTO nil "+0200") + (TZNAME nil CEST) + (DTSTART nil "19700329T020000") + (RRULE nil "FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU")) + t))) + + ;; testcase: dtstart is mandatory + (should (null (icalendar--convert-tz-offset + '((TZOFFSETFROM nil "+0100") + (TZOFFSETTO nil "+0200") + (RRULE nil "FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU")) + t))) + + ;; FIXME: rrule and rdate are NOT mandatory! Must fix code + ;; before activating these testcases + ;; ;; testcase: no rrule and no rdate => no result + ;; (should (null (icalendar--convert-tz-offset + ;; '((TZOFFSETFROM nil "+0100") + ;; (TZOFFSETTO nil "+0200") + ;; (DTSTART nil "19700329T020000")) + ;; t))) + ;; ;; testcase: no rrule with rdate => no result + ;; (should (null (icalendar--convert-tz-offset + ;; '((TZOFFSETFROM nil "+0100") + ;; (TZOFFSETTO nil "+0200") + ;; (DTSTART nil "18840101T000000") + ;; (RDATE nil "18840101T000000")) + ;; t))) + ) + ;; restore time-zone even if something went terribly wrong + (setenv "TZ" tz)))) + +(ert-deftest icalendar--decode-isoduration () + "Test `icalendar--decode-isoduration'." + + ;; testcase: 7 days + (should (equal '(0 0 0 7 0 0) + (icalendar--decode-isoduration "P7D"))) + + ;; testcase: 7 days, one second -- see bug#34315 + (should (equal '(1 0 0 7 0 0) + (icalendar--decode-isoduration "P7DT1S"))) + + ;; testcase: 3 hours, 2 minutes, one second + (should (equal '(1 2 3 0 0 0) + (icalendar--decode-isoduration "PT3H2M1S"))) + + ;; testcase: 99 days, 3 hours, 2 minutes, one second -- see bug#34315 + (should (equal '(1 2 3 99 0 0) + (icalendar--decode-isoduration "P99DT3H2M1S"))) + + ;; testcase: 2 weeks + (should (equal '(0 0 0 14 0 0) + (icalendar--decode-isoduration "P2W"))) + + ;; testcase: rfc2445, section 4.3.6: 15 days, 5 hours and 20 seconds -- see bug#34315 + (should (equal '(20 0 5 15 0 0) + (icalendar--decode-isoduration "P15DT5H0M20S"))) + + ;; testcase: rfc2445, section 4.3.6: 7 weeks + (should (equal '(0 0 0 49 0 0) + (icalendar--decode-isoduration "P7W"))) + ) + ;; ====================================================================== ;; Export tests @@ -842,13 +973,16 @@ END:VALARM ;; Import tests ;; ====================================================================== -(defun icalendar-tests--test-import (input expected-iso expected-european - expected-american) +(defun icalendar-tests--test-import (filename expected-iso expected-european + expected-american) "Perform import test. -Argument INPUT icalendar event string. -Argument EXPECTED-ISO expected iso style diary string. -Argument EXPECTED-EUROPEAN expected european style diary string. -Argument EXPECTED-AMERICAN expected american style diary string. +Argument FILENAME ics file to import. +Argument EXPECTED-ISO diary-file containing expected +iso-calendar-style result. +Argument EXPECTED-EUROPEAN diary-file containing expected +european-calendar-style result. +Argument EXPECTED-AMERICAN diary-file containing expected +american-calendar-style result. During import test the timezone is set to Central European Time." (let ((timezone (getenv "TZ"))) (unwind-protect @@ -857,14 +991,7 @@ During import test the timezone is set to Central European Time." ;; Eg hydra.nixos.org. (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") (with-temp-buffer - (if (string-match "^BEGIN:VCALENDAR" input) - (insert input) - (insert "BEGIN:VCALENDAR\nPRODID:-//Emacs//NONSGML icalendar.el//EN\n") - (insert "VERSION:2.0\nBEGIN:VEVENT\n") - (insert input) - (unless (eq (char-before) ?\n) - (insert "\n")) - (insert "END:VEVENT\nEND:VCALENDAR\n")) + (insert (icalendar-tests--get-file-contents filename)) (let ((icalendar-import-format "%s%d%l%o%t%u%c%U") (icalendar-import-format-summary "%s") (icalendar-import-format-location "\n Location: %s") @@ -877,26 +1004,29 @@ During import test the timezone is set to Central European Time." calendar-date-style) (when expected-iso (setq calendar-date-style 'iso) - (icalendar-tests--do-test-import input expected-iso)) + (icalendar-tests--do-test-import + (icalendar-tests--get-file-contents expected-iso))) (when expected-european (setq calendar-date-style 'european) - (icalendar-tests--do-test-import input expected-european)) + (icalendar-tests--do-test-import + (icalendar-tests--get-file-contents expected-european))) (when expected-american (setq calendar-date-style 'american) - (icalendar-tests--do-test-import input expected-american))))) + (icalendar-tests--do-test-import + (icalendar-tests--get-file-contents expected-american)))))) (setenv "TZ" timezone)))) -(defun icalendar-tests--do-test-import (input expected-output) +(defun icalendar-tests--do-test-import (expected-output) "Actually perform import test. -Argument INPUT input icalendar string. -Argument EXPECTED-OUTPUT expected diary string." +Argument EXPECTED-OUTPUT file containing expected diary string." (let ((temp-file (make-temp-file "icalendar-test-diary"))) ;; Test the Catch-the-mysterious-coding-header logic below. ;; Ruby-mode adds an after-save-hook which inserts the header! ;; (save-excursion ;; (find-file temp-file) ;; (ruby-mode)) - (icalendar-import-buffer temp-file t t) + (let ((coding-system-for-write 'raw-text)) + (icalendar-import-buffer temp-file t t)) (save-excursion (find-file temp-file) ;; Check for the mysterious "# coding: ..." header, remove it @@ -924,452 +1054,135 @@ Argument EXPECTED-OUTPUT expected diary string." (ert-deftest icalendar-import-non-recurring () "Perform standard import tests." - (icalendar-tests--test-import - "SUMMARY:non-recurring -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000" - "&2003/9/19 09:00-11:30 non-recurring\n" - "&19/9/2003 09:00-11:30 non-recurring\n" - "&9/19/2003 09:00-11:30 non-recurring\n") - (icalendar-tests--test-import - "SUMMARY:non-recurring allday -DTSTART;VALUE=DATE-TIME:20030919" - "&2003/9/19 non-recurring allday\n" - "&19/9/2003 non-recurring allday\n" - "&9/19/2003 non-recurring allday\n") - (icalendar-tests--test-import - ;; Checkdoc removes trailing blanks. Therefore: format! - (format "%s\n%s\n%s" "SUMMARY:long " " summary" - "DTSTART;VALUE=DATE:20030919") - "&2003/9/19 long summary\n" - "&19/9/2003 long summary\n" - "&9/19/2003 long summary\n") - (icalendar-tests--test-import - "UID:748f2da0-0d9b-11d8-97af-b4ec8686ea61 -SUMMARY:Sommerferien -STATUS:TENTATIVE -CLASS:PRIVATE -X-MOZILLA-ALARM-DEFAULT-UNITS:Minuten -X-MOZILLA-RECUR-DEFAULT-INTERVAL:0 -DTSTART;VALUE=DATE:20040719 -DTEND;VALUE=DATE:20040828 -DTSTAMP:20031103T011641Z -" - "&%%(and (diary-block 2004 7 19 2004 8 27)) Sommerferien - Status: TENTATIVE - Class: PRIVATE - UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 -" - "&%%(and (diary-block 19 7 2004 27 8 2004)) Sommerferien - Status: TENTATIVE - Class: PRIVATE - UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 -" - "&%%(and (diary-block 7 19 2004 8 27 2004)) Sommerferien - Status: TENTATIVE - Class: PRIVATE - UID: 748f2da0-0d9b-11d8-97af-b4ec8686ea61 -") - (icalendar-tests--test-import - "UID - :04979712-3902-11d9-93dd-8f9f4afe08da -SUMMARY - :folded summary -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - :20041123T140000 -DTEND - :20041123T143000 -DTSTAMP - :20041118T013430Z -LAST-MODIFIED - :20041118T013640Z -" - "&2004/11/23 14:00-14:30 folded summary - Status: TENTATIVE - Class: PRIVATE - UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" - "&23/11/2004 14:00-14:30 folded summary - Status: TENTATIVE - Class: PRIVATE - UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n" - "&11/23/2004 14:00-14:30 folded summary - Status: TENTATIVE - Class: PRIVATE - UID: 04979712-3902-11d9-93dd-8f9f4afe08da\n") - - (icalendar-tests--test-import - "UID - :6161a312-3902-11d9-b512-f764153bb28b -SUMMARY - :another example -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - :20041123T144500 -DTEND - :20041123T154500 -DTSTAMP - :20041118T013641Z -" - "&2004/11/23 14:45-15:45 another example - Status: TENTATIVE - Class: PRIVATE - UID: 6161a312-3902-11d9-b512-f764153bb28b\n" - "&23/11/2004 14:45-15:45 another example - Status: TENTATIVE - Class: PRIVATE - UID: 6161a312-3902-11d9-b512-f764153bb28b\n" - "&11/23/2004 14:45-15:45 another example - Status: TENTATIVE - Class: PRIVATE - UID: 6161a312-3902-11d9-b512-f764153bb28b\n")) + (icalendar-tests--test-import "import-non-recurring-1.ics" + "import-non-recurring-1.diary-iso" + "import-non-recurring-1.diary-european" + "import-non-recurring-1.diary-american") + (icalendar-tests--test-import "import-non-recurring-all-day.ics" + "import-non-recurring-all-day.diary-iso" + "import-non-recurring-all-day.diary-european" + "import-non-recurring-all-day.diary-american") + (icalendar-tests--test-import "import-non-recurring-long-summary.ics" + "import-non-recurring-long-summary.diary-iso" + "import-non-recurring-long-summary.diary-european" + "import-non-recurring-long-summary.diary-american") + (icalendar-tests--test-import "import-non-recurring-block.ics" + "import-non-recurring-block.diary-iso" + "import-non-recurring-block.diary-european" + "import-non-recurring-block.diary-american") + (icalendar-tests--test-import "import-non-recurring-folded-summary.ics" + "import-non-recurring-folded-summary.diary-iso" + "import-non-recurring-folded-summary.diary-european" + "import-non-recurring-folded-summary.diary-american") + (icalendar-tests--test-import "import-non-recurring-another-example.ics" + "import-non-recurring-another-example.diary-iso" + "import-non-recurring-another-example.diary-european" + "import-non-recurring-another-example.diary-american")) + (ert-deftest icalendar-import-rrule () - (icalendar-tests--test-import - "SUMMARY:rrule daily -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY; -" - "&%%(and (diary-cyclic 1 2003 9 19)) 09:00-11:30 rrule daily\n" - "&%%(and (diary-cyclic 1 19 9 2003)) 09:00-11:30 rrule daily\n" - "&%%(and (diary-cyclic 1 9 19 2003)) 09:00-11:30 rrule daily\n") - ;; RRULE examples - (icalendar-tests--test-import - "SUMMARY:rrule daily -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY;INTERVAL=2 -" - "&%%(and (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily\n" - "&%%(and (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily\n" - "&%%(and (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily\n") - (icalendar-tests--test-import - "SUMMARY:rrule daily with exceptions -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY;INTERVAL=2 -EXDATE:20030921,20030925 -" - "&%%(and (not (diary-date 2003 9 25)) (not (diary-date 2003 9 21)) (diary-cyclic 2 2003 9 19)) 09:00-11:30 rrule daily with exceptions\n" - "&%%(and (not (diary-date 25 9 2003)) (not (diary-date 21 9 2003)) (diary-cyclic 2 19 9 2003)) 09:00-11:30 rrule daily with exceptions\n" - "&%%(and (not (diary-date 9 25 2003)) (not (diary-date 9 21 2003)) (diary-cyclic 2 9 19 2003)) 09:00-11:30 rrule daily with exceptions\n") - (icalendar-tests--test-import - "SUMMARY:rrule weekly -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=WEEKLY; -" - "&%%(and (diary-cyclic 7 2003 9 19)) 09:00-11:30 rrule weekly\n" - "&%%(and (diary-cyclic 7 19 9 2003)) 09:00-11:30 rrule weekly\n" - "&%%(and (diary-cyclic 7 9 19 2003)) 09:00-11:30 rrule weekly\n") - (icalendar-tests--test-import - "SUMMARY:rrule monthly no end -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY; -" - "&%%(and (diary-date t t 19) (diary-block 2003 9 19 9999 1 1)) 09:00-11:30 rrule monthly no end\n" - "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n" - "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 1 9999)) 09:00-11:30 rrule monthly no end\n") - (icalendar-tests--test-import - "SUMMARY:rrule monthly with end -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY;UNTIL=20050819; -" - "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2005 8 19)) 09:00-11:30 rrule monthly with end\n" - "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 8 2005)) 09:00-11:30 rrule monthly with end\n" - "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 8 19 2005)) 09:00-11:30 rrule monthly with end\n") - (icalendar-tests--test-import - "DTSTART;VALUE=DATE:20040815 -DTEND;VALUE=DATE:20040816 -SUMMARY:Maria Himmelfahrt -RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=8 -" - "&%%(and (diary-anniversary 2004 8 15)) Maria Himmelfahrt\n" - "&%%(and (diary-anniversary 15 8 2004)) Maria Himmelfahrt\n" - "&%%(and (diary-anniversary 8 15 2004)) Maria Himmelfahrt\n") - (icalendar-tests--test-import - "SUMMARY:rrule yearly -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=YEARLY;INTERVAL=2 -" - "&%%(and (diary-anniversary 2003 9 19)) 09:00-11:30 rrule yearly\n" ;FIXME - "&%%(and (diary-anniversary 19 9 2003)) 09:00-11:30 rrule yearly\n" ;FIXME - "&%%(and (diary-anniversary 9 19 2003)) 09:00-11:30 rrule yearly\n") ;FIXME - (icalendar-tests--test-import - "SUMMARY:rrule count daily short -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY;COUNT=1;INTERVAL=1 -" - "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 9 19)) 09:00-11:30 rrule count daily short\n" - "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 19 9 2003)) 09:00-11:30 rrule count daily short\n" - "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 9 19 2003)) 09:00-11:30 rrule count daily short\n") - (icalendar-tests--test-import - "SUMMARY:rrule count daily long -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=DAILY;COUNT=14;INTERVAL=1 -" - "&%%(and (diary-cyclic 1 2003 9 19) (diary-block 2003 9 19 2003 10 2)) 09:00-11:30 rrule count daily long\n" - "&%%(and (diary-cyclic 1 19 9 2003) (diary-block 19 9 2003 2 10 2003)) 09:00-11:30 rrule count daily long\n" - "&%%(and (diary-cyclic 1 9 19 2003) (diary-block 9 19 2003 10 2 2003)) 09:00-11:30 rrule count daily long\n") - (icalendar-tests--test-import - "SUMMARY:rrule count bi-weekly 3 times -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=WEEKLY;COUNT=3;INTERVAL=2 -" - "&%%(and (diary-cyclic 14 2003 9 19) (diary-block 2003 9 19 2003 10 31)) 09:00-11:30 rrule count bi-weekly 3 times\n" - "&%%(and (diary-cyclic 14 19 9 2003) (diary-block 19 9 2003 31 10 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n" - "&%%(and (diary-cyclic 14 9 19 2003) (diary-block 9 19 2003 10 31 2003)) 09:00-11:30 rrule count bi-weekly 3 times\n") - (icalendar-tests--test-import - "SUMMARY:rrule count monthly -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY;INTERVAL=1;COUNT=5 -" - "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 1 19)) 09:00-11:30 rrule count monthly\n" - "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 1 2004)) 09:00-11:30 rrule count monthly\n" - "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 1 19 2004)) 09:00-11:30 rrule count monthly\n") - (icalendar-tests--test-import - "SUMMARY:rrule count every second month -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=MONTHLY;INTERVAL=2;COUNT=5 -" - "&%%(and (diary-date t t 19) (diary-block 2003 9 19 2004 5 19)) 09:00-11:30 rrule count every second month\n" ;FIXME - "&%%(and (diary-date 19 t t) (diary-block 19 9 2003 19 5 2004)) 09:00-11:30 rrule count every second month\n" ;FIXME - "&%%(and (diary-date t 19 t) (diary-block 9 19 2003 5 19 2004)) 09:00-11:30 rrule count every second month\n") ;FIXME - (icalendar-tests--test-import - "SUMMARY:rrule count yearly -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=YEARLY;INTERVAL=1;COUNT=5 -" - "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2007 9 19)) 09:00-11:30 rrule count yearly\n" - "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2007)) 09:00-11:30 rrule count yearly\n" - "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2007)) 09:00-11:30 rrule count yearly\n") - (icalendar-tests--test-import - "SUMMARY:rrule count every second year -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000 -RRULE:FREQ=YEARLY;INTERVAL=2;COUNT=5 -" - "&%%(and (diary-date t 9 19) (diary-block 2003 9 19 2011 9 19)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! - "&%%(and (diary-date 19 9 t) (diary-block 19 9 2003 19 9 2011)) 09:00-11:30 rrule count every second year\n" ;FIXME!!! - "&%%(and (diary-date 9 19 t) (diary-block 9 19 2003 9 19 2011)) 09:00-11:30 rrule count every second year\n") ;FIXME!!! -) + (icalendar-tests--test-import "import-rrule-daily.ics" + "import-rrule-daily.diary-iso" + "import-rrule-daily.diary-european" + "import-rrule-daily.diary-american") + (icalendar-tests--test-import "import-rrule-daily-two-day.ics" + "import-rrule-daily-two-day.diary-iso" + "import-rrule-daily-two-day.diary-european" + "import-rrule-daily-two-day.diary-american") + (icalendar-tests--test-import "import-rrule-daily-with-exceptions.ics" + "import-rrule-daily-with-exceptions.diary-iso" + "import-rrule-daily-with-exceptions.diary-european" + "import-rrule-daily-with-exceptions.diary-american") + (icalendar-tests--test-import "import-rrule-weekly.ics" + "import-rrule-weekly.diary-iso" + "import-rrule-weekly.diary-european" + "import-rrule-weekly.diary-american") + (icalendar-tests--test-import "import-rrule-monthly-no-end.ics" + "import-rrule-monthly-no-end.diary-iso" + "import-rrule-monthly-no-end.diary-european" + "import-rrule-monthly-no-end.diary-american") + (icalendar-tests--test-import "import-rrule-monthly-with-end.ics" + "import-rrule-monthly-with-end.diary-iso" + "import-rrule-monthly-with-end.diary-european" + "import-rrule-monthly-with-end.diary-american") + (icalendar-tests--test-import "import-rrule-anniversary.ics" + "import-rrule-anniversary.diary-iso" + "import-rrule-anniversary.diary-european" + "import-rrule-anniversary.diary-american") + (icalendar-tests--test-import "import-rrule-yearly.ics" + "import-rrule-yearly.diary-iso" + "import-rrule-yearly.diary-european" + "import-rrule-yearly.diary-american") + (icalendar-tests--test-import "import-rrule-count-daily-short.ics" + "import-rrule-count-daily-short.diary-iso" + "import-rrule-count-daily-short.diary-european" + "import-rrule-count-daily-short.diary-american") + (icalendar-tests--test-import "import-rrule-count-daily-long.ics" + "import-rrule-count-daily-long.diary-iso" + "import-rrule-count-daily-long.diary-european" + "import-rrule-count-daily-long.diary-american") + (icalendar-tests--test-import "import-rrule-count-monthly.ics" + "import-rrule-count-monthly.diary-iso" + "import-rrule-count-monthly.diary-european" + "import-rrule-count-monthly.diary-american") + (icalendar-tests--test-import "import-rrule-count-every-second-month.ics" + "import-rrule-count-every-second-month.diary-iso" + "import-rrule-count-every-second-month.diary-european" + "import-rrule-count-every-second-month.diary-american") + (icalendar-tests--test-import "import-rrule-count-yearly.ics" + "import-rrule-count-yearly.diary-iso" + "import-rrule-count-yearly.diary-european" + "import-rrule-count-yearly.diary-american") + (icalendar-tests--test-import "import-rrule-count-every-second-year.ics" + "import-rrule-count-every-second-year.diary-iso" + "import-rrule-count-every-second-year.diary-european" + "import-rrule-count-every-second-year.diary-american") + ) (ert-deftest icalendar-import-duration () - ;; duration - (icalendar-tests--test-import - "DTSTART;VALUE=DATE:20050217 -SUMMARY:duration -DURATION:P7D -" - "&%%(and (diary-block 2005 2 17 2005 2 23)) duration\n" - "&%%(and (diary-block 17 2 2005 23 2 2005)) duration\n" - "&%%(and (diary-block 2 17 2005 2 23 2005)) duration\n") - (icalendar-tests--test-import - "UID:20041127T183329Z-18215-1001-4536-49109@andromeda -DTSTAMP:20041127T183315Z -LAST-MODIFIED:20041127T183329 -SUMMARY:Urlaub -DTSTART;VALUE=DATE:20011221 -DTEND;VALUE=DATE:20011221 -RRULE:FREQ=DAILY;UNTIL=20011229;INTERVAL=1;WKST=SU -CLASS:PUBLIC -SEQUENCE:1 -CREATED:20041127T183329 -" - "&%%(and (diary-cyclic 1 2001 12 21) (diary-block 2001 12 21 2001 12 29)) Urlaub - Class: PUBLIC - UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" - "&%%(and (diary-cyclic 1 21 12 2001) (diary-block 21 12 2001 29 12 2001)) Urlaub - Class: PUBLIC - UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n" - "&%%(and (diary-cyclic 1 12 21 2001) (diary-block 12 21 2001 12 29 2001)) Urlaub - Class: PUBLIC - UID: 20041127T183329Z-18215-1001-4536-49109@andromeda\n")) + (icalendar-tests--test-import "import-duration.ics" + "import-duration.diary-iso" + "import-duration.diary-european" + "import-duration.diary-american") + ;; duration-2: this is actually an rrule test + (icalendar-tests--test-import "import-duration-2.ics" + "import-duration-2.diary-iso" + "import-duration-2.diary-european" + "import-duration-2.diary-american")) (ert-deftest icalendar-import-bug-6766 () ;;bug#6766 -- multiple byday values in a weekly rrule - (icalendar-tests--test-import -"CLASS:PUBLIC -DTEND;TZID=America/New_York:20100421T120000 -DTSTAMP:20100525T141214Z -DTSTART;TZID=America/New_York:20100421T113000 -RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=MO,WE,TH,FR -SEQUENCE:1 -STATUS:CONFIRMED -SUMMARY:Scrum -TRANSP:OPAQUE -UID:8814e3f9-7482-408f-996c-3bfe486a1262 -END:VEVENT -BEGIN:VEVENT -CLASS:PUBLIC -DTSTAMP:20100525T141214Z -DTSTART;VALUE=DATE:20100422 -DTEND;VALUE=DATE:20100423 -RRULE:FREQ=WEEKLY;INTERVAL=1;BYDAY=TU,TH -SEQUENCE:1 -SUMMARY:Tues + Thurs thinking -TRANSP:OPAQUE -UID:8814e3f9-7482-408f-996c-3bfe486a1263 -" -"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 2010 4 21)) 11:30-12:00 Scrum - Status: CONFIRMED - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1262 -&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 2010 4 22)) Tues + Thurs thinking - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1263 -" -"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 21 4 2010)) 11:30-12:00 Scrum - Status: CONFIRMED - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1262 -&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 22 4 2010)) Tues + Thurs thinking - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1263 -" -"&%%(and (memq (calendar-day-of-week date) '(1 3 4 5)) (diary-cyclic 1 4 21 2010)) 11:30-12:00 Scrum - Status: CONFIRMED - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1262 -&%%(and (memq (calendar-day-of-week date) '(2 4)) (diary-cyclic 1 4 22 2010)) Tues + Thurs thinking - Class: PUBLIC - UID: 8814e3f9-7482-408f-996c-3bfe486a1263 -")) + (icalendar-tests--test-import "import-bug-6766.ics" + "import-bug-6766.diary-iso" + "import-bug-6766.diary-european" + "import-bug-6766.diary-american")) (ert-deftest icalendar-import-bug-24199 () ;;bug#24199 -- monthly rule with byday-clause - (icalendar-tests--test-import -" -SUMMARY:Summary -DESCRIPTION:Desc -LOCATION:Loc -DTSTART:20151202T124600 -DTEND:20151202T160000 -RRULE:FREQ=MONTHLY;BYDAY=1WE;INTERVAL=1 -EXDATE:20160106T114600Z -EXDATE:20160203T114600Z -EXDATE:20160302T114600Z -EXDATE:20160504T104600Z -EXDATE:20160601T104600Z -CLASS:DEFAULT -TRANSP:OPAQUE -BEGIN:VALARM -ACTION:DISPLAY -TRIGGER;VALUE=DURATION:-PT3H -END:VALARM -LAST-MODIFIED:20160805T191040Z -UID:9188710a-08a7-4061-bae3-d4cf4972599a -" -"&%%(and (not (diary-date 2016 1 6)) (not (diary-date 2016 2 3)) (not (diary-date 2016 3 2)) (not (diary-date 2016 5 4)) (not (diary-date 2016 6 1)) (diary-float t 3 1) (diary-block 2015 12 2 9999 1 1)) 12:46-16:00 Summary - Desc: Desc - Location: Loc - Class: DEFAULT - UID: 9188710a-08a7-4061-bae3-d4cf4972599a -" -"&%%(and (not (diary-date 6 1 2016)) (not (diary-date 3 2 2016)) (not (diary-date 2 3 2016)) (not (diary-date 4 5 2016)) (not (diary-date 1 6 2016)) (diary-float t 3 1) (diary-block 2 12 2015 1 1 9999)) 12:46-16:00 Summary - Desc: Desc - Location: Loc - Class: DEFAULT - UID: 9188710a-08a7-4061-bae3-d4cf4972599a -" -"&%%(and (not (diary-date 1 6 2016)) (not (diary-date 2 3 2016)) (not (diary-date 3 2 2016)) (not (diary-date 5 4 2016)) (not (diary-date 6 1 2016)) (diary-float t 3 1) (diary-block 12 2 2015 1 1 9999)) 12:46-16:00 Summary - Desc: Desc - Location: Loc - Class: DEFAULT - UID: 9188710a-08a7-4061-bae3-d4cf4972599a -" -)) + (icalendar-tests--test-import "import-bug-24199.ics" + "import-bug-24199.diary-iso" + "import-bug-24199.diary-european" + "import-bug-24199.diary-american")) (ert-deftest icalendar-import-bug-33277 () ;;bug#33277 -- start time equals end time - (icalendar-tests--test-import - "DTSTART:20181105T200000Z -DTSTAMP:20181105T181652Z -DESCRIPTION: -LAST-MODIFIED:20181105T181646Z -LOCATION: -SEQUENCE:0 -SUMMARY:event with same start/end time -TRANSP:OPAQUE -" - - "&2018/11/5 21:00 event with same start/end time\n" - "&5/11/2018 21:00 event with same start/end time\n" - "&11/5/2018 21:00 event with same start/end time\n" - )) + (icalendar-tests--test-import "import-bug-33277.ics" + "import-bug-33277.diary-iso" + "import-bug-33277.diary-european" + "import-bug-33277.diary-american")) (ert-deftest icalendar-import-multiple-vcalendars () - (icalendar-tests--test-import - "DTSTART;VALUE=DATE:20110723 -SUMMARY:event-1 -" - "&2011/7/23 event-1\n" - "&23/7/2011 event-1\n" - "&7/23/2011 event-1\n") - - (icalendar-tests--test-import - "BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0\nBEGIN:VEVENT -DTSTART;VALUE=DATE:20110723 -SUMMARY:event-1 -END:VEVENT -END:VCALENDAR -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -DTSTART;VALUE=DATE:20110724 -SUMMARY:event-2 -END:VEVENT -END:VCALENDAR -BEGIN:VCALENDAR -PRODID:-//Emacs//NONSGML icalendar.el//EN -VERSION:2.0 -BEGIN:VEVENT -DTSTART;VALUE=DATE:20110725 -SUMMARY:event-3a -END:VEVENT -BEGIN:VEVENT -DTSTART;VALUE=DATE:20110725 -SUMMARY:event-3b -END:VEVENT -END:VCALENDAR -" - "&2011/7/23 event-1\n&2011/7/24 event-2\n&2011/7/25 event-3a\n&2011/7/25 event-3b\n" - "&23/7/2011 event-1\n&24/7/2011 event-2\n&25/7/2011 event-3a\n&25/7/2011 event-3b\n" - "&7/23/2011 event-1\n&7/24/2011 event-2\n&7/25/2011 event-3a\n&7/25/2011 event-3b\n")) + (icalendar-tests--test-import "import-multiple-vcalendars.ics" + "import-multiple-vcalendars.diary-iso" + "import-multiple-vcalendars.diary-european" + "import-multiple-vcalendars.diary-american")) (ert-deftest icalendar-import-with-uid () "Perform import test with uid." - (icalendar-tests--test-import - "UID:1234567890uid -SUMMARY:non-recurring -DTSTART;VALUE=DATE-TIME:20030919T090000 -DTEND;VALUE=DATE-TIME:20030919T113000" - "&2003/9/19 09:00-11:30 non-recurring\n UID: 1234567890uid\n" - "&19/9/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n" - "&9/19/2003 09:00-11:30 non-recurring\n UID: 1234567890uid\n")) + (icalendar-tests--test-import "import-with-uid.ics" + "import-with-uid.diary-iso" + "import-with-uid.diary-european" + "import-with-uid.diary-american")) (ert-deftest icalendar-import-with-timezone () ;; This is known to fail on MS-Windows, because the test assumes @@ -1378,42 +1191,13 @@ DTEND;VALUE=DATE-TIME:20030919T113000" :failed :passed) ;; bug#11473 - (icalendar-tests--test-import - "BEGIN:VCALENDAR -BEGIN:VTIMEZONE -TZID:fictional, nonexistent, arbitrary -BEGIN:STANDARD -DTSTART:20100101T000000 -TZOFFSETFROM:+0200 -TZOFFSETTO:-0200 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=01 -END:STANDARD -BEGIN:DAYLIGHT -DTSTART:20101201T000000 -TZOFFSETFROM:-0200 -TZOFFSETTO:+0200 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=1SU;BYMONTH=11 -END:DAYLIGHT -END:VTIMEZONE -BEGIN:VEVENT -SUMMARY:standardtime -DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20120115T120000 -DTEND;TZID=\"fictional, nonexistent, arbitrary\":20120115T123000 -END:VEVENT -BEGIN:VEVENT -SUMMARY:daylightsavingtime -DTSTART;TZID=\"fictional, nonexistent, arbitrary\":20121215T120000 -DTEND;TZID=\"fictional, nonexistent, arbitrary\":20121215T123000 -END:VEVENT -END:VCALENDAR" - ;; "standardtime" begins first sunday in january and is 4 hours behind CET - ;; "daylightsavingtime" begins first sunday in november and is 1 hour before CET - "&2012/1/15 15:00-15:30 standardtime -&2012/12/15 11:00-11:30 daylightsavingtime -" - nil - nil) - ) + ;; "standardtime" begins first sunday in january and is 4 hours behind CET + ;; "daylightsavingtime" begins first sunday in november and is 1 hour before CET + (icalendar-tests--test-import "import-with-timezone.ics" + "import-with-timezone.diary-iso" + nil + nil)) + ;; ====================================================================== ;; Cycle ;; ====================================================================== @@ -1511,237 +1295,27 @@ SUMMARY:and diary-anniversary :failed :passed) ;; 2003-05-29 - (icalendar-tests--test-import - "BEGIN:VCALENDAR -METHOD:REQUEST -PRODID:Microsoft CDO for Microsoft Exchange -VERSION:2.0 -BEGIN:VTIMEZONE -TZID:Kolkata, Chennai, Mumbai, New Delhi -X-MICROSOFT-CDO-TZID:23 -BEGIN:STANDARD -DTSTART:16010101T000000 -TZOFFSETFROM:+0530 -TZOFFSETTO:+0530 -END:STANDARD -BEGIN:DAYLIGHT -DTSTART:16010101T000000 -TZOFFSETFROM:+0530 -TZOFFSETTO:+0530 -END:DAYLIGHT -END:VTIMEZONE -BEGIN:VEVENT -DTSTAMP:20030509T043439Z -DTSTART;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T103000 -SUMMARY:On-Site Interview -UID:040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000 - 010000000DB823520692542408ED02D7023F9DFF9 -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Xxxxx - xxx Xxxxxxxxxxxx\":MAILTO:xxxxxxxx@xxxxxxx.com -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Yyyyyyy Y - yyyy\":MAILTO:yyyyyyy@yyyyyyy.com -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Zzzz Zzzz - zz\":MAILTO:zzzzzz@zzzzzzz.com -ORGANIZER;CN=\"Aaaaaa Aaaaa\":MAILTO:aaaaaaa@aaaaaaa.com -LOCATION:Cccc -DTEND;TZID=\"Kolkata, Chennai, Mumbai, New Delhi\":20030509T153000 -DESCRIPTION:10:30am - Blah -SEQUENCE:0 -PRIORITY:5 -CLASS: -CREATED:20030509T043439Z -LAST-MODIFIED:20030509T043459Z -STATUS:CONFIRMED -TRANSP:OPAQUE -X-MICROSOFT-CDO-BUSYSTATUS:BUSY -X-MICROSOFT-CDO-INSTTYPE:0 -X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY -X-MICROSOFT-CDO-ALLDAYEVENT:FALSE -X-MICROSOFT-CDO-IMPORTANCE:1 -X-MICROSOFT-CDO-OWNERAPPTID:126441427 -BEGIN:VALARM -ACTION:DISPLAY -DESCRIPTION:REMINDER -TRIGGER;RELATED=START:-PT00H15M00S -END:VALARM -END:VEVENT -END:VCALENDAR" - nil - "&9/5/2003 07:00-12:00 On-Site Interview - Desc: 10:30am - Blah - Location: Cccc - Organizer: MAILTO:aaaaaaa@aaaaaaa.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 -" - "&5/9/2003 07:00-12:00 On-Site Interview - Desc: 10:30am - Blah - Location: Cccc - Organizer: MAILTO:aaaaaaa@aaaaaaa.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E0080000000080B6DE661216C301000000000000000010000000DB823520692542408ED02D7023F9DFF9 -") + (icalendar-tests--test-import "import-real-world-2003-05-29.ics" + nil + "import-real-world-2003-05-29.diary-european" + "import-real-world-2003-05-29.diary-american") ;; created with http://apps.marudot.com/ical/ - (icalendar-tests--test-import - "BEGIN:VCALENDAR -VERSION:2.0 -PRODID:-//www.marudot.com//iCal Event Maker -X-WR-CALNAME:Test -CALSCALE:GREGORIAN -BEGIN:VTIMEZONE -TZID:Asia/Tehran -TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tehran -X-LIC-LOCATION:Asia/Tehran -BEGIN:STANDARD -TZOFFSETFROM:+0330 -TZOFFSETTO:+0330 -TZNAME:IRST -DTSTART:19700101T000000 -END:STANDARD -END:VTIMEZONE -BEGIN:VEVENT -DTSTAMP:20141116T171439Z -UID:20141116T171439Z-678877132@marudot.com -DTSTART;TZID=\"Asia/Tehran\":20141116T070000 -DTEND;TZID=\"Asia/Tehran\":20141116T080000 -SUMMARY:NoDST -DESCRIPTION:Test event from timezone without DST -LOCATION:Everywhere -END:VEVENT -END:VCALENDAR" - nil - "&16/11/2014 04:30-05:30 NoDST - Desc: Test event from timezone without DST - Location: Everywhere - UID: 20141116T171439Z-678877132@marudot.com -" - "&11/16/2014 04:30-05:30 NoDST - Desc: Test event from timezone without DST - Location: Everywhere - UID: 20141116T171439Z-678877132@marudot.com -") - + (icalendar-tests--test-import "import-real-world-no-dst.ics" + nil + "import-real-world-no-dst.diary-european" + "import-real-world-no-dst.diary-american") ;; 2003-06-18 a - (icalendar-tests--test-import - "DTSTAMP:20030618T195512Z -DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T110000 -SUMMARY:Dress Rehearsal for XXXX-XXXX -UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 - 0100000007C3A6D65EE726E40B7F3D69A23BD567E -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"AAAAA,AAA - AA (A-AAAAAAA,ex1)\":MAILTO:aaaaa_aaaaa@aaaaa.com -ORGANIZER;CN=\"ABCD,TECHTRAINING - (A-Americas,exgen1)\":MAILTO:xxx@xxxxx.com -LOCATION:555 or TN 555-5555 ID 5555 & NochWas (see below) -DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T120000 -DESCRIPTION:753 Zeichen hier radiert -SEQUENCE:0 -PRIORITY:5 -CLASS: -CREATED:20030618T195518Z -LAST-MODIFIED:20030618T195527Z -STATUS:CONFIRMED -TRANSP:OPAQUE -X-MICROSOFT-CDO-BUSYSTATUS:BUSY -X-MICROSOFT-CDO-INSTTYPE:0 -X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY -X-MICROSOFT-CDO-ALLDAYEVENT:FALSE -X-MICROSOFT-CDO-IMPORTANCE:1 -X-MICROSOFT-CDO-OWNERAPPTID:1022519251 -BEGIN:VALARM -ACTION:DISPLAY -DESCRIPTION:REMINDER -TRIGGER;RELATED=START:-PT00H15M00S -END:VALARM" - nil - "&23/6/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX - Desc: 753 Zeichen hier radiert - Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) - Organizer: MAILTO:xxx@xxxxx.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E -" - "&6/23/2003 11:00-12:00 Dress Rehearsal for XXXX-XXXX - Desc: 753 Zeichen hier radiert - Location: 555 or TN 555-5555 ID 5555 & NochWas (see below) - Organizer: MAILTO:xxx@xxxxx.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E -") + (icalendar-tests--test-import "import-real-world-2003-06-18a.ics" + nil + "import-real-world-2003-06-18a.diary-european" + "import-real-world-2003-06-18a.diary-american") ;; 2003-06-18 b -- uses timezone - (icalendar-tests--test-import - "BEGIN:VCALENDAR -METHOD:REQUEST -PRODID:Microsoft CDO for Microsoft Exchange -VERSION:2.0 -BEGIN:VTIMEZONE -TZID:Mountain Time (US & Canada) -X-MICROSOFT-CDO-TZID:12 -BEGIN:STANDARD -DTSTART:16010101T020000 -TZOFFSETFROM:-0600 -TZOFFSETTO:-0700 -RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=10;BYDAY=-1SU -END:STANDARD -BEGIN:DAYLIGHT -DTSTART:16010101T020000 -TZOFFSETFROM:-0700 -TZOFFSETTO:-0600 -RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=4;BYDAY=1SU -END:DAYLIGHT -END:VTIMEZONE -BEGIN:VEVENT -DTSTAMP:20030618T230323Z -DTSTART;TZID=\"Mountain Time (US & Canada)\":20030623T090000 -SUMMARY:Updated: Dress Rehearsal for ABC01-15 -UID:040000008200E00074C5B7101A82E00800000000608AA7DA9835C301000000000000000 - 0100000007C3A6D65EE726E40B7F3D69A23BD567E -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;X-REPLYTIME=20030618T20 - 0700Z;RSVP=TRUE;CN=\"AAAAA,AAAAAA -\(A-AAAAAAA,ex1)\":MAILTO:aaaaaa_aaaaa@aaaaa - .com -ORGANIZER;CN=\"ABCD,TECHTRAINING -\(A-Americas,exgen1)\":MAILTO:bbb@bbbbb.com -LOCATION:123 or TN 123-1234 ID abcd & SonstWo (see below) -DTEND;TZID=\"Mountain Time (US & Canada)\":20030623T100000 -DESCRIPTION:Viele Zeichen standen hier früher -SEQUENCE:0 -PRIORITY:5 -CLASS: -CREATED:20030618T230326Z -LAST-MODIFIED:20030618T230335Z -STATUS:CONFIRMED -TRANSP:OPAQUE -X-MICROSOFT-CDO-BUSYSTATUS:BUSY -X-MICROSOFT-CDO-INSTTYPE:0 -X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY -X-MICROSOFT-CDO-ALLDAYEVENT:FALSE -X-MICROSOFT-CDO-IMPORTANCE:1 -X-MICROSOFT-CDO-OWNERAPPTID:1022519251 -BEGIN:VALARM -ACTION:DISPLAY -DESCRIPTION:REMINDER -TRIGGER;RELATED=START:-PT00H15M00S -END:VALARM -END:VEVENT -END:VCALENDAR" - nil - "&23/6/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 - Desc: Viele Zeichen standen hier früher - Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) - Organizer: MAILTO:bbb@bbbbb.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E -" - "&6/23/2003 17:00-18:00 Updated: Dress Rehearsal for ABC01-15 - Desc: Viele Zeichen standen hier früher - Location: 123 or TN 123-1234 ID abcd & SonstWo (see below) - Organizer: MAILTO:bbb@bbbbb.com - Status: CONFIRMED - UID: 040000008200E00074C5B7101A82E00800000000608AA7DA9835C3010000000000000000100000007C3A6D65EE726E40B7F3D69A23BD567E -") + (icalendar-tests--test-import "import-real-world-2003-06-18b.ics" + nil + "import-real-world-2003-06-18b.diary-european" + "import-real-world-2003-06-18b.diary-american") ;; export 2004-10-28 block entries (icalendar-tests--test-export nil @@ -1957,169 +1531,10 @@ DTEND;VALUE=DATE-TIME:20041012T150000 SUMMARY:Tue: [2004-10-12] q1") ;; 2004-11-19 - (icalendar-tests--test-import - "BEGIN:VCALENDAR -VERSION - :2.0 -PRODID - :-//Mozilla.org/NONSGML Mozilla Calendar V1.0//EN -BEGIN:VEVENT -SUMMARY - :Jjjjj & Wwwww -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - :20041123T140000 -DTEND - :20041123T143000 -DTSTAMP - :20041118T013430Z -LAST-MODIFIED - :20041118T013640Z -END:VEVENT -BEGIN:VEVENT -SUMMARY - :BB Aaaaaaaa Bbbbb -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - :20041123T144500 -DTEND - :20041123T154500 -DTSTAMP - :20041118T013641Z -END:VEVENT -BEGIN:VEVENT -SUMMARY - :Hhhhhhhh -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - :20041123T110000 -DTEND - :20041123T120000 -DTSTAMP - :20041118T013831Z -END:VEVENT -BEGIN:VEVENT -SUMMARY - :MMM Aaaaaaaaa -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -X-MOZILLA-RECUR-DEFAULT-INTERVAL - :2 -RRULE - :FREQ=WEEKLY;INTERVAL=2;BYDAY=FR -DTSTART - :20041112T140000 -DTEND - :20041112T183000 -DTSTAMP - :20041118T014117Z -END:VEVENT -BEGIN:VEVENT -SUMMARY - :Rrrr/Cccccc ii Aaaaaaaa -DESCRIPTION - :Vvvvv Rrrr aaa Cccccc -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -DTSTART - ;VALUE=DATE - :20041119 -DTEND - ;VALUE=DATE - :20041120 -DTSTAMP - :20041118T013107Z -LAST-MODIFIED - :20041118T014203Z -END:VEVENT -BEGIN:VEVENT -SUMMARY - :Wwww aa hhhh -STATUS - :TENTATIVE -CLASS - :PRIVATE -X-MOZILLA-ALARM-DEFAULT-LENGTH - :0 -RRULE - :FREQ=WEEKLY;INTERVAL=1;BYDAY=MO -DTSTART - ;VALUE=DATE - :20041101 -DTEND - ;VALUE=DATE - :20041102 -DTSTAMP - :20041118T014045Z -LAST-MODIFIED - :20041118T023846Z -END:VEVENT -END:VCALENDAR -" - nil - "&23/11/2004 14:00-14:30 Jjjjj & Wwwww - Status: TENTATIVE - Class: PRIVATE -&23/11/2004 14:45-15:45 BB Aaaaaaaa Bbbbb - Status: TENTATIVE - Class: PRIVATE -&23/11/2004 11:00-12:00 Hhhhhhhh - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-cyclic 14 12 11 2004)) 14:00-18:30 MMM Aaaaaaaaa - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-block 19 11 2004 19 11 2004)) Rrrr/Cccccc ii Aaaaaaaa - Desc: Vvvvv Rrrr aaa Cccccc - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-cyclic 7 1 11 2004)) Wwww aa hhhh - Status: TENTATIVE - Class: PRIVATE -" - "&11/23/2004 14:00-14:30 Jjjjj & Wwwww - Status: TENTATIVE - Class: PRIVATE -&11/23/2004 14:45-15:45 BB Aaaaaaaa Bbbbb - Status: TENTATIVE - Class: PRIVATE -&11/23/2004 11:00-12:00 Hhhhhhhh - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-cyclic 14 11 12 2004)) 14:00-18:30 MMM Aaaaaaaaa - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-block 11 19 2004 11 19 2004)) Rrrr/Cccccc ii Aaaaaaaa - Desc: Vvvvv Rrrr aaa Cccccc - Status: TENTATIVE - Class: PRIVATE -&%%(and (diary-cyclic 7 11 1 2004)) Wwww aa hhhh - Status: TENTATIVE - Class: PRIVATE -") + (icalendar-tests--test-import "import-real-world-2004-11-19.ics" + nil + "import-real-world-2004-11-19.diary-european" + "import-real-world-2004-11-19.diary-american") ;; 2004-09-09 pg (icalendar-tests--test-export @@ -2149,53 +1564,16 @@ DTEND;VALUE=DATE-TIME:20041102T163000 SUMMARY:Zahnarzt") ;; 2005-02-07 lt - (icalendar-tests--test-import - "UID - :b60d398e-1dd1-11b2-a159-cf8cb05139f4 -SUMMARY - :Waitangi Day -DESCRIPTION - :abcdef -CATEGORIES - :Public Holiday -STATUS - :CONFIRMED -CLASS - :PRIVATE -DTSTART - ;VALUE=DATE - :20050206 -DTEND - ;VALUE=DATE - :20050207 -DTSTAMP - :20050128T011209Z" - nil - "&%%(and (diary-block 6 2 2005 6 2 2005)) Waitangi Day - Desc: abcdef - Status: CONFIRMED - Class: PRIVATE - UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 -" - "&%%(and (diary-block 2 6 2005 2 6 2005)) Waitangi Day - Desc: abcdef - Status: CONFIRMED - Class: PRIVATE - UID: b60d398e-1dd1-11b2-a159-cf8cb05139f4 -") + (icalendar-tests--test-import "import-real-world-2005-02-07.ics" + nil + "import-real-world-2005-02-07.diary-european" + "import-real-world-2005-02-07.diary-american") ;; 2005-03-01 lt - (icalendar-tests--test-import - "DTSTART;VALUE=DATE:20050217 -SUMMARY:Hhhhhh Aaaaa ii Aaaaaaaa -UID:6AFA7558-6994-11D9-8A3A-000A95A0E830-RID -DTSTAMP:20050118T210335Z -DURATION:P7D" - nil - "&%%(and (diary-block 17 2 2005 23 2 2005)) Hhhhhh Aaaaa ii Aaaaaaaa - UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n" - "&%%(and (diary-block 2 17 2005 2 23 2005)) Hhhhhh Aaaaa ii Aaaaaaaa - UID: 6AFA7558-6994-11D9-8A3A-000A95A0E830-RID\n") + (icalendar-tests--test-import "import-real-world-2005-03-01.ics" + nil + "import-real-world-2005-03-01.diary-european" + "import-real-world-2005-03-01.diary-american") ;; 2005-03-23 lt (icalendar-tests--test-export @@ -2222,132 +1600,24 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 ") ;; bug#11473 - (icalendar-tests--test-import - "BEGIN:VCALENDAR -METHOD:REQUEST -PRODID:Microsoft Exchange Server 2007 -VERSION:2.0 -BEGIN:VTIMEZONE -TZID:(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna -BEGIN:STANDARD -DTSTART:16010101T030000 -TZOFFSETFROM:+0200 -TZOFFSETTO:+0100 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=10 -END:STANDARD -BEGIN:DAYLIGHT -DTSTART:16010101T020000 -TZOFFSETFROM:+0100 -TZOFFSETTO:+0200 -RRULE:FREQ=YEARLY;INTERVAL=1;BYDAY=-1SU;BYMONTH=3 -END:DAYLIGHT -END:VTIMEZONE -BEGIN:VEVENT -ORGANIZER;CN=\"A. Luser\":MAILTO:a.luser@foo.com -ATTENDEE;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP=TRUE;CN=\"Luser, Oth - er\":MAILTO:other.luser@foo.com -DESCRIPTION;LANGUAGE=en-US:\nWhassup?\n\n -SUMMARY;LANGUAGE=en-US:Query -DTSTART;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\" - :20120515T150000 -DTEND;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, Vienna\":2 - 0120515T153000 -UID:040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000 - 010000000575268034ECDB649A15349B1BF240F15 -RECURRENCE-ID;TZID=\"(UTC+01:00) Amsterdam, Berlin, Bern, Rome, Stockholm, V - ienna\":20120515T170000 -CLASS:PUBLIC -PRIORITY:5 -DTSTAMP:20120514T153645Z -TRANSP:OPAQUE -STATUS:CONFIRMED -SEQUENCE:15 -LOCATION;LANGUAGE=en-US:phone -X-MICROSOFT-CDO-APPT-SEQUENCE:15 -X-MICROSOFT-CDO-OWNERAPPTID:1907632092 -X-MICROSOFT-CDO-BUSYSTATUS:TENTATIVE -X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY -X-MICROSOFT-CDO-ALLDAYEVENT:FALSE -X-MICROSOFT-CDO-IMPORTANCE:1 -X-MICROSOFT-CDO-INSTTYPE:3 -BEGIN:VALARM -ACTION:DISPLAY -DESCRIPTION:REMINDER -TRIGGER;RELATED=START:-PT15M -END:VALARM -END:VEVENT -END:VCALENDAR" - nil - "&15/5/2012 15:00-15:30 Query - Location: phone - Organizer: MAILTO:a.luser@foo.com - Status: CONFIRMED - Class: PUBLIC - UID: 040000008200E00074C5B7101A82E0080000000020FFAED0CFEFCC01000000000000000010000000575268034ECDB649A15349B1BF240F15 -" nil) + (icalendar-tests--test-import "import-bug-11473.ics" + nil + "import-bug-11473.diary-european" + nil) ;; 2015-12-05, mixed line endings and empty lines, see Bug#22092. - (icalendar-tests--test-import - "BEGIN:VCALENDAR\r -PRODID:-//www.norwegian.no//iCalendar MIMEDIR//EN\r -VERSION:2.0\r -METHOD:REQUEST\r -BEGIN:VEVENT\r -UID:RFCALITEM1\r -SEQUENCE:1512040950\r -DTSTAMP:20141204T095043Z\r -ORGANIZER:noreply@norwegian.no\r -DTSTART:20141208T173000Z\r - -DTEND:20141208T215500Z\r - -LOCATION:Stavanger-Sola\r - -DESCRIPTION:Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390\r - -X-ALT-DESC;FMTTYPE=text/html:<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2//EN\"><html><head><META NAME=\"Generator\" CONTENT=\"MS Exchange Server version 08.00.0681.000\"><title></title></head><body><b><font face=\"Calibri\" size=\"3\">Reisereferanse</p></body></html> -SUMMARY:Norwegian til Tromsoe-Langnes -\r - -CATEGORIES:Appointment\r - - -PRIORITY:5\r - -CLASS:PUBLIC\r - -TRANSP:OPAQUE\r -END:VEVENT\r -END:VCALENDAR -" -"&2014/12/8 18:30-22:55 Norwegian til Tromsoe-Langnes - - Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 - Location: Stavanger-Sola - Organizer: noreply@norwegian.no - Class: PUBLIC - UID: RFCALITEM1 -" -"&8/12/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - - Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 - Location: Stavanger-Sola - Organizer: noreply@norwegian.no - Class: PUBLIC - UID: RFCALITEM1 -" -"&12/8/2014 18:30-22:55 Norwegian til Tromsoe-Langnes - - Desc: Fly med Norwegian, reservasjon. Fra Stavanger til Tromsø 8. des 2014 18:30, DY545Fly med Norwegian, reservasjon . Fra Stavanger til Tromsø 8. des 2014 21:00, DY390 - Location: Stavanger-Sola - Organizer: noreply@norwegian.no - Class: PUBLIC - UID: RFCALITEM1 -" -) - ) + (icalendar-tests--test-import "import-bug-22092.ics" + "import-bug-22092.diary-iso" + "import-bug-22092.diary-european" + "import-bug-22092.diary-american")) (defun icalendar-test--format (string &optional day zone) + "Decode and format STRING with DAY and ZONE." (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(defun icalendar-tests--decode-isodatetime (ical-string) +(defun icalendar-tests--decode-isodatetime (_ical-string) + "Test icalendar--decode-isodatetime." (should (equal (icalendar-test--format "20040917T050910-0200") "2004-09-17T03:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910") diff --git a/test/lisp/calendar/iso8601-tests.el b/test/lisp/calendar/iso8601-tests.el index 430680c5077..c835f5792b9 100644 --- a/test/lisp/calendar/iso8601-tests.el +++ b/test/lisp/calendar/iso8601-tests.el @@ -24,49 +24,61 @@ (ert-deftest test-iso8601-date-years () (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil -1 nil))) (should (equal (iso8601-parse-date "-0003") - '(nil nil nil nil nil -3 nil nil nil))) + '(nil nil nil nil nil -3 nil -1 nil))) (should (equal (iso8601-parse-date "+1985") - '(nil nil nil nil nil 1985 nil nil nil)))) + '(nil nil nil nil nil 1985 nil -1 nil)))) (ert-deftest test-iso8601-date-dates () (should (equal (iso8601-parse-date "1985-03-14") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil -1 nil))) (should (equal (iso8601-parse-date "19850314") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-02") - '(nil nil nil nil 2 1985 nil nil nil)))) + '(nil nil nil nil 2 1985 nil -1 nil)))) (ert-deftest test-iso8601-date-obsolete () (should (equal (iso8601-parse-date "--02-01") - '(nil nil nil 1 2 nil nil nil nil))) + '(nil nil nil 1 2 nil nil -1 nil))) (should (equal (iso8601-parse-date "--0201") - '(nil nil nil 1 2 nil nil nil nil)))) + '(nil nil nil 1 2 nil nil -1 nil)))) + +(ert-deftest test-iso8601-date-obsolete-2000 () + ;; These are forms in 5.2.1.3 of the 2000 version of the standard, + ;; e) and f). + (should (equal (iso8601-parse-date "--12") + '(nil nil nil nil 12 nil nil -1 nil))) + (should (equal (iso8601-parse "--12T14") + '(0 0 14 nil 12 nil nil -1 nil))) + (should (equal (iso8601-parse-date "---12") + '(nil nil nil 12 nil nil nil -1 nil))) + (should (equal (iso8601-parse "---12T14:10:12") + '(12 10 14 12 nil nil nil -1 nil)))) (ert-deftest test-iso8601-date-weeks () (should (equal (iso8601-parse-date "2008W39-6") - '(nil nil nil 27 9 2008 nil nil nil))) + '(nil nil nil 27 9 2008 nil -1 nil))) (should (equal (iso8601-parse-date "2009W01-1") - '(nil nil nil 29 12 2008 nil nil nil))) + '(nil nil nil 29 12 2008 nil -1 nil))) (should (equal (iso8601-parse-date "2009W53-7") - '(nil nil nil 3 1 2010 nil nil nil)))) + '(nil nil nil 3 1 2010 nil -1 nil)))) (ert-deftest test-iso8601-date-ordinals () (should (equal (iso8601-parse-date "1981-095") - '(nil nil nil 5 4 1981 nil nil nil)))) + '(nil nil nil 5 4 1981 nil -1 nil)))) (ert-deftest test-iso8601-time () (should (equal (iso8601-parse-time "13:47:30") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "134730") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "1347") - '(0 47 13 nil nil nil nil nil nil)))) + '(0 47 13 nil nil nil nil -1 nil)))) (ert-deftest test-iso8601-combined () (should (equal (iso8601-parse "2008-03-02T13:47:30") - '(30 47 13 2 3 2008 nil nil nil))) + '(30 47 13 2 3 2008 nil -1 nil))) (should (equal (iso8601-parse "2008-03-02T13:47:30Z") '(30 47 13 2 3 2008 nil nil 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30+01:00") @@ -76,13 +88,13 @@ (ert-deftest test-iso8601-duration () (should (equal (iso8601-parse-duration "P3Y6M4DT12H30M5S") - '(5 30 12 4 6 3 nil nil nil))) + '(5 30 12 4 6 3 nil -1 nil))) (should (equal (iso8601-parse-duration "P1M") - '(0 0 0 0 1 0 nil nil nil))) + '(0 0 0 0 1 0 nil -1 nil))) (should (equal (iso8601-parse-duration "PT1M") - '(0 1 0 0 0 0 nil nil nil))) + '(0 1 0 0 0 0 nil -1 nil))) (should (equal (iso8601-parse-duration "P0003-06-04T12:30:05") - '(5 30 12 4 6 3 nil nil nil)))) + '(5 30 12 4 6 3 nil -1 nil)))) (ert-deftest test-iso8601-invalid () (should-not (iso8601-valid-p " 2008-03-02T13:47:30-01")) @@ -101,88 +113,88 @@ (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/P1Y2M10DT2H30M") '((0 0 13 1 3 2007 nil nil 0) (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil)))) + (0 30 2 10 2 1 nil -1 nil)))) (should (equal (iso8601-parse-interval "P1Y2M10DT2H30M/2008-05-11T15:30:00Z") '((0 0 13 1 3 2007 nil nil 0) (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil))))) + (0 30 2 10 2 1 nil -1 nil))))) (ert-deftest standard-test-dates () (should (equal (iso8601-parse-date "19850412") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985W155") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-W15-5") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-04") - '(nil nil nil nil 4 1985 nil nil nil))) + '(nil nil nil nil 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil -1 nil))) (should (equal (iso8601-parse-date "+1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "+19850412") - '(nil nil nil 12 4 1985 nil nil nil)))) + '(nil nil nil 12 4 1985 nil -1 nil)))) (ert-deftest standard-test-time-of-day-local-time () (should (equal (iso8601-parse-time "152746") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:46") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "1528") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:28") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15") - '(0 0 15 nil nil nil nil nil nil)))) + '(0 0 15 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-fractions () (should (equal (iso8601-parse-time "152735,5" t) - '((355 . 10) 27 15 nil nil nil nil nil nil))) + '((355 . 10) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:35,5" t) - '((355 . 10) 27 15 nil nil nil nil nil nil))) + '((355 . 10) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "2320,5" t) - '(30 20 23 nil nil nil nil nil nil))) + '(30 20 23 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "23:20,8" t) - '(48 20 23 nil nil nil nil nil nil))) + '(48 20 23 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "23,3" t) - '(0 18 23 nil nil nil nil nil nil)))) + '(0 18 23 nil nil nil nil -1 nil)))) (ert-deftest nonstandard-test-time-of-day-decimals () (should (equal (iso8601-parse-time "15:27:35.123" t) - '((35123 . 1000) 27 15 nil nil nil nil nil nil))) + '((35123 . 1000) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:35.123456789" t) - '((35123456789 . 1000000000) 27 15 nil nil nil nil nil nil)))) + '((35123456789 . 1000000000) 27 15 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-beginning-of-day () (should (equal (iso8601-parse-time "000000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "00:00:00") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "0000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "00:00") - '(0 0 0 nil nil nil nil nil nil)))) + '(0 0 0 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-utc () (should (equal (iso8601-parse-time "232030Z") @@ -220,11 +232,42 @@ (should (equal (iso8601-parse-time "15:27:46-05") '(46 27 15 nil nil nil nil nil -18000)))) + +(defun test-iso8601-format-time-string-zone-round-trip (offset-minutes z-format) + "Pass OFFSET-MINUTES to format-time-string with Z-FORMAT, a %z variation, +and then to iso8601-parse-zone. The result should be the original offset." + (let* ((offset-seconds (* 60 offset-minutes)) + (zone-string (format-time-string z-format 0 offset-seconds)) + (offset-rt + (condition-case nil + (iso8601-parse-zone zone-string) + (wrong-type-argument (format "(failed to parse %S)" zone-string)))) + ;; compare strings that contain enough info to debug failures + (success (format "%s(%s) -> %S -> %s" + z-format offset-minutes zone-string offset-minutes)) + (actual (format "%s(%s) -> %S -> %s" + z-format offset-minutes zone-string offset-rt))) + (should (equal success actual)))) + +(ert-deftest iso8601-format-time-string-zone-round-trip () + "Round trip zone offsets through format-time-string and iso8601-parse-zone. +Passing a time zone created by format-time-string %z to +iso8601-parse-zone should yield the original offset." + (dolist (offset-minutes + (list + ;; compare hours (1- and 2-digit), minutes, both, neither + (* 5 60) (* 11 60) 5 11 (+ (* 5 60) 30) (+ (* 11 60) 30) 0 + ;; do negative values, too + (* -5 60) (* -11 60) -5 -11 (- (* -5 60) 30) (- (* -11 60) 30))) + (dolist (z-format '("%z" "%:z" "%:::z")) + (test-iso8601-format-time-string-zone-round-trip + offset-minutes z-format)))) + (ert-deftest standard-test-date-and-time-of-day () (should (equal (iso8601-parse "19850412T101530") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985-04-12T10:15:30") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985102T235030Z") '(30 50 23 12 4 1985 nil nil 0))) @@ -232,9 +275,9 @@ '(30 50 23 12 4 1985 nil nil 0))) (should (equal (iso8601-parse "1985W155T235030") - '(30 50 23 12 4 1985 nil nil nil))) + '(30 50 23 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985-W155T23:50:30") - '(30 50 23 12 4 1985 nil nil nil)))) + '(30 50 23 12 4 1985 nil -1 nil)))) (ert-deftest standard-test-interval () ;; A time interval starting at 20 minutes and 50 seconds past 23 @@ -256,48 +299,48 @@ ;; This example doesn't seem valid according to the standard. ;; "0625" is unambiguous, and means "the year 625". Weird. ;; (should (equal (iso8601-parse-interval "19850412/0625") - ;; '((nil nil nil 12 4 1985 nil nil nil) - ;; (nil nil nil nil nil 625 nil nil nil) + ;; '((nil nil nil 12 4 1985 nil -1 nil) + ;; (nil nil nil nil nil 625 nil -1 nil) ;; (0 17 0 22 9 609 5 nil 0)))) ;; A time interval of 2 years, 10 months, 15 days, 10 hours, 20 ;; minutes and 30 seconds. (should (equal (iso8601-parse-duration "P2Y10M15DT10H20M30S") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) (should (equal (iso8601-parse-duration "P00021015T102030") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) (should (equal (iso8601-parse-duration "P0002-10-15T10:20:30") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) ;; A time interval of 1 year and 6 months. (should (equal (iso8601-parse-duration "P1Y6M") - '(0 0 0 0 6 1 nil nil nil))) + '(0 0 0 0 6 1 nil -1 nil))) (should (equal (iso8601-parse-duration "P0001-06") - '(nil nil nil nil 6 1 nil nil nil))) + '(nil nil nil nil 6 1 nil -1 nil))) ;; A time interval of seventy-two hours. (should (equal (iso8601-parse-duration "PT72H") - '(0 0 72 0 0 0 nil nil nil))) + '(0 0 72 0 0 0 nil -1 nil))) ;; Defined by start and duration ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ;; beginning on 12 April 1985 at 20 minutes past 23 hours. (should (equal (iso8601-parse-interval "19850412T232000/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil -1 nil) + (0 20 11 28 6 1986 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:00/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil -1 nil) + (0 20 11 28 6 1986 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil)))) ;; Defined by duration and end ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ending ;; on 12 April 1985 at 20 minutes past 23 hour. (should (equal (iso8601-parse-interval "P1Y2M15DT12H/19850412T232000") - '((0 20 11 28 1 1984 nil nil nil) - (0 20 23 12 4 1985 nil nil nil) - (0 0 12 15 2 1 nil nil nil))))) + '((0 20 11 28 1 1984 nil -1 nil) + (0 20 23 12 4 1985 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil))))) ;;; iso8601-tests.el ends here diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el new file mode 100644 index 00000000000..d2647aac03a --- /dev/null +++ b/test/lisp/calendar/lunar-tests.el @@ -0,0 +1,75 @@ +;;; lunar-tests.el --- tests for calendar/lunar.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'lunar) + +(defmacro with-lunar-test (&rest body) + `(let ((calendar-latitude 40.1) + (calendar-longitude -88.2) + (calendar-location-name "Urbana, IL") + (calendar-time-zone -360) + (calendar-standard-time-zone-name "CST") + (calendar-time-display-form '(12-hours ":" minutes am-pm))) + ,@body)) + +(ert-deftest lunar-test-phase () + (with-lunar-test + (should (equal (lunar-phase 1) + '((1 7 1900) "11:40pm" 1 ""))))) + +(ert-deftest lunar-test-eclipse-check () + (with-lunar-test + (should (equal (eclipse-check 1 1) "** Eclipse **")))) + +;; This fails in certain time zones. +;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests +;; Similarly with TZ=UTC. +;; Daylight saving related? +(ert-deftest lunar-test-phase-list () + :tags '(:unstable) + (with-lunar-test + (should (equal (lunar-phase-list 3 1871) + '(((3 20 1871) "11:03pm" 0 "") + ((3 29 1871) "1:46am" 1 "** Eclipse **") + ((4 5 1871) "9:20am" 2 "") + ((4 12 1871) "12:57am" 3 "** Eclipse possible **") + ((4 19 1871) "2:06pm" 0 "") + ((4 27 1871) "6:49pm" 1 "") + ((5 4 1871) "5:57pm" 2 "") + ((5 11 1871) "9:29am" 3 "") + ((5 19 1871) "5:46am" 0 "") + ((5 27 1871) "8:02am" 1 "")))))) + +(ert-deftest lunar-test-new-moon-time () + (with-lunar-test + (should (= (round (lunar-new-moon-time 1)) + 2451580)))) + +(ert-deftest lunar-test-new-moon-on-or-after () + (with-lunar-test + (should (= (round (lunar-new-moon-on-or-after (calendar-absolute-from-gregorian '(5 5 1818)))) + 664525)))) + +(provide 'lunar-tests) +;;; lunar-tests.el ends here diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el index 4924e8b072a..e1801a57307 100644 --- a/test/lisp/calendar/parse-time-tests.el +++ b/test/lisp/calendar/parse-time-tests.el @@ -1,4 +1,4 @@ -;; parse-time-tests.el --- Test suite for parse-time.el +;; parse-time-tests.el --- Test suite for parse-time.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/calendar/solar-tests.el b/test/lisp/calendar/solar-tests.el new file mode 100644 index 00000000000..441beafe71c --- /dev/null +++ b/test/lisp/calendar/solar-tests.el @@ -0,0 +1,42 @@ +;;; solar-tests.el --- tests for solar.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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/>. + +(require 'ert) +(require 'solar) + +(ert-deftest solar-sunrise-sunset () + ;; Bug#44237: wrong sunrise time on Dec 30 and 31, 2020 for Jaipur. + (let ((calendar-latitude 26.9) + (calendar-longitude 75.8) + (calendar-time-zone +330) + (calendar-standard-time-zone-name "IST") + (calendar-daylight-time-zone-name "IST") + (epsilon (/ 60.0))) ; Minute accuracy is good enough. + (let* ((sunrise-sunset (solar-sunrise-sunset '(12 30 2020))) + (sunrise (car (nth 0 sunrise-sunset))) + (sunset (car (nth 1 sunrise-sunset)))) + (should (< (abs (- sunrise 7.27)) epsilon)) + (should (< (abs (- sunset 17.72)) epsilon))) + (let* ((sunrise-sunset (solar-sunrise-sunset '(12 31 2020))) + (sunrise (car (nth 0 sunrise-sunset))) + (sunset (car (nth 1 sunrise-sunset)))) + (should (< (abs (- sunrise 7.28)) epsilon)) + (should (< (abs (- sunset 17.72)) epsilon))))) + +(provide 'solar-tests) diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 4c8f18a7a95..76a5641f34d 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -22,16 +22,73 @@ (require 'ert) (require 'time-date) +(ert-deftest test-obsolete-with-decoded-time-value () + (with-suppressed-warnings ((obsolete with-decoded-time-value)) + (with-decoded-time-value ((high low micro pico type '(1 2 3 4 5 6 8 8))) + (should (equal (list high low micro pico type) '(1 2 3 4 3)))))) + +(ert-deftest test-obsolete-encode-time-value () + (should (equal (with-suppressed-warnings ((obsolete encode-time-value)) + (encode-time-value 1 2 3 4 0)) + '(1 . 2))) + (should (equal (with-suppressed-warnings ((obsolete encode-time-value)) + (encode-time-value 1 2 3 4 1)) + '(1 2))) + (should (equal (with-suppressed-warnings ((obsolete encode-time-value)) + (encode-time-value 1 2 3 4 2)) + '(1 2 3))) + (should (equal (with-suppressed-warnings ((obsolete encode-time-value)) + (encode-time-value 1 2 3 4 3)) + '(1 2 3 4)))) + (ert-deftest test-leap-year () (should-not (date-leap-year-p 1999)) (should-not (date-leap-year-p 1900)) (should (date-leap-year-p 2000)) (should (date-leap-year-p 2004))) +(ert-deftest test-days-to-time () + (should (equal (days-to-time 0) '(0 0))) + (should (equal (days-to-time 1) '(1 20864))) + (should (equal (days-to-time 999) '(1317 2688))) + (should (equal (days-to-time 0.0) '(0 0 0 0))) + (should (equal (days-to-time 0.5) '(0 43200 0 0))) + (should (equal (days-to-time 1.0) '(1 20864 0 0))) + (should (equal (days-to-time 999.0) '(1317 2688 0 0)))) + +(ert-deftest test-seconds-to-string () + (should (equal (seconds-to-string 0) "0s")) + (should (equal (seconds-to-string 9) "9.00s")) + (should (equal (seconds-to-string 99) "99.00s")) + (should (equal (seconds-to-string 999) "16.65m")) + (should (equal (seconds-to-string 9999) "2.78h")) + (should (equal (seconds-to-string 99999) "27.78h")) + (should (equal (seconds-to-string 999999) "11.57d")) + (should (equal (seconds-to-string 9999999) "115.74d")) + (should (equal (seconds-to-string 99999999) "3.17y")) + (should (equal (seconds-to-string 999999999) "31.69y"))) + (ert-deftest test-days-in-month () (should (= (date-days-in-month 2004 2) 29)) (should (= (date-days-in-month 2004 3) 31)) - (should-not (= (date-days-in-month 1900 3) 28))) + (should (= (date-days-in-month 2019 2) 28)) + (should (= (date-days-in-month 2020 12) 31)) + (should-not (= (date-days-in-month 1900 3) 28)) + (should-error (date-days-in-month 2020 0)) + (should-error (date-days-in-month 2020 15)) + (should-error (date-days-in-month 2020 'foo))) + +(ert-deftest test-format-seconds () + (should (equal (format-seconds "%y %d %h %m %s %%" 0) "0 0 0 0 0 %")) + (should (equal (format-seconds "%y %d %h %m %s %%" 9999999) "0 115 17 46 39 %")) + (should (equal (format-seconds "%y %d %h %m %z %s %%" 1) " 1 %")) + (should (equal (format-seconds "%mm %ss" 66) "1m 6s")) + (should (equal (format-seconds "%mm %5ss" 66) "1m 6s")) + (should (equal (format-seconds "%mm %.5ss" 66.4) "1m 00006s")) + + (should (equal (format-seconds "%mm %,1ss" 66.4) "1m 6.4s")) + (should (equal (format-seconds "%mm %5,1ss" 66.4) "1m 6.4s")) + (should (equal (format-seconds "%mm %.5,1ss" 66.4) "1m 006.4s"))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) @@ -105,6 +162,42 @@ '(12 15 14 8 7 2019 1 t 7200))))) (ert-deftest test-time-since () - (should (time-equal-p 0 (time-since nil)))) + (should (time-equal-p 0 (time-since nil))) + (should (= (cadr (time-since (time-subtract (current-time) 1))) 1))) + +(ert-deftest test-time-decoded-period () + (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) + 3600)) + + (should (equal (decoded-time-period '(1 0 0 0 0 0 nil nil nil)) 1)) + (should (equal (decoded-time-period '(0 1 0 0 0 0 nil nil nil)) 60)) + (should (equal (decoded-time-period '(0 0 1 0 0 0 nil nil nil)) 3600)) + (should (equal (decoded-time-period '(0 0 0 1 0 0 nil nil nil)) 86400)) + (should (equal (decoded-time-period '(0 0 0 0 1 0 nil nil nil)) 2592000)) + (should (equal (decoded-time-period '(0 0 0 0 0 1 nil nil nil)) 31536000)) + (should (equal (decoded-time-period '(1 2 3 4 5 6 nil nil nil)) 202532521)) + + (should (equal (decoded-time-period '((135 . 10) 0 0 0 0 0 nil nil nil)) + 13.5))) + +(ert-deftest test-time-wrap-addition () + (should (equal (decoded-time-add '(0 0 0 1 11 2008 nil nil nil) + (make-decoded-time :month 1)) + '(0 0 0 1 12 2008 nil nil nil))) + (should (equal (decoded-time-add '(0 0 0 1 12 2008 nil nil nil) + (make-decoded-time :month 1)) + '(0 0 0 1 1 2009 nil nil nil))) + (should (equal (decoded-time-add '(0 0 0 1 11 2008 nil nil nil) + (make-decoded-time :month 12)) + '(0 0 0 1 11 2009 nil nil nil))) + (should (equal (decoded-time-add '(0 0 0 1 11 2008 nil nil nil) + (make-decoded-time :month 13)) + '(0 0 0 1 12 2009 nil nil nil))) + (should (equal (decoded-time-add '(0 0 0 30 12 2008 nil nil nil) + (make-decoded-time :day 1)) + '(0 0 0 31 12 2008 nil nil nil))) + (should (equal (decoded-time-add '(0 0 0 30 12 2008 nil nil nil) + (make-decoded-time :day 2)) + '(0 0 0 1 1 2009 nil nil nil)))) ;;; time-date-tests.el ends here diff --git a/test/lisp/calendar/todo-mode-resources/todo-test-1.todo b/test/lisp/calendar/todo-mode-resources/todo-test-1.todo index 598d487cad9..2375772fbe7 100644 --- a/test/lisp/calendar/todo-mode-resources/todo-test-1.todo +++ b/test/lisp/calendar/todo-mode-resources/todo-test-1.todo @@ -1,8 +1,8 @@ -(("testcat1" . [2 0 2 1]) ("testcat2" . [3 0 1 1]) ("testcat3" . [0 0 0 0])) +(("testcat1" . [2 0 2 1]) ("testcat2" . [3 0 1 1]) ("testcat3" . [0 0 0 0]) ("testcat4" . [1 0 0 0])) --==-- testcat1 [May 29, 2017] testcat1 item3 - has more than one line - to test item highlighting + has more than one line + to test item highlighting [Jul 3, 2017] testcat1 item4 ==--== DONE @@ -18,3 +18,7 @@ --==-- testcat3 ==--== DONE +--==-- testcat4 +[Jan 1, 2020] testcat4 item1 + +==--== DONE diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index d65f94d4f31..6ed55121988 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -28,19 +28,10 @@ (require 'ert-x) (require 'todo-mode) -(defvar todo-test-data-dir - (file-truename - (expand-file-name "todo-mode-resources/" - (file-name-directory (or load-file-name - buffer-file-name)))) - "Base directory of todo-mode.el test data files.") - -(defvar todo-test-file-1 (expand-file-name "todo-test-1.todo" - todo-test-data-dir) +(defvar todo-test-file-1 (ert-resource-file "todo-test-1.todo") "Todo mode test file.") -(defvar todo-test-archive-1 (expand-file-name "todo-test-1.toda" - todo-test-data-dir) +(defvar todo-test-archive-1 (ert-resource-file "todo-test-1.toda") "Todo Archive mode test file.") (defmacro with-todo-test (&rest body) @@ -52,7 +43,7 @@ (abbreviated-home-dir nil) (process-environment (cons (format "HOME=%s" todo-test-home) process-environment)) - (todo-directory todo-test-data-dir) + (todo-directory (ert-resource-directory)) (todo-default-todo-file (todo-short-file-name (car (funcall todo-files-function))))) (unwind-protect @@ -414,8 +405,15 @@ the top done item should be the first done item." (should (todo-done-item-p)) (forward-line -1) (should (looking-at todo-category-done)) - ;; Make sure marked items are no longer in first category. - (todo-backward-category) + ;; Make sure marked items are no longer in first category. Since + ;; cat1 now contains no todo or done items but does have archived + ;; items, todo-backward-category would skip it by default, so + ;; prevent this. (FIXME: Without this let-binding, + ;; todo-backward-category selects the nonempty cat4 and this test + ;; fails as expected when run interactively but not in a batch + ;; run -- why?) + (let (todo-skip-archived-categories) + (todo-backward-category)) (should (eq (point-min) (point-max))) ; All todo items were moved. ;; This passes when run interactively but fails in a batch run: ;; the message is displayed but (current-message) evaluates to @@ -808,7 +806,7 @@ buffer from which the editing command was invoked." "Add file FILE with category CAT to todo-files and show it. This provides a noninteractive API for todo-add-file for use in automatic testing." - (let ((file0 (file-truename (concat todo-test-data-dir file ".todo"))) + (let ((file0 (ert-resource-file (concat file ".todo"))) todo-add-item-if-new-category) ; Don't need an item in cat. (cl-letf (((symbol-function 'todo-read-file-name) (lambda (_prompt) file0)) @@ -848,6 +846,94 @@ should display the previously current (or default) todo file." (should (equal todo-current-todo-file todo-test-file-1)) (delete-file (concat file "~"))))) +(ert-deftest todo-test-edit-item-date-month () ; bug#42976 #3 and #4 + "Test incrementing and decrementing the month of an item's date. +If the change in month crosses a year boundary, the year of the +item's date should be adjusted accordingly." + (with-todo-test + (todo-test--show 4) + (let ((current-prefix-arg t) ; For todo-edit-item--header. + (get-date (lambda () + (save-excursion + (todo-date-string-matcher (line-end-position)) + (buffer-substring-no-properties (match-beginning 1) + (match-end 0)))))) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 0) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 1) + (should (equal (funcall get-date) "Feb 1, 2020")) + (todo-edit-item--header 'month -1) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month -1) + (should (equal (funcall get-date) "Dec 1, 2019")) + (todo-edit-item--header 'month 1) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 12) + (should (equal (funcall get-date) "Jan 1, 2021")) + (todo-edit-item--header 'month -12) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month -13) + (should (equal (funcall get-date) "Dec 1, 2018")) + (todo-edit-item--header 'month 7) + (should (equal (funcall get-date) "Jul 1, 2019")) + (todo-edit-item--header 'month 6) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 23) + (should (equal (funcall get-date) "Dec 1, 2021")) + (todo-edit-item--header 'month -23) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 24) + (should (equal (funcall get-date) "Jan 1, 2022")) + (todo-edit-item--header 'month -24) + (should (equal (funcall get-date) "Jan 1, 2020")) + (todo-edit-item--header 'month 25) + (should (equal (funcall get-date) "Feb 1, 2022")) + (todo-edit-item--header 'month -25) + (should (equal (funcall get-date) "Jan 1, 2020"))))) + +(ert-deftest todo-test-multiline-item-indentation-1 () + "Test inserting a multine item containing a hard line break. +After insertion the second line of the item should begin with a +tab character." + (with-todo-test + (let* ((item0 "Test inserting a multine item") + (item1 "containing a hard line break.") + (item (concat item0 "\n" item1))) + (todo-test--show 1) + (todo-test--insert-item item 1) + (re-search-forward (concat todo-date-string-start todo-date-pattern + (regexp-quote todo-nondiary-end) " ") + (line-end-position) t) + (should (looking-at (regexp-quote (concat item0 "\n\t" item1))))))) + +(ert-deftest todo-test-multiline-item-indentation-2 () ; bug#43068 + "Test editing an item by adding text on a new line. +After quitting todo-edit-mode the second line of the item should +begin with a tab character." + (with-todo-test + (todo-test--show 2) + (let* ((item0 (todo-item-string)) + (item1 "Second line.")) + (todo-edit-item--text 'multiline) + (insert (concat "\n" item1)) + (todo-edit-quit) + (goto-char (line-beginning-position)) + (should (looking-at (regexp-quote (concat item0 "\n\t" item1))))))) + +(ert-deftest todo-test-multiline-item-indentation-3 () + "Test adding an unindented new line to an item using todo-edit-file. +Attempting to quit todo-edit-mode should signal a user-error, +since all non-initial item lines must begin with whitespace." + (with-todo-test + (todo-test--show 2) + (let* ((item0 (todo-item-string)) + (item1 "Second line.")) + (todo-edit-file) + (should (looking-at (regexp-quote item0))) + (goto-char (line-end-position)) + (insert (concat "\n" item1)) + (should-error (todo-edit-quit) :type 'user-error)))) (provide 'todo-mode-tests) ;;; todo-mode-tests.el ends here diff --git a/test/lisp/cedet/semantic-utest-c.el b/test/lisp/cedet/semantic-utest-c.el index bdd6c050df6..c776a0fbaac 100644 --- a/test/lisp/cedet/semantic-utest-c.el +++ b/test/lisp/cedet/semantic-utest-c.el @@ -1,4 +1,4 @@ -;;; semantic-utest-c.el --- C based parsing tests. +;;; semantic-utest-c.el --- C based parsing tests. -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -40,11 +40,13 @@ (defvar semantic-utest-c-test-directory (expand-file-name "tests" cedet-utest-directory) "Location of test files.") +(defvar semantic-lex-c-nested-namespace-ignore-second) + ;;; Code: ;;;###autoload (ert-deftest semantic-test-c-preprocessor-simulation () "Run parsing test for C from the test directory." - (interactive) + :tags '(:expensive-test) (semantic-mode 1) (dolist (fp semantic-utest-c-comparisons) (let* ((semantic-lex-c-nested-namespace-ignore-second nil) @@ -146,33 +148,32 @@ gcc version 2.95.2 19991024 (release)" (ert-deftest semantic-test-gcc-output-parser () "Test the output parser against some collected strings." - (let ((fail nil)) - (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"))) - (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p) - )) - (should (and v h)) - )) - (dolist (S semantic-gcc-test-strings-fail) - (let* ((fields (semantic-gcc-fields S)) - (v (cdr (assoc 'version fields))) - (h (or (cdr (assoc '--host fields)) - (cdr (assoc 'target fields)))) - (p (cdr (assoc '--prefix fields))) - ) - ;; negative test - (should-not (and v h p)) - )) - )) + (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"))) + (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p) + )) + (should (and v h)) + )) + (dolist (S semantic-gcc-test-strings-fail) + (let* ((fields (semantic-gcc-fields S)) + (v (cdr (assoc 'version fields))) + (h (or (cdr (assoc '--host fields)) + (cdr (assoc 'target fields)))) + (p (cdr (assoc '--prefix fields))) + ) + ;; negative test + (should-not (and v h p)) + )) + ) (provide 'semantic-utest-c) diff --git a/test/lisp/cedet/semantic-utest-fmt.el b/test/lisp/cedet/semantic-utest-fmt.el index 2fc2b681868..c2f2bb7226c 100644 --- a/test/lisp/cedet/semantic-utest-fmt.el +++ b/test/lisp/cedet/semantic-utest-fmt.el @@ -1,4 +1,4 @@ -;;; cedet/semantic-utest-fmt.el --- Parsing / Formatting tests +;;; cedet/semantic-utest-fmt.el --- Parsing / Formatting tests -*- lexical-binding:t -*- ;;; Copyright (C) 2003-2004, 2007-2020 Free Software Foundation, Inc. @@ -69,7 +69,6 @@ Files to visit are in `semantic-fmt-utest-file-list'." ;; Run the tests. (let ((fb (find-buffer-visiting fname)) (b (semantic-find-file-noselect fname)) - (num 0) (tags nil)) (save-current-buffer @@ -82,7 +81,6 @@ Files to visit are in `semantic-fmt-utest-file-list'." (semantic-clear-toplevel-cache) ;; Force the reparse (setq tags (semantic-fetch-tags)) - (setq num (length tags)) (save-excursion (while tags diff --git a/test/lisp/cedet/semantic-utest-ia.el b/test/lisp/cedet/semantic-utest-ia.el index 5761224d756..c99ef97b509 100644 --- a/test/lisp/cedet/semantic-utest-ia.el +++ b/test/lisp/cedet/semantic-utest-ia.el @@ -1,4 +1,4 @@ -;;; semantic-utest-ia.el --- Analyzer unit tests +;;; semantic-utest-ia.el --- Analyzer unit tests -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -211,7 +211,7 @@ ;; completions, then remove the below debug-on-error setting. (debug-on-error nil) (acomp - (condition-case err + (condition-case _err (semantic-analyze-possible-completions ctxt) ((error user-error) nil)) )) @@ -438,11 +438,10 @@ tag that contains point, and return that." (let* ((ctxt (semantic-analyze-current-context)) (target (car (reverse (oref ctxt prefix)))) (tag (semantic-current-tag)) - (start (current-time)) (Lcount 0)) (when (semantic-tag-p target) (semantic-symref-hits-in-region - target (lambda (start end prefix) (setq Lcount (1+ Lcount))) + target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount))) (semantic-tag-start tag) (semantic-tag-end tag)) Lcount))) diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index 7e336557948..bcbd7d686e3 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -1,4 +1,4 @@ -;;; semantic-utest.el --- Tests for semantic's parsing system. +;;; semantic-utest.el --- Tests for semantic's parsing system. -*- lexical-binding:t -*- ;;; Copyright (C) 2003-2004, 2007-2020 Free Software Foundation, Inc. @@ -38,14 +38,9 @@ (defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory) "Location of test files.") -(defvar semantic-utest-temp-directory (if (fboundp 'temp-directory) - (temp-directory) - temporary-file-directory) - "Temporary directory to use when creating files.") - (defun semantic-utest-fname (name) "Create a filename for NAME in /tmp." - (expand-file-name name semantic-utest-temp-directory)) + (expand-file-name name temporary-file-directory)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Data for C tests @@ -537,10 +532,9 @@ Pre-fill the buffer with CONTENTS." -(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme) +(defun semantic-utest-generic (filename contents name-contents names-removed killme insertme) "Generic unit test according to template. Should work for languages without .h files, python javascript java. -TESTNAME is the name of the test. FILENAME is the name of the file to create. CONTENTS is the contents of the file to test. NAME-CONTENTS is the list of names that should be in the contents. @@ -564,10 +558,8 @@ INSERTME is the text to be inserted after the deletion." (sit-for 0) ;; Run the tests. - ;;(message "First parsing test %s." testname) (should (semantic-utest-verify-names name-contents)) - ;;(message "Invalid tag test %s." testname) (semantic-utest-last-invalid name-contents names-removed killme insertme) (should (semantic-utest-verify-names name-contents)) @@ -576,16 +568,17 @@ INSERTME is the text to be inserted after the deletion." (kill-buffer buff) ))) +(defvar python-indent-guess-indent-offset) ; Silence byte-compiler. (ert-deftest semantic-utest-Python() - (skip-unless (featurep 'python-mode)) + (skip-unless (fboundp 'python-mode)) (let ((python-indent-guess-indent-offset nil)) - (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") + (semantic-utest-generic (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") )) (ert-deftest semantic-utest-Javascript() (if (fboundp 'javascript-mode) - (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") (message "Skipping JavaScript test: NO major mode.")) ) @@ -593,34 +586,34 @@ INSERTME is the text to be inserted after the deletion." ;; If JDE is installed, it might mess things up depending on the version ;; that was installed. (let ((auto-mode-alist '(("\\.java\\'" . java-mode)))) - (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") )) (ert-deftest semantic-utest-Makefile() - (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") + (semantic-utest-generic (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") ) (ert-deftest semantic-utest-Scheme() (skip-unless nil) ;; There is a bug w/ scheme parser. Skip this for now. - (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") + (semantic-utest-generic (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") ) - +(defvar html-helper-build-new-buffer) ; Silence byte-compiler. (ert-deftest semantic-utest-Html() ;; Disable html-helper auto-fill-in mode. - (let ((html-helper-build-new-buffer nil)) - (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->") + (let ((html-helper-build-new-buffer nil)) ; FIXME: Why is this bound? + (semantic-utest-generic (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->") )) (ert-deftest semantic-utest-PHP() (skip-unless (featurep 'php-mode)) - (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") + (semantic-utest-generic (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") ) ;look at http://mfgames.com/linux/csharp-mode (ert-deftest semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose (skip-unless (featurep 'csharp-mode)) - (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -758,7 +751,7 @@ JAVE this thing would need to be recursive to handle java and csharp" (sit-for 0) ) -(defun semantic-utest-last-invalid (name-contents names-removed killme insertme) +(defun semantic-utest-last-invalid (_name-contents _names-removed killme insertme) "Make the last fcn invalid." (semantic-utest-kill-indicator killme insertme) ; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet diff --git a/test/lisp/cedet/srecode-utest-getset.el b/test/lisp/cedet/srecode-utest-getset.el index e49a19594c3..fc66ac4edf2 100644 --- a/test/lisp/cedet/srecode-utest-getset.el +++ b/test/lisp/cedet/srecode-utest-getset.el @@ -1,4 +1,4 @@ -;;; srecode/test-getset.el --- Test the getset inserter. +;;; srecode/test-getset.el --- Test the getset inserter. -*- lexical-binding:t -*- ;; Copyright (C) 2008, 2009, 2011, 2019-2020 Free Software Foundation, Inc @@ -52,8 +52,10 @@ private: temporary-file-directory) "File used to do testing.") +(defvar srecode-insert-getset-fully-automatic-flag) ; Silence byte-compiler. (ert-deftest srecode-utest-getset-output () "Test various template insertion options." + :tags '(:expensive-test) (save-excursion (let ((testbuff (find-file-noselect srecode-utest-getset-testfile)) (srecode-insert-getset-fully-automatic-flag t)) diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 4dd64e2ea8c..7c5bbc599a3 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -1,4 +1,4 @@ -;;; srecode/test.el --- SRecode Core Template tests. +;;; srecode/test.el --- SRecode Core Template tests. -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -323,7 +323,6 @@ INSIDE SECTION: ARG HANDLER ONE") (ert-deftest srecode-utest-project () "Test that project filtering works." - :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme (save-excursion (let ((testbuff (find-file-noselect srecode-utest-testfile)) (temp nil)) @@ -347,6 +346,10 @@ INSIDE SECTION: ARG HANDLER ONE") ;; Load the application templates, and make sure we can find them. (srecode-load-tables-for-mode major-mode 'tests) + (dolist (table (oref (srecode-table) tables)) + (when (gethash "test" (oref table contexthash)) + (oset table project default-directory))) + (setq temp (srecode-template-get-table (srecode-table) "test-project" "test" diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index 0e55dfbb8ed..599d9d614f9 100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@ -4,18 +4,20 @@ ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 9c27a92d2bf..923f588e9e6 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -1,4 +1,4 @@ -;;; comint-testsuite.el +;;; comint-tests.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. @@ -39,6 +39,7 @@ "Passphrase for key root@GNU.ORG: " ; plink "[sudo] password for user:" ; Ubuntu sudo "[sudo] user 的密码：" ; localized + "doas (user@host) password:" ; OpenBSD doas "PIN for user:" ; Bug#35523 "Password (again):" "Enter password:" @@ -52,73 +53,41 @@ (dolist (str comint-testsuite-password-strings) (should (string-match comint-password-prompt-regexp str)))) -(ert-deftest comint-test-no-password-function () - "Test that `comint-password-function' not being set does not -alter normal password flow." - (cl-letf - (((symbol-function 'read-passwd) - (lambda (_prompt &optional _confirm _default) - "PaSsWoRd123"))) - (let ((cat (executable-find "cat"))) - (when cat +(defun comint-tests/test-password-function (password-function) + "PASSWORD-FUNCTION can return nil or a string." + (when-let ((cat (executable-find "cat"))) + (let ((comint-password-function password-function)) + (cl-letf (((symbol-function 'read-passwd) + (lambda (&rest _args) "non-nil"))) (with-temp-buffer (make-comint-in-buffer "test-comint-password" (current-buffer) cat) (let ((proc (get-buffer-process (current-buffer)))) (set-process-query-on-exit-flag proc nil) - (comint-send-string proc "Password: ") - (comint-send-eof) - (while (accept-process-output proc 0.1 nil t)) - (should (string-equal (buffer-substring-no-properties (point-min) (point-max)) - "Password: PaSsWoRd123\n")) - (when (process-live-p proc) - (kill-process proc)) - (accept-process-output proc 0 1 t))))))) + (set-process-query-on-exit-flag proc nil) + (comint-send-invisible "Password: ") + (accept-process-output proc 0.1) + (should (string-equal + (buffer-substring-no-properties (point-min) (point-max)) + (concat (or (and password-function + (funcall password-function)) + "non-nil") + "\n"))))))))) + +(ert-deftest comint-test-no-password-function () + "Test that `comint-password-function' not being set does not +alter normal password flow." + (comint-tests/test-password-function nil)) (ert-deftest comint-test-password-function-with-value () "Test that `comint-password-function' alters normal password flow. Hook function returns alternative password." - (cl-letf - (((symbol-function 'read-passwd) - (lambda (_prompt &optional _confirm _default) - "PaSsWoRd123"))) - (let ((cat (executable-find "cat")) - (comint-password-function (lambda (_prompt) "MaGiC-PaSsWoRd789"))) - (when cat - (with-temp-buffer - (make-comint-in-buffer "test-comint-password" (current-buffer) cat) - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-query-on-exit-flag proc nil) - (comint-send-string proc "Password: ") - (comint-send-eof) - (while (accept-process-output proc 0.1 nil t)) - (should (string-equal (buffer-substring-no-properties (point-min) (point-max)) - "Password: MaGiC-PaSsWoRd789\n")) - (when (process-live-p proc) - (kill-process proc)) - (accept-process-output proc 0 1 t))))))) + (comint-tests/test-password-function + (lambda (&rest _args) "MaGiC-PaSsWoRd789"))) (ert-deftest comint-test-password-function-with-nil () "Test that `comint-password-function' does not alter the normal password flow if it returns a nil value." - (cl-letf - (((symbol-function 'read-passwd) - (lambda (_prompt &optional _confirm _default) - "PaSsWoRd456"))) - (let ((cat (executable-find "cat")) - (comint-password-function (lambda (_prompt) nil))) - (when cat - (with-temp-buffer - (make-comint-in-buffer "test-comint-password" (current-buffer) cat) - (let ((proc (get-buffer-process (current-buffer)))) - (set-process-query-on-exit-flag proc nil) - (comint-send-string proc "Password: ") - (comint-send-eof) - (while (accept-process-output proc 0.1 nil t)) - (should (string-equal (buffer-substring-no-properties (point-min) (point-max)) - "Password: PaSsWoRd456\n")) - (when (process-live-p proc) - (kill-process proc)) - (accept-process-output proc 0 1 t))))))) + (comint-tests/test-password-function #'ignore)) ;; Local Variables: ;; no-byte-compile: t diff --git a/test/lisp/completion-tests.el b/test/lisp/completion-tests.el new file mode 100644 index 00000000000..7473bbbb0c5 --- /dev/null +++ b/test/lisp/completion-tests.el @@ -0,0 +1,170 @@ +;;; completion-tests.el --- Tests for completion.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'completion) + +(ert-deftest completion-test-cmpl-string-case-type () + (should (eq (cmpl-string-case-type "123ABCDEF456") :up)) + (should (eq (cmpl-string-case-type "123abcdef456") :down)) + (should (eq (cmpl-string-case-type "123aBcDeF456") :mixed)) + (should (eq (cmpl-string-case-type "123456") :neither)) + (should (eq (cmpl-string-case-type "Abcde123") :capitalized))) + +(ert-deftest completion-test-cmpl-merge-string-cases () + (should (equal (cmpl-merge-string-cases "AbCdEf456" "abc") "AbCdEf456")) + (should (equal (cmpl-merge-string-cases "abcdef456" "ABC") "ABCDEF456")) + (should (equal (cmpl-merge-string-cases "ABCDEF456" "Abc") "Abcdef456")) + (should (equal (cmpl-merge-string-cases "ABCDEF456" "abc") "abcdef456"))) + +(ert-deftest completion-test-add-find-delete-tail () + (unwind-protect + (progn + ;; - Add and Find - + (should (equal (add-completion-to-head "banana") '("banana" 0 nil 0))) + (should (equal (find-exact-completion "banana") '("banana" 0 nil 0))) + (should (equal (find-exact-completion "bana") nil)) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + + (should (equal (add-completion-to-head "banish") '("banish" 0 nil 0))) + (should (equal (find-exact-completion "banish") '("banish" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + + (should (equal (add-completion-to-head "banana") '("banana" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + + ;; - Deleting - + (should (equal (add-completion-to-head "banner") '("banner" 0 nil 0))) + (delete-completion "banner") + (should-not (find-exact-completion "banner")) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + (should (equal (add-completion-to-head "banner") '("banner" 0 nil 0))) + (delete-completion "banana") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0)))) + (delete-completion "banner") + (delete-completion "banish") + (should-not (find-cmpl-prefix-entry "ban")) + (should-error (delete-completion "banner")) + + ;; - Tail - + (should (equal (add-completion-to-tail-if-new "banana") '("banana" 0 nil 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0)))) + (add-completion-to-tail-if-new "banish") '("banish" 0 nil 0) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 0 nil 0) ("banish" 0 nil 0)))) + (should (equal (cdr (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0))))) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "banner")) + (ignore-errors (kill-completion "banish")))) + +(ert-deftest completion-test-add-find-accept-delete () + (unwind-protect + (progn + ;; - Add and Find - + (add-completion "banana" 5 10) + (should (equal (find-exact-completion "banana") '("banana" 5 10 0))) + (add-completion "banana" 6) + (should (equal (find-exact-completion "banana") '("banana" 6 10 0))) + (add-completion "banish") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banish" 0 nil 0) ("banana" 6 10 0)))) + + ;; - Accepting - + (setq completion-to-accept "banana") + (accept-completion) + (should (equal (find-exact-completion "banana") '("banana" 7 10 0))) + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banana" 7 10 0) ("banish" 0 nil 0)))) + (setq completion-to-accept "banish") + (add-completion "banner") + (should (equal (car (find-cmpl-prefix-entry "ban")) + '(("banner" 0 nil 0) ("banish" 1 nil 0) ("banana" 7 10 0)))) + + ;; - Deleting - + (kill-completion "banish") + (should (equal (car (find-cmpl-prefix-entry "ban")) '(("banner" 0 nil 0) ("banana" 7 10 0))))) + (ignore-errors (kill-completion "banish")) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "banner")))) + +(ert-deftest completion-test-search () + (unwind-protect + (progn + ;; - Add and Find - + (add-completion "banana") + (completion-search-reset "ban") + (should (equal (car (completion-search-next 0)) "banana")) + + ;; - Discrimination - + (add-completion "cumberland") + (add-completion "cumberbund") + ;; cumbering + (completion-search-reset "cumb") + (should (equal (car (completion-search-peek t)) "cumberbund")) + (should (equal (car (completion-search-next 0)) "cumberbund")) + (should (equal (car (completion-search-peek t)) "cumberland")) + (should (equal (car (completion-search-next 1)) "cumberland")) + (should-not (completion-search-peek nil)) + + ;; FIXME + ;; (should (equal (completion-search-next 2) "cumbering")) ; {cdabbrev} + ;;(completion-search-next 3) --> nil or "cumming" {depends on context} + + (should (equal (car (completion-search-next 1)) "cumberland")) + + ;; FIXME + ;; (should (equal (completion-search-peek t) "cumbering")) ; {cdabbrev} + + ;; - Accepting - + (should (equal (car (completion-search-next 1)) "cumberland")) + (setq completion-to-accept "cumberland") + (completion-search-reset "foo") + (completion-search-reset "cum") + (should (equal (car (completion-search-next 0)) "cumberland")) + + ;; - Deleting - + (kill-completion "cumberland") + (add-completion "cummings") + (completion-search-reset "cum") + (should (equal (car (completion-search-next 0)) "cummings")) + (should (equal (car (completion-search-next 1)) "cumberbund")) + + ;; - Ignoring Capitalization - + (completion-search-reset "CuMb") + (should (equal (car (completion-search-next 0)) "cumberbund"))) + (ignore-errors (kill-completion "banana")) + (ignore-errors (kill-completion "cumberland")) + (ignore-errors (kill-completion "cumberbund")) + (ignore-errors (kill-completion "cummings")))) + +(ert-deftest completion-test-lisp-def-regexp () + (should (= (and (string-match *lisp-def-regexp* "\n(defun foo") (match-end 0)) 8)) + (should (= (and (string-match *lisp-def-regexp* "\n(si:def foo") (match-end 0)) 9)) + (should (= (and (string-match *lisp-def-regexp* "\n(def-bar foo")(match-end 0)) 10)) + (should (= (and (string-match *lisp-def-regexp* "\n(defun (foo") (match-end 0)) 9))) + +(provide 'completion-tests) +;;; completion-tests.el ends here diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el new file mode 100644 index 00000000000..bb88b8dd9fa --- /dev/null +++ b/test/lisp/cus-edit-tests.el @@ -0,0 +1,80 @@ +;;; cus-edit-tests.el --- Tests for cus-edit.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'ert-x) +(eval-when-compile (require 'cl-lib)) +(require 'cus-edit) + +(defmacro with-cus-edit-test (buffer &rest body) + (declare (indent 1)) + `(save-window-excursion + (unwind-protect + (progn ,@body) + (when-let ((buf (get-buffer ,buffer))) + (kill-buffer buf))))) + + +;;;; showing/hiding obsolete options + +(defgroup cus-edit-tests nil "test" + :group 'test-group) + +(defcustom cus-edit-tests--obsolete-option-tag nil + "This should never be removed; it is obsolete for testing purposes." + :type 'boolean + :version "917.10") ; a super high version number +(make-obsolete-variable 'cus-edit-tests--obsolete-option-tag nil "X.X-test") +(defconst cus-edit-tests--obsolete-option-tag + (custom-unlispify-tag-name 'cus-edit-tests--obsolete-option-tag)) + +(ert-deftest cus-edit-tests-customize-apropos/hide-obsolete () + (with-cus-edit-test "*Customize Apropos*" + (customize-apropos "cus-edit-tests") + (should-not (search-forward cus-edit-tests--obsolete-option-tag nil t)))) + +(ert-deftest cus-edit-tests-customize-changed-options/hide-obsolete () + (with-cus-edit-test "*Customize Changed Options*" + (customize-changed-options "917.2") ; some future version + (should-not (search-forward cus-edit-tests--obsolete-option-tag nil t)))) + +(ert-deftest cus-edit-tests-customize-group/hide-obsolete () + "Check that obsolete variables do not show up." + (with-cus-edit-test "*Customize Group: Cus Edit Tests*" + (customize-group 'cus-edit-tests) + (should-not (search-forward cus-edit-tests--obsolete-option-tag nil t)))) + +(ert-deftest cus-edit-tests-customize-option/show-obsolete () + (with-cus-edit-test "*Customize Option: Cus Edit Tests Obsolete Option Tag*" + (customize-option 'cus-edit-tests--obsolete-option-tag) + (goto-char (point-min)) + (should (search-forward cus-edit-tests--obsolete-option-tag nil t)))) + +(ert-deftest cus-edit-tests-customize-saved/show-obsolete () + (with-cus-edit-test "*Customize Saved*" + (cl-letf (((get 'cus-edit-tests--obsolete-option-tag 'saved-value) '(t))) + (customize-saved) + (should (search-forward cus-edit-tests--obsolete-option-tag nil t))))) + +(provide 'cus-edit-tests) +;;; cus-edit-tests.el ends here diff --git a/test/lisp/custom-resources/custom--test-theme.el b/test/lisp/custom-resources/custom--test-theme.el index da9121e0a0a..4ced98a50bc 100644 --- a/test/lisp/custom-resources/custom--test-theme.el +++ b/test/lisp/custom-resources/custom--test-theme.el @@ -1,3 +1,5 @@ +;;; custom--test-theme.el -- A test theme. -*- lexical-binding:t -*- + (deftheme custom--test "A test theme.") diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index e71b7913f06..232e3bed439 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'wid-edit) (require 'cus-edit) @@ -99,10 +100,8 @@ ;; This is demonstrating bug#34027. (ert-deftest custom--test-theme-variables () "Test variables setting with enabling / disabling a custom theme." - :expected-result :failed ;; We load custom-resources/custom--test-theme.el. - (let ((custom-theme-load-path - `(,(expand-file-name "custom-resources" (file-name-directory #$))))) + (let ((custom-theme-load-path `(,(ert-resource-directory)))) (load-theme 'custom--test 'no-confirm 'no-enable) ;; The variables have still their initial values. (should (equal custom--test-user-option 'foo)) @@ -115,15 +114,10 @@ (should (equal custom--test-user-option 'baz)) (should (equal custom--test-variable 'baz)) + ;; Enable and then disable. (enable-theme 'custom--test) - ;; The variables have the theme values. - (should (equal custom--test-user-option 'bar)) - (should (equal custom--test-variable 'bar)) - (disable-theme 'custom--test) ;; The variables should have the changed values, by reverting. - ;; This doesn't work as expected. Instead, they have their - ;; initial values `foo'. (should (equal custom--test-user-option 'baz)) (should (equal custom--test-variable 'baz)))) @@ -151,6 +145,26 @@ (widget-apply field :value-to-internal origvalue) "bar")))))) +(defconst custom-test-admin-cus-test + (expand-file-name "admin/cus-test.el" source-directory)) + +(declare-function cus-test-opts custom-test-admin-cus-test) + +(ert-deftest check-for-wrong-custom-types () + :tags '(:expensive-test) + (skip-unless (file-readable-p custom-test-admin-cus-test)) + (load custom-test-admin-cus-test) + (should (null (cus-test-opts t)))) + +(ert-deftest custom-test-enable-theme-keeps-settings () + "Test that enabling a theme doesn't change its settings." + (let* ((custom-theme-load-path `(,(ert-resource-directory))) + settings) + (load-theme 'custom--test 'no-confirm 'no-enable) + (setq settings (get 'custom--test 'theme-settings)) + (enable-theme 'custom--test) + (should (equal settings (get 'custom--test 'theme-settings))))) + (defcustom custom--test-local-option 'initial "Buffer-local user option for testing." :group 'emacs diff --git a/test/lisp/dabbrev-tests.el b/test/lisp/dabbrev-tests.el index 0a2f67e91c7..06c5c0655a7 100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@ -1,4 +1,4 @@ -;;; dabbrev-tests.el --- Test suite for dabbrev. +;;; dabbrev-tests.el --- Test suite for dabbrev. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el index 74fcdf5af37..b060dffb0ff 100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@ -75,18 +75,18 @@ (goto-char (point-min)) (should (eq ?a (following-char))) ; make sure we are where we think we are ;; Function should return nil for an ASCII character. - (should (not (describe-char-eldoc))) + (should (not (describe-char-eldoc 'ignore))) (goto-char (1+ (point))) (should (eq ?… (following-char))) (let ((eldoc-echo-area-use-multiline-p t)) ;; Function should return description of an Unicode character. (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" - (describe-char-eldoc)))) + (describe-char-eldoc 'ignore)))) (goto-char (point-max)) ;; At the end of the buffer, function should return nil and not blow up. - (should (not (describe-char-eldoc))))) + (should (not (describe-char-eldoc 'ignore))))) (provide 'descr-text-test) diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 1fe155718d5..6bb8ced1f30 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -28,7 +28,7 @@ (let* ((foo (make-temp-file "foo")) (files (list foo))) (unwind-protect - (cl-letf (((symbol-function 'y-or-n-p) 'error)) + (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) (dired temporary-file-directory) (dired-goto-file foo) ;; `dired-do-shell-command' returns nil on success. @@ -40,7 +40,7 @@ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) (delete-file foo)))) -;; Auxiliar macro for `dired-test-bug28834': it binds +;; Auxiliary macro for `dired-test-bug28834': it binds ;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. ;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to ;; to avoid the prompt. @@ -114,6 +114,49 @@ (mapc #'delete-file `(,file1 ,file2)) (kill-buffer buf))))) +(defun dired-test--check-highlighting (command positions) + (let ((start 1)) + (dolist (pos positions) + (should-not (text-property-not-all start (1- pos) 'face nil command)) + (should (equal 'warning (get-text-property pos 'face command))) + (setq start (1+ pos))) + (should-not (text-property-not-all + start (length command) 'face nil command)))) + +(ert-deftest dired-test-highlight-metachar () + "Check that non-isolated meta-characters are highlighted." + (let* ((command "sed -r -e 's/oo?/a/' -e 's/oo?/a/' ? `?`") + (markers " ^ ^") + (result (dired--highlight-no-subst-chars + (dired--need-confirm-positions command "?") + command + t)) + (lines (split-string result "\n"))) + (should (= (length lines) 2)) + (should (string-match (regexp-quote command) (nth 0 lines))) + (should (string-match (regexp-quote markers) (nth 1 lines))) + (dired-test--check-highlighting (nth 0 lines) '(15 29))) + ;; Note that `?` is considered isolated, but `*` is not. + (let* ((command "sed -e 's/o*/a/' -e 's/o`*` /a/'") + (markers " ^ ^") + (result (dired--highlight-no-subst-chars + (dired--need-confirm-positions command "*") + command + t)) + (lines (split-string result "\n"))) + (should (= (length lines) 2)) + (should (string-match (regexp-quote command) (nth 0 lines))) + (should (string-match (regexp-quote markers) (nth 1 lines))) + (dired-test--check-highlighting (nth 0 lines) '(11 25))) + (let* ((command "sed 's/\\?/!/'") + (result (dired--highlight-no-subst-chars + (dired--need-confirm-positions command "?") + command + nil)) + (lines (split-string result "\n"))) + (should (= (length lines) 1)) + (should (string-match (regexp-quote command) (nth 0 lines))) + (dired-test--check-highlighting (nth 0 lines) '(8)))) (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 5c6649cba46..66f8ed95b89 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -24,11 +24,11 @@ (ert-deftest dired-autoload () "Tests to see whether dired-x has been autoloaded" (should - (fboundp 'dired-jump)) + (fboundp 'dired-do-relsymlink)) (should (autoloadp (symbol-function - 'dired-jump)))) + 'dired-do-relsymlink)))) (ert-deftest dired-test-bug22694 () "Test for https://debbugs.gnu.org/22694 ." @@ -293,6 +293,7 @@ (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." + :tags '(:unstable) (dired (list (expand-file-name "src" source-directory) "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c")) (let ((orig dired-hide-details-mode)) @@ -440,6 +441,81 @@ (should (= 6 (length (dired-get-marked-files)))) ; All empty dirs but zeta-empty-dir deleted. (advice-remove 'read-answer 'dired-test-bug27940-advice)))) +(ert-deftest dired-test-directory-files () + "Test for `directory-files'." + (let ((testdir (expand-file-name + "directory-files-test" (temporary-file-directory))) + (nod directory-files-no-dot-files-regexp)) + (unwind-protect + (progn + (when (file-directory-p testdir) + (delete-directory testdir t)) + + (make-directory testdir) + (when (file-directory-p testdir) + ;; directory-empty-p: test non-existent dir + (should-not (directory-empty-p "some-imaginary-dir")) + (should (= 2 (length (directory-files testdir)))) + ;; directory-empty-p: test empty dir + (should (directory-empty-p testdir)) + (should-not (directory-files testdir nil nod t 1)) + (dolist (file '(a b c d)) + (make-empty-file (expand-file-name (symbol-name file) testdir))) + (should (= 6 (length (directory-files testdir)))) + (should (equal "abcd" (mapconcat 'identity (directory-files + testdir nil nod) ""))) + (should (= 2 (length (directory-files testdir nil "[bc]")))) + (should (= 3 (length (directory-files testdir nil nod nil 3)))) + (dolist (file '(5 4 3 2 1)) + (make-empty-file + (expand-file-name (number-to-string file) testdir))) + ;;(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))) + + (delete-directory testdir t))))) + +(ert-deftest dired-test-directory-files-and-attributes () + "Test for `directory-files-and-attributes'." + (let ((testdir (expand-file-name + "directory-files-test" (temporary-file-directory))) + (nod directory-files-no-dot-files-regexp)) + + (unwind-protect + (progn + (when (file-directory-p testdir) + (delete-directory testdir t)) + + (make-directory testdir) + (when (file-directory-p testdir) + (should (= 2 (length (directory-files testdir)))) + (should-not (directory-files-and-attributes testdir t nod t 1)) + (dolist (file '(a b c d)) + (make-directory (expand-file-name (symbol-name file) testdir))) + (should (= 6 (length (directory-files-and-attributes testdir)))) + (dolist (dir (directory-files-and-attributes testdir t nod)) + (should (file-directory-p (car dir))) + (should-not (file-regular-p (car dir)))) + (should (= 2 (length + (directory-files-and-attributes testdir nil "[bc]")))) + (should (= 3 (length + (directory-files-and-attributes + testdir nil nod nil nil 3)))) + (dolist (file '(5 4 3 2 1)) + (make-empty-file + (expand-file-name (number-to-string file) testdir))) + ;; (should (= 0 (length (directory-files-and-attributes testdir nil + ;; "[0-9]" t + ;; nil -1)))) + (should (= 5 (length + (directory-files-and-attributes + testdir nil "[0-9]" t)))) + (should (= 5 (length + (directory-files-and-attributes + testdir nil "[0-9]" t nil 50)))))) + (when (file-directory-p testdir) + (delete-directory testdir t))))) (provide 'dired-tests) ;; dired-tests.el ends here diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el index d44851eb13b..f743df78fd5 100644 --- a/test/lisp/dom-tests.el +++ b/test/lisp/dom-tests.el @@ -84,6 +84,13 @@ (dom-set-attribute dom attr value) (should (equal (dom-attr dom attr) value)))) +(ert-deftest dom-tests-remove-attribute () + (let ((dom (copy-tree '(body ((foo . "bar") (zot . "foobar")))))) + (should (equal (dom-attr dom 'foo) "bar")) + (dom-remove-attribute dom 'foo) + (should (equal (dom-attr dom 'foo) nil)) + (should (equal dom '(body ((zot . "foobar"))))))) + (ert-deftest dom-tests-attr () (let ((dom (dom-tests--tree))) (should-not (dom-attr dom 'id)) diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 69e5de32bfb..5f63f6831b3 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -5,18 +5,20 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -547,6 +549,24 @@ baz\"\"" (should (equal "" (buffer-string)))))) +;;; Undoing +(ert-deftest electric-pair-undo-unrelated-state () + "Make sure `electric-pair-mode' does not confuse `undo' (bug#39680)." + (with-temp-buffer + (buffer-enable-undo) + (electric-pair-local-mode) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (let ((last-command-event ?a)) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (ert-simulate-command '(undo)) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (should (string= (buffer-string) "(())")))) + + ;;; Electric newlines between pairs ;;; TODO: better tests (ert-deftest electric-pair-open-extra-newline () diff --git a/test/lisp/elide-head-tests.el b/test/lisp/elide-head-tests.el new file mode 100644 index 00000000000..c9ef26a8181 --- /dev/null +++ b/test/lisp/elide-head-tests.el @@ -0,0 +1,62 @@ +;;; elide-head-tests.el --- Tests for elide-head.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'elide-head) +(require 'ert) + +(ert-deftest elide-head-tests-elide-head () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (let ((o (car (overlays-at 14)))) + (should (= (overlay-start o) 10)) + (should (= (overlay-end o) 21)) + (should (overlay-get o 'invisible)) + (should (overlay-get o 'evaporate)))))) + +(ert-deftest elide-head-tests-elide-head-with-prefix-arg () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (should (overlays-at 14)) + (elide-head t) + (should-not (overlays-at 14))))) + +(ert-deftest elide-head-tests-show () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (should (overlays-at 14)) + (elide-head-show) + (should-not (overlays-at 14))))) + +(provide 'elide-head-tests) +;;; elide-head-tests.el ends here diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index f8efa7902a4..842ef10bc57 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -1,4 +1,4 @@ -;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; -*- +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; coding: utf-8; -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. @@ -94,6 +94,28 @@ (src-ip . [192 168 1 101]) (dest-ip . - [192 168 1 100])))))) + [192 168 1 100])))))) + +(ert-deftest bindat-test-pack/multibyte-string-fails () + (should-error (bindat-pack nil nil "ö"))) + +(ert-deftest bindat-test-unpack/multibyte-string-fails () + (should-error (bindat-unpack nil "ö"))) + +(ert-deftest bindat-test-format-vector () + (should (equal (bindat-format-vector [1 2 3] "%d" "x" 2) "1x2")) + (should (equal (bindat-format-vector [1 2 3] "%d" "x") "1x2x3"))) + +(ert-deftest bindat-test-vector-to-dec () + (should (equal (bindat-vector-to-dec [1 2 3]) "1.2.3")) + (should (equal (bindat-vector-to-dec [2048 1024 512] ".") "2048.1024.512"))) + +(ert-deftest bindat-test-vector-to-hex () + (should (equal (bindat-vector-to-hex [1 2 3]) "01:02:03")) + (should (equal (bindat-vector-to-hex [2048 1024 512] ".") "800.400.200"))) + +(ert-deftest bindat-test-ip-to-string () + (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) + (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) ;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 3aba9af3e79..680aa514a27 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-tests.el +;;; bytecomp-tests.el -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -47,6 +47,11 @@ (let ((a 1.0)) (/ 3 a 2)) (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) (let ((a 3) (b 2)) (/ a b 1.0)) + (let ((a -0.0)) (+ a)) + (let ((a -0.0)) (- a)) + (let ((a -0.0)) (* a)) + (let ((a -0.0)) (min a)) + (let ((a -0.0)) (max a)) (/ 3 -1) (+ 4 3 2 1) (+ 4 3 2.0 1) @@ -360,7 +365,12 @@ '(((a b)) a b (c) (d))) (mapcar (lambda (x) (cond ((memq '(a b) x) 1) ((equal x '(c)) 2))) - '(((a b)) a b (c) (d)))) + '(((a b)) a b (c) (d))) + + (assoc 'b '((a 1) (b 2) (c 3))) + (assoc "b" '(("a" 1) ("b" 2) ("c" 3))) + (let ((x '((a 1) (b 2) (c 3)))) (assoc 'c x)) + (assoc 'a '((a 1) (b 2) (c 3)) (lambda (u v) (not (equal u v))))) "List of expression for test. Each element will be executed by interpreter and with bytecompiled code, and their results compared.") @@ -368,24 +378,24 @@ bytecompiled code, and their results compared.") (defun bytecomp-check-1 (pat) "Return non-nil if PAT is the same whether directly evalled or compiled." (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (v0 (condition-case nil + (byte-compile-warnings nil) + (v0 (condition-case err (eval pat) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (equal v0 v1))) (put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) (defun bytecomp-explain-1 (pat) - (let ((v0 (condition-case nil + (let ((v0 (condition-case err (eval pat) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -408,12 +418,12 @@ Subtests signal errors if something goes wrong." (print-quoted t) v0 v1) (dolist (pat byte-opt-testsuite-arith-data) - (condition-case nil + (condition-case err (setq v0 (eval pat)) - (error (setq v0 nil))) - (condition-case nil + (error (setq v0 (list 'bytecomp-check-error (car err))))) + (condition-case err (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 nil))) + (error (setq v1 (list 'bytecomp-check-error (car err))))) (insert (format "%s" pat)) (indent-to-column 65) (if (equal v0 v1) @@ -439,8 +449,8 @@ Subtests signal errors if something goes wrong." (if compile (let ((byte-compile-dest-file-function (lambda (e) elcfile))) - (byte-compile-file elfile t)) - (load elfile nil 'nomessage))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)) (when elfile (delete-file elfile)) (when elcfile (delete-file elcfile))))) (put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) @@ -482,6 +492,7 @@ Subtests signal errors if something goes wrong." (ert-deftest bytecomp-tests--warnings () (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer))) + (mapc #'fmakunbound '(my-test0 my--test11 my--test12 my--test2)) (test-byte-comp-compile-and-load t '(progn (defun my-test0 () @@ -505,19 +516,25 @@ Subtests signal errors if something goes wrong." ;; 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) + (declare (indent 1)) + `(with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer)) + (byte-compile ,@form) + (ert-info ((buffer-string) :prefix "buffer: ") + (should (re-search-forward ,re-warning))))) + (ert-deftest bytecomp-warn-wrong-args () - (with-current-buffer (get-buffer-create "*Compile-Log*") - (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile '(remq 1 2 3)) - (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward "remq.*3.*2"))))) + (bytecomp--with-warning-test "remq.*3.*2" + '(remq 1 2 3))) (ert-deftest bytecomp-warn-wrong-args-subr () - (with-current-buffer (get-buffer-create "*Compile-Log*") - (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile '(safe-length 1 2 3)) - (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward "safe-length.*3.*1"))))) + (bytecomp--with-warning-test "safe-length.*3.*1" + '(safe-length 1 2 3))) + +(ert-deftest bytecomp-warn-variable-lacks-prefix () + (bytecomp--with-warning-test "foo.*lacks a prefix" + '(defvar foo nil))) (ert-deftest test-eager-load-macro-expansion () (test-byte-comp-compile-and-load nil @@ -567,25 +584,25 @@ bytecompiled code, and their results compared.") "Return non-nil if PAT is the same whether directly evalled or compiled." (let ((warning-minimum-log-level :emergency) (byte-compile-warnings nil) - (v0 (condition-case nil + (v0 (condition-case err (eval pat t) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (let ((lexical-binding t)) (byte-compile `(lambda nil ,pat)))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (equal v0 v1))) (put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) (defun bytecomp-lexbind-explain-1 (pat) - (let ((v0 (condition-case nil + (let ((v0 (condition-case err (eval pat t) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (let ((lexical-binding t)) (byte-compile (list 'lambda nil pat)))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -628,17 +645,6 @@ literals (Bug#20852)." (let ((byte-compile-dest-file-function (lambda (_) destination))) (should (byte-compile-file source))))))) -(ert-deftest bytecomp-tests--old-style-backquotes () - "Check that byte compiling warns about old-style backquotes." - (bytecomp-tests--with-temp-file source - (write-region "(` (a b))" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) '("Old-style backquotes detected!"))))))) - - (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." (bytecomp-tests--with-temp-file source @@ -651,7 +657,8 @@ literals (Bug#20852)." (setq bytecomp-tests--foobar (bytecomp-tests--foobar)))) (print form (current-buffer))) (write-region (point-min) (point-max) source nil 'silent) - (byte-compile-file source t) + (byte-compile-file source) + (load source) (should (equal bytecomp-tests--foobar (cons 1 2))))) (ert-deftest bytecomp-tests--test-no-warnings-with-advice () @@ -809,6 +816,12 @@ literals (Bug#20852)." (test-suppression '(defun zot () + (next-line)) + '((interactive-only next-line)) + "interactive use only") + + (test-suppression + '(defun zot () (mapcar #'list '(1 2 3)) nil) '((mapcar mapcar)) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index c8d46541ad4..0ea9742be49 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -20,6 +20,166 @@ ;;; Commentary: (require 'ert) +(require 'cl-lib) + +(ert-deftest cconv-tests-lambda-:documentation () + "Docstring for lambda can be specified with :documentation." + (let ((fun (lambda () + (:documentation (concat "lambda" " documentation")) + 'lambda-result))) + (should (string= (documentation fun) "lambda documentation")) + (should (eq (funcall fun) 'lambda-result)))) + +(ert-deftest cconv-tests-pcase-lambda-:documentation () + "Docstring for pcase-lambda can be specified with :documentation." + (let ((fun (pcase-lambda (`(,a ,b)) + (:documentation (concat "pcase-lambda" " documentation")) + (list b a)))) + (should (string= (documentation fun) "pcase-lambda documentation")) + (should (equal '(2 1) (funcall fun '(1 2)))))) + +(defun cconv-tests-defun () + (:documentation (concat "defun" " documentation")) + 'defun-result) +(ert-deftest cconv-tests-defun-:documentation () + "Docstring for defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defun) + "defun documentation")) + (should (eq (cconv-tests-defun) 'defun-result))) + +(cl-defun cconv-tests-cl-defun () + (:documentation (concat "cl-defun" " documentation")) + 'cl-defun-result) +(ert-deftest cconv-tests-cl-defun-:documentation () + "Docstring for cl-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defun) + "cl-defun documentation")) + (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (defmacro cconv-tests-defmacro () +;; (:documentation (concat "defmacro" " documentation")) +;; '(quote defmacro-result)) +;; (ert-deftest cconv-tests-defmacro-:documentation () +;; "Docstring for defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-defmacro) +;; "defmacro documentation")) +;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (cl-defmacro cconv-tests-cl-defmacro () +;; (:documentation (concat "cl-defmacro" " documentation")) +;; '(quote cl-defmacro-result)) +;; (ert-deftest cconv-tests-cl-defmacro-:documentation () +;; "Docstring for cl-defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-cl-defmacro) +;; "cl-defmacro documentation")) +;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) + +(cl-iter-defun cconv-tests-cl-iter-defun () + (:documentation (concat "cl-iter-defun" " documentation")) + (iter-yield 'cl-iter-defun-result)) +(ert-deftest cconv-tests-cl-iter-defun-:documentation () + "Docstring for cl-iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :tags '(:unstable) + :expected-result :failed + (should (string= (documentation 'cconv-tests-cl-iter-defun) + "cl-iter-defun documentation")) + (should (eq (iter-next (cconv-tests-cl-iter-defun)) + 'cl-iter-defun-result))) + +(iter-defun cconv-tests-iter-defun () + (:documentation (concat "iter-defun" " documentation")) + (iter-yield 'iter-defun-result)) +(ert-deftest cconv-tests-iter-defun-:documentation () + "Docstring for iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :tags '(:unstable) + :expected-result :failed + (should (string= (documentation 'cconv-tests-iter-defun) + "iter-defun documentation")) + (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) + +(ert-deftest cconv-tests-iter-lambda-:documentation () + "Docstring for iter-lambda can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((iter-fun + (iter-lambda () + (:documentation (concat "iter-lambda" " documentation")) + (iter-yield 'iter-lambda-result)))) + (should (string= (documentation iter-fun) "iter-lambda documentation")) + (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) + +(ert-deftest cconv-tests-cl-function-:documentation () + "Docstring for cl-function can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((fun (cl-function (lambda (&key arg) + (:documentation (concat "cl-function" + " documentation")) + (list arg 'cl-function-result))))) + (should (string= (documentation fun) "cl-function documentation")) + (should (equal (funcall fun :arg t) '(t cl-function-result))))) + +(ert-deftest cconv-tests-function-:documentation () + "Docstring for lambda inside function can be specified with :documentation." + (let ((fun #'(lambda (arg) + (:documentation (concat "function" " documentation")) + (list arg 'function-result)))) + (should (string= (documentation fun) "function documentation")) + (should (equal (funcall fun t) '(t function-result))))) + +(fmakunbound 'cconv-tests-cl-defgeneric) +(setplist 'cconv-tests-cl-defgeneric nil) +(cl-defgeneric cconv-tests-cl-defgeneric (n) + (:documentation (concat "cl-defgeneric" " documentation"))) +(cl-defmethod cconv-tests-cl-defgeneric ((n integer)) + (:documentation (concat "cl-defmethod" " documentation")) + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric documentation" descr)) + (should (string-match-p "cl-defmethod documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric 10)))) + +(fmakunbound 'cconv-tests-cl-defgeneric-literal) +(setplist 'cconv-tests-cl-defgeneric-literal nil) +(cl-defgeneric cconv-tests-cl-defgeneric-literal (n) + (:documentation "cl-defgeneric-literal documentation")) +(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) + (:documentation "cl-defmethod-literal documentation") + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric-literal documentation" descr)) + (should (string-match-p "cl-defmethod-literal documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) + +(defsubst cconv-tests-defsubst () + (:documentation (concat "defsubst" " documentation")) + 'defsubst-result) +(ert-deftest cconv-tests-defsubst-:documentation () + "Docstring for defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defsubst) + "defsubst documentation")) + (should (eq (cconv-tests-defsubst) 'defsubst-result))) + +(cl-defsubst cconv-tests-cl-defsubst () + (:documentation (concat "cl-defsubst" " documentation")) + 'cl-defsubst-result) +(ert-deftest cconv-tests-cl-defsubst-:documentation () + "Docstring for cl-defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defsubst) + "cl-defsubst documentation")) + (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () "Bug#30872." diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el new file mode 100644 index 00000000000..bb9542114c4 --- /dev/null +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -0,0 +1,116 @@ +;;; check-declare-tests.el --- Tests for check-declare.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'check-declare) +(require 'ert) +(eval-when-compile (require 'subr-x)) + +(ert-deftest check-declare-tests-locate () + (should (file-exists-p (check-declare-locate "check-declare" ""))) + (should + (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) + +(ert-deftest check-declare-tests-scan () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly)))) + (delete-file file)))) + +(ert-deftest check-declare-tests-verify () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))))) + (delete-file file)))) + +(ert-deftest check-declare-tests-verify-mismatch () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch"))))) + (delete-file file)))) + +(ert-deftest check-declare-tests-sort () + (should-not (check-declare-sort '())) + (should (equal (check-declare-sort '((a (1 a)) (b (2)) (d (1 d)))) + '((2 (b)) (1 (a a) (d d)))))) + +(ert-deftest check-declare-tests-warn () + (with-temp-buffer + (let ((check-declare-warning-buffer (buffer-name))) + (check-declare-warn + "foo-file" "foo-fun" "bar-file" "it wasn't" 999) + (let ((res (buffer-string))) + ;; Don't care too much about the format of the output, but + ;; check that key information is present. + (should (string-match-p "foo-file" res)) + (should (string-match-p "foo-fun" res)) + (should (string-match-p "bar-file" res)) + (should (string-match-p "it wasn't" res)) + (should (string-match-p "999" res)))))) + +(provide 'check-declare-tests) +;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 51c9884ddc8..9582907e511 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'cl-generic) +(require 'edebug) ;; Don't indirectly require `cl-lib' at run-time. (eval-when-compile (require 'ert)) @@ -239,7 +240,7 @@ (let ((retval (cl--generic-method-files 'cl-generic-tests--generic))) (should (equal (length retval) 2)) (mapc (lambda (x) - (should (equal (car x) cl-generic-tests--this-file)) + (should (equal (file-truename (car x)) cl-generic-tests--this-file)) (should (equal (cadr x) 'cl-generic-tests--generic))) retval) (should-not (equal (nth 0 retval) (nth 1 retval))))) @@ -249,5 +250,42 @@ (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) +(ert-deftest cl-defgeneric/edebug/method () + "Check that `:method' forms in `cl-defgeneric' create unique +Edebug symbols (Bug#42672)." + (with-temp-buffer + (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) + (:method ((_ number)) 1) + (:method ((_ string)) 2) + (:method :around ((_ number)) 3)) + (cl-defgeneric cl-defgeneric/edebug/method/2 (_) + (:method ((_ number)) 3)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + (should (equal + (reverse instrumented-names) + ;; The generic function definitions come after the + ;; method definitions because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `cl-defgeneric/edebug/method/1 ((_ number))', but + ;; that requires further changes to Edebug. + (list (intern "cl-generic-:method@10000 ((_ number))") + (intern "cl-generic-:method@10001 ((_ string))") + (intern "cl-generic-:method@10002 :around ((_ number))") + 'cl-defgeneric/edebug/method/1 + (intern "cl-generic-:method@10003 ((_ number))") + 'cl-defgeneric/edebug/method/2)))))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 57b9d23efb0..40dd7e4eeb0 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -242,6 +242,22 @@ (should (= (cl-the integer (cl-incf side-effect)) 1)) (should (= side-effect 1)))) +(ert-deftest cl-lib-test-incf () + (let ((var 0)) + (should (= (cl-incf var) 1)) + (should (= var 1))) + (let ((alist)) + (should (= (cl-incf (alist-get 'a alist 0)) 1)) + (should (= (alist-get 'a alist 0) 1)))) + +(ert-deftest cl-lib-test-decf () + (let ((var 1)) + (should (= (cl-decf var) 0)) + (should (= var 0))) + (let ((alist)) + (should (= (cl-decf (alist-get 'a alist 0)) -1)) + (should (= (alist-get 'a alist 0) -1)))) + (ert-deftest cl-lib-test-plusp () (should-not (cl-plusp -1.0e+INF)) (should-not (cl-plusp -1.5e2)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index c357ecde951..29ae95e2771 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -39,6 +39,15 @@ collect (list c b a)) '((4.0 2 1) (8.3 6 5) (10.4 9 8))))) +(ert-deftest cl-macs-loop-and-arrays () + "Bug#40727" + (should (equal (cl-loop for y = (- (or x 0)) and x across [1 2] + collect (cons x y)) + '((1 . 0) (2 . -1)))) + (should (equal (cl-loop for x across [1 2] and y = (- (or x 0)) + collect (cons x y)) + '((1 . 0) (2 . -1))))) + (ert-deftest cl-macs-loop-destructure () (should (equal (cl-loop for (a b c) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) @@ -416,7 +425,9 @@ collection clause." '(2 3 4 5 6)))) (ert-deftest cl-macs-loop-across-ref () - (should (equal (cl-loop with my-vec = ["one" "two" "three"] + (should (equal (cl-loop with my-vec = (vector (cl-copy-seq "one") + (cl-copy-seq "two") + (cl-copy-seq "three")) for x across-ref my-vec do (setf (aref x 0) (upcase (aref x 0))) finally return my-vec) @@ -498,7 +509,6 @@ collection clause." (ert-deftest cl-macs-loop-for-as-equals-and () "Test for https://debbugs.gnu.org/29799 ." - :expected-result :failed (let ((arr (make-vector 3 0))) (should (equal '((0 0) (1 1) (2 2)) (cl-loop for k below 3 for x = k and z = (elt arr k) @@ -532,7 +542,6 @@ collection clause." (ert-deftest cl-macs-loop-conditional-step-clauses () "These tests failed under the initial fixes in #bug#29799." - :expected-result :failed (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) if (not (= i j)) return nil @@ -592,4 +601,13 @@ collection clause." collect y into result1 finally return (equal (nreverse result) result1)))) +(ert-deftest cl-macs-aux-edebug () + "Check that Bug#40431 is fixed." + (with-temp-buffer + (prin1 '(cl-defun cl-macs-aux-edebug-test-fun (&aux ((a . b) '(1 . 2))) + (list a b)) + (current-buffer)) + ;; Just make sure the function can be instrumented. + (edebug-defun))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el index cddefbbdee8..7e0f5384542 100644 --- a/test/lisp/emacs-lisp/cl-seq-tests.el +++ b/test/lisp/emacs-lisp/cl-seq-tests.el @@ -294,6 +294,7 @@ Body are forms defining the test." (ert-deftest cl-seq-test-bug24264 () "Test for https://debbugs.gnu.org/24264 ." + :tags '(:expensive-test) (let ((list (append (make-list 8000005 1) '(8))) (list2 (make-list 8000005 2))) (should (cl-position 8 list)) diff --git a/test/lisp/emacs-lisp/copyright-tests.el b/test/lisp/emacs-lisp/copyright-tests.el new file mode 100644 index 00000000000..77b9e05da67 --- /dev/null +++ b/test/lisp/emacs-lisp/copyright-tests.el @@ -0,0 +1,50 @@ +;;; copyright-tests.el --- tests for copyright.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 'cl-lib) +(require 'copyright) + +(defmacro with-copyright-test (orig result) + `(cl-letf (((symbol-function 'format-time-string) (lambda (&rest _) "2019"))) + (let ((copyright-query nil) + (copyright-current-year 2019)) + (with-temp-buffer + (insert ,orig) + (copyright-update) + (should (equal (buffer-string) ,result)))))) + +(defvar copyright-tests--data + '((";; Copyright (C) 2017 Free Software Foundation, Inc." + . ";; Copyright (C) 2017, 2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2005-2006, 2015, 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2005-2006, 2015, 2017-2019 Free Software Foundation, Inc.") + (";; copyright '18 FSF" + . ";; copyright '18, '19 FSF"))) + +(ert-deftest test-copyright-update () + (dolist (test copyright-tests--data) + (with-copyright-test (car test) (cdr test)))) + +(provide 'copyright-tests) +;;; copyright-tests.el ends here diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el new file mode 100644 index 00000000000..bbd01970b5b --- /dev/null +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -0,0 +1,65 @@ +;;; easy-mmode-tests.el --- tests for easy-mmode.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 'easy-mmode) +(require 'message) + +(ert-deftest easy-mmode--globalized-predicate () + (with-temp-buffer + (emacs-lisp-mode) + (should (eq (easy-mmode--globalized-predicate-p nil) nil)) + (should (eq (easy-mmode--globalized-predicate-p t) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode))) nil)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode) t)) t)) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode emacs-lisp-mode)) + t)) + (mail-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + nil)) + (text-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + t)))) + +(define-minor-mode easy-mmode-test-mode "A test.") + +(ert-deftest easy-mmode--minor-mode () + (with-temp-buffer + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode nil) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode -33) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 33) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode t)))) + +(provide 'easy-mmode-tests) + +;;; easy-mmode-tests.el ends here diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index 60e49ab93a4..7be057db8b2 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -1,4 +1,4 @@ -;;; edebug-test-code.el --- Sample code for the Edebug test suite +;;; edebug-test-code.el --- Sample code for the Edebug test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 88c4a0fe175..8aae26a1aca 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -36,17 +36,6 @@ (require 'edebug) (require 'kmacro) -;; Use `eval-and-compile' because this is used by the macro -;; `edebug-tests-deftest'. -(eval-and-compile - (defvar edebug-tests-sample-code-file - (expand-file-name - "edebug-resources/edebug-test-code.el" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Name of file containing code samples for Edebug tests.")) - (defvar edebug-tests-temp-file nil "Name of temp file containing sample code stripped of stop point symbols.") (defvar edebug-tests-stop-points nil @@ -116,7 +105,8 @@ back to the top level.") (declare (debug (body))) `(edebug-tests-with-default-config (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el"))) + (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) + (find-file-suppress-same-file-warnings t)) (edebug-tests-setup-code-file edebug-tests-temp-file) (ert-with-message-capture edebug-tests-messages @@ -221,6 +211,7 @@ be the same as every keystroke) execute the thunk at the same index." (let* ((edebug-tests-thunks thunks) (edebug-tests-kbd-macro-index 0) + (find-file-suppress-same-file-warnings t) saved-local-map) (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq saved-local-map overriding-local-map) @@ -344,7 +335,7 @@ evaluate to \"symbol\", \"symbol-1\", \"symbol-2\", etc." Write the loadable code to a buffer for TMPFILE, and set `edebug-tests-stop-points' to a map from defined symbols to stop point names to positions in the file." - (with-current-buffer (find-file-noselect edebug-tests-sample-code-file) + (with-current-buffer (find-file-noselect (ert-resource-file "edebug-test-code.el")) (let ((marked-up-code (buffer-string))) (with-temp-file tmpfile (insert marked-up-code)))) @@ -938,5 +929,99 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result '(0 1)))))) +(ert-deftest edebug-cl-defmethod-qualifier () + "Check that secondary `cl-defmethod' forms don't stomp over +primary ones (Bug#42671)." + (with-temp-buffer + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (defined-symbols ()) + (edebug-new-definition-function + (lambda (def-name) + (push def-name defined-symbols) + (edebug-new-definition def-name)))) + (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number))) + (cl-defmethod edebug-cl-defmethod-qualifier + :around ((_ number))))) + (print form (current-buffer))) + (eval-buffer) + (should + (equal + defined-symbols + (list (intern "edebug-cl-defmethod-qualifier :around ((_ number))") + (intern "edebug-cl-defmethod-qualifier ((_ number))"))))))) + +(ert-deftest edebug-tests-cl-flet () + "Check that Edebug can instrument `cl-flet' forms without name +clashes (Bug#41853)." + (with-temp-buffer + (dolist (form '((defun edebug-tests-cl-flet-1 () + (cl-flet ((inner () 0)) (message "Hi")) + (cl-flet ((inner () 1)) (inner))) + (defun edebug-tests-cl-flet-2 () + (cl-flet ((inner () 2)) (inner))))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + (should (equal (reverse instrumented-names) + ;; The outer definitions come after the inner + ;; ones because their body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#41988. + ;; Once that bug is fixed, remove the duplicates. + ;; FIXME: We'd rather have names such as + ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', + ;; but that requires further changes to Edebug. + '(inner@cl-flet@10000 + inner@cl-flet@10001 + inner@cl-flet@10002 + inner@cl-flet@10003 + edebug-tests-cl-flet-1 + inner@cl-flet@10004 + inner@cl-flet@10005 + edebug-tests-cl-flet-2)))))) + +(ert-deftest edebug-tests-duplicate-symbol-backtrack () + "Check that Edebug doesn't create duplicate symbols when +backtracking (Bug#42701)." + (with-temp-buffer + (dolist (form '((require 'subr-x) + (defun edebug-tests-duplicate-symbol-backtrack () + (if-let (x (funcall (lambda (y) 1) 2)) 3 4)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; The anonymous symbols are uninterned. Use their names so we + ;; can perform the assertion. The names should still be unique. + (should (equal (mapcar #'symbol-name (reverse instrumented-names)) + ;; The outer definition comes after the inner + ;; ones because its body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#42701. + ;; Once that bug is fixed, remove the duplicates. + '("edebug-anon10000" + "edebug-anon10001" + "edebug-tests-duplicate-symbol-backtrack")))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index b3e296db16b..73c3ea82e2d 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -1,4 +1,4 @@ -;;; eieio-testsinvoke.el -- eieio tests for method invocation +;;; eieio-testsinvoke.el -- eieio tests for method invocation -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008, 2010, 2013-2020 Free Software Foundation, ;; Inc. @@ -83,36 +83,36 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((p eitest-B-base1)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((p eitest-B-base2)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((p eitest-B)) +(defmethod eitest-F :BEFORE ((_p eitest-B)) (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((p eitest-B)) +(defmethod eitest-F ((_p eitest-B)) (eieio-test-method-store :PRIMARY 'eitest-B) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base1)) +(defmethod eitest-F ((_p eitest-B-base1)) (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base2)) +(defmethod eitest-F ((_p eitest-B-base2)) (eieio-test-method-store :PRIMARY 'eitest-B-base2) (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F :AFTER ((p eitest-B-base1)) +(defmethod eitest-F :AFTER ((_p eitest-B-base1)) (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((p eitest-B-base2)) +(defmethod eitest-F :AFTER ((_p eitest-B-base2)) (eieio-test-method-store :AFTER 'eitest-B-base2)) -(defmethod eitest-F :AFTER ((p eitest-B)) +(defmethod eitest-F :AFTER ((_p eitest-B)) (eieio-test-method-store :AFTER 'eitest-B)) (ert-deftest eieio-test-method-order-list-3 () @@ -136,7 +136,7 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((class eitest-A)) +(defmethod eitest-H :STATIC ((_class eitest-A)) "No need to do work in here." 'moose) @@ -147,15 +147,15 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((a eitest-A)) +(defmethod eitest-I :BEFORE ((_a eitest-A)) (eieio-test-method-store :BEFORE 'eitest-A) ":before") -(defmethod eitest-I :PRIMARY ((a eitest-A)) +(defmethod eitest-I :PRIMARY ((_a eitest-A)) (eieio-test-method-store :PRIMARY 'eitest-A) ":primary") -(defmethod eitest-I :AFTER ((a eitest-A)) +(defmethod eitest-I :AFTER ((_a eitest-A)) (eieio-test-method-store :AFTER 'eitest-A) ":after") @@ -174,17 +174,17 @@ (defclass C (C-base1 C-base2) ()) ;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((p C-base1) &rest args) +(defmethod constructor :STATIC ((_p C-base1) &rest _args) (eieio-test-method-store :STATIC 'C-base1) (if (next-method-p) (call-next-method)) ) -(defmethod make-instance :STATIC ((p C-base2) &rest args) +(defmethod make-instance :STATIC ((_p C-base2) &rest _args) (eieio-test-method-store :STATIC 'C-base2) (if (next-method-p) (call-next-method)) ) -(cl-defmethod make-instance ((p (subclass C)) &rest args) +(cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) (cl-call-next-method) ) @@ -213,24 +213,24 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((p D)) +(defmethod eitest-F ((_p D)) "D" (eieio-test-method-store :PRIMARY 'D) (call-next-method)) -(defmethod eitest-F ((p D-base0)) +(defmethod eitest-F ((_p D-base0)) "D-base0" (eieio-test-method-store :PRIMARY 'D-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p D-base1)) +(defmethod eitest-F ((_p D-base1)) "D-base1" (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) -(defmethod eitest-F ((p D-base2)) +(defmethod eitest-F ((_p D-base2)) "D-base2" (eieio-test-method-store :PRIMARY 'D-base2) (when (next-method-p) @@ -256,21 +256,21 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((p E)) +(defmethod eitest-F ((_p E)) (eieio-test-method-store :PRIMARY 'E) (call-next-method)) -(defmethod eitest-F ((p E-base0)) +(defmethod eitest-F ((_p E-base0)) (eieio-test-method-store :PRIMARY 'E-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p E-base1)) +(defmethod eitest-F ((_p E-base1)) (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) -(defmethod eitest-F ((p E-base2)) +(defmethod eitest-F ((_p E-base2)) (eieio-test-method-store :PRIMARY 'E-base2) (when (next-method-p) (call-next-method)) @@ -293,7 +293,7 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) ;(message "+Ja") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -304,7 +304,7 @@ (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) ;(message "+Jb") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -318,7 +318,7 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((this eitest-Jd) &rest slots) +(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) ;(message "+Jd") (when (next-method-p) (call-next-method)) @@ -357,7 +357,7 @@ (call-next-method this (cons 'CNM-1-1 args)))) -(defmethod CNM-M ((this CNM-1-2) args) +(defmethod CNM-M ((_this CNM-1-2) args) (push (cons 'CNM-1-2 (copy-sequence args)) eieio-test-call-next-method-arguments) (when (next-method-p) 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 3c5aeaf708f..6979da8482b 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -1,4 +1,4 @@ -;;; eieio-test-persist.el --- Tests for eieio-persistent class +;;; eieio-test-persist.el --- Tests for eieio-persistent class -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 34c20b2003f..21adc91e555 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,4 +1,4 @@ -;;; eieio-tests.el -- eieio tests routines +;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2020 Free Software ;; Foundation, Inc. @@ -356,7 +356,7 @@ METHOD is the method that was attempting to be called." (oset a test-tag 1)) (let ((ca (class-a))) - (should-not (/= (oref ca test-tag) 2)))) + (should (= (oref ca test-tag) 2)))) ;;; Perform slot testing @@ -852,6 +852,7 @@ Subclasses to override slot attributes.") "Instance Tracker test object.") (ert-deftest eieio-test-33-instance-tracker () + (defvar IT-list) (let (IT-list IT1) (should (setq IT1 (IT))) ;; The instance tracker must find this diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 96189356c02..1f54c8d07e4 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -801,6 +801,11 @@ This macro is used to test if macroexpansion in `should' works." (should (eql 0 (ert-stats-completed-unexpected stats))) (should (eql 1 (ert-stats-skipped stats))))) +(ert-deftest ert-test-with-demoted-errors () + "Check that ERT correctly handles `with-demoted-errors'." + :expected-result :failed ;; FIXME! Bug#11218 + (should-not (with-demoted-errors (error "Foo")))) + (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index e910329c201..f342bff0472 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -1,4 +1,4 @@ -;;; ert-x-tests.el --- Tests for ert-x.el +;;; ert-x-tests.el --- Tests for ert-x.el -*- lexical-binding:t -*- ;; Copyright (C) 2008, 2010-2020 Free Software Foundation, Inc. @@ -187,18 +187,15 @@ "Tests `ert-describe-test'." (save-window-excursion (ert-with-buffer-renamed ("*Help*") - (if (< emacs-major-version 24) - (should (equal (should-error (ert-describe-test 'ert-describe-test)) - '(error "Requires Emacs 24"))) - (ert-describe-test 'ert-test-describe-test) - (with-current-buffer "*Help*" - (let ((case-fold-search nil)) - (should (string-match (concat - "\\`ert-test-describe-test is a test" - " defined in" - " ['`‘]ert-x-tests.elc?['’]\\.\n\n" - "Tests ['`‘]ert-describe-test['’]\\.\n\\'") - (buffer-string))))))))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string)))))))) (ert-deftest ert-test-message-log-truncation () :tags '(:causes-redisplay) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el index 3017b52ab54..c77f2dc4990 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -1,4 +1,4 @@ -;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ (0 (progn (add-text-properties (match-beginning 0) (match-end 0) - '(help-echo "Baloon tip: Fly smoothly!")) + '(help-echo "Balloon tip: Fly smoothly!")) font-lock-warning-face)))) "Highlight rules for `faceup-test-mode'.") diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el index ab638ef932f..d8ab02b650e 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -1,4 +1,4 @@ -;;; faceup-test-this-file-directory.el --- Support file for faceup tests +;;; faceup-test-this-file-directory.el --- Support file for faceup tests -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup index 7d4938adf17..ec9e82148fd 100644 --- a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -1,7 +1,7 @@ This is a test of `faceup', a regression test system for font-lock keywords. It should use major mode `faceup-test-mode'. -«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +«(help-echo):"Balloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use `font-lock-warning-face', and a tooltip should be displayed if the mouse pointer is moved over it. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el index 0838981fcb9..3c9ec76cdf7 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -1,4 +1,4 @@ -;;; faceup-test-basics.el --- Tests for the `faceup' package. +;;; faceup-test-basics.el --- Tests for the `faceup' package. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el index 4f5fe180bb3..a87c16d66c0 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -1,4 +1,4 @@ -;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el new file mode 100644 index 00000000000..d77eb6757ff --- /dev/null +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -0,0 +1,47 @@ +;;; find-func-tests.el --- Unit tests for find-func.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; 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-x) ;For `ert-run-keys'. + +(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)) + ;; Check that `partial-completion' works when completing library names. + (should (equal "org/org" + (ert-simulate-keys + (kbd "o / o r g TAB RET") + (read-library-name)))) + ;; Check that absolute file names also work. + (should (equal (expand-file-name "nxml/" data-directory) + (ert-simulate-keys + (concat data-directory (kbd "n x / TAB RET")) + (read-library-name))))) + +(provide 'find-func-tests) +;;; find-func-tests.el ends here diff --git a/test/lisp/emacs-lisp/float-sup-tests.el b/test/lisp/emacs-lisp/float-sup-tests.el new file mode 100644 index 00000000000..9f9a3daa28b --- /dev/null +++ b/test/lisp/emacs-lisp/float-sup-tests.el @@ -0,0 +1,33 @@ +;;; float-sup-tests.el --- Tests for float-sup.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) + +(ert-deftest float-sup-degrees-and-radians () + (should (equal (degrees-to-radians 180.0) float-pi)) + (should (equal (radians-to-degrees float-pi) 180.0)) + (should (equal (radians-to-degrees (degrees-to-radians 360.0)) 360.0)) + (should (equal (degrees-to-radians (radians-to-degrees float-pi)) float-pi))) + +(provide 'float-sup-tests) +;;; float-sup-tests.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index e0d9167118e..72eee07be8c 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -30,6 +30,8 @@ (require 'ert) (require 'cl-lib) +;;; Code: + (defun generator-list-subrs () (cl-loop for x being the symbols when (and (fboundp x) @@ -306,4 +308,13 @@ identical output." (1+ it))))))) -2))) +(ert-deftest generator-tests-edebug () + "Check that Bug#40434 is fixed." + (with-temp-buffer + (prin1 '(iter-defun generator-tests-edebug () + (iter-yield 123)) + (current-buffer)) + (edebug-defun)) + (should (eql (iter-next (generator-tests-edebug)) 123))) + ;;; generator-tests.el ends here diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 7fa4cd50b08..29e4273b478 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -19,6 +19,7 @@ ;;; Code: +(require 'edebug) (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -134,8 +135,67 @@ "--eval" (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 99) (message "%d" (car gv-test-pair))))) - (should (equal (buffer-string) - "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) + (should (string-match + "\\`Symbol.s function definition is void: \\\\(setf\\\\ gv-test-foo\\\\)\n\\'" + (buffer-string)))))) + +(ert-deftest gv-setter-edebug () + "Check that a setter can be defined and edebugged together with +its getter (Bug#41853)." + (with-temp-buffer + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (dolist (form '((defun gv-setter-edebug-help (b) b) + (defun gv-setter-edebug-get (a b) + (get a (gv-setter-edebug-help b))) + (gv-define-setter gv-setter-edebug-get (x a b) + `(setf (get ,a (gv-setter-edebug-help ,b)) ,x)) + (push 123 (gv-setter-edebug-get 'gv-setter-edebug + 'gv-setter-edebug-prop)))) + (print form (current-buffer))) + ;; Only check whether evaluation works in general. + (eval-buffer))) + (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) + +(ert-deftest gv-plist-get () + (require 'cl-lib) + + ;; Simple setf usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :b) "modify") + target) + '(:a "a" :b "modify" :c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :c)) + target) + '(:a "a" :b "c" :c "b"))) + + ;; Add new key value pair at top of list if setf for missing key. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :d) "modify") + target) + '(:d "modify" :a "a" :b "b" :c "c"))) + + ;; Rotate with missing value. + ;; The value corresponding to the missing key is assumed to be nil. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :d)) + target) + '(:d "b" :a "a" :b nil :c "c"))) + + ;; Simple setf usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (setf (plist-get target 'b) "modify") + target) + '(a "a" b "modify" c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (cl-rotatef (plist-get target 'b) (plist-get target 'c)) + target) + '(a "a" b "c" c "b")))) ;; `ert-deftest' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el new file mode 100644 index 00000000000..41d3f2f3ccf --- /dev/null +++ b/test/lisp/emacs-lisp/hierarchy-tests.el @@ -0,0 +1,556 @@ +;;; hierarchy-tests.el --- Tests for hierarchy.el -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 Damien Cassou + +;; Author: Damien Cassou <damien@cassou.me> +;; 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: + +;; Tests for hierarchy.el + +;;; Code: + +(require 'ert) +(require 'hierarchy) + +(defun hierarchy-animals () + "Create a sorted animal hierarchy." + (let ((parentfn (lambda (item) (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal) + (dolphin 'animal) + (cow 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (hierarchy-add-tree hierarchy 'dolphin parentfn) + (hierarchy-add-tree hierarchy 'cow parentfn) + (hierarchy-sort hierarchy) + hierarchy)) + +(ert-deftest hierarchy-add-one-root () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-one-item-with-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-same-root-twice () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-same-child-twice () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-child () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-two-items-sharing-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-two-hierarchies () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (circle 'shape)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'circle parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird shape))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))) + (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) + +(ert-deftest hierarchy-add-with-childrenfn () + (let ((childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal nil childrenfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-with-parentfn-and-childrenfn () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (animal 'life-form)))) + (childrenfn (lambda (item) + (cl-case item + (bird '(dove pigeon)) + (pigeon '(ashy-wood-pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-roots hierarchy) '(life-form))) + (should (equal (hierarchy-children hierarchy 'life-form) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))) + (should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon))))) + +(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn () + (let* ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-trees () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-trees hierarchy '(dove pigeon) parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-from-list () + (let ((hierarchy (hierarchy-from-list + '(animal (bird (dove) + (pigeon)) + (cow) + (dolphin))))) + (hierarchy-sort hierarchy (lambda (item1 item2) + (string< (car item1) + (car item2)))) + (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item)))) + "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-from-list-with-duplicates () + (let ((hierarchy (hierarchy-from-list + '(a (b) (b)) + t))) + (hierarchy-sort hierarchy (lambda (item1 item2) + ;; sort by ID + (< (car item1) (car item2)))) + (should (equal (hierarchy-length hierarchy) 3)) + (should (equal (hierarchy-to-string + hierarchy + (lambda (item) + (format "%s(%s)" + (cadr item) + (car item)))) + "a(1)\n b(2)\n b(3)\n")))) + +(ert-deftest hierarchy-from-list-with-childrenfn () + (let ((hierarchy (hierarchy-from-list + "abc" + nil + (lambda (item) + (when (string= item "abc") + (split-string item "" t)))))) + (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2))) + (should (equal (hierarchy-length hierarchy) 4)) + (should (equal (hierarchy-to-string hierarchy) + "abc\n a\n b\n c\n")))) + +(ert-deftest hierarchy-add-relation-check-error-when-different-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should-error + (hierarchy--add-relation hierarchy 'bird 'cow #'identity)))) + +(ert-deftest hierarchy-empty-p-return-non-nil-for-empty () + (should (hierarchy-empty-p (hierarchy-new)))) + +(ert-deftest hierarchy-empty-p-return-nil-for-non-empty () + (should-not (hierarchy-empty-p (hierarchy-animals)))) + +(ert-deftest hierarchy-length-of-empty-is-0 () + (should (equal (hierarchy-length (hierarchy-new)) 0))) + +(ert-deftest hierarchy-length-of-non-empty-counts-items () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-length hierarchy) 4)))) + +(ert-deftest hierarchy-has-root () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (should-not (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)))) + +(ert-deftest hierarchy-leafs () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals) + '(dove pigeon dolphin cow))))) + +(ert-deftest hierarchy-leafs-includes-lonely-roots () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'foo parentfn) + (should (equal (hierarchy-leafs hierarchy) + '(foo))))) + +(ert-deftest hierarchy-leafs-of-node () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals 'cow) '())) + (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow))) + (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon))) + (should (equal (hierarchy-leafs animals 'dove) '())))) + +(ert-deftest hierarchy-child-p () + (let ((animals (hierarchy-animals))) + (should (hierarchy-child-p animals 'dove 'bird)) + (should (hierarchy-child-p animals 'bird 'animal)) + (should (hierarchy-child-p animals 'cow 'animal)) + (should-not (hierarchy-child-p animals 'cow 'bird)) + (should-not (hierarchy-child-p animals 'bird 'cow)) + (should-not (hierarchy-child-p animals 'animal 'dove)) + (should-not (hierarchy-child-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant () + (let ((animals (hierarchy-animals))) + (should (hierarchy-descendant-p animals 'dove 'animal)) + (should (hierarchy-descendant-p animals 'dove 'bird)) + (should (hierarchy-descendant-p animals 'bird 'animal)) + (should (hierarchy-descendant-p animals 'cow 'animal)) + (should-not (hierarchy-descendant-p animals 'cow 'bird)) + (should-not (hierarchy-descendant-p animals 'bird 'cow)) + (should-not (hierarchy-descendant-p animals 'animal 'dove)) + (should-not (hierarchy-descendant-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant-if-not-same () + (let ((animals (hierarchy-animals))) + (should-not (hierarchy-descendant-p animals 'cow 'cow)) + (should-not (hierarchy-descendant-p animals 'dove 'dove)) + (should-not (hierarchy-descendant-p animals 'bird 'bird)) + (should-not (hierarchy-descendant-p animals 'animal 'animal)))) + +;; keywords supported: :test :key +(ert-deftest hierarchy--set-equal () + (should (hierarchy--set-equal '(1 2 3) '(1 2 3))) + (should (hierarchy--set-equal '(1 2 3) '(3 2 1))) + (should (hierarchy--set-equal '(3 2 1) '(1 2 3))) + (should-not (hierarchy--set-equal '(2 3) '(3 2 1))) + (should-not (hierarchy--set-equal '(1 2 3) '(2 3))) + (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq)) + (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal)) + (should-not (hierarchy--set-equal '(1 2) '(-1 -2))) + (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)))) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal)) + (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal))) + +(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals animals)) + (should (hierarchy-equal (hierarchy-animals) animals)))) + +(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals (hierarchy-copy animals))))) + +(ert-deftest hierarchy-map-item-on-leaf () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals))) + (should (equal result '((cow . 0)))))) + +(ert-deftest hierarchy-map-item-on-leaf-with-indent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals + 2))) + (should (equal result '((cow . 2)))))) + +(ert-deftest hierarchy-map-item-on-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'bird + animals))) + (should (equal result '((bird . 0) (dove . 1) (pigeon . 1)))))) + +(ert-deftest hierarchy-map-item-on-grand-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'animal + animals))) + (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2) + (cow . 1) (dolphin . 1)))))) + +(ert-deftest hierarchy-map-conses () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map (lambda (item indent) + (cons item indent)) + animals))) + (should (equal result '((animal . 0) + (bird . 1) + (dove . 2) + (pigeon . 2) + (cow . 1) + (dolphin . 1)))))) + +(ert-deftest hierarchy-map-tree () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-map-tree (lambda (item indent children) + (list item indent children)) + animals) + '(animal + 0 + ((bird 1 ((dove 2 nil) (pigeon 2 nil))) + (cow 1 nil) + (dolphin 1 nil))))))) + +(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-hierarchy (lambda (item _) (identity item)) + animals))) + (should (hierarchy-equal animals result)))) + +(ert-deftest hierarchy-map-applies-function () + (let* ((animals (hierarchy-animals)) + (parentfn (lambda (item) + (cond + ((equal item "bird") "animal") + ((equal item "dove") "bird") + ((equal item "pigeon") "bird") + ((equal item "cow") "animal") + ((equal item "dolphin") "animal")))) + (expected (hierarchy-new))) + (hierarchy-add-tree expected "dove" parentfn) + (hierarchy-add-tree expected "pigeon" parentfn) + (hierarchy-add-tree expected "cow" parentfn) + (hierarchy-add-tree expected "dolphin" parentfn) + (should (hierarchy-equal + (hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals) + expected)))) + +(ert-deftest hierarchy-extract-tree () + (let* ((animals (hierarchy-animals)) + (birds (hierarchy-extract-tree animals 'bird))) + (hierarchy-sort birds) + (should (equal (hierarchy-roots birds) '(animal))) + (should (equal (hierarchy-children birds 'animal) '(bird))) + (should (equal (hierarchy-children birds 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy () + (let* ((animals (hierarchy-animals))) + (should-not (hierarchy-extract-tree animals 'foobar)))) + +(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty () + (should (seq-empty-p (hierarchy-items (hierarchy-new))))) + +(ert-deftest hierarchy-items-returns-sequence-of-same-length () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (= (seq-length result) (hierarchy-length animals))))) + +(ert-deftest hierarchy-items-return-all-elements-of-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon))))) + +(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 0) + (buffer-substring (point-min) (point-max))) + "foo")))) + +(ert-deftest hierarchy-labelfn-indent-three-times-if-3 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 3) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-default-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-custom-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base "###")) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))))) + (should (equal content "###foo")))) + +(ert-deftest hierarchy-labelfn-button-propertize () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (properties (with-temp-buffer + (funcall labelfn "bar" 1) + (text-properties-at 1)))) + (should (equal (car properties) 'action)))) + +(ert-deftest hierarchy-labelfn-button-execute-labelfn () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal content "foo")))) + +(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) nil))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 0))))) + +(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) t))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 1))))) + +(ert-deftest hierarchy-labelfn-to-string () + (let ((labelfn (lambda (item _indent) (insert item)))) + (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo")))) + +(ert-deftest hierarchy-print () + (let* ((animals (hierarchy-animals)) + (result (with-temp-buffer + (hierarchy-print animals) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-to-string () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-to-string animals))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-tabulated-display () + (let* ((animals (hierarchy-animals)) + (labelfn (lambda (item _indent) (insert (symbol-name item)))) + (contents (with-temp-buffer + (hierarchy-tabulated-display animals labelfn (current-buffer)) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n")))) + +(ert-deftest hierarchy-sort-non-root-nodes () + (let* ((animals (hierarchy-animals))) + (should (equal (hierarchy-roots animals) '(animal))) + (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin))) + (should (equal (hierarchy-children animals 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-sort-roots () + (let* ((organisms (hierarchy-new)) + (parentfn (lambda (item) + (cl-case item + (oak 'plant) + (bird 'animal))))) + (hierarchy-add-tree organisms 'oak parentfn) + (hierarchy-add-tree organisms 'bird parentfn) + (hierarchy-sort organisms) + (should (equal (hierarchy-roots organisms) '(animal plant))))) + +(provide 'hierarchy-tests) +;;; hierarchy-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index febac8f4789..d1183d83f6a 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -153,7 +153,7 @@ noindent\" 3 (should (equal (buffer-string) str))))) (ert-deftest indent-sexp-stop-before-eol-non-lisp () - "`indent-sexp' shouldn't be too agressive in non-Lisp modes." + "`indent-sexp' shouldn't be too aggressive in non-Lisp modes." ;; See https://debbugs.gnu.org/35286#13. (with-temp-buffer (prolog-mode) @@ -294,6 +294,18 @@ Expected initialization file: `%s'\" (insert "\"\n") (lisp-indent-region (point-min) (point-max)))) +(ert-deftest lisp-indent-defun () + (with-temp-buffer + (lisp-mode) + (let ((orig "(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff))))")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + ;;; Fontification diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 8736ac70201..437b907ba13 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -136,8 +136,7 @@ (text-mode) (insert "\"foo\"") (goto-char (point-min)) - (delete-pair) - (should (string-equal "fo\"" (buffer-string))))) + (should-error (delete-pair)))) (ert-deftest lisp-delete-pair-quotes-text-mode-syntax-table () "Test \\[delete-pair] with modified Text Mode syntax for #15014." @@ -296,7 +295,7 @@ (lambda () (up-list 1 t t)) (or "(1 '2 ( 2' 1 '2 ) 2' 1)") ;; abcdefghijklmnopqrstuvwxy - i k x scan-error) + i k x user-error) (define-lisp-up-list-test backward-up-list-basic (lambda () (backward-up-list)) @@ -367,6 +366,61 @@ start." " "Test buffer for `mark-defun'.")) +;;; end-of-defun + +(ert-deftest end-of-defun-twice () + "Test behavior of prefix arg for `end-of-defun' (Bug#24427). +Calling `end-of-defun' twice should be the same as a prefix arg +of two." + (setq last-command nil) + (cl-flet ((eod2 (lambda () + (goto-char (point-min)) + (end-of-defun) + (end-of-defun) + (let ((pt-eod2 (point))) + (goto-char (point-min)) + (end-of-defun 2) + (should (= (point) pt-eod2)))))) + (with-temp-buffer + (insert "\ +\(defun a ()) + +\(defun b ()) + +\(defun c ())") + (eod2)) + (with-temp-buffer + (insert "\ +\(defun a ()) +\(defun b ()) +\(defun c ())") + (eod2))) + (elisp-tests-with-temp-buffer ";; Comment header + +\(defun func-1 (arg) + \"docstring\" + body) +=!p1= +;; Comment before a defun +\(defun func-2 (arg) + \"docstring\" + body) + +\(defun func-3 (arg) + \"docstring\" + body) +=!p2=(defun func-4 (arg) + \"docstring\" + body) + +;; end +" + (goto-char p1) + (end-of-defun 2) + (should (= (point) p2)))) + +;;; mark-defun + (ert-deftest mark-defun-no-arg-region-inactive () "Test `mark-defun' with no prefix argument and inactive region." diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index c52bb83fa33..1888baf6017 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -376,5 +376,11 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-plist-pcase () + (let ((plist '(:one 1 :two 2))) + (should (equal (pcase-let (((map :one (:two two)) plist)) + (list one two)) + '(1 2))))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index eabe3cb1970..a955df0a696 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -1,4 +1,4 @@ -;;; advice-tests.el --- Test suite for the new advice thingy. +;;; nadvice-tests.el --- Test suite for the new advice thingy. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub index a326d34e54f..5e2ebc55d35 100644 --- a/test/lisp/emacs-lisp/package-resources/key.pub +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -1,18 +1,20 @@ -----BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -mQENBFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAG0HkouIFIuIEhhY2tlciA8 -anJoQGV4YW1wbGUuY29tPokBOAQTAQIAIgUCUk0HyAIbAwYLCQgHAwIGFQgCCQoL -BBYCAwECHgECF4AACgkQtpVAhgkYletuhQf+JAyHYhTZNxjq0UYlikuLX8EtYbXX -PB+03J0B73SMzEai5XsiTU2ADxqxwr7pveVK1INf+IGLiiXBlQq+4DSOvQY4xLfp -58jTOYRV1ECvlXK/JtvVOwufXREADaydf9l/MUxA5G2PPBWIuQknh3ysPSsx68OJ -SzNHFwklLn0DKc4WloE/GLDpTzimnCg7QGzuUo3Iilpjdy8EvTdI5d3jx/mGJIwI -goB+YZgyxSPM+GjDwh5DEwD7OexNqqa7RynnmU0epmlYyi9UufCHLwgiiEIzjpWi -6+iF+CQ45ZAKncovByenIUv73J3ImOudrsskeAHBmahljv1he6uV9Egj2Q== -=b5Kg +mI0EX48EbAEEANrsWXyZ4MRZRjVbLAh5jX/+1+31oB/aJ/q/5DkH1qUHJf0La9LC +sykUSM3H2u5VWLytX/ozrxIRYX13GR2xBxyJlUkDWB209AAVLFrjSp1yUX/Sb5SU +Kb7p421ZAeHiOxfnLRuErFZkTfzY19mUCyw4cdamw430V3mUC9uns/d9ABEBAAG0 +LUouIFJhbmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojO +BBMBCgA4FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJ +CAsCBBYCAwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3 +aDX9jORiNfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQ +rFFiH4IAZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4 +lEPWXW0AycylbdbE7024jQRfjwRsAQQApjTw9kONmSVouCi8ZIQwwYiA9tLzbSZv +CYxbJ6KH0icRhBLfdb1hL/Kn8x3k+xll9A0c/ABVkMxRcbQkY98xsFck7E2GcvnC +sY+w/NdcUUZJYMB3l2MH5ojCbOk5jSAZzxzeFcJhNAhmLqomMHg2LI6KDVey6iYU +FxyIpIQ3SlkAEQEAAYi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+P +BGwCGwwACgkQMKdkJgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKw +wS74Pq407Zv0VD9ual/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYr +YSqWxANyek8otsvppJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOU +Yn923VI= +=NRtx -----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/key.sec b/test/lisp/emacs-lisp/package-resources/key.sec index d21e6ae9a45..dbc80f43cb7 100644 --- a/test/lisp/emacs-lisp/package-resources/key.sec +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -1,33 +1,35 @@ -----BEGIN PGP PRIVATE KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -lQO+BFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAH+AwMCKCCpPNXkXuVgF7cz -eByuvgIO7wImDYGOdJqsASSzV4q0u1acnGtlxg7WphKDF9RnC5+1ZZ1ZcrBcv2uJ -xZm2jHdjqM3FmgQTN70GVzO1nKEur2wxlKotG4Q+8BtaRDwHdKpQFk+QW9aInH3C -BkNWTK97iFwZaoUGxKuRJb35qjMe3SsDE7kdbtOqO+tOeppRVeOOZCn7F33ir/6i -j2gmIME6LFDzvBi6YAyMBSh90Ak70HJINt0QfXlZf5MtX1NaxaEcnsRmwwcNqxh9 -JvcC9q4WrR92NhHCHI+lOsAe7hbwo/VkwRjSSx0HdKkx6kvdcNj/9LeX/jykzLvg -kEqvAqT4Jmk57W2seqvpNcAO+eUVrJ5D1OR6khsUtikPp2pQH5MDXJDGcie+ZAFb -w6BwoWBDBjooKtfuP0LKqrdtJG2JLe6yhBhWvfqHPBlUU1SsA7a5aTCLo8FiqgEI -Kyy60zMx/2Mi48oN1a/mAoV1MTWLhOVUWJlIHM7nVLj1OaX0316LcLX/uTLTq40p -apHKwERanzY7f8ROiv/Fa/J+9cCsfOLKfjFAjpBVUVoOb39HsyS/vvkGMY4kgaD6 -K6r9JPdsaoYvsLkxk5HyHF7Mk2uS1z1EIArD2/3lRiX6ag+IU1Nl3XDkgfZj06K3 -juS84dGF8CmN49uOEjzAJAQZH9jTs5OKzUuZhGJF+gt0L78vLOoKRr8bu1N1GPqU -wnS908HWruXzjJl1CAhnuCa8FnDaU+tmEKjYpWuelx85kolpMW7LT5gOFZr84MIj -Kq3Rt2hU6qQ7Cdy1ep531YKkmyh9Y4l/Tgir1OtnQQqtNuwHI497l7qAUnKZBBHZ -guApjS9BoHsRXkw2mgDssZ+khOwj/xJm876nFSiQeCD0aIbU/4zJ9e2HUOJAZI1r -d7QeSi4gUi4gSGFja2VyIDxqcmhAZXhhbXBsZS5jb20+iQE4BBMBAgAiBQJSTQfI -AhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRC2lUCGCRiV626FB/4kDIdi -FNk3GOrRRiWKS4tfwS1htdc8H7TcnQHvdIzMRqLleyJNTYAPGrHCvum95UrUg1/4 -gYuKJcGVCr7gNI69BjjEt+nnyNM5hFXUQK+Vcr8m29U7C59dEQANrJ1/2X8xTEDk -bY88FYi5CSeHfKw9KzHrw4lLM0cXCSUufQMpzhaWgT8YsOlPOKacKDtAbO5SjciK -WmN3LwS9N0jl3ePH+YYkjAiCgH5hmDLFI8z4aMPCHkMTAPs57E2qprtHKeeZTR6m -aVjKL1S58IcvCCKIQjOOlaLr6IX4JDjlkAqdyi8HJ6chS/vcnciY652uyyR4AcGZ -qGWO/WF7q5X0SCPZ -=5FZK +lQIGBF+PBGwBBADa7Fl8meDEWUY1WywIeY1//tft9aAf2if6v+Q5B9alByX9C2vS +wrMpFEjNx9ruVVi8rV/6M68SEWF9dxkdsQcciZVJA1gdtPQAFSxa40qdclF/0m+U +lCm+6eNtWQHh4jsX5y0bhKxWZE382NfZlAssOHHWpsON9Fd5lAvbp7P3fQARAQAB +/gcDAngNw4ppSPBe/w734cz++xNEv0TDgwxGBWp2wGSwWao04Nl1U4LkjiIy+dkc +uUPwEZMvxXwMcq10PPH26ifP8Xfi/zANXUoLJ0DsG6rtE3BcSC9MPFe3EJENtcIP +a0jFLsbi72aBzolNEDCZCv93znXFPekaXw/RAeeFLJz8GR2Sx6bHbTJKklXgWPHw +C5Dw6xr/kEZktgjlhjkx280STpLGaFO4jiiGZ4Obp5ePp7kyOzDUzaimdZgJwClT +VbZDNQMTzgQrBOP8doXlo9euW4Wo1IYBIOwgeYieM3ZA9YjJAmp4lFnk/KFYt0Ak +0H9IWzDU8VERcU4B04PSXahzvB1Ii7C7bbHxPyuu6sAfMK8DRkrGjwgAlrhuWNLX +M07acT/E9Pm+mBlDcdkyKB2LfwgaVb9F3C25sfcFSvc5p+sqgZp1Zx7Qg9pOhQjw +U7Ln+96c0bUl+iQKdm3TGjOXAFUHYXbRkx2cJ4gxnMVNj0D68xBtBSm0LUouIFJh +bmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojOBBMBCgA4 +FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJCAsCBBYC +AwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3aDX9jORi +NfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQrFFiH4IA +ZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4lEPWXW0A +ycylbdbE702dAgYEX48EbAEEAKY08PZDjZklaLgovGSEMMGIgPbS820mbwmMWyei +h9InEYQS33W9YS/yp/Md5PsZZfQNHPwAVZDMUXG0JGPfMbBXJOxNhnL5wrGPsPzX +XFFGSWDAd5djB+aIwmzpOY0gGc8c3hXCYTQIZi6qJjB4NiyOig1XsuomFBcciKSE +N0pZABEBAAH+BwMCXeUOBwcOsxb/AY6rnHmgACNTGwIa5vgelw0qfET0ms/YzVrN +ufikyV9dEWVxJyuTKav978wanPu7VcCh0pTjL2nTm2nZWyRJN4gb3UIC0MA1xfB2 +yPLTCmsGeJhVOqi4Af/r06mk+NOQ96ivOA2CJuw1LSpcUtuYxB5t/grGyEojYjRP +s0Htvf2bfN9KbFJ26DGsfYzC8bCxm9szPFHBQjw4NboCigUSAHmkoTW01aWZU9Vq +brY4cWhdmCqHgfmsQgzP3LfaAQ6kJ/bkuKef7z57lz5XmlyjMQGWcZWp5xf2n81p +BV6unaIPyavzkKVAXizVfNiHNJgK9PoVoEOJkPLjRfMxVmFSGN/oF7lVTRWfOIwo +68rtNPhr6UzE4ArGHYv/pK3kijUp5daWmfrySWPcwoVAaR3mIIVs/1rhd9aZrwn6 +Q07Yo5u11rH9b8anZQF3BdTcrnU9pUzLYlFPnfhtyGqhikQILtPTf0iwr8hpG9b2 +Zoi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwwACgkQMKdk +JgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKwwS74Pq407Zv0VD9u +al/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYrYSqWxANyek8otsvp +pJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOUYn923VI= +=2DW8 -----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el index 7251622fa59..61c1b045990 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el @@ -1,4 +1,4 @@ -;;; new-pkg.el --- A package only seen after "updating" archive-contents +;;; new-pkg.el --- A package only seen after "updating" archive-contents -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el index 7b1c00c06db..301993deb30 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.4 diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig Binary files differindex 658edd3f60e..dac168b0e4c 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el index 3734823876e..ff070c6526f 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el @@ -1,4 +1,4 @@ -;;; signed-bad.el --- A single-file package with bad signature +;;; signed-bad.el --- A single-file package with bad signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el index 22718df2763..60b1b8663d9 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el @@ -1,4 +1,4 @@ -;;; signed-good.el --- A single-file package with good signature +;;; signed-good.el --- A single-file package with good signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig Binary files differindex 747918794ca..5b1c721e32a 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh new file mode 100755 index 00000000000..a48c9bb1aa2 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh @@ -0,0 +1,32 @@ +#! /bin/sh + +# Generate a new key and update the signatures for tests. + +# Copyright (C) 2020 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/>. + +export GPG_AGENT="" +KEYRING="./key.ring" +TRUSTDB="./trust.db" +GPG="gpg --no-default-keyring --trustdb-name $TRUSTDB --keyring $KEYRING --yes" + +rm $KEYRING +$GPG --full-generate-key +$GPG --export --armor > "../key.pub" +$GPG --export-secret-keys -armor > "../key.sec" +$GPG --detach-sign --sign "./archive-contents" +$GPG --detach-sign --sign "./signed-good-1.0.el" diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el index b58b658d024..cb003905bb5 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -1,4 +1,4 @@ -;;; simple-depend.el --- A single-file package with a dependency. +;;; simple-depend.el --- A single-file package with a dependency. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el index 6756a28080b..9c3f427ff48 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.3 diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el index 9cfe5c0d4e2..a0a9607350a 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -1,4 +1,4 @@ -;;; simple-two-depend.el --- A single-file package with two dependencies. +;;; simple-two-depend.el --- A single-file package with two dependencies. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.1 diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 4fcaf0e84c2..23267545f83 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -1,4 +1,4 @@ -;;; package-test.el --- Tests for the Emacs package system +;;; package-tests.el --- Tests for the Emacs package system -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -39,6 +39,7 @@ (require 'package) (require 'ert) +(require 'ert-x) (require 'cl-lib) (setq package-menu-async nil) @@ -102,13 +103,9 @@ (multi-file (0 1)))) "`package-desc' used for testing dependencies.") -(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir) +(defvar package-test-data-dir (ert-resource-directory) "Base directory of package test files.") -(defvar package-test-fake-contents-file - (expand-file-name "archive-contents" package-test-data-dir) - "Path to a static copy of \"archive-contents\".") - (cl-defmacro with-package-test ((&optional &key file basedir install @@ -143,8 +140,8 @@ ,(if basedir `(cd ,basedir)) (unless (file-directory-p package-user-dir) (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) ,@(when install `((package-initialize) (package-refresh-contents) @@ -154,6 +151,15 @@ `(insert-file-contents ,file)) ,@body))) + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) (when (file-directory-p package-test-user-dir) (delete-directory package-test-user-dir t)) @@ -175,9 +181,8 @@ (defun package-test-suffix-matches (base suffix-list) "Return file names matching BASE concatenated with each item in SUFFIX-LIST" - (cl-mapcan - '(lambda (item) (file-expand-wildcards (concat base item))) - suffix-list)) + (mapcan (lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) (defvar tar-parse-info) (declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct @@ -216,20 +221,20 @@ 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 "package-resources" :file "simple-single-1.3.el") + (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 "package-resources" :file "simple-depend-1.0.el") + (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))) - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "multi-file-0.2.3.tar") (tar-mode) (should (equal (package-tar-file-info) multi-file-desc)))) (ert-deftest package-test-install-single () "Install a single file without using an archive." - (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") (should (package-install-from-buffer)) (package-initialize) (should (package-installed-p 'simple-single)) @@ -272,7 +277,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-macro-compilation () "Install a package which includes a dependency." - (with-package-test (:basedir "package-resources") + (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) ;; `macro-problem-func' uses a macro from `macro-aux'. @@ -311,8 +316,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-prioritized () "Install a lower version from a higher-prioritized archive." (with-package-test () - (let* ((newer-version (expand-file-name "package-resources/newer-versions" - package-test-file-dir)) + (let* ((newer-version (ert-resource-file "newer-versions")) (package-archives `(("older" . ,package-test-data-dir) ("newer" . ,newer-version))) (package-archive-priorities '(("older" . 100)))) @@ -327,7 +331,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-multifile () "Check properties of the installed multi-file package." - (with-package-test (:basedir "package-resources" :install '(multi-file)) + (with-package-test (:basedir (ert-resource-directory) :install '(multi-file)) (let ((autoload-file (expand-file-name "multi-file-autoloads.el" (expand-file-name @@ -352,55 +356,128 @@ Must called from within a `tar-mode' buffer." (goto-char (point-min)) (should (re-search-forward re nil t))))))) + +;;; Package Menu tests + +(defmacro with-package-menu-test (&rest body) + "Set up Package Menu (\"*Packages*\") buffer for testing." + (declare (indent 0) (debug (([&rest form]) body))) + `(with-package-test () + (let ((buf (package-list-packages))) + (unwind-protect + (progn ,@body) + (kill-buffer buf))))) + (ert-deftest package-test-update-listing () "Ensure installed package status is updated." - (with-package-test () - (let ((buf (package-list-packages))) - (search-forward-regexp "^ +simple-single") - (package-menu-mark-install) - (package-menu-execute) - (run-hooks 'post-command-hook) - (should (package-installed-p 'simple-single)) - (switch-to-buffer "*Packages*") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) - (goto-char (point-min)) - (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) - (kill-buffer buf)))) + (with-package-menu-test + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)))) + +(ert-deftest package-test-list-filter-by-archive () + "Ensure package list is filtered correctly by archive version." + (with-package-menu-test + ;; TODO: Add another package archive to test filtering, because + ;; the testing environment currently only has one. + (package-menu-filter-by-archive "gnu") + (goto-char (point-min)) + (should (looking-at "^\\s-+multi-file")) + (should (= (count-lines (point-min) (point-max)) 4)) + (should-error (package-menu-filter-by-archive "non-existent archive")))) + +(ert-deftest package-test-list-filter-by-keyword () + "Ensure package list is filtered correctly by package keyword." + (with-package-menu-test + (package-menu-filter-by-keyword "frobnicate") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (should-error (package-menu-filter-by-keyword "non-existent-keyword")))) (ert-deftest package-test-list-filter-by-name () "Ensure package list is filtered correctly by package name." + (with-package-menu-test () + (package-menu-filter-by-name "tetris") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+tetris" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)))) + +(ert-deftest package-test-list-filter-by-status () + "Ensure package list is filtered correctly by package status." + (with-package-menu-test + (package-menu-filter-by-status "available") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+multi-file" nil t)) + (should (= (count-lines (point-min) (point-max)) 4)) + ;; No installed packages in default environment. + (should-error (package-menu-filter-by-status "installed")))) + +(ert-deftest package-test-list-filter-marked () + "Ensure package list is filtered correctly by non-empty mark." (with-package-test () - (let ((buf (package-list-packages))) - (package-menu-filter-by-name "tetris") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+tetris" nil t)) - (should (= (count-lines (point-min) (point-max)) 1)) - (kill-buffer buf)))) + (package-list-packages) + (revert-buffer) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-filter-marked) + (goto-char (point-min)) + (should (re-search-forward "^I +simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-mark-unmark) + ;; No marked packages in default environment. + (should-error (package-menu-filter-marked)))) + +(ert-deftest package-test-list-filter-by-version () + (with-package-menu-test + (should-error (package-menu-filter-by-version "1.1" 'unknown-symbol))) ) + +(defun package-test-filter-by-version (version predicate name) + (with-package-menu-test + (package-menu-filter-by-version version predicate) + (goto-char (point-min)) + ;; We just check that the given package is included in the + ;; listing. One could be more ambitious. + (should (re-search-forward name)))) + +(ert-deftest package-test-list-filter-by-version-= () + "Ensure package list is filtered correctly by package version (=)." + (package-test-filter-by-version "1.1" '= "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-< () + "Ensure package list is filtered correctly by package version (<)." + (package-test-filter-by-version "1.2" '< "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-> () + "Ensure package list is filtered correctly by package version (>)." + (package-test-filter-by-version "1.0" '> "^\\s-+simple-two-depend")) (ert-deftest package-test-list-clear-filter () "Ensure package list filter is cleared correctly." - (with-package-test () - (let ((buf (package-list-packages))) - (let ((num-packages (count-lines (point-min) (point-max)))) - (should (> num-packages 1)) - (package-menu-filter-by-name "tetris") - (should (= (count-lines (point-min) (point-max)) 1)) - (package-menu-clear-filter) - (should (= (count-lines (point-min) (point-max)) num-packages))) - (kill-buffer buf)))) + (with-package-menu-test + (let ((num-packages (count-lines (point-min) (point-max)))) + (package-menu-filter-by-name "tetris") + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-clear-filter) + (should (= (count-lines (point-min) (point-max)) num-packages))))) (ert-deftest package-test-update-archives () "Test updating package archives." (with-package-test () - (let ((buf (package-list-packages))) + (let ((_buf (package-list-packages))) (revert-buffer) (search-forward-regexp "^ +simple-single") (package-menu-mark-install) (package-menu-execute) (should (package-installed-p 'simple-single)) - (let ((package-test-data-dir - (expand-file-name "package-resources/newer-versions" package-test-file-dir))) + (let ((package-test-data-dir (ert-resource-file "newer-versions"))) (setq package-archives `(("gnu" . ,package-test-data-dir))) (revert-buffer) @@ -419,6 +496,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-update-archives-async () "Test updating package archives asynchronously." + :tags '(:expensive-test) (skip-unless (executable-find "python2")) (let* ((package-menu-async t) (default-directory package-test-data-dir) @@ -438,7 +516,7 @@ Must called from within a `tar-mode' buffer." (when (re-search-forward "Server started, \\(.*\\)\n" nil t) (setq addr (match-string 1)))) addr))) - (with-package-test (:basedir package-test-data-dir :location addr) + (with-package-test (:basedir (ert-resource-directory) :location addr) (list-packages) (should package--downloads-in-progress) (should mode-line-process) @@ -458,8 +536,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-update-archives/ignore-nil-entry () "Ignore any packages that are nil. Test for Bug#28502." (with-package-test () - (let* ((with-nil-entry (expand-file-name "package-resources/with-nil-entry" - package-test-file-dir)) + (let* ((with-nil-entry (ert-resource-file "with-nil-entry")) (package-archives `(("with-nil-entry" . ,with-nil-entry)))) (package-initialize) (package-refresh-contents) @@ -537,6 +614,7 @@ Must called from within a `tar-mode' buffer." (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) +(defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." (skip-unless (let ((homedir (make-temp-file "package-test" t))) @@ -559,8 +637,7 @@ Must called from within a `tar-mode' buffer." prog-alist))) (delete-directory homedir t)))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) - (package-test-data-dir - (expand-file-name "package-resources/signed" package-test-file-dir))) + (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () (package-initialize) (package-import-keyring keyring) @@ -577,8 +654,8 @@ Must called from within a `tar-mode' buffer." (should (progn (package-install 'signed-good) 'noerror)) (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. - (let ((buf (package-list-packages))) - (revert-buffer) + (let ((_buf (package-list-packages))) + (revert-buffer) (should (re-search-forward "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" nil t)) @@ -621,7 +698,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-x-test-upload-buffer () "Test creating an \"archive-contents\" file" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -654,7 +731,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-x-test-upload-new-version () "Test uploading a new version of a package" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -731,4 +808,4 @@ Must called from within a `tar-mode' buffer." (provide 'package-test) -;;; package-test.el ends here +;;; package-tests.el ends here diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 0b69bd99f32..ac512416b71 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -1,4 +1,4 @@ -;;; pcase-tests.el --- Test suite for pcase macro. +;;; pcase-tests.el --- Test suite for pcase macro. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 0179ac4f1f4..ff93b8b759e 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -25,27 +25,14 @@ (require 'regexp-opt) -(defun regexp-opt-test--permutation (n list) - "The Nth permutation of LIST, 0 ≤ N < (length LIST)!." - (let ((len (length list)) - (perm-list nil)) - (dotimes (i len) - (let* ((d (- len i)) - (k (mod n d))) - (push (nth k list) perm-list) - (setq list (append (butlast list (- (length list) k)) - (nthcdr (1+ k) list))) - (setq n (/ n d)))) - (nreverse perm-list))) - -(defun regexp-opt-test--factorial (n) - "N!" - (apply #'* (number-sequence 1 n))) - -(defun regexp-opt-test--permutations (list) - "All permutations of LIST." - (mapcar (lambda (i) (regexp-opt-test--permutation i list)) - (number-sequence 0 (1- (regexp-opt-test--factorial (length list)))))) +(defun regexp-opt-test--permutations (l) + "All permutations of L, assuming no duplicates." + (if (cdr l) + (mapcan (lambda (x) + (mapcar (lambda (p) (cons x p)) + (regexp-opt-test--permutations (remove x l)))) + l) + (list l))) (ert-deftest regexp-opt-longest-match () "Check that the regexp always matches as much as possible." diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 5dee206e931..5add24c479a 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -5,18 +5,20 @@ ;; Author: Tino Calancha <tino.calancha@gmail.com> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 05779b4e0a6..d2e11cf06aa 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -56,13 +56,17 @@ (ert-deftest rx-def-in-or () (rx-let ((a b) (b (or "abc" c)) - (c ?a)) + (c ?a) + (d (any "a-z"))) (should (equal (rx (or a (| "ab" "abcde") "abcd")) - "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")))) + "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) + (should (equal (rx (or ?m (not d))) + "[^a-ln-z]")))) (ert-deftest rx-char-any () "Test character alternatives with `]' and `-' (Bug#25123)." (should (equal + ;; relint suppression: Range .<-]. overlaps previous .]-{ (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:))) string-end) "\\`[.-:<-{-]+\\'"))) @@ -127,8 +131,12 @@ "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) "[][:lower:][:upper:]][^][:lower:][:upper:]]")) - (should (equal (rx (any "-a" "c-" "f-f" "--/*--")) - "[*-/acf]")) + ;; relint suppression: Duplicated character .-. + ;; relint suppression: Single-character range .f-f + ;; relint suppression: Range .--/. overlaps previous .- + ;; relint suppression: Range .\*--. overlaps previous .--/ + (should (equal (rx (any "-a" "c-" "f-f" "--/*--") (any "," "-" "A")) + "[*-/acf][,A-]")) (should (equal (rx (any "]-a" ?-) (not (any "]-a" ?-))) "[]-a-][^]-a-]")) (should (equal (rx (any "--]") (not (any "--]")) @@ -140,6 +148,7 @@ "\\`a\\`[^z-a]")) (should (equal (rx (any "") (not (any ""))) "\\`a\\`[^z-a]")) + ;; relint suppression: Duplicated class .space. (should (equal (rx (any space ?a digit space)) "[a[:space:][:digit:]]")) (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) @@ -392,6 +401,8 @@ "ab"))) (ert-deftest rx-literal () + (should (equal (rx (literal "$a")) + "\\$a")) (should (equal (rx (literal (char-to-string 42)) nonl) "\\*.")) (let ((x "a+b")) @@ -532,6 +543,9 @@ (ert-deftest rx-compat () "Test old symbol retained for compatibility (bug#37517)." - (should (equal (rx-submatch-n '(group-n 3 (+ nonl) eol)) "\\(?3:.+$\\)"))) + (should (equal + (with-no-warnings + (rx-submatch-n '(group-n 3 (+ nonl) eol))) + "\\(?3:.+$\\)"))) (provide 'rx-tests) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 77ee4f5c38d..a6a80952360 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -1,4 +1,4 @@ -;;; seq-tests.el --- Tests for sequences.el +;;; seq-tests.el --- Tests for seq.el -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -126,7 +126,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) - (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (should (equal (seq-filter (lambda (_) nil) seq) '()))) (with-test-sequences (seq '()) (should (equal (seq-filter #'test-sequences-evenp seq) '())))) @@ -134,7 +134,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) - (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (should (same-contents-p (seq-remove (lambda (_) nil) seq) seq))) (with-test-sequences (seq '()) (should (equal (seq-remove #'test-sequences-evenp seq) '())))) @@ -142,7 +142,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-count #'test-sequences-evenp seq) 3)) (should (equal (seq-count #'test-sequences-oddp seq) 2)) - (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (should (equal (seq-count (lambda (_) nil) seq) 0))) (with-test-sequences (seq '()) (should (equal (seq-count #'test-sequences-evenp seq) 0)))) @@ -199,7 +199,7 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-every-p () (with-test-sequences (seq '(43 54 22 1)) - (should (seq-every-p (lambda (elt) t) seq)) + (should (seq-every-p (lambda (_) t) seq)) (should-not (seq-every-p #'test-sequences-oddp seq)) (should-not (seq-every-p #'test-sequences-evenp seq))) (with-test-sequences (seq '(42 54 22 2)) diff --git a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el +++ b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el +++ b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-tests.el b/test/lisp/emacs-lisp/shadow-tests.el index 219312a5578..5d6215ab6f3 100644 --- a/test/lisp/emacs-lisp/shadow-tests.el +++ b/test/lisp/emacs-lisp/shadow-tests.el @@ -20,30 +20,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'shadow) (eval-when-compile (require 'cl-lib)) -(defconst shadow-tests-data-directory - (expand-file-name "lisp/emacs-lisp/shadow-resources" - (or (getenv "EMACS_TEST_DIRECTORY") - (expand-file-name "../../.." - (or load-file-name - buffer-file-name)))) - "Directory for shadow test files.") - (ert-deftest shadow-case-insensitive () "Test shadowing for case insensitive filenames." ;; Override `file-name-case-insensitive-p' so we test the same thing ;; regardless of what file system we're running on. (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) t))) - (should (equal (list (expand-file-name "p1/foo" shadow-tests-data-directory) - (expand-file-name "p2/FOO" shadow-tests-data-directory)) + (should (equal (list (ert-resource-file "p1/foo") + (ert-resource-file "p2/FOO")) (load-path-shadows-find - (list (expand-file-name "p1/" shadow-tests-data-directory) - (expand-file-name "p2/" shadow-tests-data-directory)))))) + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) nil))) (should-not (load-path-shadows-find - (list (expand-file-name "p1/" shadow-tests-data-directory) - (expand-file-name "p2/" shadow-tests-data-directory)))))) + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) ;;; shadow-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 220ce0c08f0..9d14a5ab7ec 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -1,22 +1,24 @@ -;;; subr-x-tests.el --- Testing the extended lisp routines +;;; subr-x-tests.el --- Testing the extended lisp routines -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..9d4c4113fdd --- /dev/null +++ b/test/lisp/emacs-lisp/syntax-tests.el @@ -0,0 +1,67 @@ +;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 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 'syntax) + +(ert-deftest syntax-propertize--shift-groups-and-backrefs () + "Test shifting of numbered groups and back-references in regexps." + ;; A numbered group must be shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foobar" 2) + "\\(?4:[abc]+\\)foobar")) + ;; A back-reference \1 on a normal sub-regexp context must be + ;; shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2) + "\\(a\\)\\3")) + ;; Shifting must not happen if the \1 appears in a character class, + ;; or in a \{\} repetition construct (although \1 isn't valid there + ;; anyway). + (let ((rx-with-class "\\(a\\)[\\1-2]") + (rx-with-rep "\\(a\\)\\{1,\\1\\}")) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-class 2) + rx-with-class)) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2) + rx-with-rep))) + ;; Now numbered groups and back-references in combination. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foo\\(\\2\\)" 2) + "\\(?4:[abc]+\\)foo\\(\\4\\)")) + ;; Emacs supports only the back-references \1,...,\9, so when a + ;; shift would result in \10 or more, an error must be signalled. + (should-error + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; syntax-tests.el ends here. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 6870d49acb2..9e7a3bf31e3 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -31,26 +31,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'testcover) (require 'skeleton) -;; Use `eval-and-compile' around all these definitions because they're -;; used by the macro `testcover-tests-define-tests'. - -(eval-and-compile - (defvar testcover-tests-file-dir - (expand-file-name - "testcover-resources/" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Directory of the \"testcover-tests.el\" file.")) - -(eval-and-compile - (defvar testcover-tests-test-cases - (expand-file-name "testcases.el" testcover-tests-file-dir) - "File containing marked up code to instrument and check.")) - ;; Convert Testcover's overlays to plain text. (eval-and-compile @@ -62,6 +46,7 @@ is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) + (find-file-suppress-same-file-warnings t) (code (buffer-substring beg end)) (marked-up-code)) (unwind-protect @@ -114,7 +99,8 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))) + (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) + (find-file-suppress-same-file-warnings t)) (unwind-protect (progn (with-temp-file tempfile @@ -149,7 +135,7 @@ Construct and return a list of `ert-deftest' forms. See testcases.el for documentation of the test definition format." (let (results) (with-temp-buffer - (insert-file-contents testcover-tests-test-cases) + (insert-file-contents (ert-resource-file "testcases.el")) (goto-char (point-min)) (while (re-search-forward (concat "^;; ==== \\([^ ]+?\\) ====\n" diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el index 26b89b72312..f643e49aa5e 100644 --- a/test/lisp/emacs-lisp/text-property-search-tests.el +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -1,22 +1,24 @@ -;;; text-property-search-tests.el --- Testing text-property-search +;;; text-property-search-tests.el --- Testing text-property-search -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -151,6 +153,24 @@ 46 57 nil (point-max))) + +;;;; Position after search. + +(defun text-property-search--pos-test (fun pos &optional reverse) + (with-temp-buffer + (insert (concat "foo " + (propertize "bar" 'x t) + " baz")) + (goto-char (if reverse (point-max) (point-min))) + (funcall fun 'x t) + (should (= (point) pos)))) + +(ert-deftest text-property-search-forward-point-at-beginning () + (text-property-search--pos-test #'text-property-search-forward 5)) + +(ert-deftest text-property-search-backward-point-at-end () + (text-property-search--pos-test #'text-property-search-backward 8 t)) + (provide 'text-property-search-tests) ;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el new file mode 100644 index 00000000000..06c40d28ca9 --- /dev/null +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -0,0 +1,154 @@ +;;; unsafep-tests.el --- tests for unsafep.el -*- lexical-binding: t; -*- + +;; Author: Jonathan Yavner <jyavner@member.fsf.org> + +;; Copyright (C) 2002-2020 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 'unsafep) + +(defvar safe-functions) + +;;; These forms are all considered safe +(defconst unsafep-tests--safe + '(((lambda (x) (* x 2)) 14) + (apply 'cdr (mapcar (lambda (x) (car x)) y)) + (cond ((= x 4) 5) (t 27)) + (condition-case x (car y) (error (car x))) + (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) + (let (x) (apply (lambda (x) (* x 2)) 14)) + (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) + (let ((x 1) (y 2)) (setq x (+ x y))) + (let ((x 1)) (let ((y (+ x 3))) (* x y))) + (let* nil (current-time)) + (let* ((x 1) (y (+ x 3))) (* x y)) + (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) + (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") + (setq buffer-display-count 14 mark-active t) + ;;This is not safe if you insert it into a buffer! + (propertize "x" 'display '(height (progn (delete-file "x") 1)))) + "List of forms that `unsafep' should decide are safe.") + +;;; These forms are considered unsafe +(defconst unsafep-tests--unsafe + '(( (add-to-list x y) + . (unquoted x)) + ( (add-to-list y x) + . (unquoted y)) + ( (add-to-list 'y x) + . (global-variable y)) + ( (not (delete-file "unsafep.el")) + . (function delete-file)) + ( (cond (t (aset local-abbrev-table 0 0))) + . (function aset)) + ( (cond (t (setq unsafep-vars ""))) + . (risky-local-variable unsafep-vars)) + ( (condition-case format-alist 1) + . (risky-local-variable format-alist)) + ( (condition-case x 1 (error (setq format-alist ""))) + . (risky-local-variable format-alist)) + ( (dolist (x (sort globalvar 'car)) (princ x)) + . (function sort)) + ( (dotimes (x 14) (delete-file "x")) + . (function delete-file)) + ( (let ((post-command-hook "/tmp/")) 1) + . (risky-local-variable post-command-hook)) + ( (let ((x (delete-file "x"))) 2) + . (function delete-file)) + ( (let (x) (add-to-list 'x (delete-file "x"))) + . (function delete-file)) + ( (let (x) (condition-case y (setq x 1 z 2))) + . (global-variable z)) + ( (let (x) (condition-case z 1 (error (delete-file "x")))) + . (function delete-file)) + ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) + . (function setcar)) + ( (let (y) (push (delete-file "x") y)) + . (function delete-file)) + ( (let* ((x 1)) (setq y 14)) + . (global-variable y)) + ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) + . (function kill-buffer)) + ( (mapcar x y) + . (unquoted x)) + ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) + . (function rename-file)) + ( (mapconcat x1 x2 " ") + . (unquoted x1)) + ( (pop format-alist) + . (risky-local-variable format-alist)) + ( (push 1 format-alist) + . (risky-local-variable format-alist)) + ( (setq buffer-display-count (delete-file "x")) + . (function delete-file)) + ;;These are actually safe (they signal errors) + ( (apply '(x) '(1 2 3)) + . (function (x))) + ( (let (((x))) 1) + . (variable (x))) + ( (let (1) 2) + . (variable 1)) + ( (error "asdf") + . #'error) + ( (signal 'error "asdf") + . #'signal) + ( (throw 'asdf) + . #'throw) + ( (catch 'asdf 17) + . #'catch) + ( (play-sound-file "asdf") + . #'play-sound-file) + ( (replace-regexp-in-string "a" "b") + . #'replace-regexp-in-string) + ) + "A-list of (FORM . REASON)... that `unsafep' should decide are unsafe.") + +(ert-deftest test-unsafep/safe () + "Check safe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--safe) + (should-not (unsafep x))))) + +(ert-deftest test-unsafep/message () + "Check that message is considered unsafe." + (should (unsafep '(dolist (x y) (message "here: %s" x)))) + (should (unsafep '(dotimes (x 14 (* x 2)) (message "here: %d" x))))) + +(ert-deftest test-unsafep/unsafe () + "Check unsafe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--unsafe) + (should (equal (unsafep (car x)) (cdr x)))))) + +(ert-deftest test-unsafep/safe-functions-t () + "safe-functions=t should allow delete-file" + (let ((safe-functions t)) + (should-not (unsafep '(delete-file "x"))) + (should-not (unsafep-function 'delete-file)))) + +(ert-deftest test-unsafep/safe-functions-setcar () + "safe-functions=(setcar) should allow setcar but not setcdr" + (let ((safe-functions '(setcar))) + (should-not (unsafep '(setcar x 1))) + (should (unsafep '(setcdr x 1))))) + +(provide 'unsafep-tests) + +;;; unsafep-tests.el ends here diff --git a/test/lisp/emacs-lisp/warnings-tests.el b/test/lisp/emacs-lisp/warnings-tests.el new file mode 100644 index 00000000000..02c09b41ca5 --- /dev/null +++ b/test/lisp/emacs-lisp/warnings-tests.el @@ -0,0 +1,60 @@ +;;; warnings-tests.el --- tests for warnings.el -*- lexical-binding: t; -*- + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; Copyright (C) 2020 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 'warnings) + +(ert-deftest test-warning-suppress-p () + (should (warning-suppress-p 'foo '((foo)))) + (should (warning-suppress-p '(foo bar) '((foo bar)))) + (should (warning-suppress-p '(foo bar baz) '((foo bar)))) + (should-not (warning-suppress-p '(foo bar baz) '((foo bax)))) + (should-not (warning-suppress-p 'foobar nil))) + +(ert-deftest test-display-warning () + (dolist (level '(:emergency :error :warning)) + (with-temp-buffer + (display-warning '(foo) "Hello123" level (current-buffer)) + (should (string-match "foo" (buffer-string))) + (should (string-match "Hello123" (buffer-string)))) + (with-current-buffer "*Messages*" + (should (string-match "Hello123" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-level () + ;; This test only works interactively: + :expected-result :failed + (let ((warning-minimum-level :emergency)) + (with-temp-buffer + (display-warning '(foo) "baz" :warning (current-buffer))) + (with-current-buffer "*Messages*" + (should-not (string-match "baz" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-log-level () + (let ((warning-minimum-log-level :error)) + (with-temp-buffer + (display-warning '(foo) "hello" :warning (current-buffer)) + (should-not (string-match "hello" (buffer-string)))))) + +(provide 'warnings-tests) + +;;; warnings-tests.el ends here diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index 33f85e51254..b981938fe19 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -1,4 +1,4 @@ -;;; viper-tests.el --- tests for viper. +;;; viper-tests.el --- tests for viper. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/epg-resources/dummy-pinentry b/test/lisp/epg-resources/dummy-pinentry new file mode 100755 index 00000000000..2228dfb0c6d --- /dev/null +++ b/test/lisp/epg-resources/dummy-pinentry @@ -0,0 +1,22 @@ +#! /bin/bash +# Dummy pinentry +# +# Copyright 2008 g10 Code GmbH +# +# This file is free software; as a special exception the author gives +# unlimited permission to copy and/or distribute it, with or without +# modifications, as long as this notice is preserved. +# +# This file is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY, to the extent permitted by law; without even the +# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +# PURPOSE. + +echo OK Your orders please + +while read cmd; do + case $cmd in + GETPIN) echo D test0123456789; echo OK;; + *) echo OK;; + esac +done diff --git a/test/lisp/epg-resources/pubkey.asc b/test/lisp/epg-resources/pubkey.asc new file mode 100644 index 00000000000..c0bf28f6200 --- /dev/null +++ b/test/lisp/epg-resources/pubkey.asc @@ -0,0 +1,20 @@ +-----BEGIN PGP PUBLIC KEY BLOCK----- +Version: GnuPG v1 + +mI0EVRDxCAEEALcScrRmxq5N+Hh+NxPg75RJJdtEi824pwtqMlT/3wG1esmP5gNu +ZIPVaTTSGNZkEzeYdhaLXBUe5qD+RQIQVh+MLt9nisF9nD35imyOrhHwAHnglOPx +GdylH8nQ/tIO5p/lfUlw+iCBlPH7eZHqFJhwP0hJML4PKE8ArWG6RtsxABEBAAG0 +J0pvZSBUZXN0ZXIgKHRlc3Qga2V5KSA8am9lQGV4YW1wbGUuY29tPoi4BBMBAgAi +BQJVEPEIAhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRAoscCWMvu4GGYO +A/0Zzoc2z/dvAtFVLh4ovKqP2qliQt2qschJHVP30hJnKT7dmJfJl7kz9mXmMfSt +Ym0luYmeSzdeWORM9SygLRYXuDfN6G4ZPJTlsRhgnARhNzNhSx+YlcFh48Z+a5zR +goBMn7DgYVqfU4UteZOSXMlnuA2Z5ao1qgGhVqESSJgU5riNBFUQ8QgBBADacLkK +D0U11nmlsScxPGkrDr0aJPrG8MEaDRnKjHJKNp3XTp1psGBUpWF/ErjQAIu+psFt +LO8owCGsg/vJM7CzTv2dVBRbrZXjIKvdq7HdivosTMaHArQBpEtSO9rmgVHO+jaQ +q/M2oGvNEB86zo3nfTWhOgBiB32m8kttWRiuWQARAQABiJ8EGAECAAkFAlUQ8QgC +GwwACgkQKLHAljL7uBj44AQAkMJRm7VJUryrDKFtfIfytQx/vmyU/cZcVV6IpKqP +KhztgR+QD9czlHvQhz+y3hqtLRShu2Eyf75dNexcUvKs/lS4LIDXg5V7pWSRk9eQ +G403muqR/NGu6+QmUx09rJl72trdaGxNkyHA7Zy7ZDGkcMvQsd3qoSNGsPR5TKes +w7Q= +=NMxb +-----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/epg-resources/seckey.asc b/test/lisp/epg-resources/seckey.asc new file mode 100644 index 00000000000..4ac7ba4a502 --- /dev/null +++ b/test/lisp/epg-resources/seckey.asc @@ -0,0 +1,33 @@ +-----BEGIN PGP PRIVATE KEY BLOCK----- +Version: GnuPG v1 + +lQHYBFUQ8QgBBAC3EnK0ZsauTfh4fjcT4O+USSXbRIvNuKcLajJU/98BtXrJj+YD +bmSD1Wk00hjWZBM3mHYWi1wVHuag/kUCEFYfjC7fZ4rBfZw9+Ypsjq4R8AB54JTj +8RncpR/J0P7SDuaf5X1JcPoggZTx+3mR6hSYcD9ISTC+DyhPAK1hukbbMQARAQAB +AAP9Hs9agZTobA5QOksXjt9kwqJ63gePtbwVVNz3AoobaGi39PMkRUCPZwaEEbEo +H/CwsUMV4J5sjVtpef/A8mN4csai7NYp82mbo+dPim4p+SUtBg4Ms8ujGVcQeRQd +1CXtIkixDu6fw4wDtNw03ZyNJOhBOXVTgAyOTSlIz3D+6n8CAMeCqEFBHQIVoQpf +Bza4YvFtJRdfGMTix3u7Cb6y9CHGBok7uUgQAeWnzQvMGTCHc3e8iHGAYBQ88GPF +v1TpiusCAOroRe69Aiid5JMVTjWoJ0SHKd47nIj0gQFiDfa5de0BNq9gYj7JLg+R +EjsJbJN39z+Z9HWjIOCUOIXDvucmM1MB/iNxW1Z8mEMflEYK5rop+PDxwqUbr8uZ +kzogw98ZdmuEuN0bheGWUiJI+0Pd8jb40zlR1KgOEMx1mZchToAJdtybMLQnSm9l +IFRlc3RlciAodGVzdCBrZXkpIDxqb2VAZXhhbXBsZS5jb20+iLgEEwECACIFAlUQ +8QgCGwMGCwkIBwMCBhUIAgkKCwQWAgMBAh4BAheAAAoJECixwJYy+7gYZg4D/RnO +hzbP928C0VUuHii8qo/aqWJC3aqxyEkdU/fSEmcpPt2Yl8mXuTP2ZeYx9K1ibSW5 +iZ5LN15Y5Ez1LKAtFhe4N83obhk8lOWxGGCcBGE3M2FLH5iVwWHjxn5rnNGCgEyf +sOBhWp9ThS15k5JcyWe4DZnlqjWqAaFWoRJImBTmnQHYBFUQ8QgBBADacLkKD0U1 +1nmlsScxPGkrDr0aJPrG8MEaDRnKjHJKNp3XTp1psGBUpWF/ErjQAIu+psFtLO8o +wCGsg/vJM7CzTv2dVBRbrZXjIKvdq7HdivosTMaHArQBpEtSO9rmgVHO+jaQq/M2 +oGvNEB86zo3nfTWhOgBiB32m8kttWRiuWQARAQABAAP7B8uNtb/DLvGoRfL+mA0Q +REhgOJ1WpRcU6rvKYNPh8xTkKMvM+EK0nVU/znBedEpXjb0pY1WRT0uvXs2pzY2V +YeaugyKIkdUpPWnyWoEQwI8hFvHOWmU2rNHyXLW0MY7bxcGgqv2XbkL4m7/D6VQS +SR8hQ2CxBbW+9ov6aBMwv/UCAOW89+5xxuzkv48AVraWlMnaU0ggVOf6ht0Qa40+ ++uw2yziNlD403gAAAycoICiB/oqwslx61B2xOHn0laCKrgsCAPNpIsHRlAwWbAsq +uCtfIQxg+C3mPXkqsNTMjeK5NjLNytrmO49NXco36zVEG6q7qz5Zj9d9IPYoGOSa +I+dQZ6sB/RKF5aonR5/e7IHJgc8BG7I0yiya4llE0AB9ghnRI/3uHwnCBnmo/32a +n4+rQkx6vm+rg3JA/09Gi7W4R9SwV+ane4ifBBgBAgAJBQJVEPEIAhsMAAoJECix +wJYy+7gY+OAEAJDCUZu1SVK8qwyhbXyH8rUMf75slP3GXFVeiKSqjyoc7YEfkA/X +M5R70Ic/st4arS0UobthMn++XTXsXFLyrP5UuCyA14OVe6VkkZPXkBuNN5rqkfzR +ruvkJlMdPayZe9ra3WhsTZMhwO2cu2QxpHDL0LHd6qEjRrD0eUynrMO0 +=iCIm +-----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 2a9c021c67b..c9c92f529be 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -22,14 +22,11 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'epg) (defvar epg-tests-context nil) -(defvar epg-tests-data-directory - (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) - "Directory containing epg test data.") - (defconst epg-tests--config-program-alist ;; The default `epg-config--program-alist' requires gpg2 2.1 or ;; greater due to some practical problems with pinentry. But most @@ -85,8 +82,7 @@ '(with-temp-file (expand-file-name "gpg-agent.conf" epg-tests-home-directory) (insert "pinentry-program " - (expand-file-name "dummy-pinentry" - epg-tests-data-directory) + (ert-resource-file "dummy-pinentry") "\n") (epg-context-set-passphrase-callback context @@ -94,11 +90,11 @@ ,(if require-public-key '(epg-import-keys-from-file context - (expand-file-name "pubkey.asc" epg-tests-data-directory))) + (ert-resource-file "pubkey.asc"))) ,(if require-secret-key '(epg-import-keys-from-file context - (expand-file-name "seckey.asc" epg-tests-data-directory))) + (ert-resource-file "seckey.asc"))) (with-temp-buffer (make-local-variable 'epg-tests-context) (setq epg-tests-context context) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el new file mode 100644 index 00000000000..27f48fa8131 --- /dev/null +++ b/test/lisp/erc/erc-tests.el @@ -0,0 +1,47 @@ +;;; erc-tests.el --- Tests for erc. -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.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/>. + +;;; Code: + +(require 'ert) +(require 'erc) + +(ert-deftest erc--read-time-period () + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " "))) + (should (equal (erc--read-time-period "foo: ") nil))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 432 "))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "432"))) + (should (equal (erc--read-time-period "foo: ") 432))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h"))) + (should (equal (erc--read-time-period "foo: ") 3600))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1h10s"))) + (should (equal (erc--read-time-period "foo: ") 3610))) + + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) + (should (equal (erc--read-time-period "foo: ") 86400)))) diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index b0ed4bbcb67..457f08cb73c 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -1,4 +1,4 @@ -;;; erc-track-tests.el --- Tests for erc-track. +;;; erc-track-tests.el --- Tests for erc-track. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. @@ -107,8 +107,8 @@ (ert-deftest erc-track--erc-faces-in () "`erc-faces-in' should pick up both 'face and 'font-lock-face properties." - (let ((str0 "is bold") - (str1 "is bold")) + (let ((str0 (copy-sequence "is bold")) + (str1 (copy-sequence "is bold"))) ;; Turn on Font Lock mode: this initialize `char-property-alias-alist' ;; to '((face font-lock-face)). Note that `font-lock-mode' don't ;; turn on the mode if the test is run on batch mode or if the diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index a08a7a2afcb..5bb16f64a46 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -1,4 +1,4 @@ -;;; tests/em-hist-tests.el --- em-hist test suite +;;; tests/em-hist-tests.el --- em-hist test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index da3e224a94d..975701e3838 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -1,4 +1,4 @@ -;;; tests/em-ls-tests.el --- em-ls test suite +;;; tests/em-ls-tests.el --- em-ls test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el index af6c089c16b..caba153cf73 100644 --- a/test/lisp/eshell/esh-opt-tests.el +++ b/test/lisp/eshell/esh-opt-tests.el @@ -1,4 +1,4 @@ -;;; tests/esh-opt-tests.el --- esh-opt test suite +;;; tests/esh-opt-tests.el --- esh-opt test suite -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 70694309443..1b93fb0fbbc 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -1,4 +1,4 @@ -;;; tests/eshell-tests.el --- Eshell test suite +;;; tests/eshell-tests.el --- Eshell test suite -*- lexical-binding:t -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -61,6 +61,8 @@ (eshell-insert-command text func) (eshell-match-result regexp)) +(defvar eshell-history-file-name) + (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." (let ((eshell-directory-name (make-temp-file "eshell" t)) @@ -170,6 +172,13 @@ e.g. \"{(+ 1 2)} 3\" => 3" (eshell-command-result-p "+ 1 2; + $_ 4" "3\n6\n"))) +(ert-deftest eshell-test/inside-emacs-var () + "Test presence of \"INSIDE_EMACS\" in subprocesses" + (with-temp-eshell + (eshell-command-result-p "env" + (format "INSIDE_EMACS=%s,eshell" + emacs-version)))) + (ert-deftest eshell-test/escape-nonspecial () "Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a special character." diff --git a/test/lisp/faces-resources/faces-test-dark-theme.el b/test/lisp/faces-resources/faces-test-dark-theme.el new file mode 100644 index 00000000000..a5e2ca43627 --- /dev/null +++ b/test/lisp/faces-resources/faces-test-dark-theme.el @@ -0,0 +1,35 @@ +;;; faces-test-dark-theme.el --- A dark theme from tests ;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2020 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: + +(deftheme faces-test-dark + "") + +(custom-theme-set-faces + 'faces-test-dark + '(spiff-added ((t (:foreground "Green" :extend t)))) + '(spiff-changed-face ((t (:foreground "Khaki")))) + '(spiff-file-header-face ((t (:background "grey20" :foreground "ivory1"))))) + +(provide-theme 'faces-test-dark) + +;;; faces-test-dark-theme.el ends here diff --git a/test/lisp/faces-resources/faces-test-light-theme.el b/test/lisp/faces-resources/faces-test-light-theme.el new file mode 100644 index 00000000000..b2f7ec69742 --- /dev/null +++ b/test/lisp/faces-resources/faces-test-light-theme.el @@ -0,0 +1,34 @@ +;;; faces-test-light-theme.el --- A dark theme from tests ;;; -*- lexical-binding: t; -*- + +;; Copyright (C) 2019-2020 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: + +(deftheme faces-test-light + "") + +(custom-theme-set-faces + 'faces-test-light + '(spiff-added ((t (:inherit diff-changed :background "light green" :extend t)))) + '(spiff-changed ((t (:background "light steel blue"))))) + +(provide-theme 'faces-test-light) + +;;; faces-test-light-theme.el ends here diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index d5dc19349a4..b19cef5decd 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -5,29 +5,27 @@ ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: (require 'ert) +(require 'ert-x) (require 'faces) -(defvar faces--test-data-dir - (expand-file-name "../data/" - (file-name-directory (or load-file-name - buffer-file-name)))) - (defgroup faces--test nil "" :group 'faces--test) @@ -120,7 +118,7 @@ (should (equal (face-attribute 'spiff-changed-face :extend) t)) (should (equal (face-attribute 'spiff-added :extend) 'unspecified)) (should (equal (face-attribute 'spiff-file-header-face :extend) nil)) - (add-to-list 'custom-theme-load-path (concat faces--test-data-dir "themes")) + (add-to-list 'custom-theme-load-path (ert-resource-directory)) (load-theme 'faces-test-dark t t) (load-theme 'faces-test-light t t) (should (equal (face-attribute 'faces--test-inherit-extend :extend) diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index eaf39680e48..ca8c10831fd 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -74,9 +74,55 @@ left alone when opening a URL in an external browser." (urls nil) (ffap-url-fetcher (lambda (url) (push url urls) nil))) (should-not (ffap-other-window "https://www.gnu.org")) - (should (equal (current-window-configuration) old)) + (should (compare-window-configurations (current-window-configuration) old)) (should (equal urls '("https://www.gnu.org"))))) +(defun ffap-test-string (space string) + (let ((ffap-file-name-with-spaces space)) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (forward-char 10) + (ffap-string-at-point)))) + +(ert-deftest ffap-test-with-spaces () + (should + (equal + (ffap-test-string + t "c:/Program Files/Open Text Evaluation Media/Open Text Exceed 14 x86/Program here.txt") + "/Program Files/Open Text Evaluation Media/Open Text Exceed 14 x86/Program here.txt")) + (should + (equal + (ffap-test-string + nil "c:/Program Files/Open Text Evaluation Media/Open Text Exceed 14 x86/Program here.txt") + "c:/Program")) + (should + (equal + (ffap-test-string + t "c:/Program Files/Open Text Evaluation Media/Open Text Exceed 14 x86/Program Files/Hummingbird/") + "/Program Files/Open Text Evaluation Media/Open Text Exceed 14 x86/Program Files/Hummingbird/")) + (should + (equal + (ffap-test-string + t "c:\\Program Files\\Open Text Evaluation Media\\Open Text Exceed 14 x86\\Program Files\\Hummingbird\\") + "\\Program Files\\Open Text Evaluation Media\\Open Text Exceed 14 x86\\Program Files\\Hummingbird\\")) + (should + (equal + (ffap-test-string + t "c:\\Program Files\\Freescale\\CW for MPC55xx and MPC56xx 2.10\\PowerPC_EABI_Tools\\Command_Line_Tools\\CLT_Usage_Notes.txt") + "\\Program Files\\Freescale\\CW for MPC55xx and MPC56xx 2.10\\PowerPC_EABI_Tools\\Command_Line_Tools\\CLT_Usage_Notes.txt")) + (should + (equal + (ffap-test-string + t "C:\\temp\\program.log on Windows or /var/log/program.log on Unix.") + "\\temp\\program.log"))) + +(ert-deftest ffap-test-no-newlines () + (should-not + (with-temp-buffer + (save-excursion (insert "type=")) + (ffap-guess-file-name-at-point)))) + (provide 'ffap-tests) ;;; ffap-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index e9dc7532d59..268c3185bc6 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -200,8 +202,7 @@ Return nil when any other file notification watch is still active." (setq file-notify-debug nil password-cache-expiry nil - tramp-verbose 0 - tramp-message-show-message nil) + tramp-verbose 0) ;; This should happen on hydra only. (when (getenv "EMACS_HYDRA_CI") @@ -220,7 +221,8 @@ remote case we return always t." (or file-notify--library (file-remote-p temporary-file-directory))) -(defvar file-notify--test-remote-enabled-checked nil +(defvar file-notify--test-remote-enabled-checked + (if (getenv "EMACS_HYDRA_CI") '(t . nil)) "Cached result of `file-notify--test-remote-enabled'. If the function did run, the value is a cons cell, the `cdr' being the result.") @@ -611,6 +613,7 @@ delivered." (ert-deftest file-notify-test03-events () "Check file creation/change/removal notifications." + :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -772,9 +775,9 @@ delivered." (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) ;; The next two events shall not be visible. (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) + (set-file-modes file-notify--test-tmpfile 000 'nofollow) (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) + (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) (file-notify--test-read-event) (delete-directory file-notify--test-tmpdir 'recursive)) (file-notify-rm-watch file-notify--test-desc) @@ -865,9 +868,9 @@ delivered." (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) + (set-file-modes file-notify--test-tmpfile 000 'nofollow) (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) + (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) (file-notify--test-read-event) (delete-file file-notify--test-tmpfile)) (file-notify-rm-watch file-notify--test-desc) @@ -888,6 +891,7 @@ delivered." (ert-deftest file-notify-test04-autorevert () "Check autorevert via file notification." + :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) ;; `auto-revert-buffers' runs every 5". And we must wait, until the @@ -929,17 +933,18 @@ delivered." ;; Modify file. We wait for a second, in order to have ;; another timestamp. (ert-with-message-capture captured-messages - (sleep-for 1) - (write-region - "another text" nil file-notify--test-tmpfile nil 'no-message) - - ;; Check, that the buffer has been reverted. - (file-notify--test-wait-for-events - timeout - (string-match - (format-message "Reverting buffer `%s'." (buffer-name buf)) - captured-messages)) - (should (string-match "another text" (buffer-string)))) + (let ((inhibit-message t)) + (sleep-for 1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (file-notify--test-wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + captured-messages)) + (should (string-match "another text" (buffer-string))))) ;; Stop file notification. Autorevert shall still work via polling. (file-notify-rm-watch auto-revert-notify-watch-descriptor) @@ -953,17 +958,18 @@ delivered." ;; have another timestamp. One second seems to be too ;; short. And Cygwin sporadically requires more than two. (ert-with-message-capture captured-messages - (sleep-for (if (eq system-type 'cygwin) 3 2)) - (write-region - "foo bla" nil file-notify--test-tmpfile nil 'no-message) - - ;; Check, that the buffer has been reverted. - (file-notify--test-wait-for-events - timeout - (string-match - (format-message "Reverting buffer `%s'." (buffer-name buf)) - captured-messages)) - (should (string-match "foo bla" (buffer-string)))) + (let ((inhibit-message t)) + (sleep-for (if (eq system-type 'cygwin) 3 2)) + (write-region + "foo bla" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (file-notify--test-wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + captured-messages)) + (should (string-match "foo bla" (buffer-string))))) ;; Stop autorevert, in order to cleanup descriptor. (auto-revert-mode -1)) @@ -981,6 +987,7 @@ delivered." (ert-deftest file-notify-test05-file-validity () "Check `file-notify-valid-p' for files." + :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -1233,6 +1240,7 @@ delivered." (ert-deftest file-notify-test08-backup () "Check that backup keeps file notification." + :tags '(:expensive-test) (skip-unless (file-notify--test-local-enabled)) (unwind-protect diff --git a/test/lisp/files-resources/files-bug18141.el.gz b/test/lisp/files-resources/files-bug18141.el.gz Binary files differnew file mode 100644 index 00000000000..53d463e85b5 --- /dev/null +++ b/test/lisp/files-resources/files-bug18141.el.gz diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 11e1f4db794..8818099a223 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'nadvice) (eval-when-compile (require 'cl-lib)) (require 'bytecomp) ; `byte-compiler-base-file-name'. @@ -151,7 +152,7 @@ form.") (should (file-test--do-local-variables-test str subtest))))))) (defvar files-test-bug-18141-file - (expand-file-name "data/files-bug18141.el.gz" (getenv "EMACS_TEST_DIRECTORY")) + (ert-resource-file "files-bug18141.el.gz") "Test file for bug#18141.") (ert-deftest files-tests-bug-18141 () @@ -190,7 +191,6 @@ form.") (ert-deftest files-tests-bug-21454 () "Test for https://debbugs.gnu.org/21454 ." - :expected-result :failed (let ((input-result '(("/foo/bar//baz/:/bar/foo/baz//" nil ("/foo/bar/baz/" "/bar/foo/baz/")) ("/foo/bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) @@ -1003,9 +1003,9 @@ unquoted file names." (ert-deftest files-tests-file-name-non-special-set-file-times () (files-tests--with-temp-non-special (tmpfile nospecial) - (set-file-times nospecial)) + (set-file-times nospecial nil 'nofollow)) (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) - (should-error (set-file-times nospecial)))) + (should-error (set-file-times nospecial nil 'nofollow)))) (ert-deftest files-tests-file-name-non-special-set-visited-file-modtime () (files-tests--with-temp-non-special (tmpfile nospecial) @@ -1164,6 +1164,42 @@ works as expected if the default directory is quoted." (should-not (make-directory a/b t)) (delete-directory dir 'recursive))) +(ert-deftest files-tests-file-modes-symbolic-to-number () + (let ((alist (list (cons "a=rwx" #o777) + (cons "o=t" #o1000) + (cons "o=xt" #o1001) + (cons "o=tx" #o1001) ; Order doesn't matter. + (cons "u=rwx,g=rx,o=rx" #o755) + (cons "u=rwx,g=,o=" #o700) + (cons "u=rwx" #o700) ; Empty permissions can be ignored. + (cons "u=rw,g=r,o=r" #o644) + (cons "u=rw,g=r,o=t" #o1640) + (cons "u=rw,g=r,o=xt" #o1641) + (cons "u=rwxs,g=rs,o=xt" #o7741) + (cons "u=rws,g=rs,o=t" #o7640) + (cons "u=rws,g=rs,o=r" #o6644) + (cons "a=r" #o444) + (cons "u=S" nil) + (cons "u=T" nil) + (cons "u=Z" nil)))) + (dolist (x alist) + (if (cdr-safe x) + (should (equal (cdr x) (file-modes-symbolic-to-number (car x)))) + (should-error (file-modes-symbolic-to-number (car x))))))) + +(ert-deftest files-tests-file-modes-number-to-symbolic () + (let ((alist (list (cons #o755 "-rwxr-xr-x") + (cons #o700 "-rwx------") + (cons #o644 "-rw-r--r--") + (cons #o1640 "-rw-r----T") + (cons #o1641 "-rw-r----t") + (cons #o7741 "-rwsr-S--t") + (cons #o7640 "-rwSr-S--T") + (cons #o6644 "-rwSr-Sr--") + (cons #o444 "-r--r--r--")))) + (dolist (x alist) + (should (equal (cdr x) (file-modes-number-to-symbolic (car x))))))) + (ert-deftest files-tests-no-file-write-contents () "Test that `write-contents-functions' permits saving a file. Usually `basic-save-buffer' will prompt for a file name if the @@ -1326,5 +1362,75 @@ See <https://debbugs.gnu.org/36401>." (normal-mode) (should (not (eq major-mode 'text-mode)))))) +(ert-deftest files-colon-path () + (should (equal (parse-colon-path "/foo//bar/baz") + '("/foo/bar/baz/")))) + +(ert-deftest files-test-magic-mode-alist-doctype () + "Test that DOCTYPE and variants put files in mhtml-mode." + (with-temp-buffer + (goto-char (point-min)) + (insert "<!DOCTYPE html>") + (normal-mode) + (should (eq major-mode 'mhtml-mode)) + (erase-buffer) + (insert "<!doctype html>") + (normal-mode) + (should (eq major-mode 'mhtml-mode)))) + +(defvar files-tests-lao "The Way that can be told of is not the eternal Way; +The name that can be named is not the eternal name. +The Nameless is the origin of Heaven and Earth; +The Named is the mother of all things. +Therefore let there always be non-being, + so we may see their subtlety, +And let there always be being, + so we may see their outcome. +The two are the same, +But after they are produced, + they have different names. +") + +(defvar files-tests-tzu "The Nameless is the origin of Heaven and Earth; +The named is the mother of all things. + +Therefore let there always be non-being, + so we may see their subtlety, +And let there always be being, + so we may see their outcome. +The two are the same, +But after they are produced, + they have different names. +They both may be called deep and profound. +Deeper and more profound, +The door of all subtleties! +") + +(ert-deftest files-tests-revert-buffer () + "Test that revert-buffer is successful." + (files-tests--with-temp-file temp-file-name + (with-temp-buffer + (insert files-tests-lao) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (revert-buffer t t t) + (should (compare-strings files-tests-lao nil nil + (buffer-substring (point-min) (point-max)) + nil nil))))) + +(ert-deftest files-tests-revert-buffer-with-fine-grain () + "Test that revert-buffer-with-fine-grain is successful." + (files-tests--with-temp-file temp-file-name + (with-temp-buffer + (insert files-tests-lao) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (should (revert-buffer-with-fine-grain t t)) + (should (compare-strings files-tests-lao nil nil + (buffer-substring (point-min) (point-max)) + nil nil))))) + (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 d3ed4b5312c..6b05e6a88c3 100644 --- a/test/lisp/files-x-tests.el +++ b/test/lisp/files-x-tests.el @@ -1,4 +1,4 @@ -;;; files-x-tests.el --- tests for files-x.el. +;;; files-x-tests.el --- tests for files-x.el. -*- lexical-binding: t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. @@ -35,6 +35,7 @@ '((remote-null-device . "/dev/null"))) (defconst files-x-test--variables4 '((remote-null-device . "null"))) +(defvar remote-null-device) (put 'remote-shell-file-name 'safe-local-variable #'identity) (put 'remote-shell-command-switch 'safe-local-variable #'identity) (put 'remote-shell-interactive-switch 'safe-local-variable #'identity) @@ -273,7 +274,8 @@ (should-not (local-variable-p 'remote-shell-file-name)) (should-not (boundp 'remote-shell-file-name)))))) -(defvar tramp-connection-local-default-profile) +(defvar tramp-connection-local-default-shell-variables) +(defvar tramp-connection-local-default-system-variables) (ert-deftest files-x-test-with-connection-local-variables () "Test setting connection-local variables." @@ -334,7 +336,10 @@ (append (nreverse (copy-tree files-x-test--variables3)) (nreverse (copy-tree files-x-test--variables2)) - (nreverse (copy-tree tramp-connection-local-default-profile))))) + (nreverse + (copy-tree tramp-connection-local-default-shell-variables)) + (nreverse + (copy-tree tramp-connection-local-default-system-variables))))) ;; The variables exist also as local variables. (should (local-variable-p 'remote-shell-file-name)) (should (local-variable-p 'remote-null-device)) diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el index 23ee88c5269..11882217afb 100644 --- a/test/lisp/format-spec-tests.el +++ b/test/lisp/format-spec-tests.el @@ -22,22 +22,145 @@ (require 'ert) (require 'format-spec) -(ert-deftest test-format-spec () +(ert-deftest format-spec-make () + "Test `format-spec-make'." + (should-not (format-spec-make)) + (should-error (format-spec-make ?b)) + (should (equal (format-spec-make ?b "b") '((?b . "b")))) + (should-error (format-spec-make ?b "b" ?a)) + (should (equal (format-spec-make ?b "b" ?a 'a) + '((?b . "b") + (?a . a))))) + +(ert-deftest format-spec-parse-flags () + "Test `format-spec--parse-flags'." + (should-not (format-spec--parse-flags nil)) + (should-not (format-spec--parse-flags "")) + (should (equal (format-spec--parse-flags "-") '(:pad-right))) + (should (equal (format-spec--parse-flags " 0") '(:pad-zero))) + (should (equal (format-spec--parse-flags " -x0y< >^_z ") + '(:pad-right :pad-zero :chop-left :chop-right + :upcase :downcase)))) + +(ert-deftest format-spec-do-flags () + "Test `format-spec--do-flags'." + (should (equal (format-spec--do-flags "" () nil nil) "")) + (dolist (flag '(:pad-zero :pad-right :upcase :downcase + :chop-left :chop-right)) + (should (equal (format-spec--do-flags "" (list flag) nil nil) ""))) + (should (equal (format-spec--do-flags "FOOBAR" '(:downcase :chop-right) 5 2) + " fo")) + (should (equal (format-spec--do-flags + "foobar" '(:pad-zero :pad-right :upcase :chop-left) 5 2) + "AR000"))) + +(ert-deftest format-spec-do-flags-truncate () + "Test `format-spec--do-flags' truncation." + (let (flags) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "a"))) + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "d")))) + +(ert-deftest format-spec-do-flags-pad () + "Test `format-spec--do-flags' padding." + (let (flags) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) " a"))) + (let ((flags '(:pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "0a"))) + (let ((flags '(:pad-right))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a "))) + (let ((flags '(:pad-right :pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a0")))) + +(ert-deftest format-spec-do-flags-chop () + "Test `format-spec--do-flags' chopping." + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "d"))) + (let ((flags '(:chop-right))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "a")))) + +(ert-deftest format-spec-do-flags-case () + "Test `format-spec--do-flags' case fiddling." + (dolist (flag '(:pad-zero :pad-right :chop-left :chop-right)) + (let ((flags (list flag))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))) + (let ((flags (list flag :downcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "a"))) + (let ((flags (list flag :upcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "A")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))))) + +(ert-deftest format-spec () + (should (equal (format-spec "" ()) "")) + (should (equal (format-spec "a" ()) "a")) + (should (equal (format-spec "b" '((?b . "bar"))) "b")) + (should (equal (format-spec "%%%b%%b%b%%" '((?b . "bar"))) "%bar%bbar%")) (should (equal (format-spec "foo %b zot" `((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %-10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) - "foo bar zot"))) + "foo bar zot")) + (should (equal-including-properties + (format-spec (propertize "a" 'a 'b) '((?a . "foo"))) + #("a" 0 1 (a b)))) + (let ((fmt (concat (propertize "%a" 'a 'b) + (propertize "%%" 'c 'd) + "%b" + (propertize "%b" 'e 'f)))) + (should (equal-including-properties + (format-spec fmt '((?b . "asd") (?a . "fgh"))) + #("fgh%asdasd" 0 3 (a b) 3 4 (c d) 7 10 (e f)))))) -(ert-deftest test-format-unknown () +(ert-deftest format-spec-unknown () (should-error (format-spec "foo %b %z zot" '((?b . "bar")))) + (should-error (format-spec "foo %b %%%z zot" '((?b . "bar")))) (should (equal (format-spec "foo %b %z zot" '((?b . "bar")) t) "foo bar %z zot")) - (should (equal (format-spec "foo %b %z %% zot" '((?b . "bar")) t) - "foo bar %z %% zot"))) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) t) + "foo bar %%%4z %%4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'ignore) + "foo bar %%4z %4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'delete) + "foo bar % %4 zot"))) -(ert-deftest test-format-modifiers () +(ert-deftest format-spec-flags () (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo % 10b zot" '((?b . "bar"))) diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el new file mode 100644 index 00000000000..dd265b4fa97 --- /dev/null +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -0,0 +1,259 @@ +;;; gnus-icalendar-tests.el --- tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Jan Tatarik <jan.tatarik@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 'gnus-icalendar) + + +(defun gnus-icalendar-tests--get-ical-event (ical-string &optional participant) + "Return gnus-icalendar event for ICAL-STRING." + (let (event) + (with-temp-buffer + (insert ical-string) + (setq event (gnus-icalendar-event-from-buffer (buffer-name) participant))) + event)) + +(ert-deftest gnus-icalendar-parse () + "test" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:-//Google Inc//Google Calendar 70.9054//EN +VERSION:2.0 +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:America/New_York +X-LIC-LOCATION:America/New_York +BEGIN:DAYLIGHT +TZOFFSETFROM:-0500 +TZOFFSETTO:-0400 +TZNAME:EDT +DTSTART:19700308T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=2SU +END:DAYLIGHT +BEGIN:STANDARD +TZOFFSETFROM:-0400 +TZOFFSETTO:-0500 +TZNAME:EST +DTSTART:19701101T020000 +RRULE:FREQ=YEARLY;BYMONTH=11;BYDAY=1SU +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=America/New_York:20201208T090000 +DTEND;TZID=America/New_York:20201208T100000 +DTSTAMP:20200728T182853Z +ORGANIZER;CN=Company Events:mailto:anoncompany.com_3bm6fh805bme9uoeliqcle1sa + g@group.calendar.google.com +UID:iipdt88slddpeu7hheuu09sfmd@google.com +X-MICROSOFT-CDO-OWNERAPPTID:-362490173 +RECURRENCE-ID;TZID=America/New_York:20201208T091500 +CREATED:20200309T134939Z +DESCRIPTION:In this meeting\\, we will cover topics from product and enginee + ring presentations and demos to new hire announcements to watching the late +LAST-MODIFIED:20200728T182852Z +LOCATION:New York-22-Town Hall Space (250) [Chrome Box] +SEQUENCE:4 +STATUS:CONFIRMED +SUMMARY:Townhall | All Company Meeting +TRANSP:OPAQUE +END:VEVENT +END:VCALENDAR +"))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (not (gnus-icalendar-event:recurring-p event))) + (should (string= (gnus-icalendar-event:start event) "2020-12-08 15:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "anoncompany.com_3bm6fh805bme9uoeliqcle1sag@group.calendar.google.com")) + (should (string= summary "Townhall | All Company Meeting")) + (should (string= description "In this meeting, we will cover topics from product and engineering presentations and demos to new hire announcements to watching the late")) + (should (string= location "New York-22-Town Hall Space (250) [Chrome Box]")) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-12-08 16:00")) + (should (string= uid "iipdt88slddpeu7hheuu09sfmd@google.com")) + (should (not rsvp)) + (should (eq participation-type 'non-participant)))) + (setenv "TZ" tz)))) + +(ert-deftest gnus-icalendary-byday () + "" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:Zimbra-Calendar-Provider +VERSION:2.0 +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:America/New_York +BEGIN:STANDARD +DTSTART:16010101T020000 +TZOFFSETTO:-0500 +TZOFFSETFROM:-0400 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=11;BYDAY=1SU +TZNAME:EST +END:STANDARD +BEGIN:DAYLIGHT +DTSTART:16010101T020000 +TZOFFSETTO:-0400 +TZOFFSETFROM:-0500 +RRULE:FREQ=YEARLY;WKST=MO;INTERVAL=1;BYMONTH=3;BYDAY=2SU +TZNAME:EDT +END:DAYLIGHT +END:VTIMEZONE +BEGIN:VEVENT +UID:903a5415-9067-4f63-b499-1b6205f49c88 +RRULE:FREQ=DAILY;UNTIL=20200825T035959Z;INTERVAL=1;BYDAY=MO,TU,WE,TH,FR +SUMMARY:appointment every weekday\\, start jul 24\\, 2020\\, end aug 24\\, 2020 +ATTENDEE;CN=Mark Hershberger;ROLE=REQ-PARTICIPANT;PARTSTAT=NEEDS-ACTION;RSVP + =TRUE:mailto:hexmode <at> gmail.com +ORGANIZER;CN=Mark A. Hershberger:mailto:mah <at> nichework.com +DTSTART;TZID=\"America/New_York\":20200724T090000 +DTEND;TZID=\"America/New_York\":20200724T093000 +STATUS:CONFIRMED +CLASS:PUBLIC +X-MICROSOFT-CDO-INTENDEDSTATUS:BUSY +TRANSP:OPAQUE +LAST-MODIFIED:20200719T150815Z +DTSTAMP:20200719T150815Z +SEQUENCE:0 +DESCRIPTION:The following is a new meeting request: +BEGIN:VALARM +ACTION:DISPLAY +TRIGGER;RELATED=START:-PT5M +DESCRIPTION:Reminder +END:VALARM +END:VEVENT +END:VCALENDAR" (list "Mark Hershberger")))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (gnus-icalendar-event:recurring-p event)) + (should (string= (gnus-icalendar-event:recurring-interval event) "1")) + (should (string= (gnus-icalendar-event:start event) "2020-07-24 15:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "mah <at> nichework.com")) + (should (string= summary "appointment every weekday, start jul 24, 2020, end aug 24, 2020")) + (should (string= description "The following is a new meeting request:")) + (should (null location)) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-07-24 15:30")) + (should (string= uid "903a5415-9067-4f63-b499-1b6205f49c88")) + (should rsvp) + (should (eq participation-type 'required))) + (should (equal (gnus-icalendar-event:recurring-days event) '(1 2 3 4 5))) + (should (string= (gnus-icalendar-event:org-timestamp event) "<2020-07-24 15:00-15:30 +1w> +<2020-07-27 15:00-15:30 +1w> +<2020-07-28 15:00-15:30 +1w> +<2020-07-29 15:00-15:30 +1w> +<2020-07-30 15:00-15:30 +1w>"))) + (setenv "TZ" tz)))) + +(ert-deftest gnus-icalendary-weekly-byday () + "" + (let ((tz (getenv "TZ")) + (event (gnus-icalendar-tests--get-ical-event "\ +BEGIN:VCALENDAR +PRODID:-//Google Inc//Google Calendar 70.9054//EN +VERSION:2.0 +CALSCALE:GREGORIAN +METHOD:REQUEST +BEGIN:VTIMEZONE +TZID:Europe/Berlin +X-LIC-LOCATION:Europe/Berlin +BEGIN:DAYLIGHT +TZOFFSETFROM:+0100 +TZOFFSETTO:+0200 +TZNAME:CEST +DTSTART:19700329T020000 +RRULE:FREQ=YEARLY;BYMONTH=3;BYDAY=-1SU +END:DAYLIGHT +BEGIN:STANDARD +TZOFFSETFROM:+0200 +TZOFFSETTO:+0100 +TZNAME:CET +DTSTART:19701025T030000 +RRULE:FREQ=YEARLY;BYMONTH=10;BYDAY=-1SU +END:STANDARD +END:VTIMEZONE +BEGIN:VEVENT +DTSTART;TZID=Europe/Berlin:20200915T140000 +DTEND;TZID=Europe/Berlin:20200915T143000 +RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE +DTSTAMP:20200915T120627Z +ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com +UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com +ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE + ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com +CREATED:20200325T095723Z +DESCRIPTION:Coffee talk +LAST-MODIFIED:20200915T120623Z +LOCATION: +SEQUENCE:0 +STATUS:CONFIRMED +SUMMARY:Casual coffee talk +TRANSP:OPAQUE +END:VEVENT +END:VCALENDAR" (list "participant@anoncompany.com")))) + + (unwind-protect + (progn + ;; Use this form so as not to rely on system tz database. + ;; Eg hydra.nixos.org. + (setenv "TZ" "CET-1CEST,M3.5.0/2,M10.5.0/3") + (should (eq (eieio-object-class event) 'gnus-icalendar-event-request)) + (should (gnus-icalendar-event:recurring-p event)) + (should (string= (gnus-icalendar-event:recurring-interval event) "1")) + (should (string= (gnus-icalendar-event:start event) "2020-09-15 14:00")) + (with-slots (organizer summary description location end-time uid rsvp participation-type) event + (should (string= organizer "anon@anoncompany.com")) + (should (string= summary "Casual coffee talk")) + (should (string= description "Coffee talk")) + (should (string= location "")) + (should (string= (format-time-string "%Y-%m-%d %H:%M" end-time) "2020-09-15 14:30")) + (should (string= uid "7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com")) + (should rsvp) + (should (eq participation-type 'required))) + (should (equal (sort (gnus-icalendar-event:recurring-days event) #'<) '(1 2 3 4 5))) + (should (string= (gnus-icalendar-event:org-timestamp event) "<2020-09-15 14:00-14:30 +1w> +<2020-09-16 14:00-14:30 +1w> +<2020-09-17 14:00-14:30 +1w> +<2020-09-18 14:00-14:30 +1w> +<2020-09-21 14:00-14:30 +1w>"))) + (setenv "TZ" tz)))) + +(provide 'gnus-icalendar-tests) +;;; gnus-icalendar-tests.el ends here diff --git a/test/lisp/gnus/gnus-search-tests.el b/test/lisp/gnus/gnus-search-tests.el new file mode 100644 index 00000000000..5bae9cb14d0 --- /dev/null +++ b/test/lisp/gnus/gnus-search-tests.el @@ -0,0 +1,96 @@ +;;; gnus-search-tests.el --- Tests for Gnus' search routines -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> +;; Keywords: + +;; 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the search parsing, search engines, and their +;; transformations. + +;;; Code: + +(require 'ert) +(require 'gnus-search) + +(ert-deftest gnus-s-parse () + "Test basic structural parsing." + (let ((pairs + '(("string" . ("string")) + ("from:john" . ((from . "john"))) + ("here and there" . ("here" and "there")) + ("here or there" . ((or "here" "there"))) + ("here (there or elsewhere)" . ("here" ((or "there" "elsewhere")))) + ("here not there" . ("here" (not "there"))) + ("from:boss or not vacation" . ((or (from . "boss") (not "vacation"))))))) + (dolist (p pairs) + (should (equal (gnus-search-parse-query (car p)) (cdr p)))))) + +(ert-deftest gnus-s-expand-keyword () + "Test expansion of keywords" + (let ((gnus-search-expandable-keys + (default-value 'gnus-search-expandable-keys)) + (pairs + '(("su" . "subject") + ("sin" . "since")))) + (dolist (p pairs) + (should (equal (gnus-search-query-expand-key (car p)) + (cdr p)))) + (should-error (gnus-search-query-expand-key "s") + :type 'gnus-search-parse-error))) + +(ert-deftest gnus-s-parse-date () + "Test parsing of date expressions." + (let ((rel-date (encode-time 0 0 0 15 4 2017)) + (pairs + '(("January" . (nil 1 nil)) + ("2017" . (nil nil 2017)) + ("15" . (15 nil nil)) + ("January 15" . (15 1 nil)) + ("tuesday" . (11 4 2017)) + ("1d" . (14 4 2017)) + ("1w" . (8 4 2017))))) + (dolist (p pairs) + (should (equal (gnus-search-query-parse-date (car p) rel-date) + (cdr p)))))) + +(ert-deftest gnus-s-delimited-string () + "Test proper functioning of `gnus-search-query-return-string'." + (with-temp-buffer + (insert "one\ntwo words\nthree \"words with quotes\"\n\"quotes at start\"\n/alternate \"quotes\"/\n(more bits)") + (goto-char (point-min)) + (should (string= (gnus-search-query-return-string) + "one")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "two")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "three")) + (forward-line) + (should (string= (gnus-search-query-return-string "\"") + "\"quotes at start\"")) + (forward-line) + (should (string= (gnus-search-query-return-string "/") + "/alternate \"quotes\"/")) + (forward-line) + (should (string= (gnus-search-query-return-string ")" t) + "more bits")))) + +(provide 'gnus-search-tests) +;;; search-tests.el ends here diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index d18b3fbed0f..fb1b204f042 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -1,4 +1,4 @@ -;;; gnus-tests.el --- Wrapper for the Gnus tests +;;; gnus-tests.el --- Wrapper for the Gnus tests -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el new file mode 100644 index 00000000000..5a5e66594fa --- /dev/null +++ b/test/lisp/gnus/gnus-util-tests.el @@ -0,0 +1,172 @@ +;;; gnus-util-tests.el --- Selectived tests only. -*- lexical-binding:t -*- +;; Copyright (C) 2015-2020 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> + +;; This file is not 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, 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 'gnus-util) + +(ert-deftest gnus-string> () + ;; Failure paths + (should-error (gnus-string> "" 1) + :type 'wrong-type-argument) + (should-error (gnus-string> "") + :type 'wrong-number-of-arguments) + + ;; String tests + (should (gnus-string> "def" "abc")) + (should (gnus-string> 'def 'abc)) + (should (gnus-string> "abc" "DEF")) + (should (gnus-string> "abc" 'DEF)) + (should (gnus-string> "αβγ" "abc")) + (should (gnus-string> "אבג" "αβγ")) + (should (gnus-string> nil "")) + (should (gnus-string> "abc" "")) + (should (gnus-string> "abc" "ab")) + (should-not (gnus-string> "abc" "abc")) + (should-not (gnus-string> "abc" "def")) + (should-not (gnus-string> "DEF" "abc")) + (should-not (gnus-string> 'DEF "abc")) + (should-not (gnus-string> "123" "abc")) + (should-not (gnus-string> "" ""))) + +(ert-deftest gnus-string< () + ;; Failure paths + (should-error (gnus-string< "" 1) + :type 'wrong-type-argument) + (should-error (gnus-string< "") + :type 'wrong-number-of-arguments) + + ;; String tests + (setq case-fold-search nil) + (should (gnus-string< "abc" "def")) + (should (gnus-string< 'abc 'def)) + (should (gnus-string< "DEF" "abc")) + (should (gnus-string< "DEF" 'abc)) + (should (gnus-string< "abc" "αβγ")) + (should (gnus-string< "αβγ" "אבג")) + (should (gnus-string< "" nil)) + (should (gnus-string< "" "abc")) + (should (gnus-string< "ab" "abc")) + (should-not (gnus-string< "abc" "abc")) + (should-not (gnus-string< "def" "abc")) + (should-not (gnus-string< "abc" "DEF")) + (should-not (gnus-string< "abc" 'DEF)) + (should-not (gnus-string< "abc" "123")) + (should-not (gnus-string< "" "")) + + ;; gnus-string< checks case-fold-search + (setq case-fold-search t) + (should (gnus-string< "abc" "DEF")) + (should (gnus-string< "abc" 'GHI)) + (should (gnus-string< 'abc "DEF")) + (should (gnus-string< 'GHI 'JKL)) + (should (gnus-string< "abc" "ΑΒΓ")) + (should-not (gnus-string< "ABC" "abc")) + (should-not (gnus-string< "def" "ABC"))) + +(ert-deftest gnus-subsetp () + ;; False for non-lists. + (should-not (gnus-subsetp "1" "1")) + (should-not (gnus-subsetp "1" '("1"))) + (should-not (gnus-subsetp '("1") "1")) + + ;; Real tests. + (should (gnus-subsetp '() '())) + (should (gnus-subsetp '() '("1"))) + (should (gnus-subsetp '("1") '("1"))) + (should (gnus-subsetp '(42) '("1" 42))) + (should (gnus-subsetp '(42) '(42 "1"))) + (should (gnus-subsetp '(42) '("1" 42 2))) + (should-not (gnus-subsetp '("1") '())) + (should-not (gnus-subsetp '("1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2))) + (should-not (gnus-subsetp '(2 "1") '(2))) + (should-not (gnus-subsetp '("1" 2) '(2 3))) + + ;; Duplicates don't matter for sets. + (should (gnus-subsetp '("1" "1") '("1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1"))) + (should (gnus-subsetp '("1" 2 "1") '(2 "1" "1" 2))) + (should-not (gnus-subsetp '("1" 2 "1" 3) '(2 "1" "1" 2)))) + +(ert-deftest gnus-setdiff () + ;; False for non-lists. + (should-not (gnus-setdiff "1" "1")) + (should-not (gnus-setdiff "1" '())) + (should-not (gnus-setdiff '() "1")) + + ;; Real tests. + (should-not (gnus-setdiff '() '())) + (should-not (gnus-setdiff '() '("1"))) + (should-not (gnus-setdiff '("1") '("1"))) + (should (equal '("1") (gnus-setdiff '("1") '()))) + (should (equal '("1") (gnus-setdiff '("1") '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2) '(2)))) + (should (equal '("1") (gnus-setdiff '("1" 2 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 "1" 3) '(3 2)))) + (should (equal '("1") (gnus-setdiff '(2 3 "1") '(3 2)))) + (should (equal '(2 "1") (gnus-setdiff '(2 3 "1") '(3)))) + + ;; Duplicates aren't touched for sets if they are not removed. + (should-not (gnus-setdiff '("1" "1") '("1"))) + (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) + (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) + +(ert-deftest gnus-base64-repad () + (should-error (gnus-base64-repad 1) + :type 'wrong-type-argument) + + ;; RFC4648 test vectors + (should (equal "" (gnus-base64-repad ""))) + (should (equal "Zg==" (gnus-base64-repad "Zg=="))) + (should (equal "Zm8=" (gnus-base64-repad "Zm8="))) + (should (equal "Zm9v" (gnus-base64-repad "Zm9v"))) + (should (equal "Zm9vYg==" (gnus-base64-repad "Zm9vYg=="))) + (should (equal "Zm9vYmE=" (gnus-base64-repad "Zm9vYmE="))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy"))) + + (should (equal "Zm8=" (gnus-base64-repad "Zm8"))) + (should (equal "Zg==" (gnus-base64-repad "Zg"))) + (should (equal "Zg==" (gnus-base64-repad "Zg===="))) + + (should-error (gnus-base64-repad " ") + :type 'error) + (should-error (gnus-base64-repad "Zg== ") + :type 'error) + (should-error (gnus-base64-repad "Z?\x00g==") + :type 'error) + ;; line-length + (should-error (gnus-base64-repad "Zg====" nil 4) + :type 'error) + ;; reject-newlines + (should-error (gnus-base64-repad "Zm9v\r\nYmFy" t) + :type 'error) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9vYmFy" t))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\nYmFy\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v\r\n YmFy\r\n"))) + (should (equal "Zm9vYmFy" (gnus-base64-repad "Zm9v \r\n\tYmFy"))) + (should-error (gnus-base64-repad "Zm9v\r\nYmFy" nil 3) + :type 'error)) + +;;; gnustest-gnus-util.el ends here diff --git a/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated b/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/.gpg-v21-migrated diff --git a/test/lisp/gnus/mml-sec-resources/gpg-agent.conf b/test/lisp/gnus/mml-sec-resources/gpg-agent.conf new file mode 100644 index 00000000000..20192990caf --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/gpg-agent.conf @@ -0,0 +1,5 @@ +# pinentry-program /usr/bin/pinentry-gtk-2 + +# verbose +# log-file /tmp/gpg-agent.log +# debug-all diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key Binary files differnew file mode 100644 index 00000000000..58fd0b5edbc --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/02089CDDC6DFE93B8EA10D9E876F983E61FEC476.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key Binary files differnew file mode 100644 index 00000000000..62f4ab25a69 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/171B444DE92BEF997229000D9784118A94EEC1C9.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key Binary files differnew file mode 100644 index 00000000000..2a8ce135fb2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/19FFEBC04DF3E037E16F6A4474DCB7984406975D.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key Binary files differnew file mode 100644 index 00000000000..9f8de71c5e2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/1E36D27DF9DAB96302D35268DADC5CE73EF45A2A.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key Binary files differnew file mode 100644 index 00000000000..6e4a4e548fd --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/293109315BE584AB2EFEFCFCAD64666221D8B36C.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key Binary files differnew file mode 100644 index 00000000000..cff58edaa89 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/335689599E1C0F66D73ADCF51E03EE36C97D121F.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key Binary files differnew file mode 100644 index 00000000000..14af8662f79 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/40BF94E540E3726CB150A1ADF7C1B514444B3FA6.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key Binary files differnew file mode 100644 index 00000000000..207a7237d3a --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/515D4637EFC6C09DB1F78BE8C2F2A3D63E7756C3.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key Binary files differnew file mode 100644 index 00000000000..85ca78da04d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/5A11B1935C46D0B227A73978DCA1293A85604F1D.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key Binary files differnew file mode 100644 index 00000000000..79f3cd2b841 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/62643CEBC7AEBE6817577A34399483700D76BD64.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key Binary files differnew file mode 100644 index 00000000000..776ddf7e9e2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/680D01F368916A0021C14E3453B27B3C5F900683.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key Binary files differnew file mode 100644 index 00000000000..2b464f0ccbe --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/6DF2D9DF7AED06F0524BEB642DF0FB48EFDBDB93.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key Binary files differnew file mode 100644 index 00000000000..28a07668b21 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/78C17E134E86E691297F7B719B2F2CDF41976234.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key Binary files differnew file mode 100644 index 00000000000..137659693bd --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/7F714F4D9D9676638214991E96D45704E4FFC409.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key Binary files differnew file mode 100644 index 00000000000..c99824ccd43 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/854752F5D8090CA36EFBDD79C72BDFF6FA2D1FF0.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key Binary files differnew file mode 100644 index 00000000000..49c2dc58bd8 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/93FF37C268FDBF0767F5FFDC49409DDAC9388B2C.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key Binary files differnew file mode 100644 index 00000000000..ca128408952 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A3BA94EAE83509CC90DB1B77B54A51959D8DABEA.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key Binary files differnew file mode 100644 index 00000000000..3f14b40927a --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/A73E9D01F0465B518E8E7D5AD529077AAC1603B4.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key Binary files differnew file mode 100644 index 00000000000..06adc06c427 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/AE6A24B17A8D0CAF9B7E000AA77F0B41D7BFFFCF.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key Binary files differnew file mode 100644 index 00000000000..cf9a60d233b --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C072AF82DCCCB9A7F1B85FFA10B802DC4ED16703.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key Binary files differnew file mode 100644 index 00000000000..0ed35172fe0 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C43E1A079B28DFAEBB39CBA01793BDE11EF4B490.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key Binary files differnew file mode 100644 index 00000000000..090059d9e81 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/C67DAD345455EAD6D51368008FC3A53B8D195B5A.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key Binary files differnew file mode 100644 index 00000000000..9061f675121 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CB5E00CE582C2645D2573FC16B2F14F85A7F47AA.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key Binary files differnew file mode 100644 index 00000000000..89f6013100d --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/CC68630A06B048F5A91136C162C7A3273E20DE6F.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key Binary files differnew file mode 100644 index 00000000000..41dac37574e --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/E7E73903E1BF93481DE0E7C9769D6C31E1863CFF.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key Binary files differnew file mode 100644 index 00000000000..5df7b4a5953 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F0117468BE801ED4B81972E159A98FDD4814DCEC.key diff --git a/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key Binary files differnew file mode 100644 index 00000000000..03daf80975b --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/private-keys-v1.d/F4C5EFD5779BE892CAFD5B721D68DED677C9B151.key diff --git a/test/lisp/gnus/mml-sec-resources/pubring.gpg b/test/lisp/gnus/mml-sec-resources/pubring.gpg Binary files differnew file mode 100644 index 00000000000..6bd169963df --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/pubring.gpg diff --git a/test/lisp/gnus/mml-sec-resources/pubring.kbx b/test/lisp/gnus/mml-sec-resources/pubring.kbx Binary files differnew file mode 100644 index 00000000000..399a0414fd2 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/pubring.kbx diff --git a/test/lisp/gnus/mml-sec-resources/secring.gpg b/test/lisp/gnus/mml-sec-resources/secring.gpg Binary files differnew file mode 100644 index 00000000000..b323c072c04 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/secring.gpg diff --git a/test/lisp/gnus/mml-sec-resources/trustdb.gpg b/test/lisp/gnus/mml-sec-resources/trustdb.gpg Binary files differnew file mode 100644 index 00000000000..09ebd8db114 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/trustdb.gpg diff --git a/test/lisp/gnus/mml-sec-resources/trustlist.txt b/test/lisp/gnus/mml-sec-resources/trustlist.txt new file mode 100644 index 00000000000..f886572d283 --- /dev/null +++ b/test/lisp/gnus/mml-sec-resources/trustlist.txt @@ -0,0 +1,26 @@ +# This is the list of trusted keys. Comment lines, like this one, as +# well as empty lines are ignored. Lines have a length limit but this +# is not a serious limitation as the format of the entries is fixed and +# checked by gpg-agent. A non-comment line starts with optional white +# space, followed by the SHA-1 fingerpint in hex, followed by a flag +# which may be one of 'P', 'S' or '*' and optionally followed by a list of +# other flags. The fingerprint may be prefixed with a '!' to mark the +# key as not trusted. You should give the gpg-agent a HUP or run the +# command "gpgconf --reload gpg-agent" after changing this file. + + +# Include the default trust list +include-default + + +# CN=No Expiry +D0:6A:A1:18:65:3C:C3:8E:9D:0C:AF:56:ED:7A:21:35:E1:58:21:77 S relax + +# CN=Second Key Pair +0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 S relax + +# CN=No Expiry two UIDs +D4:CA:78:E1:47:0B:9F:C2:AE:45:D7:84:64:9B:8C:E6:4E:BB:32:0C S relax + +# CN=Different subkeys +4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC S relax diff --git a/test/lisp/gnus/mml-sec-tests.el b/test/lisp/gnus/mml-sec-tests.el new file mode 100644 index 00000000000..a6002b4d51e --- /dev/null +++ b/test/lisp/gnus/mml-sec-tests.el @@ -0,0 +1,890 @@ +;;; mml-sec-tests.el --- Tests mml-sec.el, see README-mml-secure.txt. -*- lexical-binding:t -*- +;; Copyright (C) 2015, 2020 Free Software Foundation, Inc. + +;; Author: Jens Lechtenbörger <jens.lechtenboerger@fsfe.org> + +;; This file is not 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, 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 'ert-x) + +(require 'message) +(require 'epa) +(require 'epg) +(require 'mml-sec) +(require 'gnus-sum) + +(defvar with-smime nil + "If nil, exclude S/MIME from tests as passphrases need to entered manually. +Mostly, the empty passphrase is used. However, the keys for + \"No Expiry two UIDs\" have the passphrase \"Passphrase\" (for OpenPGP as well + as S/MIME).") + +(defun test-conf () + ;; Emacs doesn't have support for finding the name of the PGP agent + ;; on MacOS, so disable the checks. + (and (not (eq system-type 'darwin)) + (ignore-errors (epg-find-configuration 'OpenPGP)))) + +(defun enc-standards () + (if with-smime '(enc-pgp enc-pgp-mime enc-smime) + '(enc-pgp enc-pgp-mime))) +(defun enc-sign-standards () + (if with-smime + '(enc-sign-pgp enc-sign-pgp-mime enc-sign-smime) + '(enc-sign-pgp enc-sign-pgp-mime))) +(defun sign-standards () + (if with-smime + '(sign-pgp sign-pgp-mime sign-smime) + '(sign-pgp sign-pgp-mime))) + +(defvar mml-smime-use) + +(defun mml-secure-test-fixture (body &optional interactive) + "Setup GnuPG home containing test keys and prepare environment for BODY. +If optional INTERACTIVE is non-nil, allow questions to the user in case of +key problems. +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)))) + +(defun mml-secure-test-message-setup (method to from &optional text bcc) + "Setup a buffer with MML METHOD, TO, and FROM headers. +Optionally, a message TEXT and BCC header can be passed." + (with-temp-buffer + (when bcc (insert (format "Bcc: %s\n" bcc))) + (insert (format "To: %s +From: %s +Subject: Test +%s\n" to from mail-header-separator)) + (if text + (insert (format "%s" text)) + (spook)) + (cond ((eq method 'enc-pgp-mime) + (mml-secure-message-encrypt-pgpmime 'nosig)) + ((eq method 'enc-sign-pgp-mime) + (mml-secure-message-encrypt-pgpmime)) + ((eq method 'enc-pgp) (mml-secure-message-encrypt-pgp 'nosig)) + ((eq method 'enc-sign-pgp) (mml-secure-message-encrypt-pgp)) + ((eq method 'enc-smime) (mml-secure-message-encrypt-smime 'nosig)) + ((eq method 'enc-sign-smime) (mml-secure-message-encrypt-smime)) + ((eq method 'sign-pgp-mime) (mml-secure-message-sign-pgpmime)) + ((eq method 'sign-pgp) (mml-secure-message-sign-pgp)) + ((eq method 'sign-smime) (mml-secure-message-sign-smime)) + (t (error "Unknown method"))) + (buffer-string))) + +(defun mml-secure-test-mail-fixture (method to from body2 + &optional interactive) + "Setup buffer encrypted using METHOD for TO from FROM, call BODY2. +Pass optional INTERACTIVE to mml-secure-test-fixture." + (mml-secure-test-fixture + (lambda () + (let ((_context (if (memq method '(enc-smime enc-sign-smime sign-smime)) + (epg-make-context 'CMS) + (epg-make-context 'OpenPGP))) + ;; Verify and decrypt by default. + (mm-verify-option 'known) + (mm-decrypt-option 'known) + (plaintext "The Magic Words are Squeamish Ossifrage")) + (with-temp-buffer + (insert (mml-secure-test-message-setup method to from plaintext)) + (message-options-set-recipient) + (message-encode-message-body) + ;; Replace separator line with newline. + (goto-char (point-min)) + (re-search-forward + (concat "^" (regexp-quote mail-header-separator) "\n")) + (replace-match "\n") + ;; The following treatment of handles, plainbuf, and multipart + ;; resulted from trial-and-error. + ;; Someone with more knowledge on how to decrypt messages and verify + ;; signatures might know more appropriate functions to invoke + ;; instead. + (let* ((handles (or (mm-dissect-buffer) + (mm-uu-dissect))) + (isplain (bufferp (car handles))) + (ismultipart (equal (car handles) "multipart/mixed")) + (plainbuf (if isplain + (car handles) + (if ismultipart + (car (cadadr handles)) + (caadr handles)))) + (decrypted + (with-current-buffer plainbuf (buffer-string))) + (gnus-info + (if isplain + nil + (if ismultipart + (or (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-details) + (mm-handle-multipart-ctl-parameter + (cadr handles) 'gnus-info)) + (mm-handle-multipart-ctl-parameter + handles 'gnus-info))))) + (funcall body2 gnus-info plaintext decrypted))))) + interactive)) + +;; TODO If the variable BODY3 is renamed to BODY, an infinite recursion +;; occurs. Emacs bug? +(defun mml-secure-test-key-fixture (body3) + "Customize unique keys for sub@example.org and call BODY3. +For OpenPGP, we have: +- 1E6B FA97 3D9E 3103 B77F D399 C399 9CF1 268D BEA2 + uid Different subkeys <sub@example.org> +- 1463 2ECA B9E2 2736 9C8D D97B F7E7 9AB7 AE31 D471 + uid Second Key Pair <sub@example.org> + +For S/MIME: + ID: 0x479DC6E2 + Subject: /CN=Second Key Pair + aka: sub@example.org + fingerprint: 0E:58:22:9B:80:EE:33:95:9F:F7:18:FE:EF:25:40:2B:47:9D:C6:E2 + + ID: 0x5F88E9FC + Subject: /CN=Different subkeys + aka: sub@example.org + fingerprint: 4F:96:2A:B7:F4:76:61:6A:78:3D:72:AA:40:35:D5:9B:5F:88:E9:FC + +In both cases, the first key is customized for signing and encryption." + (mml-secure-test-fixture + (lambda () + (let* ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (pkey (epg-list-keys pcontext "C3999CF1268DBEA2")) + (scontext (epg-make-context 'CMS)) + (skey (epg-list-keys scontext "0x479DC6E2"))) + (mml-secure-cust-record-keys pcontext 'encrypt "sub@example.org" pkey) + (mml-secure-cust-record-keys pcontext 'sign "sub@example.org" pkey) + (mml-secure-cust-record-keys scontext 'encrypt "sub@example.org" skey) + (mml-secure-cust-record-keys scontext 'sign "sub@example.org" skey) + (funcall body3))))) + +(ert-deftest mml-secure-key-checks () + "Test mml-secure-check-user-id and mml-secure-check-sub-key on sample keys." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (keys1 (epg-list-keys context "expired@example.org")) + (keys2 (epg-list-keys context "no-exp@example.org")) + (keys3 (epg-list-keys context "sub@example.org")) + (keys4 (epg-list-keys context "revoked-uid@example.org")) + (keys5 (epg-list-keys context "disabled@example.org")) + (keys6 (epg-list-keys context "sign@example.org")) + (keys7 (epg-list-keys context "jens.lechtenboerger@fsfe")) + ) + (should (and (= 1 (length keys1)) (= 1 (length keys2)) + (= 2 (length keys3)) + (= 1 (length keys4)) (= 1 (length keys5)) + )) + ;; key1 is expired + (should-not (mml-secure-check-user-id (car keys1) "expired@example.org")) + (should-not (mml-secure-check-sub-key context (car keys1) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys1) 'sign)) + + ;; key2 does not expire, but does not have the UID expired@example.org + (should-not (mml-secure-check-user-id (car keys2) "expired@example.org")) + (should (mml-secure-check-user-id (car keys2) "no-exp@example.org")) + (should (mml-secure-check-sub-key context (car keys2) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys2) 'sign)) + + ;; Two keys exist for sub@example.org. + (should (mml-secure-check-user-id (car keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (car keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys3) 'sign)) + (should (mml-secure-check-user-id (cadr keys3) "sub@example.org")) + (should (mml-secure-check-sub-key context (cadr keys3) 'encrypt)) + (should (mml-secure-check-sub-key context (cadr keys3) 'sign)) + + ;; The UID revoked-uid@example.org is revoked. The key itself is + ;; usable, though (with the UID sub@example.org). + (should-not + (mml-secure-check-user-id (car keys4) "revoked-uid@example.org")) + (should (mml-secure-check-sub-key context (car keys4) 'encrypt)) + (should (mml-secure-check-sub-key context (car keys4) 'sign)) + (should (mml-secure-check-user-id (car keys4) "sub@example.org")) + + ;; The next key is disabled and, thus, unusable. + (should (mml-secure-check-user-id (car keys5) "disabled@example.org")) + (should-not (mml-secure-check-sub-key context (car keys5) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys5) 'sign)) + + ;; The next key has multiple subkeys. + ;; 42466F0F is valid sign subkey, 501FFD98 is expired + (should (mml-secure-check-sub-key context (car keys6) 'sign "42466F0F")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "501FFD98")) + ;; DC7F66E7 is encrypt subkey + (should + (mml-secure-check-sub-key context (car keys6) 'encrypt "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'sign "DC7F66E7")) + (should-not + (mml-secure-check-sub-key context (car keys6) 'encrypt "42466F0F")) + + ;; The final key is just a public key. + (should (mml-secure-check-sub-key context (car keys7) 'encrypt)) + (should-not (mml-secure-check-sub-key context (car keys7) 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-1 () + "Make sure that expired and disabled keys and revoked UIDs are not used." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "expired@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'encrypt)) + (should-not + (mml-secure-find-usable-keys context "disabled@example.org" 'sign)) + + (should-not + (mml-secure-find-usable-keys + context "<revoked-uid@example.org>" 'encrypt)) + (should-not + (mml-secure-find-usable-keys + context "<revoked-uid@example.org>" 'sign)) + ;; Same test without ankles. Will fail for Ma Gnus v0.14 and earlier. + (should-not + (mml-secure-find-usable-keys + context "revoked-uid@example.org" 'encrypt)) + + ;; Expired key should not be usable. + ;; Will fail for Ma Gnus v0.14 and earlier. + ;; sign@example.org has the expired subkey 0x501FFD98. + (should-not + (mml-secure-find-usable-keys context "0x501FFD98" 'sign)) + + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'encrypt)) + (should + (mml-secure-find-usable-keys context "no-exp@example.org" 'sign)) + )))) + +(ert-deftest mml-secure-find-usable-keys-2 () + "Test different ways to search for keys." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + ;; Plain substring search is not supported. + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'encrypt)))) + (should + (= 0 (length + (mml-secure-find-usable-keys context "No Expiry" 'sign)))) + + ;; Search for e-mail addresses works with and without ankle brackets. + (should + (= 1 (length (mml-secure-find-usable-keys + context "<no-exp@example.org>" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "<no-exp@example.org>" 'sign)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "no-exp@example.org" 'sign)))) + + ;; Use full UID string. + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry <no-exp@example.org>" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "No Expiry <no-exp@example.org>" 'sign)))) + + ;; If just the public key is present, only encryption is possible. + ;; Search works with key IDs, with and without prefix "0x". + (should + (= 1 (length (mml-secure-find-usable-keys + context "A142FD84" 'encrypt)))) + (should + (= 1 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'encrypt)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "A142FD84" 'sign)))) + (should + (= 0 (length (mml-secure-find-usable-keys + context "0xA142FD84" 'sign)))) + )))) + +(ert-deftest mml-secure-select-preferred-keys-1 () + "If only one key exists for an e-mail address, it is the preferred one." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP))) + (should (equal "832F3CC6518D37BC658261B802372A42CA6D40FB" + (mml-secure-fingerprint + (car (mml-secure-select-preferred-keys + context '("no-exp@example.org") 'encrypt))))))))) + +(ert-deftest mml-secure-select-preferred-keys-2 () + "If multiple keys exists for an e-mail address, customization is necessary." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let* ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pref (car (mml-secure-find-usable-keys + context "sub@example.org" 'encrypt)))) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (list pref)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'sign)) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should + (equal (list (mml-secure-fingerprint pref)) + (mml-secure-cust-fpr-lookup context 'encrypt "sub@example.org"))) + (should (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)))))) + +(ert-deftest mml-secure-select-preferred-keys-3 () + "Expired customized keys are removed if multiple keys are available." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((context (epg-make-context 'OpenPGP)) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + ;; sub@example.org has two keys (268DBEA2, AE31D471). + ;; Normal preference works. + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "268DBEA2")) + (should (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org") + + ;; Fake preference for expired (unrelated) key CE15FAE7, + ;; results in error (and automatic removal of outdated preference). + (mml-secure-cust-record-keys + context 'encrypt "sub@example.org" (epg-list-keys context "CE15FAE7")) + (should-error (mml-secure-select-preferred-keys + context '("sub@example.org") 'encrypt)) + (should-not + (mml-secure-cust-remove-keys context 'encrypt "sub@example.org")))))) + +(ert-deftest mml-secure-select-preferred-keys-4 () + "Multiple keys can be recorded per recipient or signature." + (skip-unless (test-conf)) + (mml-secure-test-fixture + (lambda () + (let ((pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (pkeys '("1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" + "14632ECAB9E227369C8DD97BF7E79AB7AE31D471")) + (skeys '("0x5F88E9FC" "0x479DC6E2")) + (mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt))))) + + ;; OpenPGP preferences via pcontext + (dolist (key pkeys nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key 'secret))) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs))) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-e-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-e-fprs)) + (should (member "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2" p-s-fprs)) + (should (member "14632ECAB9E227369C8DD97BF7E79AB7AE31D471" p-s-fprs))) + ;; Duplicate record does not change anything. + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" + (epg-list-keys pcontext "1E6BFA973D9E3103B77FD399C3999CF1268DBEA2")) + (let ((p-e-fprs (mml-secure-cust-fpr-lookup + pcontext 'encrypt "sub@example.org")) + (p-s-fprs (mml-secure-cust-fpr-lookup + pcontext 'sign "sub@example.org"))) + (should (= 2 (length p-e-fprs))) + (should (= 2 (length p-s-fprs)))) + + ;; S/MIME preferences via scontext + (dolist (key skeys nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" + (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" + (epg-list-keys scontext key 'secret))) + (let ((s-e-fprs (mml-secure-cust-fpr-lookup + scontext 'encrypt "sub@example.org")) + (s-s-fprs (mml-secure-cust-fpr-lookup + scontext 'sign "sub@example.org"))) + (should (= 2 (length s-e-fprs))) + (should (= 2 (length s-s-fprs)))) + )))) + +(defun mml-secure-test-en-decrypt + (method to from + &optional checksig checkplain enc-keys expectfail interactive) + "Encrypt message using METHOD, addressed to TO, from FROM. +If optional CHECKSIG is non-nil, it must be a number, and a signature check is +performed; the number indicates how many signatures are expected. +If optional CHECKPLAIN is non-nil, the expected plaintext should be obtained +via decryption. +If optional ENC-KEYS is non-nil, it is a list of pairs of encryption keys (for +OpenPGP and S/SMIME) expected in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected. +Pass optional INTERACTIVE to mml-secure-test-mail-fixture." + (mml-secure-test-mail-fixture method to from + (lambda (gnus-info plaintext decrypted) + (if expectfail + (should-not (equal plaintext decrypted)) + (when checkplain + (should (equal plaintext decrypted))) + (let ((protocol (if (memq method + '(enc-smime enc-sign-smime sign-smime)) + 'CMS + 'OpenPGP))) + (when checksig + (let* ((context (epg-make-context protocol)) + (signer-names (mml-secure-signer-names protocol from)) + (signer-keys (mml-secure-signers context signer-names)) + (signer-fprs (mapcar 'mml-secure-fingerprint signer-keys))) + (should (eq checksig (length signer-fprs))) + (if (eq checksig 0) + ;; First key in keyring + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + "0E58229B80EE33959FF718FEEF25402B479DC6E2" + "02372A42CA6D40FB")) + gnus-info))) + (dolist (fpr signer-fprs nil) + ;; OpenPGP: "Good signature from 02372A42CA6D40FB No Expiry <no-exp@example.org> (trust undefined) created ..." + ;; S/MIME: "Good signature from D06AA118653CC38E9D0CAF56ED7A2135E1582177 /CN=No Expiry (trust full) ..." + (should (string-match-p + (concat "Good signature from " + (if (eq protocol 'CMS) + fpr + (substring fpr -16 nil))) + gnus-info))))) + (when enc-keys + (with-current-buffer epg-debug-buffer + (goto-char (point-min)) + ;; The following regexp does not necessarily match at the + ;; start of the line as a path may or may not be present. + ;; Also note that gpg.* matches gpg2 and gpgsm as well. + (let* ((line (concat "gpg.*--encrypt.*$")) + (end (re-search-forward line)) + (match (match-string 0))) + (should (and end match)) + (dolist (pair enc-keys nil) + (let ((fpr (if (eq protocol 'OpenPGP) + (car pair) + (cdr pair)))) + (should (string-match-p (concat "-r " fpr) match)))) + (goto-char (point-max)) + )))))) + interactive)) + +(defvar mml-smime-cache-passphrase) +(defvar mml2015-cache-passphrase) +(defvar mml1991-cache-passphrase) + +(defun mml-secure-test-en-decrypt-with-passphrase + (method to from checksig jl-passphrase do-cache + &optional enc-keys expectfail) + "Call mml-secure-test-en-decrypt with changed passphrase caching. +Args METHOD, TO, FROM, CHECKSIG are passed to mml-secure-test-en-decrypt. +JL-PASSPHRASE is fixed as return value for `read-passwd', +boolean DO-CACHE determines whether to cache the passphrase. +If optional ENC-KEYS is non-nil, it is a list of encryption keys expected +in `epg-debug-buffer'. +If optional EXPECTFAIL is non-nil, a decryption failure is expected." + (let ((mml-secure-cache-passphrase do-cache) + (mml1991-cache-passphrase do-cache) + (mml2015-cache-passphrase do-cache) + (mml-smime-cache-passphrase do-cache) + ) + (cl-letf (((symbol-function 'read-passwd) + (lambda (_prompt &optional _confirm _default) jl-passphrase))) + (mml-secure-test-en-decrypt method to from checksig t enc-keys expectfail) + ))) + +(ert-deftest mml-secure-en-decrypt-1 () + "Encrypt message; then decrypt and test for expected result. +In this test, the single matching key is chosen automatically." + (skip-unless (test-conf)) + (dolist (method (enc-standards) nil) + ;; no-exp@example.org with single encryption key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "02372A42CA6D40FB" "ED7A2135E1582177"))))) + +(ert-deftest mml-secure-en-decrypt-2 () + "Encrypt message; then decrypt and test for expected result. +In this test, the encryption key needs to fixed among multiple ones." + (skip-unless (test-conf)) + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2"))))))) + +(ert-deftest mml-secure-en-decrypt-3 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to t." + (skip-unless (test-conf)) + ;; sub@example.org with multiple candidate keys, + ;; fixture customizes preferred ones. + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))))))) + +(ert-deftest mml-secure-en-decrypt-4 () + "Encrypt message; then decrypt and test for expected result. +In this test, encrypt-to-self variables are set to lists." + (skip-unless (test-conf)) + ;; Send from sub@example.org, which has two keys; encrypt to both. + (let ((mml-secure-openpgp-encrypt-to-self + '("C3999CF1268DBEA2" "F7E79AB7AE31D471")) + (mml-secure-smime-encrypt-to-self + '("EF25402B479DC6E2" "4035D59B5F88E9FC"))) + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" nil t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "F7E79AB7AE31D471" "4035D59B5F88E9FC")))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-1-single () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (method (enc-sign-standards) nil) + ;; no-exp with just one key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-exp@example.org" 1 t) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 1 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 1 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-2-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; Now use both keys to sign. The customized one via sign-with-sender, + ;; the other one via the following setting. + (let ((mml-secure-openpgp-signers '("F7E79AB7AE31D471")) + (mml-secure-smime-signers '("0x5F88E9FC"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t))))))) + +(ert-deftest mml-secure-en-decrypt-sign-1-3-double () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, just multiple encryption and signing keys may be available." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + ;; Now use both keys for sub@example.org to sign an e-mail from + ;; a different address (without associated keys). + (let ((mml-secure-openpgp-sign-with-sender nil) + (mml-secure-smime-sign-with-sender nil) + (mml-secure-openpgp-signers + '("F7E79AB7AE31D471" "C3999CF1268DBEA2")) + (mml-secure-smime-signers '("0x5F88E9FC" "0x479DC6E2"))) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "no-keys@example.org" 2 t)))))) + +(ert-deftest mml-secure-en-decrypt-sign-2 () + "Sign and encrypt message; then decrypt and test for expected result. +In this test, lists of encryption and signing keys are customized." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-key-preferences + '((OpenPGP (sign) (encrypt)) (CMS (sign) (encrypt)))) + (pcontext (epg-make-context 'OpenPGP)) + (scontext (epg-make-context 'CMS)) + (mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + (dolist (key '("F7E79AB7AE31D471" "C3999CF1268DBEA2") nil) + (mml-secure-cust-record-keys + pcontext 'encrypt "sub@example.org" (epg-list-keys pcontext key)) + (mml-secure-cust-record-keys + pcontext 'sign "sub@example.org" (epg-list-keys pcontext key t))) + (dolist (key '("0x5F88E9FC" "0x479DC6E2") nil) + (mml-secure-cust-record-keys + scontext 'encrypt "sub@example.org" (epg-list-keys scontext key)) + (mml-secure-cust-record-keys + scontext 'sign "sub@example.org" (epg-list-keys scontext key t))) + (dolist (method (enc-sign-standards) nil) + ;; customized choice for encryption key + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t) + ;; customized choice for signing key + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 t) + ;; customized choice for both keys + (mml-secure-test-en-decrypt + method "sub@example.org" "sub@example.org" 2 t) + ))))) + +(ert-deftest mml-secure-en-decrypt-sign-3 () + "Sign and encrypt message; then decrypt and test for expected result. +Use sign-with-sender and encrypt-to-self." + :tags '(:unstable) + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-openpgp-encrypt-to-self t) + (mml-secure-smime-sign-with-sender t) + (mml-secure-smime-encrypt-to-self t)) + (dolist (method (enc-sign-standards) nil) + (mml-secure-test-en-decrypt + method "sub@example.org" "no-exp@example.org" 1 t + (list (cons "C3999CF1268DBEA2" "EF25402B479DC6E2") + (cons "02372A42CA6D40FB" "ED7A2135E1582177")))) + )))) + +(ert-deftest mml-secure-sign-verify-1 () + "Sign message with sender; then verify and test for expected result." + (skip-unless (test-conf)) + (mml-secure-test-key-fixture + (lambda () + (dolist (method (sign-standards) nil) + (let ((mml-secure-openpgp-sign-with-sender t) + (mml-secure-smime-sign-with-sender t)) + ;; A single signing key for sender sub@example.org is customized + ;; in the fixture. + (mml-secure-test-en-decrypt + method "uid1@example.org" "sub@example.org" 1 nil) + + ;; From sub@example.org, sign with two keys; + ;; sign-with-sender and one from signers-variable: + (let ((mml-secure-openpgp-signers '("02372A42CA6D40FB")) + (mml-secure-smime-signers + '("D06AA118653CC38E9D0CAF56ED7A2135E1582177"))) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sub@example.org" 2 nil)) + ))))) + +(ert-deftest mml-secure-sign-verify-3 () + "Try to sign message with expired OpenPGP subkey, which raises an error. +With Ma Gnus v0.14 and earlier a signature would be created with a wrong key." + (skip-unless (test-conf)) + (should-error + (mml-secure-test-key-fixture + (lambda () + (let ((with-smime nil) + (mml-secure-openpgp-sign-with-sender nil) + (mml-secure-openpgp-signers '("501FFD98"))) + (dolist (method (sign-standards) nil) + (mml-secure-test-en-decrypt + method "no-exp@example.org" "sign@example.org" 1 nil) + )))))) + +;; TODO Passphrase passing and caching in Emacs does not seem to work +;; with gpgsm at all. +;; Independently of caching settings, a pinentry dialogue is displayed. +;; Thus, the following tests require the user to enter the correct gpgsm +;; passphrases at the correct points in time. (Either empty string or +;; "Passphrase".) +(ert-deftest mml-secure-en-decrypt-passphrase-cache () + "Encrypt message; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, in the second one it + is taken from a cache." + (skip-unless (test-conf)) + (ert-skip "Requires passphrase") + (mml-secure-test-key-fixture + (lambda () + (dolist (method (enc-standards) nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + ;; Beware! For passphrases copy-sequence is necessary, as they may + ;; be erased, which actually changes the function's code and causes + ;; multiple invocations to fail. I was surprised... + (copy-sequence "Passphrase") t) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") t))))) + +(defun mml-secure-en-decrypt-passphrase-no-cache (method) + "Encrypt message with METHOD; then decrypt and test for expected result. +In this test, a key is used that requires the passphrase \"Passphrase\". +In the first decryption this passphrase is hardcoded, but caching disabled. +So the second decryption fails." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Passphrase") nil) + (mml-secure-test-en-decrypt-with-passphrase + method "uid1@example.org" "sub@example.org" nil + (copy-sequence "Incorrect") nil nil t)))) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-openpgp-todo () + "Passphrase caching with OpenPGP only for GnuPG 1.x." + (skip-unless (test-conf)) + (skip-unless (string< (cdr (assq 'version (epg-find-configuration 'OpenPGP))) + "2")) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp) + (mml-secure-en-decrypt-passphrase-no-cache 'enc-pgp-mime)) + +(ert-deftest mml-secure-en-decrypt-passphrase-no-cache-smime-todo () + "Passphrase caching does not work with S/MIME (and gpgsm)." + :expected-result :failed + (skip-unless (test-conf)) + (if with-smime + (mml-secure-en-decrypt-passphrase-no-cache 'enc-smime) + (should nil))) + + +;; Test truncation of question in y-or-n-p. +(defun mml-secure-select-preferred-keys-todo () + "Manual customization with truncated question." + (mml-secure-test-key-fixture + (lambda () + (mml-secure-test-en-decrypt + 'enc-pgp-mime + "jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de" + "no-exp@example.org" nil t nil nil t)))) + +(defun mml-secure-select-preferred-keys-ok () + "Manual customization with entire question." + (mml-secure-test-fixture + (lambda () + (mml-secure-select-preferred-keys + (epg-make-context 'OpenPGP) + '("jens.lechtenboerger@informationelle-selbstbestimmung-im-internet.de") + 'encrypt)) + t)) + + +;; ERT entry points +(defun mml-secure-run-tests () + "Run all tests with defaults." + (ert-run-tests-batch)) + +(defun mml-secure-run-tests-with-gpg2 () + "Run all tests with gpg2 instead of gpg." + (let* ((epg-gpg-program "gpg2"); ~/local/gnupg-2.1.9/PLAY/inst/bin/gpg2 + (gpg-version (cdr (assq 'version (epg-find-configuration 'OpenPGP)))) + ;; Empty passphrases do not seem to work with gpgsm in 2.1.x: + ;; https://lists.gnupg.org/pipermail/gnupg-users/2015-October/054575.html + (with-smime (string< gpg-version "2.1"))) + (ert-run-tests-batch))) + +(defun mml-secure-run-tests-without-smime () + "Skip S/MIME tests (as they require manual passphrase entry)." + (let ((with-smime nil)) + (ert-run-tests-batch))) + +(defun mml-sec-test--kill-gpg-agent () + (dolist (pid (list-system-processes)) + (let ((atts (process-attributes pid))) + (when (and (equal (cdr (assq 'user atts)) (user-login-name)) + (equal (cdr (assq 'comm atts)) "gpg-agent") + (string-match + (concat "homedir.*" + (regexp-quote (ert-resource-directory))) + (cdr (assq 'args atts)))) + (call-process "kill" nil nil nil (format "%d" pid)))))) + +;;; mml-sec-tests.el ends here diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 4c808d8372e..3359821b68f 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -24,8 +24,9 @@ ;;; Code: (require 'ert) +(require 'help-fns) -(autoload 'help-fns-test--macro "help-fns" nil nil t) +(autoload 'help-fns-test--macro "foo" nil nil t) ;;; Several tests for describe-function @@ -56,28 +57,28 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-macro () - (let ((regexp "a Lisp macro in .subr\.el") + (let ((regexp "a Lisp macro in .+subr\\.el") (result (help-fns-tests--describe-function 'when))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defun () - (let ((regexp "a compiled Lisp function in .subr\.el") + (let ((regexp "a compiled Lisp function in .+subr\\.el") (result (help-fns-tests--describe-function 'last))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled Lisp function in .subr\.el") + (let ((regexp "a compiled Lisp function in .+subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) (ert-deftest help-fns-test-alias-to-defun () - (let ((regexp "an alias for .set-file-modes. in .subr\.el") + (let ((regexp "an alias for .set-file-modes. in .+subr\\.el") (result (help-fns-tests--describe-function 'chmod))) (should (string-match regexp result)))) (ert-deftest help-fns-test-bug23887 () "Test for https://debbugs.gnu.org/23887 ." - (let ((regexp "an alias for .re-search-forward. in .subr\.el") + (let ((regexp "an alias for .re-search-forward. in .+subr\\.el") (result (help-fns-tests--describe-function 'search-forward-regexp))) (should (string-match regexp result)))) @@ -123,4 +124,55 @@ Return first line of the output of (describe-function-1 FUNC)." (goto-char (point-min)) (should (looking-at "^font-lock-comment-face is ")))) +(defvar foo-test-map) +(defvar help-fns-test--describe-keymap-foo) + + +;;; Tests for describe-keymap +(ert-deftest help-fns-test-find-keymap-name () + (should (equal (help-fns-find-keymap-name lisp-mode-map) 'lisp-mode-map)) + ;; Follow aliasing. + (unwind-protect + (progn + (defvaralias 'foo-test-map 'lisp-mode-map) + (should (equal (help-fns-find-keymap-name foo-test-map) 'lisp-mode-map))) + (makunbound 'foo-test-map))) + +(ert-deftest help-fns-test-describe-keymap/symbol () + (describe-keymap 'minibuffer-local-must-match-map) + (with-current-buffer "*Help*" + (should (looking-at "^minibuffer-local-must-match-map is")))) + +(ert-deftest help-fns-test-describe-keymap/value () + (describe-keymap minibuffer-local-must-match-map) + (with-current-buffer "*Help*" + (should (looking-at "^key")))) + +(ert-deftest help-fns-test-describe-keymap/not-keymap () + (should-error (describe-keymap nil)) + (should-error (describe-keymap emacs-version))) + +(ert-deftest help-fns-test-describe-keymap/let-bound () + (let ((foobar minibuffer-local-must-match-map)) + (describe-keymap foobar) + (with-current-buffer "*Help*" + (should (looking-at "^key"))))) + +(ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () + (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) + (describe-keymap 'help-fns-test--describe-keymap-foo) + (with-current-buffer "*Help*" + (should (looking-at "^help-fns-test--describe-keymap-foo is")))) + +;;; Tests for find-lisp-object-file-name +(ert-deftest help-fns-test-bug24697-function-search () + (should-not (find-lisp-object-file-name 'tab-width 1))) + +(ert-deftest help-fns-test-bug24697-non-internal-variable () + (let ((help-fns--test-var (make-symbol "help-fns--test-var"))) + ;; simulate an internal variable + (put help-fns--test-var 'variable-documentation 1) + (should-not (find-lisp-object-file-name help-fns--test-var 'defface)) + (should-not (find-lisp-object-file-name help-fns--test-var 1)))) + ;;; help-fns-tests.el ends here diff --git a/test/lisp/help-mode-tests.el b/test/lisp/help-mode-tests.el new file mode 100644 index 00000000000..2b9552a8d81 --- /dev/null +++ b/test/lisp/help-mode-tests.el @@ -0,0 +1,169 @@ +;;; help-mode-tests.el --- Tests for help-mode.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'help-mode) +(require 'pp) + +(ert-deftest help-mode-tests-help-buffer () + (let ((help-xref-following nil)) + (should (equal "*Help*" (help-buffer))))) + +(ert-deftest help-mode-tests-help-buffer-current-buffer () + (with-temp-buffer + (help-mode) + (let ((help-xref-following t)) + (should (equal (buffer-name (current-buffer)) + (help-buffer)))))) + +(ert-deftest help-mode-tests-help-buffer-current-buffer-error () + (with-temp-buffer + (let ((help-xref-following t)) + (should-error (help-buffer))))) + +(ert-deftest help-mode-tests-make-xrefs () + (with-temp-buffer + (insert "car is a built-in function in ‘C source code’. + +(car LIST) + + Probably introduced at or before Emacs version 1.2. + This function does not change global state, including the match data. + +Return the car of LIST. If arg is nil, return nil. +Error if arg is not nil and not a cons cell. See also ‘car-safe’. + +See Info node ‘(elisp)Cons Cells’ for a discussion of related basic +Lisp concepts such as car, cdr, cons cell and list.") + (help-mode) + (help-make-xrefs) + (let ((car-safe-button (button-at 298))) + (should (eq (button-type car-safe-button) 'help-symbol)) + (should (eq (button-get car-safe-button 'help-function) + #'describe-symbol))) + (let ((cons-cells-info-button (button-at 333))) + (should (eq (button-type cons-cells-info-button) 'help-info)) + (should (eq (button-get cons-cells-info-button 'help-function) + #'info))))) + +(ert-deftest help-mode-tests-xref-button () + (with-temp-buffer + (insert "See also the function ‘interactive’.") + (string-match help-xref-symbol-regexp (buffer-string)) + (help-xref-button 8 'help-function) + (should-not (button-at 22)) + (should-not (button-at 35)) + (let ((button (button-at 30))) + (should (eq (button-type button) 'help-function))))) + +(ert-deftest help-mode-tests-insert-xref-button () + (with-temp-buffer + (help-insert-xref-button "[back]" 'help-back) + (goto-char (point-min)) + (should (eq (button-type (button-at (point))) 'help-back)) + (help-insert-xref-button "[forward]" 'help-forward) + ;; The back button should stay unchanged. + (should (eq (button-type (button-at (point))) 'help-back)))) + +(ert-deftest help-mode-tests-xref-on-pp () + (with-temp-buffer + (insert (pp '(cons fill-column))) + (help-xref-on-pp (point-min) (point-max)) + (goto-char (point-min)) + (search-forward "co") + (should (eq (button-type (button-at (point))) 'help-function)) + (search-forward "-") + (should (eq (button-type (button-at (point))) 'help-variable)))) + +(ert-deftest help-mode-tests-xref-go-back () + (let ((help-xref-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-xref-go-back (current-buffer)) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-xref-go-forward () + (let ((help-xref-forward-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-xref-go-forward (current-buffer)) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-back () + (let ((help-xref-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-go-back) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-back-no-stack () + (let ((help-xref-stack '())) + (should-error (help-go-back)))) + +(ert-deftest help-mode-tests-go-forward () + (let ((help-xref-forward-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-go-forward) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-forward-no-stack () + (let ((help-xref-forward-stack '())) + (should-error (help-go-forward)))) + +(ert-deftest help-mode-tests-do-xref () + (with-temp-buffer + (help-mode) + (help-do-xref 0 #'describe-symbol '(car)) + (should (looking-at-p "car is a")) + (should (string-match-p "[back]" (buffer-string))))) + +(ert-deftest help-mode-tests-follow-symbol () + (with-temp-buffer + (insert "car") + (help-mode) + (help-follow-symbol 0) + (should (looking-at-p "car is a")) + (should (string-match-p "[back]" (buffer-string))))) + +(ert-deftest help-mode-tests-follow-symbol-no-symbol () + (with-temp-buffer + (insert "fXYEWnRHI0B9w6VJqQIw") + (help-mode) + (should-error (help-follow-symbol 0)))) + +(provide 'help-mode-tests) +;;; help-mode-tests.el ends here diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 0862d1264c7..49cb40b29d9 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -3,6 +3,8 @@ ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Juanma Barranquero <lekktu@gmail.com> +;; Eli Zaretskii <eliz@gnu.org> +;; Stefan Kangas <stefankangas@gmail.com> ;; Keywords: help, internal ;; This file is part of GNU Emacs. @@ -23,6 +25,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'cl-lib)) (ert-deftest help-split-fundoc-SECTION () "Test new optional arg SECTION." @@ -51,6 +54,350 @@ (should (equal (help-split-fundoc nil t 'usage) nil)) (should (equal (help-split-fundoc nil t 'doc) nil)))) + +;;; substitute-command-keys + +(defmacro with-substitute-command-keys-test (&rest body) + `(cl-flet* ((test + (lambda (orig result) + (should (equal-including-properties + (substitute-command-keys orig) + result)))) + (test-re + (lambda (orig regexp) + (should (string-match (concat "^" regexp "$") + (substitute-command-keys orig)))))) + ,@body)) + +(ert-deftest help-tests-substitute-command-keys/no-change () + (with-substitute-command-keys-test + (test "foo" "foo") + (test "\\invalid-escape" "\\invalid-escape"))) + +(ert-deftest help-tests-substitute-command-keys/commands () + (with-substitute-command-keys-test + (test "foo \\[goto-char]" "foo M-g c") + (test "\\[next-line]" "C-n") + (test "\\[next-line]\n\\[next-line]" "C-n\nC-n") + (test "\\[next-line]\\[previous-line]" "C-nC-p") + (test "\\[next-line]\\=\\[previous-line]" "C-n\\[previous-line]") + ;; Allow any style of quotes, since the terminal might not support + ;; UTF-8. Same thing is done below. + (test-re "\\[next-line]`foo'" "C-n[`'‘]foo['’]") + (test "\\[emacs-version]" "M-x emacs-version") + (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n") + (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]"))) + +(ert-deftest help-tests-substitute-command-keys/keymaps () + (with-substitute-command-keys-test + (test "\\{minibuffer-local-must-match-map}" + "\ +key binding +--- ------- + +C-g abort-recursive-edit +TAB minibuffer-complete +C-j minibuffer-complete-and-exit +RET minibuffer-complete-and-exit +ESC Prefix Command +SPC minibuffer-complete-word +? minibuffer-completion-help +<C-tab> file-cache-minibuffer-complete +<XF86Back> previous-history-element +<XF86Forward> next-history-element +<down> next-line-or-history-element +<next> next-history-element +<prior> switch-to-completions +<up> previous-line-or-history-element + +M-v switch-to-completions + +M-< minibuffer-beginning-of-buffer +M-n next-history-element +M-p previous-history-element +M-r previous-matching-history-element +M-s next-matching-history-element + +"))) + +(ert-deftest help-tests-substitute-command-keys/keymap-change () + (with-substitute-command-keys-test + (test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-g") + (test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x"))) + +(defvar help-tests-remap-map + (let ((map (make-keymap))) + (define-key map (kbd "x") 'foo) + (define-key map (kbd "y") 'bar) + (define-key map [remap foo] 'bar) + map)) + +(ert-deftest help-tests-substitute-command-keys/remap () + (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[foo]") "y")) + (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[bar]") "y"))) + +(ert-deftest help-tests-substitute-command-keys/undefined-map () + (with-substitute-command-keys-test + (test-re "\\{foobar-map}" + "\nUses keymap [`'‘]foobar-map['’], which is not currently defined.\n"))) + +(ert-deftest help-tests-substitute-command-keys/quotes () + (with-substitute-command-keys-test + (let ((text-quoting-style 'curve)) + (test "quotes ‘like this’" "quotes ‘like this’") + (test "`x'" "‘x’") + (test "`" "‘") + (test "'" "’") + (test "\\`" "\\‘")) + (let ((text-quoting-style 'straight)) + (test "quotes `like this'" "quotes 'like this'") + (test "`x'" "'x'") + (test "`" "'") + (test "'" "'") + (test "\\`" "\\'")) + (let ((text-quoting-style 'grave)) + (test "quotes `like this'" "quotes `like this'") + (test "`x'" "`x'") + (test "`" "`") + (test "'" "'") + (test "\\`" "\\`")))) + +(ert-deftest help-tests-substitute-command-keys/literals () + (with-substitute-command-keys-test + (test "foo \\=\\[goto-char]" "foo \\[goto-char]") + (test "foo \\=\\=" "foo \\=") + (test "\\=\\=" "\\=") + (test "\\=\\[" "\\[") + (let ((text-quoting-style 'curve)) + (test "\\=`x\\='" "`x'")) + (let ((text-quoting-style 'straight)) + (test "\\=`x\\='" "`x'")) + (let ((text-quoting-style 'grave)) + (test "\\=`x\\='" "`x'")))) + +(ert-deftest help-tests-substitute-command-keys/no-change () + (with-substitute-command-keys-test + (test "\\[foobar" "\\[foobar") + (test "\\=" "\\="))) + +(ert-deftest help-tests-substitute-command-keys/multibyte () + ;; Cannot use string= here, as that compares unibyte and multibyte + ;; strings not equal. + (should (compare-strings + (substitute-command-keys "\200 \\[goto-char]") nil nil + "\200 M-g c" nil nil))) + +(ert-deftest help-tests-substitute-command-keys/apropos () + (save-window-excursion + (apropos "foo") + (switch-to-buffer "*Apropos*") + (goto-char (point-min)) + (should (looking-at "Type RET on")))) + +(defvar help-tests-major-mode-map + (let ((map (make-keymap))) + (define-key map "x" 'foo-original) + (define-key map "1" 'foo-range) + (define-key map "2" 'foo-range) + (define-key map "3" 'foo-range) + (define-key map "4" 'foo-range) + (define-key map (kbd "C-e") 'foo-something) + (define-key map '[F1] 'foo-function-key1) + (define-key map "(" 'short-range) + (define-key map ")" 'short-range) + (define-key map "a" 'foo-other-range) + (define-key map "b" 'foo-other-range) + (define-key map "c" 'foo-other-range) + map)) + +(define-derived-mode help-tests-major-mode nil + "Major mode for testing shadowing.") + +(defvar help-tests-minor-mode-map + (let ((map (make-keymap))) + (define-key map "x" 'foo-shadow) + (define-key map (kbd "C-e") 'foo-shadow) + map)) + +(define-minor-mode help-tests-minor-mode + "Minor mode for testing shadowing.") + +(ert-deftest help-tests-substitute-command-keys/test-mode () + (with-substitute-command-keys-test + (with-temp-buffer + (help-tests-major-mode) + (test "\\{help-tests-major-mode-map}" + "\ +key binding +--- ------- + +( .. ) short-range +1 .. 4 foo-range +a .. c foo-other-range + +C-e foo-something +x foo-original +<F1> foo-function-key1 + +")))) + +(ert-deftest help-tests-substitute-command-keys/shadow () + (with-substitute-command-keys-test + (with-temp-buffer + (help-tests-major-mode) + (help-tests-minor-mode) + (test "\\{help-tests-major-mode-map}" + "\ +key binding +--- ------- + +( .. ) short-range +1 .. 4 foo-range +a .. c foo-other-range + +C-e foo-something + (this binding is currently shadowed) +x foo-original + (this binding is currently shadowed) +<F1> foo-function-key1 + +")))) + +(ert-deftest help-tests-substitute-command-keys/command-remap () + (with-substitute-command-keys-test + (let ((help-tests-major-mode-map (make-keymap))) ; Protect from changes. + (with-temp-buffer + (help-tests-major-mode) + (define-key help-tests-major-mode-map [remap foo] 'bar) + (test "\\{help-tests-major-mode-map}" + "\ +key binding +--- ------- + +<remap> Prefix Command + +<remap> <foo> bar + +"))))) + +(ert-deftest help-tests-describe-map-tree/no-menu-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (menu-bar keymap + (foo menu-item "Foo" foo + :enable mark-active + :help "Help text")))))) + (describe-map-tree map nil nil nil nil t nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/no-menu-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (menu-bar keymap + (foo menu-item "Foo" foo + :enable mark-active + :help "Help text")))))) + (describe-map-tree map nil nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo +<menu-bar> Prefix Command + +<menu-bar> <foo> foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/mention-shadow-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . bar)))) + (shadow-maps '((keymap . ((1 . baz)))))) + (describe-map-tree map t shadow-maps nil nil t nil nil t) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + (this binding is currently shadowed) +C-b bar + +"))))) + +(ert-deftest help-tests-describe-map-tree/mention-shadow-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . bar)))) + (shadow-maps '((keymap . ((1 . baz)))))) + (describe-map-tree map t shadow-maps nil nil t nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-b bar + +"))))) + +(ert-deftest help-tests-describe-map-tree/partial-t () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . undefined))))) + (describe-map-tree map t nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo + +"))))) + +(ert-deftest help-tests-describe-map-tree/partial-nil () + (with-temp-buffer + (let ((standard-output (current-buffer)) + (map '(keymap . ((1 . foo) + (2 . undefined))))) + (describe-map-tree map nil nil nil nil nil nil nil nil) + (should (equal (buffer-string) "key binding +--- ------- + +C-a foo +C-b undefined + +"))))) + +(defvar help-tests--was-in-buffer nil) + +(ert-deftest help-substitute-command-keys/menu-filter-in-correct-buffer () + "Evaluate menu-filter in the original buffer. See Bug#39149." + (unwind-protect + (progn + (define-key global-map (kbd "C-c C-l r") + `(menu-item "2" identity + :filter ,(lambda (cmd) + (setq help-tests--was-in-buffer + (current-buffer)) + cmd))) + (with-temp-buffer + (substitute-command-keys "\\[identity]") + (should (eq help-tests--was-in-buffer + (current-buffer))))) + (setq help-tests--was-in-buffer nil) + (define-key global-map (kbd "C-c C-l r") nil) + (define-key global-map (kbd "C-c C-l") nil))) + +(ert-deftest help-substitute-command-keys/preserves-text-properties () + "Check that we preserve text properties (Bug#17052)." + (should (equal (substitute-command-keys + (propertize "foo \\[save-buffer]" 'face 'bold)) + (propertize "foo C-x C-s" 'face 'bold)))) + (provide 'help-tests) ;;; help-tests.el ends here diff --git a/test/lisp/hfy-cmap-resources/rgb.txt b/test/lisp/hfy-cmap-resources/rgb.txt new file mode 100644 index 00000000000..f8e369fae2a --- /dev/null +++ b/test/lisp/hfy-cmap-resources/rgb.txt @@ -0,0 +1,4 @@ +# test comment +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite diff --git a/test/lisp/hfy-cmap-tests.el b/test/lisp/hfy-cmap-tests.el new file mode 100644 index 00000000000..4cdc6ffc827 --- /dev/null +++ b/test/lisp/hfy-cmap-tests.el @@ -0,0 +1,55 @@ +;;; hfy-cmap-tests.el --- tests for hfy-cmap.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 'hfy-cmap) + +(defconst hfy-cmap-tests--data + (concat "255 250 250 snow\n" + "248 248 255 ghost white\n" + "248 248 255 GhostWhite\n")) + +(defconst hfy-cmap-tests--parsed + '(("GhostWhite" 248 248 255) + ("ghost white" 248 248 255) + ("snow" 255 250 250))) + +(ert-deftest test-hfy-cmap--parse-buffer () + (with-temp-buffer + (insert hfy-cmap-tests--data) + (should (equal (hfy-cmap--parse-buffer (current-buffer)) + hfy-cmap-tests--parsed)))) + +(ert-deftest test-htmlfontify-load-rgb-file () + :tags '(:expensive-test) + (let (hfy-rgb-txt-color-map) + (htmlfontify-load-rgb-file (ert-resource-file "rgb.txt")) + (should (equal hfy-rgb-txt-color-map + hfy-cmap-tests--parsed)))) + +(ert-deftest test-htmlfontify-load-rgb-file/non-existent-file () + (let (hfy-rgb-txt-color-map) + (htmlfontify-load-rgb-file "/non/existent/file") + (should-not hfy-rgb-txt-color-map))) + +(provide 'hfy-cmap-tests) +;;; hfy-cmap-tests.el ends here diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index dd2c28053a0..d30a6d08001 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -5,18 +5,20 @@ ;; Author: Tino Calancha <tino.calancha@gmail.com> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -48,5 +50,161 @@ ;; Only one match, then we have used just 1 face (should (equal hi-lock--unused-faces (cdr faces)))))) +(ert-deftest hi-lock-case-fold () + "Test for case-sensitivity." + (let ((hi-lock-auto-select-face t)) + (with-temp-buffer + (insert "a A b B\n") + + (dotimes (_ 2) (highlight-regexp "[a]")) + (should (= (length (overlays-in (point-min) (point-max))) 2)) + (unhighlight-regexp "[a]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[a]" nil nil "a")) + (should (= (length (overlays-in (point-min) (point-max))) 2)) + (unhighlight-regexp "a") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[A]" )) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "[A]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[A]" nil nil "A")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "A") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]"))) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "[a]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-phrase "a a")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "a a") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults)))) + (call-interactively 'unhighlight-regexp)) + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (emacs-lisp-mode) + (setq font-lock-mode t) + + (dotimes (_ 2) (highlight-regexp "[a]")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[a]")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[a]" nil nil "a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "a")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[A]" )) + (font-lock-ensure) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[A]")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[A]" nil nil "A")) + (font-lock-ensure) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "A")) + (should (null (get-text-property 3 'face))) + + (let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]"))) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (null (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[a]")) + (should (null (get-text-property 1 'face))) + + (dotimes (_ 2) (highlight-phrase "a a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "a a")) + (should (null (get-text-property 1 'face))) + + (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults))) + (font-lock-fontified t)) + (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 1 'face)))))) + +(ert-deftest hi-lock-unhighlight () + "Test for unhighlighting and `hi-lock--regexps-at-point'." + (let ((hi-lock-auto-select-face t)) + (with-temp-buffer + (insert "aAbB\n") + + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults)))) + + (highlight-regexp "a") + (highlight-regexp "b") + (should (= (length (overlays-in (point-min) (point-max))) 4)) + ;; `hi-lock--regexps-at-point' should take regexp "a" at point 1, + ;; not the last regexp "b" + (goto-char 1) + (call-interactively 'unhighlight-regexp) + (should (= (length (overlays-in 1 3)) 0)) + (should (= (length (overlays-in 3 5)) 2)) + ;; Next call should unhighlight remaining regepxs + (call-interactively 'unhighlight-regexp) + (should (= (length (overlays-in 3 5)) 0)) + + ;; Test unhighlight all + (highlight-regexp "a") + (highlight-regexp "b") + (should (= (length (overlays-in (point-min) (point-max))) 4)) + (unhighlight-regexp t) + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (emacs-lisp-mode) + (setq font-lock-mode t) + + (highlight-regexp "a") + (highlight-regexp "b") + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + ;; `hi-lock--regexps-at-point' should take regexp "a" at point 1, + ;; not the last regexp "b" + (goto-char 1) + (let ((font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + ;; Next call should unhighlight remaining regepxs + (let ((font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 3 'face))) + + ;; Test unhighlight all + (highlight-regexp "a") + (highlight-regexp "b") + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp t)) + (should (null (get-text-property 1 'face))) + (should (null (get-text-property 3 'face))))))) + (provide 'hi-lock-tests) ;;; hi-lock-tests.el ends here diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index 8dadb920547..2211cae305b 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -82,7 +82,7 @@ (test1 '((mode . org-mode) (or (size-gt . 10000) (and (not (starred-name)) - (directory . "\<org\>"))))) + (directory . "<org>"))))) (test2 '((or (mode . emacs-lisp-mode) (file-extension . "elc?") (and (starred-name) (name . "elisp")) (mode . lisp-interaction-mode)))) diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el index e66b5c6803d..43c3024721e 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -65,8 +65,13 @@ "Test `gravatar-build-url'." (let ((gravatar-default-image nil) (gravatar-force-default nil) - (gravatar-size nil)) - (should (equal (gravatar-build-url "foo") "\ + (gravatar-size nil) + (gravatar-service 'gravatar) + url) + (gravatar-build-url "foo" (lambda (u) (setq url u))) + (while (not url) + (sleep-for 0.01)) + (should (equal url "\ https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) ;;; gravatar-tests.el ends here diff --git a/test/lisp/imenu-tests.el b/test/lisp/imenu-tests.el index 684a856fe04..e5cdb9e65d1 100644 --- a/test/lisp/imenu-tests.el +++ b/test/lisp/imenu-tests.el @@ -1,4 +1,4 @@ -;;; imenu-tests.el --- Test suite for imenu. +;;; imenu-tests.el --- Test suite for imenu. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -50,24 +50,23 @@ (setq input (cdr input))))) result)) -(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) +(defmacro imenu-simple-scan-deftest (name doc mode content expected-items) "Generate an ert test for mode-own imenu expression. Run `imenu-create-index-function' at the buffer which content is -CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' -at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list -of strings which are picked up from the result with EXPECTED-ITEMS." +CONTENT with major MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with major MODE. Then it compares a +list of strings which are picked up from the result with EXPECTED-ITEMS." (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) `(ert-deftest ,xname () - ,doc + ,doc (with-temp-buffer (insert ,content) - (funcall ',major-mode) + (funcall #',mode) (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list (funcall imenu-create-index-function)) #'string-lessp)) (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) - (should (equal result-items expected-items)) - ))))) + (should (equal result-items expected-items))))))) (imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() { diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index 128b3f25ca5..940aa7d8ad1 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -1,4 +1,4 @@ -;;; info-xref.el --- tests for info-xref.el +;;; info-xref.el --- tests for info-xref.el -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index c8a5512d6f0..16e591f1dd5 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -1,3 +1,5 @@ +;;; ccl-tests.el --- unit tests for ccl.el -*- lexical-binding:t -*- + ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. @@ -230,3 +232,17 @@ At EOF: (with-temp-buffer (ccl-dump prog-midi-code) (should (equal (buffer-string) prog-midi-dump)))) + +(ert-deftest ccl-hash-table () + (let ((sym (gensym)) + (table (make-hash-table :test 'eq))) + (puthash 16 17 table) + (puthash 17 16 table) + (define-translation-hash-table sym table) + (let* ((prog `(2 + ((loop + (lookup-integer ,sym r0 r1))))) + (compiled (ccl-compile prog)) + (registers [17 0 0 0 0 0 0 0])) + (ccl-execute compiled registers) + (should (equal registers [2 16 0 0 0 0 0 1]))))) diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 91e3c2279f0..9520d9d8633 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -23,6 +23,8 @@ ;;; Code: +(require 'ert-x) ;For `ert-run-keys'. + (ert-deftest find-auto-coding--bug27391 () "Check that Bug#27391 is fixed." (with-temp-buffer @@ -41,12 +43,32 @@ (should (not (multibyte-string-p (encode-coding-char ?a 'utf-8))))) (ert-deftest mule-cmds--test-universal-coding-system-argument () - (skip-unless (not noninteractive)) (should (equal "ccccccccccccccccab" - (let ((enable-recursive-minibuffers t) - (unread-command-events - (append (kbd "C-x RET c u t f - 8 RET C-u C-u c a b RET") nil))) - (read-string "prompt:"))))) + (let ((enable-recursive-minibuffers t)) + (ert-simulate-keys + (kbd "C-x RET c u t f - 8 RET C-u C-u c a b RET") + (read-string "prompt:")))))) + +(ert-deftest mule-utf-7 () + ;; utf-7 and utf-7-imap are not ASCII-compatible. + (should-not (coding-system-get 'utf-7 :ascii-compatible-p)) + (should-not (coding-system-get 'utf-7-imap :ascii-compatible-p)) + ;; Invariant ASCII subset. + (let ((s (apply #'string (append (number-sequence #x20 #x25) + (number-sequence #x27 #x7e))))) + (should (equal (encode-coding-string s 'utf-7-imap) s)) + (should (equal (decode-coding-string s 'utf-7-imap) s))) + ;; Escaped ampersand. + (should (equal (encode-coding-string "a&bcd" 'utf-7-imap) "a&-bcd")) + (should (equal (decode-coding-string "a&-bcd" 'utf-7-imap) "a&bcd")) + ;; Ability to encode Unicode. + (should (equal (check-coding-systems-region "あ" nil '(utf-7-imap)) nil)) + (should (equal (encode-coding-string "あ" 'utf-7-imap) "&MEI-")) + (should (equal (decode-coding-string "&MEI-" 'utf-7-imap) "あ"))) + +(ert-deftest mule-hz () + ;; The chinese-hz encoding is not ASCII compatible. + (should-not (coding-system-get 'chinese-hz :ascii-compatible-p))) ;; Stop "Local Variables" above causing confusion when visiting this file. diff --git a/test/lisp/international/mule-util-tests.el b/test/lisp/international/mule-util-tests.el index c571782d635..0524dad88da 100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@ -1,4 +1,4 @@ -;;; mule-util --- tests for international/mule-util.el +;;; mule-util-tests.el --- tests for international/mule-util.el -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -75,10 +75,11 @@ (eval `(ert-deftest ,testname () ,testdoc - (should (equal (apply 'truncate-string-to-width ',(car testdata)) - ,(cdr testdata))))))) + (let ((truncate-string-ellipsis "...")) + (should (equal (apply 'truncate-string-to-width ',(car testdata)) + ,(cdr testdata)))))))) (dotimes (i (length mule-util-test-truncate-data)) (mule-util-test-truncate-create i)) -;;; mule-util.el ends here +;;; mule-util-tests.el ends here diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index 03366065ce6..2c60bd318a2 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -307,7 +307,7 @@ implementations: (list " var var)) (dolist (linos (seq-partition newval 8)) (insert (mapconcat #'number-to-string linos " ") "\n")) - (insert ")\)")) + (insert "))")) (defun ucs-normalize-check-failing-lines () (interactive) @@ -341,4 +341,15 @@ implementations: (display-buffer (current-buffer))) (message "No changes to failing lines needed")))) +(ert-deftest ucs-normalize-save-match-data () + "Verify that match data isn't clobbered (bug#41445)" + (string-match (rx (+ digit)) "a47b") + (should (equal (match-data t) '(1 3))) + (should (equal + (decode-coding-string + (encode-coding-string "Käsesoßenrührlöffel" 'utf-8-hfs) + 'utf-8-hfs) + "Käsesoßenrührlöffel")) + (should (equal (match-data t) '(1 3)))) + ;;; ucs-normalize-tests.el ends here diff --git a/test/lisp/isearch-tests.el b/test/lisp/isearch-tests.el index 3f430ab25f7..516077ac1f8 100644 --- a/test/lisp/isearch-tests.el +++ b/test/lisp/isearch-tests.el @@ -4,18 +4,20 @@ ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/jit-lock-tests.el b/test/lisp/jit-lock-tests.el index 445716c14b9..dfa74cf35e7 100644 --- a/test/lisp/jit-lock-tests.el +++ b/test/lisp/jit-lock-tests.el @@ -1,4 +1,4 @@ -;;; jit-lock-tests.el --- tests for jit-lock +;;; jit-lock-tests.el --- tests for jit-lock -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index 05837e83f90..8ac454467d3 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -1,31 +1,38 @@ -;;; json-tests.el --- Test suite for json.el +;;; json-tests.el --- Test suite for json.el -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. ;; Author: Dmitry Gutov <dgutov@yandex.ru> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: (require 'ert) (require 'json) +(require 'map) +(require 'seq) + +(eval-when-compile + (require 'cl-lib)) (defmacro json-tests--with-temp-buffer (content &rest body) "Create a temporary buffer with CONTENT and evaluate BODY there. Point is moved to beginning of the buffer." - (declare (indent 1)) + (declare (debug t) (indent 1)) `(with-temp-buffer (insert ,content) (goto-char (point-min)) @@ -33,66 +40,107 @@ Point is moved to beginning of the buffer." ;;; Utilities -(ert-deftest test-json-join () - (should (equal (json-join '() ", ") "")) - (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) - (ert-deftest test-json-alist-p () (should (json-alist-p '())) - (should (json-alist-p '((a 1) (b 2) (c 3)))) - (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) - (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should (json-alist-p '((())))) + (should (json-alist-p '((a)))) + (should (json-alist-p '((a . 1)))) + (should (json-alist-p '((a . 1) (b 2) (c)))) + (should (json-alist-p '((:a) (:b 2) (:c . 3)))) + (should (json-alist-p '(("a" . 1) ("b" 2) ("c")))) + (should-not (json-alist-p '(()))) + (should-not (json-alist-p '(a))) + (should-not (json-alist-p '(a . 1))) + (should-not (json-alist-p '((a . 1) . []))) + (should-not (json-alist-p '((a . 1) []))) (should-not (json-alist-p '(:a :b :c))) (should-not (json-alist-p '(:a 1 :b 2 :c 3))) - (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + (should-not (json-alist-p '((:a 1) (:b 2) 3))) + (should-not (json-alist-p '((:a 1) (:b 2) ()))) + (should-not (json-alist-p '(((a) 1) (b 2) (c 3)))) + (should-not (json-alist-p [])) + (should-not (json-alist-p [(a . 1)])) + (should-not (json-alist-p #s(hash-table)))) (ert-deftest test-json-plist-p () (should (json-plist-p '())) + (should (json-plist-p '(:a 1))) (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should (json-plist-p '(:a :b))) + (should (json-plist-p '(:a :b :c :d))) + (should-not (json-plist-p '(a))) + (should-not (json-plist-p '(a 1))) (should-not (json-plist-p '(a 1 b 2 c 3))) (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a))) (should-not (json-plist-p '(:a :b :c))) - (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) - -(ert-deftest test-json-plist-reverse () - (should (equal (json--plist-reverse '()) '())) - (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) - (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + (should-not (json-plist-p '(:a 1 :b 2 :c))) + (should-not (json-plist-p '((:a 1)))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3)))) + (should-not (json-plist-p [])) + (should-not (json-plist-p [:a 1])) + (should-not (json-plist-p #s(hash-table)))) + +(ert-deftest test-json-plist-nreverse () + (should (equal (json--plist-nreverse '()) '())) + (should (equal (json--plist-nreverse (list :a 1)) '(:a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2)) '(:b 2 :a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2 :c 3)) '(:c 3 :b 2 :a 1)))) -(ert-deftest test-json-plist-to-alist () - (should (equal (json--plist-to-alist '()) '())) - (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) - (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) - '((:a . 1) (:b . 2) (:c . 3))))) - (ert-deftest test-json-advance () (json-tests--with-temp-buffer "{ \"a\": 1 }" (json-advance 0) - (should (= (point) (point-min))) + (should (bobp)) + (json-advance) + (should (= (point) (1+ (point-min)))) + (json-advance 0) + (should (= (point) (1+ (point-min)))) + (json-advance 1) + (should (= (point) (+ (point-min) 2))) (json-advance 3) - (should (= (point) (+ (point-min) 3))))) + (should (= (point) (+ (point-min) 5))))) (ert-deftest test-json-peek () (json-tests--with-temp-buffer "" (should (zerop (json-peek)))) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-peek) ?{)))) + (should (= (json-peek) ?\{)) + (goto-char (1- (point-max))) + (should (= (json-peek) ?\})) + (json-advance) + (should (zerop (json-peek))))) (ert-deftest test-json-pop () (json-tests--with-temp-buffer "" (should-error (json-pop) :type 'json-end-of-file)) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-pop) ?{)) - (should (= (point) (+ (point-min) 1))))) + (should (= (json-pop) ?\{)) + (should (= (point) (1+ (point-min)))) + (goto-char (1- (point-max))) + (should (= (json-pop) ?\})) + (should-error (json-pop) :type 'json-end-of-file))) (ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "" + (json-skip-whitespace) + (should (bobp)) + (should (eobp))) + (json-tests--with-temp-buffer "{}" + (json-skip-whitespace) + (should (bobp)) + (json-advance) + (json-skip-whitespace) + (should (= (point) (1+ (point-min)))) + (json-advance) + (json-skip-whitespace) + (should (eobp))) (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?\f))) + (should (= (json-peek) ?\f))) (json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?{)))) + (should (= (json-peek) ?\{)))) ;;; Paths @@ -113,59 +161,243 @@ Point is moved to beginning of the buffer." (ert-deftest test-json-path-to-position-no-match () (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") (matched-path (json-path-to-position 5 json-string))) - (should (null matched-path)))) + (should-not matched-path))) ;;; Keywords (ert-deftest test-json-read-keyword () (json-tests--with-temp-buffer "true" - (should (json-read-keyword "true"))) + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true " + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true}" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 4)))) + (json-tests--with-temp-buffer "true false" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true }" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true |" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "false" + (let ((json-false 'false)) + (should (eq (json-read-keyword "false") 'false))) + (should (eobp))) + (json-tests--with-temp-buffer "null" + (let ((json-null 'null)) + (should (eq (json-read-keyword "null") 'null))) + (should (eobp)))) + +(ert-deftest test-json-read-keyword-invalid () + (json-tests--with-temp-buffer "" + (should (equal (should-error (json-read-keyword "")) + '(json-unknown-keyword ""))) + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) (json-tests--with-temp-buffer "true" - (should-error - (json-read-keyword "false") :type 'json-unknown-keyword)) + (should (equal (should-error (json-read-keyword "false")) + '(json-unknown-keyword "true")))) (json-tests--with-temp-buffer "foo" - (should-error - (json-read-keyword "foo") :type 'json-unknown-keyword))) + (should (equal (should-error (json-read-keyword "foo")) + '(json-unknown-keyword "foo"))) + (should (equal (should-error (json-read-keyword "bar")) + '(json-unknown-keyword "bar")))) + (json-tests--with-temp-buffer " true" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) + (json-tests--with-temp-buffer "truefalse" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "truefalse")))) + (json-tests--with-temp-buffer "true|" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "true"))))) (ert-deftest test-json-encode-keyword () (should (equal (json-encode-keyword t) "true")) - (should (equal (json-encode-keyword json-false) "false")) - (should (equal (json-encode-keyword json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode-keyword 'false) "false")) + (should (equal (json-encode-keyword json-false) "false"))) + (let ((json-null 'null)) + (should (equal (json-encode-keyword 'null) "null")) + (should (equal (json-encode-keyword json-null) "null")))) ;;; Numbers -(ert-deftest test-json-read-number () - (json-tests--with-temp-buffer "3" - (should (= (json-read-number) 3))) - (json-tests--with-temp-buffer "-5" - (should (= (json-read-number) -5))) - (json-tests--with-temp-buffer "123.456" - (should (= (json-read-number) 123.456))) - (json-tests--with-temp-buffer "1e3" - (should (= (json-read-number) 1e3))) - (json-tests--with-temp-buffer "2e+3" - (should (= (json-read-number) 2e3))) - (json-tests--with-temp-buffer "3E3" - (should (= (json-read-number) 3e3))) - (json-tests--with-temp-buffer "1e-7" - (should (= (json-read-number) 1e-7))) - (json-tests--with-temp-buffer "abc" - (should-error (json-read-number) :type 'json-number-format))) +(ert-deftest test-json-read-integer () + (json-tests--with-temp-buffer "0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "3 " + (should (= (json-read-number) 3)) + (should (eobp))) + (json-tests--with-temp-buffer "-10 " + (should (= (json-read-number) -10)) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1+ most-positive-fixnum)) + (should (= (json-read-number) (1+ most-positive-fixnum))) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1- most-negative-fixnum)) + (should (= (json-read-number) (1- most-negative-fixnum))) + (should (eobp)))) + +(ert-deftest test-json-read-fraction () + (json-tests--with-temp-buffer "0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.01 " + (should (= (json-read-number) 0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.01 " + (should (= (json-read-number) -0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "123.456 " + (should (= (json-read-number) 123.456)) + (should (eobp))) + (json-tests--with-temp-buffer "-123.456 " + (should (= (json-read-number) -123.456)) + (should (eobp)))) + +(ert-deftest test-json-read-exponent () + (json-tests--with-temp-buffer "0e0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E+0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0e-0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "12e34 " + (should (= (json-read-number) 12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E+34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "12e-34 " + (should (= (json-read-number) 12e-34)) + (should (eobp)))) + +(ert-deftest test-json-read-fraction-exponent () + (json-tests--with-temp-buffer "0.0e0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0E0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.12E-0 " + (should (= (json-read-number) 0.12e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-12.34e+56 " + (should (= (json-read-number) -12.34e+56)) + (should (eobp)))) + +(ert-deftest test-json-read-number-invalid () + (cl-flet ((read (str) + ;; Return error and point resulting from reading STR. + (json-tests--with-temp-buffer str + (cons (should-error (json-read-number)) (point))))) + ;; POS is where each of its STRINGS becomes invalid. + (pcase-dolist (`(,pos . ,strings) + '((1 "" "+" "-" "." "e" "e1" "abc" "++0" "++1" + "+0" "+0.0" "+12" "+12.34" "+12.34e56" + ".0" "+.0" "-.0" ".12" "+.12" "-.12" + ".e0" "+.e0" "-.e0" ".0e0" "+.0e0" "-.0e0") + (2 "01" "1ee1" "1e++1") + (3 "-01") + (4 "0.0.0" "1.1.1" "1e1e1") + (5 "-0.0.0" "-1.1.1"))) + ;; Expected error and point. + (let ((res `((json-number-format ,pos) . ,pos))) + (dolist (str strings) + (should (equal (read str) res))))))) (ert-deftest test-json-encode-number () + (should (equal (json-encode-number 0) "0")) + (should (equal (json-encode-number -0) "0")) (should (equal (json-encode-number 3) "3")) (should (equal (json-encode-number -5) "-5")) - (should (equal (json-encode-number 123.456) "123.456"))) + (should (equal (json-encode-number 123.456) "123.456")) + (let ((bignum (1+ most-positive-fixnum))) + (should (equal (json-encode-number bignum) + (number-to-string bignum))))) -;; Strings +;;; Strings (ert-deftest test-json-read-escaped-char () (json-tests--with-temp-buffer "\\\"" - (should (equal (json-read-escaped-char) ?\")))) + (should (= (json-read-escaped-char) ?\")) + (should (eobp))) + (json-tests--with-temp-buffer "\\\\ " + (should (= (json-read-escaped-char) ?\\)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\b " + (should (= (json-read-escaped-char) ?\b)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\f " + (should (= (json-read-escaped-char) ?\f)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\n " + (should (= (json-read-escaped-char) ?\n)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\r " + (should (= (json-read-escaped-char) ?\r)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\t " + (should (= (json-read-escaped-char) ?\t)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\x " + (should (= (json-read-escaped-char) ?x)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\ud800\\uDC00 " + (should (= (json-read-escaped-char) #x10000)) + (should (= (point) (+ (point-min) 12)))) + (json-tests--with-temp-buffer "\\ud7ff\\udc00 " + (should (= (json-read-escaped-char) #xd7ff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\uffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\ufffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6))))) + +(ert-deftest test-json-read-escaped-char-invalid () + (json-tests--with-temp-buffer "" + (should-error (json-read-escaped-char))) + (json-tests--with-temp-buffer "\\" + (should-error (json-read-escaped-char) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "\\ufff " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2))))) + (json-tests--with-temp-buffer "\\ufffg " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2)))))) (ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "" + (should-error (json-read-string))) (json-tests--with-temp-buffer "\"formfeed\f\"" - (should-error (json-read-string) :type 'json-string-format)) + (should (equal (should-error (json-read-string)) + '(json-string-format ?\f)))) + (json-tests--with-temp-buffer "\"\"" + (should (equal (json-read-string) ""))) (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" (should (equal (json-read-string) "foo \"bar\""))) (json-tests--with-temp-buffer "\"abcαβγ\"" @@ -175,57 +407,117 @@ Point is moved to beginning of the buffer." ;; Bug#24784 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\"" (should (equal (json-read-string) "\U0001D11E"))) + (json-tests--with-temp-buffer "f" + (should-error (json-read-string) :type 'json-end-of-file)) (json-tests--with-temp-buffer "foo" - (should-error (json-read-string) :type 'json-string-format))) + (should-error (json-read-string) :type 'json-end-of-file))) (ert-deftest test-json-encode-string () + (should (equal (json-encode-string "") "\"\"")) + (should (equal (json-encode-string "a") "\"a\"")) (should (equal (json-encode-string "foo") "\"foo\"")) (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) (ert-deftest test-json-encode-key () + (should (equal (json-encode-key "") "\"\"")) + (should (equal (json-encode-key '##) "\"\"")) + (should (equal (json-encode-key :) "\"\"")) (should (equal (json-encode-key "foo") "\"foo\"")) (should (equal (json-encode-key 'foo) "\"foo\"")) (should (equal (json-encode-key :foo) "\"foo\"")) - (should-error (json-encode-key 5) :type 'json-key-format) - (should-error (json-encode-key ["foo"]) :type 'json-key-format) - (should-error (json-encode-key '("foo")) :type 'json-key-format)) + (should (equal (should-error (json-encode-key 5)) + '(json-key-format 5))) + (should (equal (should-error (json-encode-key ["foo"])) + '(json-key-format ["foo"]))) + (should (equal (should-error (json-encode-key '("foo"))) + '(json-key-format ("foo"))))) ;;; Objects (ert-deftest test-json-new-object () (let ((json-object-type 'alist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let ((json-object-type 'plist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let* ((json-object-type 'hash-table) (json-object (json-new-object))) (should (hash-table-p json-object)) - (should (= (hash-table-count json-object) 0)))) + (should (map-empty-p json-object)) + (should (eq (hash-table-test json-object) #'equal)))) -(ert-deftest test-json-add-to-object () +(ert-deftest test-json-add-to-alist () (let* ((json-object-type 'alist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (equal (assq 'a obj) '(a . 1))) - (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (equal (assq 'c obj) '(c . 3))) + (should (equal (assq 'd obj) '(d . 4)))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (equal (assq :e obj) '(:e . 5))) + (should (equal (assq :f obj) '(:f . 6)))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (equal (assoc "g" obj) '("g" . 7))) + (should (equal (assoc "h" obj) '("h" . 8)))))) + +(ert-deftest test-json-add-to-plist () (let* ((json-object-type 'plist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (plist-get obj :a) 1)) - (should (= (plist-get obj :b) 2))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (plist-get obj :c) 3)) + (should (= (plist-get obj :d) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (plist-get obj 'e) 5)) + (should (= (plist-get obj 'f) 6))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (lax-plist-get obj "g") 7)) + (should (= (lax-plist-get obj "h") 8))))) + +(ert-deftest test-json-add-to-hash-table () (let* ((json-object-type 'hash-table) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (gethash "a" obj) 1)) - (should (= (gethash "b" obj) 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (gethash "c" obj) 3)) + (should (= (gethash "d" obj) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (gethash 'e obj) 5)) + (should (= (gethash 'f obj) 6))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (gethash :g obj) 7)) + (should (= (gethash :h obj) 8))))) (ert-deftest test-json-read-object () (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" @@ -238,94 +530,384 @@ Point is moved to beginning of the buffer." (let* ((json-object-type 'hash-table) (hash-table (json-read-object))) (should (= (gethash "a" hash-table) 1)) - (should (= (gethash "b" hash-table) 2)))) + (should (= (gethash "b" hash-table) 2))))) + +(ert-deftest test-json-read-object-empty () + (json-tests--with-temp-buffer "{}" + (let ((json-object-type 'alist)) + (should-not (save-excursion (json-read-object)))) + (let ((json-object-type 'plist)) + (should-not (save-excursion (json-read-object)))) + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (hash-table-p hash-table)) + (should (map-empty-p hash-table))))) + +(ert-deftest test-json-read-object-invalid () + (json-tests--with-temp-buffer "{ \"a\" 1, \"b\": 2 }" + (should (equal (should-error (json-read-object)) + '(json-object-format ":" ?1)))) (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" - (should-error (json-read-object) :type 'json-object-format))) + (should (equal (should-error (json-read-object)) + '(json-object-format "," ?\"))))) + +(ert-deftest test-json-read-object-function () + (let* ((pre nil) + (post nil) + (keys '("b" "a")) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "{ \"b\": 2, \"a\": 1 }" + (json-read-object) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-hash-table () - (let ((hash-table (make-hash-table)) - (json-encoding-object-sort-predicate 'string<) + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (puthash :a 1 hash-table) - (puthash :b 2 hash-table) - (puthash :c 3 hash-table) - (should (equal (json-encode hash-table) - "{\"a\":1,\"b\":2,\"c\":3}")))) - -(ert-deftest json-encode-simple-alist () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode '((a . 1) (b . 2))) - "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist () - (let ((plist '(:a 1 :b 2)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\"a\":1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\"a\":1,\"b\":2,\"c\":3}" + "{\"a\":1,\"c\":3,\"b\":2}" + "{\"b\":2,\"a\":1,\"c\":3}" + "{\"b\":2,\"c\":3,\"a\":1}" + "{\"c\":3,\"a\":1,\"b\":2}" + "{\"c\":3,\"b\":2,\"a\":1}"))))) + +(ert-deftest test-json-encode-hash-table-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1\n}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1\n}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1\n}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))) + +(ert-deftest test-json-encode-hash-table-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))) + +(ert-deftest test-json-encode-hash-table-sort () + (let ((json-encoding-object-sort-predicate #'string<) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist-with-sort-predicate () - (let ((plist '(:c 3 :a 1 :b 2)) - (json-encoding-object-sort-predicate 'string<) + (pcase-dolist (`(,in . ,out) + '((#s(hash-table) . "{}") + (#s(hash-table data (a 1)) . "{\"a\":1}") + (#s(hash-table data (b 2 a 1)) . "{\"a\":1,\"b\":2}") + (#s(hash-table data (c 3 b 2 a 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (map-pairs in))) + (should (equal (json-encode-hash-table in) out)) + ;; Ensure sorting isn't destructive. + (should (seq-set-equal-p (map-pairs in) copy)))))) + +(ert-deftest test-json-encode-alist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-alist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-alist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-alist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + (((a . 1)) . "{\"a\":1}") + (((b . 2) (a . 1)) . "{\"a\":1,\"b\":2}") + (((c . 3) (b . 2) (a . 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-alist in))) + (should (equal (json-encode-alist in) out)) + ;; Ensure sorting isn't destructive (bug#40693). + (should (equal in copy)))))) -(ert-deftest test-json-encode-alist-with-sort-predicate () - (let ((alist '((:c . 3) (:a . 1) (:b . 2))) - (json-encoding-object-sort-predicate 'string<) +(ert-deftest test-json-encode-plist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-plist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-plist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-plist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + ((:a 1) . "{\"a\":1}") + ((:b 2 :a 1) . "{\"a\":1,\"b\":2}") + ((:c 3 :b 2 :a 1) . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-sequence in))) + (should (equal (json-encode-plist in) out)) + ;; Ensure sorting isn't destructive. + (should (equal in copy)))))) (ert-deftest test-json-encode-list () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-list '(:a 1 :b 2)) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '((:a . 1) (:b . 2))) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-list ()) "{}")) + (should (equal (json-encode-list '(a)) "[\"a\"]")) + (should (equal (json-encode-list '(:a)) "[\"a\"]")) + (should (equal (json-encode-list '("a")) "[\"a\"]")) + (should (equal (json-encode-list '(a 1)) "[\"a\",1]")) + (should (equal (json-encode-list '("a" 1)) "[\"a\",1]")) + (should (equal (json-encode-list '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-list '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]")) + (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]")) + (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]")) + (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((:b . 2) (:a . 1))) + "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]")) + (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}")) + (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}")) + (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument) + (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument) + (should (equal (should-error (json-encode-list [])) + '(json-error []))) + (should (equal (should-error (json-encode-list [a])) + '(json-error [a]))))) ;;; Arrays (ert-deftest test-json-read-array () (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[ ]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) [1]))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) [1 2 "a" "b"])))) (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[ ]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) '(1)))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) '(1 2 "a" "b"))))) (json-tests--with-temp-buffer "[1 2]" - (should-error (json-read-array) :type 'json-error))) + (should (equal (should-error (json-read-array)) + '(json-array-format "," ?2))))) + +(ert-deftest test-json-read-array-function () + (let* ((pre nil) + (post nil) + (keys '(0 1)) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "[1, 0]" + (json-read-array) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-array () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-array [1 2 "a" "b"]) - "[1,2,\"a\",\"b\"]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[1]")) + (should (equal (json-encode-array '[1]) "[1]")) + (should (equal (json-encode-array '(2 1)) "[2,1]")) + (should (equal (json-encode-array '[2 1]) "[2,1]")) + (should (equal (json-encode-array '[:b a 2 1]) "[\"b\",\"a\",2,1]")))) + +(ert-deftest test-json-encode-array-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1\n]")) + (should (equal (json-encode-array '[1]) "[\n 1\n]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1\n]")))) + +(ert-deftest test-json-encode-array-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1]")) + (should (equal (json-encode-array '[1]) "[\n 1]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1]")))) ;;; Reader (ert-deftest test-json-read () - (json-tests--with-temp-buffer "{ \"a\": 1 }" - ;; We don't care exactly what the return value is (that is tested - ;; in `test-json-read-object'), but it should parse without error. - (should (json-read))) + (pcase-dolist (`(,fn . ,contents) + '((json-read-string "\"\"" "\"a\"") + (json-read-array "[]" "[1]") + (json-read-object "{}" "{\"a\":1}") + (json-read-keyword "null" "false" "true") + (json-read-number + "-0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))) + (dolist (content contents) + ;; Check that leading whitespace is skipped. + (dolist (str (list content (concat " " content))) + (cl-letf* ((called nil) + ((symbol-function fn) + (lambda (&rest _) (setq called t)))) + (json-tests--with-temp-buffer str + ;; We don't care exactly what the return value is (that is + ;; tested elsewhere), but it should parse without error. + (should (json-read)) + (should called))))))) + +(ert-deftest test-json-read-invalid () (json-tests--with-temp-buffer "" (should-error (json-read) :type 'json-end-of-file)) - (json-tests--with-temp-buffer "xxx" - (let ((err (should-error (json-read) :type 'json-readtable-error))) - (should (equal (cdr err) '(?x)))))) + (json-tests--with-temp-buffer " " + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x)))) + (json-tests--with-temp-buffer " x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x))))) (ert-deftest test-json-read-from-string () - (let ((json-string "{ \"a\": 1 }")) - (json-tests--with-temp-buffer json-string - (should (equal (json-read-from-string json-string) + (dolist (str '("\"\"" "\"a\"" "[]" "[1]" "{}" "{\"a\":1}" + "null" "false" "true" "0" "123")) + (json-tests--with-temp-buffer str + (should (equal (json-read-from-string str) (json-read)))))) -;;; JSON encoder +;;; Encoder (ert-deftest test-json-encode () + (should (equal (json-encode t) "true")) + (let ((json-null 'null)) + (should (equal (json-encode json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode json-false) "false"))) + (should (equal (json-encode "") "\"\"")) (should (equal (json-encode "foo") "\"foo\"")) + (should (equal (json-encode :) "\"\"")) + (should (equal (json-encode :foo) "\"foo\"")) + (should (equal (json-encode '(1)) "[1]")) + (should (equal (json-encode 'foo) "\"foo\"")) + (should (equal (json-encode 0) "0")) + (should (equal (json-encode 123) "123")) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode []) "[]")) + (should (equal (json-encode [1]) "[1]")) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}"))) (with-temp-buffer - (should-error (json-encode (current-buffer)) :type 'json-error))) + (should (equal (should-error (json-encode (current-buffer))) + (list 'json-error (current-buffer)))))) -;;; Pretty-print +;;; Pretty printing & minimizing (defun json-tests-equal-pretty-print (original &optional expected) "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. @@ -351,46 +933,45 @@ nil, ORIGINAL should stay unchanged by pretty-printing." (json-tests-equal-pretty-print "0.123")) (ert-deftest test-json-pretty-print-object () - ;; empty (regression test for bug#24252) - (json-tests-equal-pretty-print - "{}" - "{\n}") - ;; one pair + ;; Empty (regression test for bug#24252). + (json-tests-equal-pretty-print "{}") + ;; One pair. (json-tests-equal-pretty-print "{\"key\":1}" "{\n \"key\": 1\n}") - ;; two pairs + ;; Two pairs. (json-tests-equal-pretty-print "{\"key1\":1,\"key2\":2}" "{\n \"key1\": 1,\n \"key2\": 2\n}") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "{\"foo\":{\"key\":1}}" "{\n \"foo\": {\n \"key\": 1\n }\n}") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "{\"key\":[1,2]}" "{\n \"key\": [\n 1,\n 2\n ]\n}")) (ert-deftest test-json-pretty-print-array () - ;; empty + ;; Empty. (json-tests-equal-pretty-print "[]") - ;; one item + ;; One item. (json-tests-equal-pretty-print "[1]" "[\n 1\n]") - ;; two items + ;; Two items. (json-tests-equal-pretty-print "[1,2]" "[\n 1,\n 2\n]") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "[{\"key\":1}]" "[\n {\n \"key\": 1\n }\n]") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "[[1,2]]" "[\n [\n 1,\n 2\n ]\n]")) (provide 'json-tests) + ;;; json-tests.el ends here diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el index 6c08023d4f3..1ef83daed24 100644 --- a/test/lisp/jsonrpc-tests.el +++ b/test/lisp/jsonrpc-tests.el @@ -5,18 +5,20 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: tests -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -165,7 +167,7 @@ (ert-deftest deferred-action-toolate () :tags '(:expensive-test) - "Deferred request fails because noone clears the flag." + "Deferred request fails because no one clears the flag." (jsonrpc--with-emacsrpc-fixture (conn) (should-error (jsonrpc-request conn '+ [1 2] diff --git a/test/lisp/mail/flow-fill-tests.el b/test/lisp/mail/flow-fill-tests.el index 4d435aeda71..c2e4178b7d4 100644 --- a/test/lisp/mail/flow-fill-tests.el +++ b/test/lisp/mail/flow-fill-tests.el @@ -35,7 +35,8 @@ ">>> unmuzzled ratsbane!\n" ">>>> Henceforth, the coding style is to be strictly \n" ">>>> enforced, including the use of only upper case.\n" - ">>>>> I've noticed a lack of adherence to the coding \n" + ">>>>> I've noticed a lack of adherence to \n" + ">>>>> the coding \n" ">>>>> styles, of late.\n" ">>>>>> Any complaints?\n")) (output diff --git a/test/lisp/mail/footnote-tests.el b/test/lisp/mail/footnote-tests.el index 79f48072391..6594aa2b3e5 100644 --- a/test/lisp/mail/footnote-tests.el +++ b/test/lisp/mail/footnote-tests.el @@ -5,18 +5,20 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/mail/qp-tests.el b/test/lisp/mail/qp-tests.el new file mode 100644 index 00000000000..8d704499334 --- /dev/null +++ b/test/lisp/mail/qp-tests.el @@ -0,0 +1,74 @@ +;;; qp-tests.el --- Tests for qp.el -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'qp) + +;; Quote by Antoine de Saint-Exupéry, Citadelle (1948) +;; from https://en.wikipedia.org/wiki/Quoted-printable +(defvar qp-tests-quote-qp + (concat "J'interdis aux marchands de vanter trop leurs marchandises. Car ils se font =\n" + "vite p=C3=A9dagogues et t'enseignent comme but ce qui n'est par essence qu'=\n" + "un moyen, et te trompant ainsi sur la route =C3=A0 suivre les voil=C3=A0 bi=\n" + "ent=C3=B4t qui te d=C3=A9gradent, car si leur musique est vulgaire ils te f=\n" + "abriquent pour te la vendre une =C3=A2me vulgaire.")) +(defvar qp-tests-quote-utf8 + (concat "J'interdis aux marchands de vanter trop leurs marchandises. Car ils se font " + "vite pédagogues et t'enseignent comme but ce qui n'est par essence qu'" + "un moyen, et te trompant ainsi sur la route à suivre les voilà bi" + "entôt qui te dégradent, car si leur musique est vulgaire ils te f" + "abriquent pour te la vendre une âme vulgaire.")) + +(ert-deftest qp-test--quoted-printable-decode-region () + (with-temp-buffer + (insert qp-tests-quote-qp) + (encode-coding-region (point-min) (point-max) 'utf-8) + (quoted-printable-decode-region (point-min) (point-max) 'utf-8) + (should (equal (buffer-string) qp-tests-quote-utf8)))) + +(ert-deftest qp-test--quoted-printable-decode-string () + (should (equal (quoted-printable-decode-string "foo!") "foo!")) + (should (equal (quoted-printable-decode-string "=0C") "\^L")) + (should (equal (quoted-printable-decode-string "=3D") "=")) + (should (equal (quoted-printable-decode-string "=A1Hola, se=F1or!?") + "\241Hola, se\361or!?"))) + +(ert-deftest qp-test--quoted-printable-encode-region () + (with-temp-buffer + (insert (make-string 26 ?=)) + ;; (encode-coding-region (point-min) (point-max) 'utf-8) + (quoted-printable-encode-region (point-min) (point-max) t) + (should (equal (buffer-string) + (concat "=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D" + "=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=\n=3D"))))) + +(ert-deftest qp-test--quoted-printable-encode-string () + (should (equal (quoted-printable-encode-string "\241Hola, se\361or!?") + "=A1Hola, se=F1or!?")) + ;; Multibyte character. + (should-error (quoted-printable-encode-string "å"))) + +(provide 'qp-tests) +;;; qp-tests.el ends here diff --git a/test/lisp/mail/rfc2045-tests.el b/test/lisp/mail/rfc2045-tests.el new file mode 100644 index 00000000000..edd7a88c69e --- /dev/null +++ b/test/lisp/mail/rfc2045-tests.el @@ -0,0 +1,37 @@ +;;; rfc2045-tests.el --- Tests for rfc2045.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'rfc2045) + +(ert-deftest rfc2045-test-encode-string () + (should (equal (rfc2045-encode-string "foo" "bar") "foo=bar")) + (should (equal (rfc2045-encode-string "foo" "bar-baz") "foo=bar-baz")) + (should (equal (rfc2045-encode-string "foo" "bar baz") "foo=\"bar baz\"")) + (should (equal (rfc2045-encode-string "foo" "bar\tbaz") "foo=\"bar\tbaz\"")) + (should (equal (rfc2045-encode-string "foo" "bar\nbaz") "foo=\"bar\nbaz\""))) + +(provide 'rfc2045-tests) +;;; rfc2045-tests.el ends here diff --git a/test/lisp/mail/rfc2368-tests.el b/test/lisp/mail/rfc2368-tests.el new file mode 100644 index 00000000000..c35b8e33ad5 --- /dev/null +++ b/test/lisp/mail/rfc2368-tests.el @@ -0,0 +1,39 @@ +;;; rfc2368-tests.el --- Tests for rfc2368.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'rfc2368) + +(ert-deftest rfc2368-unhexify-string () + (should (equal (rfc2368-unhexify-string "hello%20there") "hello there"))) + +(ert-deftest rfc2368-parse-mailto-url () + (should (equal (rfc2368-parse-mailto-url "mailto:foo@example.org?subject=Foo&bar=baz") + '(("To" . "foo@example.org") ("Subject" . "Foo") ("Bar" . "baz")))) + (should (equal (rfc2368-parse-mailto-url "mailto:foo@bar.com?to=bar@example.org") + '(("To" . "foo@bar.com, bar@example.org")))) + (should (equal (rfc2368-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz") + '(("To" . "foo@bar.com") ("Subject" . "bar baz"))))) + +(provide 'rfc2368-tests) +;;; rfc2368-tests.el ends here diff --git a/test/lisp/mail/rfc822-tests.el b/test/lisp/mail/rfc822-tests.el new file mode 100644 index 00000000000..d13966c59cc --- /dev/null +++ b/test/lisp/mail/rfc822-tests.el @@ -0,0 +1,83 @@ +;;; rfc822-tests.el --- Tests for rfc822.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'rfc822) + +(defmacro rfc822-tests-deftest (email desc &optional valid) + `(ert-deftest ,(intern (format "rfc822-email-%s-%s" + (if valid "valid" "invalid") + desc)) () + (if ,valid + (should (equal (rfc822-addresses ,email) (list ,email))) + (let ((addresses (rfc822-addresses ,email))) + ;; `rfc822-addresses' returns a string if parsing fails. + (while (and (consp addresses) + (not (eq (string-to-char (car addresses)) ?\())) + (setq addresses (cdr addresses))) + ;; Found saved error. + (should (= (length addresses) 1)))))) + +;;;; Valid emails + +(rfc822-tests-deftest "email@example.org" "email" t) +(rfc822-tests-deftest "firstname.lastname@example.org" "dot-in-address" t) +(rfc822-tests-deftest "email@subdomain.example.org" "dot-in-subdomain" t) +(rfc822-tests-deftest "firstname+lastname@example.org" "contains-plus-sign" t) +(rfc822-tests-deftest "email@123.123.123.123" "domain-valid-ip" t) +(rfc822-tests-deftest "email@[123.123.123.123]" "domain-valid-ip-square-bracket" t) +(rfc822-tests-deftest "\"email\"@example.org" "quotes-around-email" t) +(rfc822-tests-deftest "1234567890@example.org" "digits-in-address" t) +(rfc822-tests-deftest "email@example-one.com" "dash-in-domain-name" t) +(rfc822-tests-deftest "_______@example.org" "underscore-in-address" t) +(rfc822-tests-deftest "email@example.name" "dotname-tld" t) +(rfc822-tests-deftest "email@example.co.jp" "dot-in-tld" t) +(rfc822-tests-deftest "firstname-lastname@example.org" "dash-in-address" t) +(rfc822-tests-deftest "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghiklm@example.org" "address-long" t) + +;;;; Invalid emails + +(rfc822-tests-deftest "#@%^%#$@#$@#.com" "garbage") +(rfc822-tests-deftest "@example.org" "missing-username") +(rfc822-tests-deftest "email@example@example.org" "two-at-signs") +(rfc822-tests-deftest ".email@example.org" "address-leading-dot") +(rfc822-tests-deftest "email.@example.org" "address-trailing-dot") +(rfc822-tests-deftest "email..email@example.org" "address-multiple-dots") +(rfc822-tests-deftest "email@example..org" "domain-multiple-dots") +(rfc822-tests-deftest "email@example.org." "domain-trailing-dot") +(rfc822-tests-deftest "email@.example.org" "domain-leading-dot") +(rfc822-tests-deftest "test\\@test@example.org" "address-escaped-at-sign") + +;; FIXME: Should these fail? +;; (rfc822-tests-deftest "plainaddress" "missing-at-sign-and-domain") +;; (rfc822-tests-deftest "email@example.org (J. Random Hacker)" "text-following-email") +;; (rfc822-tests-deftest "email@-example.org" "leading-dash-in-domain-is-invalid") +;; (rfc822-tests-deftest "email@example-.org" "trailing-dash-in-domain-is-invalid") +;; (rfc822-tests-deftest "あいうえお@example.org" "address-unicode-chars") +;; (rfc822-tests-deftest "email.example.org" "missing-at") +;; (rfc822-tests-deftest "email@111.222.333.44444" "invalid-IP-format") +;; (rfc822-tests-deftest "email@domain" "missing-top-level-domain") +;; (rfc822-tests-deftest "email@domain.web" ".web-is-not-a-valid-top-level-domain") + +(provide 'rfc822-tests) +;;; rfc822-tests.el ends here diff --git a/test/lisp/mail/rmailmm-tests.el b/test/lisp/mail/rmailmm-tests.el new file mode 100644 index 00000000000..645bb96d113 --- /dev/null +++ b/test/lisp/mail/rmailmm-tests.el @@ -0,0 +1,117 @@ +;;; rmailmm-tests.el --- Tests for rmailmm.el -*- lexical-binding:t -*- + +;; Copyright (C) 2006-2020 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: + +;; Converted to ert from previous manual tests. + +;; FIXME: Some of these still lack a condition for success. + +;;; Code: + +(require 'ert) +(require 'rmailmm) + +(ert-deftest rmailmm-test-handler () + "Test of a mail using no MIME parts at all." + (let ((mail "To: alex@gnu.org +Content-Type: text/plain; charset=koi8-r +Content-Transfer-Encoding: 8bit +MIME-Version: 1.0 + +\372\304\322\301\327\323\324\327\325\312\324\305\41") + (correct "To: alex@gnu.org +Content-Type: text/plain; charset=koi8-r +Content-Transfer-Encoding: 8bit +MIME-Version: 1.0 + +Здравствуйте! +")) + (with-temp-buffer + (erase-buffer) + (set-buffer-multibyte nil) + (insert mail) + (rmail-mime-show t) + (set-buffer-multibyte t) + (should (equal (buffer-string) correct))))) + +;;;; FIXME: This doesn't seem to be working. +(ert-deftest rmailmm-test-bulk-handler () + "Test of a mail used as an example in RFC 2183." + :tags '(:unstable) + (let ((mail "Content-Type: image/jpeg +Content-Disposition: attachment; filename=genome.jpeg; + modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\"; +Content-Description: a complete map of the human genome +Content-Transfer-Encoding: base64 + +iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ +TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy ++ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me +WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv +9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L +UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx +lgAAAABJRU5ErkJggg== +")) + (with-temp-buffer + (erase-buffer) + (insert mail) + (rmail-mime-show) + ;; FIXME: What is the condition for success? + ))) + +;; FIXME: Has no condition for success -- see below. +(ert-deftest rmailmm-test-multipart-handler () + "Test of a mail used as an example in RFC 2046." + :tags '(:unstable) + (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com> +To: Ned Freed <ned@innosoft.com> +Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST) +Subject: Sample message +MIME-Version: 1.0 +Content-type: multipart/mixed; boundary=\"simple boundary\" + +This is the preamble. It is to be ignored, though it +is a handy place for composition agents to include an +explanatory note to non-MIME conformant readers. + +--simple boundary + +This is implicitly typed plain US-ASCII text. +It does NOT end with a linebreak. +--simple boundary +Content-type: text/plain; charset=us-ascii + +This is explicitly typed plain US-ASCII text. +It DOES end with a linebreak. + +--simple boundary-- + +This is the epilogue. It is also to be ignored.")) + (switch-to-buffer (get-buffer-create "*test*")) + (erase-buffer) + (insert mail) + (rmail-mime-show t) + ;; FIXME: What is the condition for success? + (should nil) ; expected fail for now + )) + +(provide 'rmailmm-tests) + +;; rmailmm-tests.el ends here diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el index 4c9650f556c..17566250a92 100644 --- a/test/lisp/mail/uudecode-tests.el +++ b/test/lisp/mail/uudecode-tests.el @@ -24,15 +24,9 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'uudecode) -(defvar uudecode-tests-data-dir - (file-truename - (expand-file-name "uudecode-resources/" - (file-name-directory (or load-file-name - buffer-file-name)))) - "Base directory of uudecode-tests.el test data files.") - (defun uudecode-tests-read-file (file) "Read contents of FILE and return as string." (with-temp-buffer @@ -40,13 +34,11 @@ (buffer-string))) (defvar uudecode-tests-encoded-str - (uudecode-tests-read-file - (expand-file-name "uuencoded.txt" uudecode-tests-data-dir)) + (uudecode-tests-read-file (ert-resource-file "uuencoded.txt")) "Uuencoded data for bookmark-tests.el Same as `uudecode-tests-decoded-str' but uuencoded.") (defvar uudecode-tests-decoded-str - (uudecode-tests-read-file - (expand-file-name "uudecoded.txt" uudecode-tests-data-dir)) + (uudecode-tests-read-file (ert-resource-file "uudecoded.txt")) "Plain text data for bookmark-tests.el Same as `uudecode-tests-encoded-str' but plain text.") diff --git a/test/lisp/man-tests.el b/test/lisp/man-tests.el index fba4d748ce1..ddf22ecd404 100644 --- a/test/lisp/man-tests.el +++ b/test/lisp/man-tests.el @@ -1,4 +1,4 @@ -;;; man-tests.el --- Test suite for man. +;;; man-tests.el --- Test suite for man. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ sinl [sin] (3) - sine function" sin(3), sinf(3), sinl(3) - sine functions" . (#("sin(3)" 0 6 (help-echo "sine functions")) #("sinf(3)" 0 7 (help-echo "sine functions")) #("sinl(3)" 0 7 (help-echo "sine functions")))) ;; SunOS, Solaris - ;; http://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html + ;; https://docs.oracle.com/cd/E19455-01/805-6331/usradm-7/index.html ;; SunOS 4 ("\ tset, reset (1) - establish or restore terminal characteristics" @@ -61,7 +61,7 @@ cawf, nroff (1) - C version of the nroff-like, Amazingly Workable (text) Formatt whatis (5) - database of online manual pages" . (#("cawf(1)" 0 7 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("nroff(1)" 0 8 (help-echo "C version of the nroff-like, Amazingly Workable (text) Formatter")) #("whatis(5)" 0 9 (help-echo "database of online manual pages")))) ;; HP-UX - ;; http://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html + ;; https://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/man.1.html ;; Assuming that the line break in the zgrep description was ;; introduced by the man page formatting. ("\ @@ -114,7 +114,7 @@ in the cdr of the element.") (dolist (test man-tests-parse-man-k-tests) (should (man-tests-parse-man-k-test-case test)))) -(defun man-tests-filter-strings (buffer strings) +(defun man-tests-filter-strings (_buffer strings) "Run `Man-bgproc-filter' on each of STRINGS. The formatted result will be inserted into BUFFER." (let ((proc (start-process "dummy man-tests proc" (current-buffer) "cat"))) diff --git a/test/lisp/minibuffer-resources/data/minibuffer-test-cttq$tion b/test/lisp/minibuffer-resources/data/minibuffer-test-cttq$tion new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/minibuffer-resources/data/minibuffer-test-cttq$tion diff --git a/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest-c.test b/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest-c.test new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest-c.test diff --git a/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest.test b/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest.test new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/minibuffer-resources/lisp/cedet/semantic-utest.test diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index f4c840c1171..32734794413 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -5,18 +5,20 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -24,6 +26,9 @@ ;;; Code: +(require 'ert) +(require 'ert-x) + (eval-when-compile (require 'cl-lib)) (ert-deftest completion-test1 () @@ -83,7 +88,7 @@ (ert-deftest completion-table-test-quoting () (let ((process-environment `("CTTQ1=ed" "CTTQ2=et/" ,@process-environment)) - (default-directory (expand-file-name "test" source-directory))) + (default-directory (ert-resource-directory))) (pcase-dolist (`(,input ,output) '( ;; Test that $ in files is properly $$ quoted. diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el new file mode 100644 index 00000000000..fbcbfb7d0cc --- /dev/null +++ b/test/lisp/misc-tests.el @@ -0,0 +1,77 @@ +;;; misc-tests.el --- Tests for misc.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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) + +(defmacro with-misc-test (original result &rest body) + (declare (indent 2)) + `(with-temp-buffer + (insert ,original) + ,@body + (should (equal (buffer-string) ,result)))) + +(ert-deftest misc-test-copy-from-above-command () + (with-misc-test "abc\n" "abc\nabc" + (copy-from-above-command)) + (with-misc-test "abc\n" "abc\nab" + (copy-from-above-command 2))) + +(ert-deftest misc-test-zap-up-to-char () + (with-misc-test "abcde" "cde" + (goto-char (point-min)) + (zap-up-to-char 1 ?c)) + (with-misc-test "abcde abc123" "c123" + (goto-char (point-min)) + (zap-up-to-char 2 ?c))) + +(ert-deftest misc-test-upcase-char () + (with-misc-test "abcde" "aBCDe" + (goto-char (1+ (point-min))) + (upcase-char 3))) + +(ert-deftest misc-test-forward-to-word () + (with-temp-buffer + (insert " - abc") + (goto-char (point-min)) + (forward-to-word 1) + (should (equal (point) 9))) + (with-temp-buffer + (insert "a b c") + (goto-char (point-min)) + (forward-to-word 3) + (should (equal (point) 6)))) + +(ert-deftest misc-test-backward-to-word () + (with-temp-buffer + (insert "abc - ") + (backward-to-word 1) + (should (equal (point) 4))) + (with-temp-buffer + (insert "a b c") + (backward-to-word 3) + (should (equal (point) 1)))) + +(provide 'misc-tests) +;;; misc-tests.el ends here diff --git a/test/lisp/mwheel-tests.el b/test/lisp/mwheel-tests.el new file mode 100644 index 00000000000..315f25edae8 --- /dev/null +++ b/test/lisp/mwheel-tests.el @@ -0,0 +1,46 @@ +;;; mwheel-tests.el --- tests for mwheel.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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 'mwheel) + +(ert-deftest mwheel-test-enable/disable () + (mouse-wheel-mode 1) + (should (eq (lookup-key (current-global-map) `[,mouse-wheel-up-event]) 'mwheel-scroll)) + (mouse-wheel-mode -1) + (should (eq (lookup-key (current-global-map) `[,mouse-wheel-up-event]) nil))) + +(ert-deftest mwheel-test--create-scroll-keys () + (should (equal (mouse-wheel--create-scroll-keys 10 'mouse-4) + '([mouse-4] + [left-margin mouse-4] [right-margin mouse-4] + [left-fringe mouse-4] [right-fringe mouse-4] + [vertical-scroll-bar mouse-4] [horizontal-scroll-bar mouse-4] + [mode-line mouse-4] [header-line mouse-4]))) + ;; Don't bind modifiers outside of buffer area (e.g. for fringes). + (should (equal (mouse-wheel--create-scroll-keys '((shift) . 1) 'mouse-4) + '([(shift mouse-4)]))) + (should (equal (mouse-wheel--create-scroll-keys '((control) . 9) 'mouse-7) + '([(control mouse-7)]))) + (should (equal (mouse-wheel--create-scroll-keys '((meta) . 5) 'mouse-5) + '([(meta mouse-5)])))) + +;;; mwheel-tests.el ends here diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el new file mode 100644 index 00000000000..b2b27d2ae7b --- /dev/null +++ b/test/lisp/net/browse-url-tests.el @@ -0,0 +1,119 @@ +;;; browse-url-tests.el --- Tests for browse-url.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'browse-url) +(require 'ert) + +(ert-deftest browse-url-tests-browser-kind () + (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") + 'internal)) + (should + (eq (browse-url--browser-kind #'browse-url-firefox "gnu.org") + 'external))) + +(ert-deftest browse-url-tests-non-html-file-url-p () + (should (browse-url--non-html-file-url-p "file://foo.txt")) + (should-not (browse-url--non-html-file-url-p "file://foo.html"))) + +(ert-deftest browse-url-tests-select-handler-mailto () + (should (eq (browse-url-select-handler "mailto:foo@bar.org") + 'browse-url--mailto)) + (should (eq (browse-url-select-handler "mailto:foo@bar.org" + 'internal) + 'browse-url--mailto)) + (should-not (browse-url-select-handler "mailto:foo@bar.org" + 'external))) + +(ert-deftest browse-url-tests-select-handler-man () + (should (eq (browse-url-select-handler "man:ls") 'browse-url--man)) + (should (eq (browse-url-select-handler "man:ls" 'internal) + 'browse-url--man)) + (should-not (browse-url-select-handler "man:ls" 'external))) + +(ert-deftest browse-url-tests-select-handler-file () + (should (eq (browse-url-select-handler "file://foo.txt") + 'browse-url-emacs)) + (should (eq (browse-url-select-handler "file://foo.txt" 'internal) + 'browse-url-emacs)) + (should-not (browse-url-select-handler "file://foo.txt" 'external))) + +(ert-deftest browse-url-tests-url-encode-chars () + (should (equal (browse-url-url-encode-chars "foobar" "[ob]") + "f%6F%6F%62ar"))) + +(ert-deftest browse-url-tests-encode-url () + (should (equal (browse-url-encode-url "") "")) + (should (equal (browse-url-encode-url "a b c") "a b c")) + (should (equal (browse-url-encode-url "\"a\" \"b\"") + "\"a%22\"b\"")) + (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) + (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) + +(ert-deftest browse-url-tests-url-at-point () + (with-temp-buffer + (insert "gnu.org") + (should (equal (browse-url-url-at-point) "http://gnu.org")))) + +(ert-deftest browse-url-tests-file-url () + (should (equal (browse-url-file-url "/foo") "file:///foo")) + (should (equal (browse-url-file-url "/foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/ftp@foo:") "ftp://foo/")) + (should (equal (browse-url-file-url "/anonymous@foo:") + "ftp://foo/"))) + +(ert-deftest browse-url-tests-delete-temp-file () + (let ((browse-url-temp-file-name + (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file) + (should-not (file-exists-p browse-url-temp-file-name))) + (let ((file (make-temp-file "browse-url-tests-"))) + (browse-url-delete-temp-file file) + (should-not (file-exists-p file)))) + +(ert-deftest browse-url-tests-add-buttons () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (goto-char (- (point-max) 1)) + (should (eq (get-text-property (point) 'face) + 'browse-url-button)) + (should (get-text-property (point) 'browse-url-data)))) + +(ert-deftest browse-url-tests-button-copy () + (with-temp-buffer + (insert "Visit https://gnu.org") + (goto-char (point-min)) + (browse-url-add-buttons) + (should-error (browse-url-button-copy)) + (goto-char (- (point-max) 1)) + (browse-url-button-copy) + (should (equal (car kill-ring) "https://gnu.org")))) + +(provide 'browse-url-tests) +;;; browse-url-tests.el ends here diff --git a/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml new file mode 100644 index 00000000000..620f10510f2 --- /dev/null +++ b/test/lisp/net/dbus-resources/org.gnu.Emacs.TestDBus.xml @@ -0,0 +1,49 @@ +<?xml version="1.0"?> +<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN" "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"> +<node> + <interface name="org.freedesktop.DBus.Introspectable"> + <method name="Introspect"> + <arg name="xml" type="s" direction="out"/> + </method> + </interface> + <interface name="org.freedesktop.DBus.Properties"> + <method name="Get"> + <arg name="interface" type="s" direction="in"/> + <arg name="name" type="s" direction="in"/> + <arg name="value" type="v" direction="out"/> + </method> + <method name="Set"> + <arg name="interface" type="s" direction="in"/> + <arg name="name" type="s" direction="in"/> + <arg name="value" type="v" direction="in"/> + </method> + <method name="GetAll"> + <arg name="interface" type="s" direction="in"/> + <arg name="properties" type="a{sv}" direction="out"/> + </method> + <signal name="PropertiesChanged"> + <arg name="interface" type="s"/> + <arg name="changed_properties" type="a{sv}"/> + <arg name="invalidated_properties" type="as"/> + </signal> + </interface> + <interface name="org.gnu.Emacs.TestDBus.Interface"> + <method name="Connect"> + <arg name="uuid" type="s" direction="in"/> + <arg name="mode" type="y" direction="in"/> + <arg name="options" type="a{sv}" direction="in"/> + <arg name="interface" type="s" direction="out"/> + </method> + <method name="DeprecatedMethod0"> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </method> + <method name="DeprecatedMethod1"> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </method> + <property name="Connected" type="b" access="read"/> + <property name="Player" type="o" access="read"/> + <annotation name="org.freedesktop.DBus.Deprecated" value="true"/> + </interface> + <node name="node0"/> + <node name="node1"/> +</node> diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 68f69f62b56..3cfb4b7d9e7 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1,40 +1,52 @@ -;;; dbus-tests.el --- Tests of D-Bus integration into Emacs +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; 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. -;; +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: (require 'ert) +(require 'ert-x) (require 'dbus) (defvar dbus-debug nil) (declare-function dbus-get-unique-name "dbusbind.c" (bus)) -(defvar dbus--test-enabled-session-bus +(defconst dbus--test-enabled-session-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :session))) "Check, whether we are registered at the session bus.") -(defvar dbus--test-enabled-system-bus +(defconst dbus--test-enabled-system-bus (and (featurep 'dbusbind) (dbus-ignore-errors (dbus-get-unique-name :system))) "Check, whether we are registered at the system bus.") +(defconst dbus--test-service "org.gnu.Emacs.TestDBus" + "Test service.") + +(defconst dbus--test-path "/org/gnu/Emacs/TestDBus" + "Test object path.") + +(defconst dbus--test-interface "org.gnu.Emacs.TestDBus.Interface" + "Test interface.") + (defun dbus--test-availability (bus) "Test availability of D-Bus BUS." (should (dbus-list-names bus)) @@ -54,6 +66,8 @@ (ert-deftest dbus-test01-type-conversion () "Check type conversion functions." + (skip-unless dbus--test-enabled-session-bus) + (let ((ustr "0123abc_xyz\x01\xff") (mstr "Grüß Göttin")) (should @@ -82,31 +96,391 @@ (string-equal (dbus-unescape-from-identifier (dbus-escape-as-identifier mstr)) mstr)))) +(ert-deftest dbus-test01-basic-types () + "Check basic D-Bus type arguments." + (skip-unless dbus--test-enabled-session-bus) + + ;; No argument or unknown keyword. + (should-error + (dbus-check-arguments :session dbus--test-service) + :type 'wrong-number-of-arguments) + (should-error + (dbus-check-arguments :session dbus--test-service :keyword) + :type 'wrong-type-argument) + + ;; `:string'. + (should (dbus-check-arguments :session dbus--test-service "string")) + (should (dbus-check-arguments :session dbus--test-service :string "string")) + (should-error + (dbus-check-arguments :session dbus--test-service :string) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :string 0.5) + :type 'wrong-type-argument) + + ;; `:object-path'. + (should + (dbus-check-arguments + :session dbus--test-service :object-path "/object/path")) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path "string") + :type 'dbus-error) + (should-error + (dbus-check-arguments :session dbus--test-service :object-path 0.5) + :type 'wrong-type-argument) + + ;; `:signature'. + (should (dbus-check-arguments :session dbus--test-service :signature "as")) + (should-error + (dbus-check-arguments :session dbus--test-service :signature) + :type 'wrong-type-argument) + ;; Raises an error on stderr. + (should-error + (dbus-check-arguments :session dbus--test-service :signature "string") + :type 'dbus-error) + (should-error + (dbus-check-arguments :session dbus--test-service :signature 0.5) + :type 'wrong-type-argument) + + ;; `:boolean'. + (should (dbus-check-arguments :session dbus--test-service nil)) + (should (dbus-check-arguments :session dbus--test-service t)) + (should (dbus-check-arguments :session dbus--test-service :boolean nil)) + (should (dbus-check-arguments :session dbus--test-service :boolean t)) + (should (dbus-check-arguments :session dbus--test-service :boolean 'whatever)) + (should-error + (dbus-check-arguments :session dbus--test-service :boolean) + :type 'wrong-type-argument) + + ;; `:byte'. + (should (dbus-check-arguments :session dbus--test-service :byte 0)) + ;; Only the least significant byte is taken into account. + (should + (dbus-check-arguments :session dbus--test-service :byte most-positive-fixnum)) + (should-error + (dbus-check-arguments :session dbus--test-service :byte) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte -1) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :byte "string") + :type 'wrong-type-argument) + + ;; `:int16'. + (should (dbus-check-arguments :session dbus--test-service :int16 0)) + (should (dbus-check-arguments :session dbus--test-service :int16 #x7fff)) + (should (dbus-check-arguments :session dbus--test-service :int16 #x-8000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int16) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 #x8000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 #x-8001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int16 "string") + :type 'wrong-type-argument) + + ;; `:uint16'. + (should (dbus-check-arguments :session dbus--test-service :uint16 0)) + (should (dbus-check-arguments :session dbus--test-service :uint16 #xffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 #x10000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 -1) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 0.5) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint16 "string") + :type 'wrong-type-argument) + + ;; `:int32'. + (should (dbus-check-arguments :session dbus--test-service :int32 0)) + (should (dbus-check-arguments :session dbus--test-service :int32 #x7fffffff)) + (should (dbus-check-arguments :session dbus--test-service :int32 #x-80000000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int32) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 #x80000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 #x-80000001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int32 "string") + :type 'wrong-type-argument) + + ;; `:uint32'. + (should (dbus-check-arguments :session dbus--test-service 0)) + (should (dbus-check-arguments :session dbus--test-service :uint32 0)) + (should (dbus-check-arguments :session dbus--test-service :uint32 #xffffffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 #x100000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint32 "string") + :type 'wrong-type-argument) + + ;; `:int64'. + (should (dbus-check-arguments :session dbus--test-service :int64 0)) + (should + (dbus-check-arguments :session dbus--test-service :int64 #x7fffffffffffffff)) + (should + (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000000)) + (should-error + (dbus-check-arguments :session dbus--test-service :int64) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 #x8000000000000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 #x-8000000000000001) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :int64 "string") + :type 'wrong-type-argument) + + ;; `:uint64'. + (should (dbus-check-arguments :session dbus--test-service :uint64 0)) + (should + (dbus-check-arguments :session dbus--test-service :uint64 #xffffffffffffffff)) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 #x10000000000000000) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :uint64 "string") + :type 'wrong-type-argument) + + ;; `:double'. + (should (dbus-check-arguments :session dbus--test-service :double 0)) + (should (dbus-check-arguments :session dbus--test-service :double 0.5)) + (should (dbus-check-arguments :session dbus--test-service :double -0.5)) + (should (dbus-check-arguments :session dbus--test-service :double -1)) + ;; Shall both be supported? + (should (dbus-check-arguments :session dbus--test-service :double 1.0e+INF)) + (should (dbus-check-arguments :session dbus--test-service :double 0.0e+NaN)) + (should-error + (dbus-check-arguments :session dbus--test-service :double) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :double "string") + :type 'wrong-type-argument) + + ;; `:unix-fd'. UNIX file descriptors are transferred out-of-band. + ;; We do not support this, and so we cannot do much testing here for + ;; `:unix-fd' being an argument (which is an index to the file + ;; descriptor in the array of file descriptors that accompany the + ;; D-Bus message). Mainly testing, that values out of `:uint32' + ;; type range fail. + (should (dbus-check-arguments :session dbus--test-service :unix-fd 0)) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd -1) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd 0.5) + :type 'args-out-of-range) + (should-error + (dbus-check-arguments :session dbus--test-service :unix-fd "string") + :type 'wrong-type-argument)) + +(ert-deftest dbus-test01-compound-types () + "Check basic D-Bus type arguments." + (skip-unless dbus--test-enabled-session-bus) + + ;; `:array'. It contains several elements of the same type. + (should (dbus-check-arguments :session dbus--test-service '("string"))) + (should (dbus-check-arguments :session dbus--test-service '(:array "string"))) + (should + (dbus-check-arguments :session dbus--test-service '(:array :string "string"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:array :string "string1" "string2"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:array :signature "s" :signature "ao"))) + ;; Empty array (of strings). + (should (dbus-check-arguments :session dbus--test-service '(:array))) + ;; Empty array (of object paths). + (should + (dbus-check-arguments :session dbus--test-service '(:array :signature "o"))) + ;; Different element types. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array :string "string" :object-path "/object/path")) + :type 'wrong-type-argument) + ;; Different variant types in array don't matter. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array + (:variant :string "string1") + (:variant (:struct :string "string2" :object-path "/object/path"))))) + + ;; `:variant'. It contains exactly one element. + (should + (dbus-check-arguments + :session dbus--test-service '(:variant :string "string"))) + (should + (dbus-check-arguments + :session dbus--test-service '(:variant (:array "string")))) + ;; Empty variant. + (should-error + (dbus-check-arguments :session dbus--test-service '(:variant)) + :type 'wrong-type-argument) + ;; More than one element. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:variant :string "string" :object-path "/object/path")) + :type 'wrong-type-argument) + + ;; `:dict-entry'. It must contain two elements; the first one must + ;; be of a basic type. It must be an element of an array. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry :string "string" :boolean nil)))) + ;; This is an alternative syntax. + (should + (dbus-check-arguments + :session dbus--test-service + '(:array :dict-entry (:string "string" :boolean t)))) + ;; Empty dict-entry. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry))) + :type 'wrong-type-argument) + ;; One element. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:array (:dict-entry :string "string"))) + :type 'wrong-type-argument) + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry :string "string" :boolean t :boolean t))) + :type 'wrong-type-argument) + ;; The first element ist not of a basic type. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array (:dict-entry (:array :string "string") :boolean t))) + :type 'wrong-type-argument) + ;; It is not an element of an array. + (should-error + (dbus-check-arguments + :session dbus--test-service '(:dict-entry :string "string" :boolean t)) + :type 'wrong-type-argument) + ;; Different dict entry types in array. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array + (:dict-entry :string "string1" :boolean t) + (:dict-entry :string "string2" :object-path "/object/path"))) + :type 'wrong-type-argument) + + ;; `:struct'. There is no restriction what could be an element of a struct. + (should + (dbus-check-arguments + :session dbus--test-service + '(:struct + :string "string" + :object-path "/object/path" + (:variant (:array :unix-fd 1 :unix-fd 2 :unix-fd 3 :unix-fd 4))))) + ;; Empty struct. + (should-error + (dbus-check-arguments :session dbus--test-service '(:struct)) + :type 'wrong-type-argument) + ;; Different struct types in array. + (should-error + (dbus-check-arguments + :session dbus--test-service + '(:array + (:struct :string "string1" :boolean t) + (:struct :object-path "/object/path"))) + :type 'wrong-type-argument)) + (defun dbus--test-register-service (bus) "Check service registration at BUS." ;; Cleanup. - (dbus-ignore-errors (dbus-unregister-service bus dbus-service-emacs)) + (dbus-ignore-errors (dbus-unregister-service bus dbus--test-service)) ;; Register an own service. - (should (eq (dbus-register-service bus dbus-service-emacs) :primary-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-register-service bus dbus-service-emacs) :already-owner)) - (should (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :primary-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-register-service bus dbus--test-service) :already-owner)) + (should (member dbus--test-service (dbus-list-known-names bus))) ;; Unregister the service. - (should (eq (dbus-unregister-service bus dbus-service-emacs) :released)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) - (should (eq (dbus-unregister-service bus dbus-service-emacs) :non-existent)) - (should-not (member dbus-service-emacs (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :released)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) + (should (eq (dbus-unregister-service bus dbus--test-service) :non-existent)) + (should-not (member dbus--test-service (dbus-list-known-names bus))) ;; `dbus-service-dbus' is reserved for the BUS itself. - (should-error (dbus-register-service bus dbus-service-dbus)) - (should-error (dbus-unregister-service bus dbus-service-dbus))) + (should + (equal + (butlast + (should-error (dbus-register-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args))) + (should + (equal + (butlast + (should-error (dbus-unregister-service bus dbus-service-dbus))) + `(dbus-error ,dbus-error-invalid-args)))) (ert-deftest dbus-test02-register-service-session () "Check service registration at `:session' bus." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs))) + (dbus-register-service :session dbus--test-service))) (dbus--test-register-service :session) (let ((service "org.freedesktop.Notifications")) @@ -124,7 +498,7 @@ (ert-deftest dbus-test02-register-service-system () "Check service registration at `:system' bus." (skip-unless (and dbus--test-enabled-system-bus - (dbus-register-service :system dbus-service-emacs))) + (dbus-register-service :system dbus--test-service))) (dbus--test-register-service :system)) (ert-deftest dbus-test02-register-service-own-bus () @@ -148,7 +522,7 @@ This includes initialization and closing the bus." (featurep 'dbusbind) (dbus-init-bus bus) (dbus-get-unique-name bus) - (dbus-register-service bus dbus-service-emacs)))) + (dbus-register-service bus dbus--test-service)))) ;; Run the test. (dbus--test-register-service bus)) @@ -159,25 +533,1472 @@ This includes initialization and closing the bus." "Check `dbus-interface-peer' methods." (skip-unless (and dbus--test-enabled-session-bus - (dbus-register-service :session dbus-service-emacs) + (dbus-register-service :session dbus--test-service) ;; "GetMachineId" is not implemented (yet). When it returns a ;; value, another D-Bus client like dbus-monitor is reacting ;; on `dbus-interface-peer'. We cannot test then. (not (dbus-ignore-errors (dbus-call-method - :session dbus-service-emacs dbus-path-dbus + :session dbus--test-service dbus-path-dbus dbus-interface-peer "GetMachineId" :timeout 100))))) - (should (dbus-ping :session dbus-service-emacs 100)) - (dbus-unregister-service :session dbus-service-emacs) - (should-not (dbus-ping :session dbus-service-emacs 100))) + (should (dbus-ping :session dbus--test-service 100)) + (dbus-unregister-service :session dbus--test-service) + (should-not (dbus-ping :session dbus--test-service 100))) + +(defun dbus--test-method-handler (&rest args) + "Method handler for `dbus-test04-register-method'." + (cond + ;; No argument. + ((null args) + :ignore) + ;; One argument. + ((= 1 (length args)) + (car args)) + ;; Two arguments. + ((= 2 (length args)) + `(:error ,dbus-error-invalid-args + ,(format-message "Wrong arguments %s" args))) + ;; More than two arguments. + (t (signal 'dbus-error (cons "D-Bus signal" args))))) + +(ert-deftest dbus-test04-register-method () + "Check method registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((method1 "Method1") + (method2 "Method2") + (handler #'dbus--test-method-handler) + registered) + + ;; The service is not registered yet. + (should + (equal + (butlast + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 :timeout 10 "foo"))) + `(dbus-error ,dbus-error-service-unknown))) + + ;; Register. + (should + (equal + (setq + registered + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 handler)) + `((:method :session ,dbus--test-interface ,method1) + (,dbus--test-service ,dbus--test-path ,handler)))) + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method2 handler) + `((:method :session ,dbus--test-interface ,method2) + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; No argument, returns nil. + (should-not + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1)) + ;; One argument, returns the argument. + (should + (string-equal + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo") + "foo")) + ;; Two arguments, D-Bus error activated as `(:error ...)' list. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo" "bar")) + `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) + ;; Three arguments, D-Bus error activated by `dbus-error' signal. + (should + (equal + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 "foo" "bar" "baz")) + `(dbus-error + ,dbus-error-failed + "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))) + + ;; Unregister method. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + (should + (equal + (butlast + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method1 :timeout 10 "foo"))) + `(dbus-error ,dbus-error-no-reply)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defun dbus--test-method-reentry-handler (&rest _args) + "Method handler for `dbus-test04-method-reentry'." + (dbus-get-all-managed-objects :session dbus--test-service dbus--test-path) + 42) + +(ert-deftest dbus-test04-method-reentry () + "Check receiving method call while awaiting response. +Ensure that incoming method calls are handled when call to `dbus-call-method' +is in progress." + :tags '(:expensive-test) + ;; Simulate application registration. (Bug#43251) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((method "Reentry")) + (should + (equal + (dbus-register-method + :session dbus--test-service dbus--test-path + dbus--test-interface method #'dbus--test-method-reentry-handler) + `((:method :session ,dbus--test-interface ,method) + (,dbus--test-service ,dbus--test-path + dbus--test-method-reentry-handler)))) + + (should + (= + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus--test-interface method) + 42))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test04-call-method-timeout () + "Verify `dbus-call-method' request timeout." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + ;; Test timeout override for method call. + (should-error + (dbus-call-method + :session dbus--test-service dbus--test-path + dbus-interface-introspectable "Introspect" :timeout 2500) + :type 'dbus-error) + + (should + (< 2.4 (float-time (time-since start)) 2.7))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defvar dbus--test-signal-received nil + "Received signal value in `dbus--test-signal-handler'.") + +(defun dbus--test-signal-handler (&rest args) + "Signal handler for `dbus-test*-signal' and `dbus-test08-register-monitor'." + (setq dbus--test-signal-received args)) + +(defun dbus--test-timeout-handler (&rest _ignore) + "Timeout handler, reporting a failed test." + (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) + +(ert-deftest dbus-test05-register-signal () + "Check signal registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((member "Member") + (handler #'dbus--test-signal-handler) + registered) + + ;; Register signal handler. + (should + (equal + (setq + registered + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member handler)) + `((:signal :session ,dbus--test-interface ,member) + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; Send one argument, basic type. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should (equal dbus--test-signal-received '("foo"))) + + ;; Send two arguments, compound types. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface member + '(:array :byte 1 :byte 2 :byte 3) '(:variant :string "bar")) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should (equal dbus--test-signal-received '((1 2 3) ("bar")))) + + ;; Unregister signal. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test06-register-property () + "Check property registration for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property1 "Property1") + (property2 "Property2") + (property3 "Property3") + (property4 "Property4") + registered) + + ;; `:read' property. + (should + (equal + (setq + registered + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 :read "foo")) + `((:property :session ,dbus--test-interface ,property1) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + ;; Due to `:read' access type, we don't get a proper reply + ;; from `dbus-set-property'. + (should + (equal + (butlast + (should-error + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 "foofoo"))) + `(dbus-error ,dbus-error-property-read-only))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + + ;; `:write' property. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 :write "bar") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,dbus--test-path)))) + ;; Due to `:write' access type, we don't get a proper reply + ;; from `dbus-get-property'. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2))) + `(dbus-error ,dbus-error-access-denied))) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 "barbar") + "barbar")) + ;; Still `:write' access type. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2))) + `(dbus-error ,dbus-error-access-denied))) + + ;; `:readwrite' property, typed value (Bug#43252). + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 :readwrite :object-path "/baz") + `((:property :session ,dbus--test-interface ,property3) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "/baz")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3 :object-path "/baz/baz") + "/baz/baz")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property3) + "/baz/baz")) + + ;; Not registered property. + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property4))) + `(dbus-error ,dbus-error-unknown-property))) + (should + (equal + (butlast + (should-error + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property4 "foobarbaz"))) + `(dbus-error ,dbus-error-unknown-property))) + + ;; `dbus-get-all-properties'. We cannot retrieve a value for + ;; the property with `:write' access type. + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (string-equal (cdr (assoc property1 result)) "foo")) + (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) + (should-not (assoc property2 result))) + + ;; `dbus-get-all-managed-objects'. We cannot retrieve a value for + ;; the property with `:write' access type. + (let ((result + (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path))) + (should (setq result (cadr (assoc dbus--test-path result)))) + (should (setq result (cadr (assoc dbus--test-interface result)))) + (should (string-equal (cdr (assoc property1 result)) "foo")) + (should (string-equal (cdr (assoc property3 result)) "/baz/baz")) + (should-not (assoc property2 result))) + + ;; Unregister property. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + (should + (equal + (butlast + (should-error + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1))) + `(dbus-error ,dbus-error-unknown-property)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +;; The following test is inspired by Bug#43146. +(ert-deftest dbus-test06-register-property-several-paths () + "Check property registration for an own service at several paths." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property1 "Property1") + (property2 "Property2") + (property3 "Property3")) + + ;; First path. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 :readwrite "foo") + `((:property :session ,dbus--test-interface ,property1) + (,dbus--test-service ,dbus--test-path)))) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 :readwrite "bar") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,dbus--test-path)))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2) + "bar")) + + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1 "foofoo") + "foofoo")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2 "barbar") + "barbar")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property1) + "foofoo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property2) + "barbar")) + + ;; Second path. + (should + (equal + (dbus-register-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2 :readwrite "foo") + `((:property :session ,dbus--test-interface ,property2) + (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) + (should + (equal + (dbus-register-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3 :readwrite "bar") + `((:property :session ,dbus--test-interface ,property3) + (,dbus--test-service ,(concat dbus--test-path dbus--test-path))))) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2) + "foo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3) + "bar")) + + (should + (string-equal + (dbus-set-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2 "foofoo") + "foofoo")) + (should + (string-equal + (dbus-set-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3 "barbar") + "barbar")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property2) + "foofoo")) + (should + (string-equal + (dbus-get-property + :session dbus--test-service (concat dbus--test-path dbus--test-path) + dbus--test-interface property3) + "barbar")) + + ;; Everything is still fine, tested with `dbus-get-all-properties'. + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should (string-equal (cdr (assoc property1 result)) "foofoo")) + (should (string-equal (cdr (assoc property2 result)) "barbar")) + (should-not (assoc property3 result))) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service + (concat dbus--test-path dbus--test-path) dbus--test-interface))) + (should (string-equal (cdr (assoc property2 result)) "foofoo")) + (should (string-equal (cdr (assoc property3 result)) "barbar")) + (should-not (assoc property1 result))) + + ;; Final check with `dbus-get-all-managed-objects'. + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (string-equal (cdr (assoc property1 result1)) "foofoo")) + (should (string-equal (cdr (assoc property2 result1)) "barbar")) + (should-not (assoc property3 result1)) + + (should + (setq + result1 + (cadr (assoc (concat dbus--test-path dbus--test-path) result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (string-equal (cdr (assoc property2 result1)) "foofoo")) + (should (string-equal (cdr (assoc property3 result1)) "barbar")) + (should-not (assoc property1 result1)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test06-register-property-emits-signal () + "Check property registration for an own service, including signalling." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + + (unwind-protect + (let ((property "Property") + (handler #'dbus--test-signal-handler)) + + ;; Register signal handler. + (should + (equal + (dbus-register-signal + :session dbus--test-service dbus--test-path + dbus-interface-properties "PropertiesChanged" handler) + `((:signal :session ,dbus-interface-properties "PropertiesChanged") + (,dbus--test-service ,dbus--test-path ,handler)))) + + ;; Register property. + (setq dbus--test-signal-received nil) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path + dbus--test-interface property :readwrite "foo" 'emits-signal) + `((:property :session ,dbus--test-interface ,property) + (,dbus--test-service ,dbus--test-path)))) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + ;; It returns three arguments, "interface" (a string), + ;; "changed_properties" (an array of dict entries) and + ;; "invalidated_properties" (an array of strings). + (should + (equal dbus--test-signal-received + `(,dbus--test-interface ((,property ("foo"))) ()))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property) + "foo")) + + ;; Set property. The new value shall be signalled. + (setq dbus--test-signal-received nil) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path + dbus--test-interface property + '(:array :byte 1 :byte 2 :byte 3)) + '(1 2 3))) + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should + (equal + dbus--test-signal-received + `(,dbus--test-interface ((,property ((1 2 3)))) ()))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface property) + '(1 2 3)))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defsubst dbus--test-run-property-test (selector name value expected) + "Generate a property test: register, set, get, getall sequence. +This is a helper function for the macro `dbus--test-property'. +The argument SELECTOR indicates whether the test should expand to +`dbus-register-property' (if SELECTOR is `register') or +`dbus-set-property' (if SELECTOR is `set'). +The argument NAME is the property name. +The argument VALUE is the value to register or set. +The argument EXPECTED is a transformed VALUE representing the +form `dbus-get-property' should return." + (cond + ((eq selector 'register) + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface name + :readwrite value) + `((:property :session ,dbus--test-interface ,name) + (,dbus--test-service ,dbus--test-path))))) + + ((eq selector 'set) + (should + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface name + value) + expected))) + + (t (signal 'wrong-type-argument "Selector should be 'register or 'set."))) + + (should + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface name) + expected)) + + (let ((result + (dbus-get-all-properties + :session dbus--test-service dbus--test-path dbus--test-interface))) + (should (equal (cdr (assoc name result)) expected))) + + (let ((result + (dbus-get-all-managed-objects :session dbus--test-service "/")) + result1) + (should (setq result1 (cadr (assoc dbus--test-path result)))) + (should (setq result1 (cadr (assoc dbus--test-interface result1)))) + (should (equal (cdr (assoc name result1)) expected)))) + +(defsubst dbus--test-property (name &rest value-list) + "Test a D-Bus property named by string argument NAME. +The argument VALUE-LIST is a sequence of pairs, where each pair +represents a value form and an expected returned value form. The +first pair in VALUES is used for `dbus-register-property'. +Subsequent pairs of the list are tested with `dbus-set-property'." + (let ((values (car value-list))) + (dbus--test-run-property-test + 'register name (car values) (cdr values))) + (dolist (values (cdr value-list)) + (dbus--test-run-property-test + 'set name (car values) (cdr values)))) + +(ert-deftest dbus-test06-property-types () + "Check property access and mutation for an own service." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (progn + (dbus--test-property + "ByteArray" + '((:array :byte 1 :byte 2 :byte 3) . (1 2 3)) + '((:array :byte 4 :byte 5 :byte 6) . (4 5 6))) + + (dbus--test-property + "StringArray" + '((:array "one" "two" :string "three") . ("one" "two" "three")) + '((:array :string "four" :string "five" "six") . ("four" "five" "six"))) + + (dbus--test-property + "ObjectArray" + '((:array + :object-path "/node00" + :object-path "/node01" + :object-path "/node0/node02") + . ("/node00" "/node01" "/node0/node02")) + '((:array + :object-path "/node10" + :object-path "/node11" + :object-path "/node0/node12") + . ("/node10" "/node11" "/node0/node12"))) + + (dbus--test-property + "Dictionary" + '((:array + :dict-entry (:string "four" (:variant :string "value of four")) + :dict-entry ("five" (:variant :object-path "/node0")) + :dict-entry ("six" (:variant (:array :byte 4 :byte 5 :byte 6)))) + . (("four" + ("value of four")) + ("five" + ("/node0")) + ("six" + ((4 5 6))))) + '((:array + :dict-entry + (:string "key0" (:variant (:array :byte 7 :byte 8 :byte 9))) + :dict-entry ("key1" (:variant :string "value")) + :dict-entry ("key2" (:variant :object-path "/node0/node1"))) + . (("key0" + ((7 8 9))) + ("key1" + ("value")) + ("key2" + ("/node0/node1"))))) + + (dbus--test-property ; Syntax emphasizing :dict compound type. + "Dictionary" + '((:array + (:dict-entry :string "seven" (:variant :string "value of seven")) + (:dict-entry "eight" (:variant :object-path "/node8")) + (:dict-entry "nine" (:variant (:array :byte 9 :byte 27 :byte 81)))) + . (("seven" + ("value of seven")) + ("eight" + ("/node8")) + ("nine" + ((9 27 81))))) + '((:array + (:dict-entry + :string "key4" (:variant (:array :byte 7 :byte 49 :byte 125))) + (:dict-entry "key5" (:variant :string "obsolete")) + (:dict-entry "key6" (:variant :object-path "/node6/node7"))) + . (("key4" + ((7 49 125))) + ("key5" + ("obsolete")) + ("key6" + ("/node6/node7"))))) + + (dbus--test-property + "ByteDictionary" + '((:array + (:dict-entry :byte 8 (:variant :string "byte-eight")) + (:dict-entry :byte 16 (:variant :object-path "/byte/sixteen")) + (:dict-entry :byte 48 (:variant (:array :byte 8 :byte 9 :byte 10)))) + . (( 8 ("byte-eight")) + (16 ("/byte/sixteen")) + (48 ((8 9 10)))))) + + (dbus--test-property + "Variant" + '((:variant "Variant string") . ("Variant string")) + '((:variant :byte 42) . (42)) + '((:variant :uint32 1000000) . (1000000)) + '((:variant :object-path "/variant/path") . ("/variant/path")) + '((:variant :signature "a{sa{sv}}") . ("a{sa{sv}}")) + '((:variant + (:struct + 42 "string" (:object-path "/structure/path") (:variant "last"))) + . ((42 "string" ("/structure/path") ("last"))))) + + ;; Test that :read prevents writes. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" :read '(:array "one" "two" :string "three")) + `((:property :session ,dbus--test-interface "StringArray") + (,dbus--test-service ,dbus--test-path)))) + + (should-error ; Cannot set property with :read access. + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray" '(:array "seven" "eight" :string "nine")) + :type 'dbus-error) + + (should ; Property value preserved on error. + (equal + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "StringArray") + '("one" "two" "three"))) + + ;; Test mismatched types in array. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "MixedArray" :readwrite + '(:array + :object-path "/node00" + :string "/node01" + :object-path "/node0/node02")) + :type 'wrong-type-argument) + + ;; Test in-range integer values. + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :readwrite :byte 255) + `((:property :session ,dbus--test-interface "ByteValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 255)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32767) + `((:property :session ,dbus--test-interface "ShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue") + 32767)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65535) + `((:property :session ,dbus--test-interface "UShortValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue") + 65535)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483647) + `((:property :session ,dbus--test-interface "IntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path + dbus--test-interface "IntValue") + 2147483647)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967295) + `((:property :session ,dbus--test-interface "UIntValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue") + 4294967295)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775807) + `((:property :session ,dbus--test-interface "LongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue") + 9223372036854775807)) + + (should + (equal + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551615) + `((:property :session ,dbus--test-interface "ULongValue") + (,dbus--test-service ,dbus--test-path)))) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue") + 18446744073709551615)) + + ;; Test integer overflow. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :byte 520) + 8)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 8)) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ShortValue" :readwrite :int16 32800) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UShortValue" :readwrite :uint16 65600) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "IntValue" :readwrite :int32 2147483700) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "UIntValue" :readwrite :uint32 4294967300) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "LongValue" :readwrite :int64 9223372036854775900) + :type 'args-out-of-range) + + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ULongValue" :readwrite :uint64 18446744073709551700) + :type 'args-out-of-range) + + ;; dbus-set-property may change property type. + (should + (= + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" 1024) + 1024)) + + (should + (= + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + 1024)) + + (should ; Another change property type test. + (equal + (dbus-set-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue" :boolean t) + t)) + + (should + (eq + (dbus-get-property + :session dbus--test-service dbus--test-path dbus--test-interface + "ByteValue") + t)) + + ;; Test invalid type specification. + (should-error + (dbus-register-property + :session dbus--test-service dbus--test-path dbus--test-interface + "InvalidType" :readwrite :keyword 128) + :type 'wrong-type-argument)) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(defun dbus--test-introspect () + "Return test introspection string." + (when (string-equal dbus--test-path (dbus-event-path-name last-input-event)) + (with-temp-buffer + (insert-file-contents-literally + (ert-resource-file "org.gnu.Emacs.TestDBus.xml")) + (buffer-string)))) + +(defsubst dbus--test-validate-interface + (iface-name expected-properties expected-methods expected-signals + expected-annotations) + "Validate an interface definition for `dbus-test07-introspection'. +The argument IFACE-NAME is a string naming the interface to validate. +The arguments EXPECTED-PROPERTIES, EXPECTED-METHODS, EXPECTED-SIGNALS, and +EXPECTED-ANNOTATIONS represent the names of the interface's properties, +methods, signals, and annotations, respectively." + + (let ((interface + (dbus-introspect-get-interface + :session dbus--test-service dbus--test-path iface-name))) + (pcase-let ((`(interface ((name . ,name)) . ,rest) interface)) + (should + (string-equal name iface-name)) + (should + (string-equal name (dbus-introspect-get-attribute interface "name"))) + + (let (properties methods signals annotations) + (mapc (lambda (x) + (let ((name (dbus-introspect-get-attribute x "name"))) + (cond + ((eq 'property (car x)) (push name properties)) + ((eq 'method (car x)) (push name methods)) + ((eq 'signal (car x)) (push name signals)) + ((eq 'annotation (car x)) (push name annotations))))) + rest) + + (should + (equal + (nreverse properties) + expected-properties)) + (should + (equal + (nreverse methods) + expected-methods)) + (should + (equal + (nreverse signals) + expected-signals)) + (should + (equal + (nreverse annotations) + expected-annotations)))))) + +(defsubst dbus--test-validate-annotations (annotations expected-annotations) + "Validate a list of D-Bus ANNOTATIONS. +Ensure each string in EXPECTED-ANNOTATIONS names an element of ANNOTATIONS. +And ensure each ANNOTATIONS has a value attribute marked \"true\"." + (mapc + (lambda (annotation) + (let ((name (dbus-introspect-get-attribute annotation "name")) + (value (dbus-introspect-get-attribute annotation "value"))) + (should + (member name expected-annotations)) + (should + (equal value "true")))) + annotations)) + +(defsubst dbus--test-validate-property + (interface property-name _expected-annotations &rest expected-args) + "Validate a property definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning PROPERTY-NAME. +The argument PROPERTY-NAME is a string naming the property to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for the property." + (let* ((property + (dbus-introspect-get-property + :session dbus--test-service dbus--test-path interface property-name)) + (name (dbus-introspect-get-attribute property "name")) + (type (dbus-introspect-get-attribute property "type")) + (access (dbus-introspect-get-attribute property "access")) + (expected (assoc-string name expected-args))) + (should expected) + + (should + (string-equal name property-name)) + + (should + (string-equal + (nth 0 expected) + name)) + + (should + (string-equal + (nth 1 expected) + type)) + + (should + (string-equal + (nth 2 expected) + access)))) + +(defsubst dbus--test-validate-m-or-s (tree expected-annotations expected-args) + "Validate a method or signal definition for `dbus-test07-introspection'. +The argument TREE is an sexp returned from either `dbus-introspect-get-method' +or `dbus-introspect-get-signal' +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method or signal. +The argument EXPECTED-ARGS is a list of expected arguments for +the method or signal." + (let (args annotations) + (mapc (lambda (elem) + (cond + ((eq 'arg (car elem)) (push elem args)) + ((eq 'annotation (car elem)) (push elem annotations)))) + tree) + (should + (equal + (nreverse args) + expected-args)) + (dbus--test-validate-annotations annotations expected-annotations))) + +(defsubst dbus--test-validate-signal + (interface signal-name expected-annotations &rest expected-args) + "Validate a signal definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning SIGNAL-NAME. +The argument SIGNAL-NAME is a string naming the signal to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the signal. +The argument EXPECTED-ARGS is a list of expected arguments for the signal." + (let ((signal + (dbus-introspect-get-signal + :session dbus--test-service dbus--test-path interface signal-name))) + (pcase-let ((`(signal ((name . ,name)) . ,rest) signal)) + (should + (string-equal name signal-name)) + (should + (string-equal name (dbus-introspect-get-attribute signal "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(defsubst dbus--test-validate-method + (interface method-name expected-annotations &rest expected-args) + "Validate a method definition for `dbus-test07-introspection'. + +The argument INTERFACE is a string naming the interface owning METHOD-NAME. +The argument METHOD-NAME is a string naming the method to validate. +The arguments EXPECTED-ANNOTATIONS is a list of strings matching +the annotation names defined for the method. +The argument EXPECTED-ARGS is a list of expected arguments for the method." + (let ((method + (dbus-introspect-get-method + :session dbus--test-service dbus--test-path interface method-name))) + (pcase-let ((`(method ((name . ,name)) . ,rest) method)) + (should + (string-equal name method-name)) + (should + (string-equal name (dbus-introspect-get-attribute method "name"))) + (dbus--test-validate-m-or-s rest expected-annotations expected-args)))) + +(ert-deftest dbus-test07-introspection () + "Register an Introspection interface then query it." + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + ;; Prepare introspection response. + (dbus-register-method + :session dbus--test-service dbus--test-path dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node0") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (dbus-register-method + :session dbus--test-service (concat dbus--test-path "/node1") + dbus-interface-introspectable + "Introspect" 'dbus--test-introspect) + (unwind-protect + (let ((start (current-time))) + ;; dbus-introspect-get-node-names + (should + (equal + (dbus-introspect-get-node-names + :session dbus--test-service dbus--test-path) + '("node0" "node1"))) + + ;; dbus-introspect-get-all-nodes + (should + (equal + (dbus-introspect-get-all-nodes + :session dbus--test-service dbus--test-path) + (list dbus--test-path + (concat dbus--test-path "/node0") + (concat dbus--test-path "/node1")))) + + ;; dbus-introspect-get-interface-names + (let ((interfaces + (dbus-introspect-get-interface-names + :session dbus--test-service dbus--test-path))) + + (should + (equal + interfaces + `(,dbus-interface-introspectable + ,dbus-interface-properties + ,dbus--test-interface))) + + (dbus--test-validate-interface + dbus-interface-introspectable nil '("Introspect") nil nil) + + ;; dbus-introspect-get-interface via `dbus--test-validate-interface'. + (dbus--test-validate-interface + dbus-interface-properties nil + '("Get" "Set" "GetAll") '("PropertiesChanged") nil) + + (dbus--test-validate-interface + dbus--test-interface '("Connected" "Player") + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1") nil + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-method-names + (let ((methods + (dbus-introspect-get-method-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + methods + '("Connect" "DeprecatedMethod0" "DeprecatedMethod1"))) + + ;; dbus-introspect-get-method via `dbus--test-validate-method'. + (dbus--test-validate-method + dbus--test-interface "Connect" nil + '(arg ((name . "uuid") (type . "s") (direction . "in"))) + '(arg ((name . "mode") (type . "y") (direction . "in"))) + '(arg ((name . "options") (type . "a{sv}") (direction . "in"))) + '(arg ((name . "interface") (type . "s") (direction . "out")))) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod0" + `(,dbus-annotation-deprecated)) + + (dbus--test-validate-method + dbus--test-interface "DeprecatedMethod1" + `(,dbus-annotation-deprecated))) + + ;; dbus-introspect-get-signal-names + (let ((signals + (dbus-introspect-get-signal-names + :session dbus--test-service dbus--test-path + dbus-interface-properties))) + (should + (equal + signals + '("PropertiesChanged"))) + + ;; dbus-introspect-get-signal via `dbus--test-validate-signal'. + (dbus--test-validate-signal + dbus-interface-properties "PropertiesChanged" nil + '(arg ((name . "interface") (type . "s"))) + '(arg ((name . "changed_properties") (type . "a{sv}"))) + '(arg ((name . "invalidated_properties") (type . "as"))))) + + ;; dbus-intropct-get-property-names + (let ((properties + (dbus-introspect-get-property-names + :session dbus--test-service dbus--test-path + dbus--test-interface))) + (should + (equal + properties + '("Connected" "Player"))) + + ;; dbus-introspect-get-property via `dbus--test-validate-property'. + (dbus--test-validate-property + dbus--test-interface "Connected" nil + '("Connected" "b" "read") + '("Player" "o" "read"))) + + ;; Elapsed time over a second suggests timeouts. + (should + (< 0.0 (float-time (time-since start)) 1.0))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test07-introspection-timeout () + "Verify introspection request timeouts." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((start (current-time))) + (dbus-introspect-xml :session dbus--test-service dbus--test-path) + ;; Introspection internal timeout is one second. + (should + (< 1.0 (float-time (time-since start))))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test08-register-monitor () + "Check monitor registration." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + + (unwind-protect + (let (registered) + (should + (equal + (setq registered + (dbus-register-monitor :session #'dbus--test-signal-handler)) + '((:monitor :session-private) + (nil nil dbus--test-signal-handler)))) + + ;; Send a signal, shall be traced. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface "Foo" "foo") + (with-timeout (1 (dbus--test-timeout-handler)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + + ;; Unregister monitor. + (should (dbus-unregister-object registered)) + (should-not (dbus-unregister-object registered)) + + ;; Send a signal, shall not be traced. + (setq dbus--test-signal-received nil) + (dbus-send-signal + :session dbus--test-service dbus--test-path + dbus--test-interface "Foo" "foo") + (with-timeout (1 (ignore)) + (while (null dbus--test-signal-received) + (read-event nil nil 0.1))) + (should-not dbus--test-signal-received)) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) + +(ert-deftest dbus-test09-get-managed-objects () + "Check `dbus-get-all-managed-objects'." + :tags '(:expensive-test) + (skip-unless dbus--test-enabled-session-bus) + (dbus-ignore-errors (dbus-unregister-service :session dbus--test-service)) + (dbus-register-service :session dbus--test-service) + + (unwind-protect + (let ((interfaces + `((,(concat dbus--test-interface ".I0") + ((,(concat dbus--test-path "/obj1") + (("I0Property1" . "Zero one one") + ("I0Property2" . "Zero one two") + ("I0Property3" . "Zero one three"))) + (,(concat dbus--test-path "/obj0/obj2") + (("I0Property1" . "Zero two one") + ("I0Property2" . "Zero two two") + ("I0Property3" . "Zero two three"))) + (,(concat dbus--test-path "/obj0/obj3") + (("I0Property1" . "Zero three one") + ("I0Property2" . "Zero three two") + ("I0Property3" . "Zero three three"))))) + (,(concat dbus--test-interface ".I1") + ((,(concat dbus--test-path "/obj0/obj2") + (("I1Property1" . "One one one") + ("I1Property2" . "One one two"))) + (,(concat dbus--test-path "/obj0/obj3") + (("I1Property1" . "One two one") + ("I1Property2" . "One two two")))))))) + + (should-not + (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path)) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (dolist (prop props) + (should + (equal + (dbus-register-property + :session dbus--test-service path iname + (car prop) :readwrite (cdr prop)) + `((:property :session ,iname ,(car prop)) + (,dbus--test-service ,path))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service dbus--test-path))) + (should + (= 3 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop)))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service + (concat dbus--test-path "/obj0")))) + (should + (= 2 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (when (string-prefix-p (concat dbus--test-path "/obj0/") path) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop))))))))))) + + (let ((result (dbus-get-all-managed-objects + :session dbus--test-service + (concat dbus--test-path "/obj0/obj2")))) + (should + (= 1 (length result))) + + (dolist (interface interfaces) + (pcase-let ((`(,iname ,objs) interface)) + (dolist (obj objs) + (pcase-let ((`(,path ,props) obj)) + (when (string-prefix-p + (concat dbus--test-path "/obj0/obj2") path) + (let* ((object (cadr (assoc-string path result))) + (iface (cadr (assoc-string iname object)))) + (should object) + (should iface) + (dolist (prop props) + (should (equal (cdr (assoc-string (car prop) iface)) + (cdr prop)))))))))))) + + ;; Cleanup. + (dbus-unregister-service :session dbus--test-service))) (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") - (funcall - (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) + "^dbus")) (provide 'dbus-tests) ;;; dbus-tests.el ends here diff --git a/test/lisp/net/dig-tests.el b/test/lisp/net/dig-tests.el new file mode 100644 index 00000000000..1b14384634e --- /dev/null +++ b/test/lisp/net/dig-tests.el @@ -0,0 +1,56 @@ +;;; dig-tests.el --- Tests for dig.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'dig) + +(defvar dig-test-result-data " +; <<>> DiG 9.11.16-2-Debian <<>> gnu.org +;; global options: +cmd +;; Got answer: +;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 7777 +;; flags: qr rd ra; QUERY: 1, ANSWER: 1, AUTHORITY: 0, ADDITIONAL: 1 + +;; OPT PSEUDOSECTION: +; EDNS: version: 0, flags:; udp: 4096 +;; QUESTION SECTION: +;gnu.org. IN A + +;; ANSWER SECTION: +gnu.org. 300 IN A 111.11.111.111 + +;; Query time: 127 msec +;; SERVER: 192.168.0.1#53(192.168.0.1) +;; WHEN: Sun Apr 26 00:47:55 CEST 2020 +;; MSG SIZE rcvd: 52 + +" "Data used to test dig.el.") + +(ert-deftest dig-test-dig-extract-rr () + (with-temp-buffer + (insert dig-test-result-data) + (should (equal (dig-extract-rr "gnu.org") + "gnu.org. 300 IN A 111.11.111.111")))) + +(provide 'dig-tests) +;;; dig-tests.el ends here diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index c2472d844c1..5205f0b851f 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -1,4 +1,4 @@ -;;; gnutls-tests.el --- Test suite for gnutls.el +;;; gnutls-tests.el --- Test suite for gnutls.el -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. @@ -241,6 +241,7 @@ (ert-deftest test-gnutls-005-aead-ciphers () "Test the GnuTLS AEAD ciphers" + :tags '(:expensive-test) (skip-unless (memq 'AEAD-ciphers (gnutls-available-p))) (setq gnutls-tests-message-prefix "AEAD verification: ") (let ((keys '("mykey" "mykey2")) diff --git a/test/lisp/net/hmac-md5-tests.el b/test/lisp/net/hmac-md5-tests.el new file mode 100644 index 00000000000..30d221ec87b --- /dev/null +++ b/test/lisp/net/hmac-md5-tests.el @@ -0,0 +1,80 @@ +;;; hmac-md5-tests.el --- Tests for hmac-md5.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'hmac-md5) + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved here from hmac-md5.el + +(ert-deftest hmac-md5-test-encode-string () + ;; RFC 2202 -- test_case 1 + (should (equal (encode-hex-string + (hmac-md5 "Hi There" (make-string 16 ?\x0b))) + "9294727a3638bb1c13f48ef8158bfc9d")) + + ;; RFC 2202 -- test_case 2 + (should (equal (encode-hex-string + (hmac-md5 "what do ya want for nothing?" "Jefe")) + "750c783e6ab0b503eaa86e310a5db738")) + + ;; RFC 2202 -- test_case 3 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string (make-string 100 ?d)) + (decode-hex-string (make-string 32 ?a)))) + "56be34521d144c88dbb8c733f0e8b3f6")) + + ;; RFC 2202 -- test_case 4 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string + (mapconcat (lambda (c) (concat (list c) "d")) + (make-string 50 ?c) "")) + (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) + "697eaf0aca3a3aea3a75164746ffaa79")) + + ;; RFC 2202 -- test_case 5 (a) + (should (equal (encode-hex-string + (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995690efd4c")) + + ;; RFC 2202 -- test_case 5 (b) + (should (equal (encode-hex-string + (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995")) + + ;; RFC 2202 -- test_case 6 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key - Hash Key First" + (decode-hex-string (make-string 160 ?a)))) + "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd")) + + ;; RFC 2202 -- test_case 7 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + (decode-hex-string (make-string 160 ?a)))) + "6f630fad67cda0ee1fb1f562db3aa53e"))) + +(provide 'hmac-md5-tests) +;;; hmac-md5-tests.el ends here diff --git a/test/lisp/net/mailcap-resources/mime.types b/test/lisp/net/mailcap-resources/mime.types new file mode 100644 index 00000000000..4bedfaf9702 --- /dev/null +++ b/test/lisp/net/mailcap-resources/mime.types @@ -0,0 +1,5 @@ +# this is a comment + +audio/ogg opus +audio/flac flac +audio/x-wav wav diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el index 8354d8e5e23..0ebbec61159 100644 --- a/test/lisp/net/mailcap-tests.el +++ b/test/lisp/net/mailcap-tests.el @@ -24,13 +24,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'mailcap) -(defconst mailcap-tests-data-dir - (expand-file-name "test/data/mailcap" source-directory)) - -(defconst mailcap-tests-path - (expand-file-name "mime.types" mailcap-tests-data-dir) +(defconst mailcap-tests-path (ert-resource-file "mime.types") "String used as PATH argument of `mailcap-parse-mimetypes'.") (defconst mailcap-tests-mime-extensions (copy-alist mailcap-mime-extensions)) diff --git a/test/lisp/net/netrc-resources/authinfo b/test/lisp/net/netrc-resources/authinfo new file mode 100644 index 00000000000..88aa1712e9d --- /dev/null +++ b/test/lisp/net/netrc-resources/authinfo @@ -0,0 +1,2 @@ +machine imap.example.org login jrh@example.org password "*foobar*" +machine ftp.example.org login jrh password "*baz*" diff --git a/test/lisp/net/netrc-resources/services b/test/lisp/net/netrc-resources/services new file mode 100644 index 00000000000..fd8a0348df2 --- /dev/null +++ b/test/lisp/net/netrc-resources/services @@ -0,0 +1,6 @@ +tcpmux 1/tcp # TCP port service multiplexer +smtp 25/tcp mail +http 80/tcp www # WorldWideWeb HTTP +kerberos 88/tcp kerberos5 krb5 kerberos-sec # Kerberos v5 +kerberos 88/udp kerberos5 krb5 kerberos-sec # Kerberos v5 +rtmp 1/ddp # Routing Table Maintenance Protocol diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el new file mode 100644 index 00000000000..291943990ad --- /dev/null +++ b/test/lisp/net/netrc-tests.el @@ -0,0 +1,53 @@ +;;; netrc-tests.el --- Tests for netrc.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'netrc) + +(ert-deftest test-netrc-parse-services () + (let ((netrc-services-file (ert-resource-file "services"))) + (should (equal (netrc-parse-services) + '(("tcpmux" 1 tcp) + ("smtp" 25 tcp) + ("http" 80 tcp) + ("kerberos" 88 tcp) + ("kerberos" 88 udp) + ("rtmp" 1 ddp)))))) + +(ert-deftest test-netrc-find-service-name () + (let ((netrc-services-file (ert-resource-file "services"))) + (should (equal (netrc-find-service-name 25) "smtp")) + (should (equal (netrc-find-service-name 88 'udp) "kerberos")) + (should-not (netrc-find-service-name 12345)))) + +(ert-deftest test-netrc-credentials () + (let ((netrc-file (ert-resource-file "authinfo"))) + (should (equal (netrc-credentials "imap.example.org") + '("jrh@example.org" "*foobar*"))) + (should (equal (netrc-credentials "ftp.example.org") + '("jrh" "*baz*"))))) + +(provide 'netrc-tests) + +;;; netrc-tests.el ends here diff --git a/test/lisp/net/network-stream-resources/cert.pem b/test/lisp/net/network-stream-resources/cert.pem new file mode 100644 index 00000000000..4df4e92e0bf --- /dev/null +++ b/test/lisp/net/network-stream-resources/cert.pem @@ -0,0 +1,25 @@ +-----BEGIN CERTIFICATE----- +MIIELTCCAxWgAwIBAgIJAI6LqlFyaPRkMA0GCSqGSIb3DQEBCwUAMIGsMQswCQYD +VQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVzMQ8wDQYDVQQHDAZTeWRu +ZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNzIExMQzESMBAGA1UECwwJ +QXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpvdDEiMCAGCSqGSIb3DQEJ +ARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzAeFw0xNjAyMDgwNDA0MzJaFw0xNjAzMDkw +NDA0MzJaMIGsMQswCQYDVQQGEwJBVTEYMBYGA1UECAwPTmV3IFNvdXRoIFdhbGVz +MQ8wDQYDVQQHDAZTeWRuZXkxITAfBgNVBAoMGEVtYWNzIFRlc3QgU2VydmljZXNz +IExMQzESMBAGA1UECwwJQXV0b21hdGVkMRcwFQYDVQQDDA50ZXN0LmVtYWNzLnpv +dDEiMCAGCSqGSIb3DQEJARYTZW1hY3MtZGV2ZWxAZnNmLm9yZzCCASIwDQYJKoZI +hvcNAQEBBQADggEPADCCAQoCggEBAM52lP7k1rBpctBX1irRVgDerxqlFSTkvg8L +WmRCfwm3XY8EZWqM/8Eex5soH7myRlWfUH/cKxbqScZqXotj0hlPxdRkM6gWgHS9 +Mml7wnz2LZGvD5PfMfs+yBHKAMrqortFXCKksHsYIJ66l9gJMm1G5XjWha6CaEr/ +k2bE5Ovw0fB2B4vH0OqhJzGyenJOspXZz1ttn3h3UC5fbDXS8fUM9k/FbgJKypWr +zB3P12GcMR939FsR5sqa8nNoCMw+WBzs4XuM5Ad+s/UtEaZvmtwvLwmdB7cgCEyM +x5gaM969SlpOmuy7dDTCCK3lBl6B5dgFKvVcChYwSW+xJz5tfL0CAwEAAaNQME4w +HQYDVR0OBBYEFG3YhH7ZzEdOGstkT67uUh1RylNjMB8GA1UdIwQYMBaAFG3YhH7Z +zEdOGstkT67uUh1RylNjMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQELBQADggEB +ADnJL2tBMnPepywA57yDfJz54FvrqRd+UAjSiB7/QySDpHnTM3b3sXWfwAkXPTjM +c+jRW2kfdnL6OQW2tpcpPZANGnwK8MJrtGcbHhtPXjgDRhVZp64hsB7ayS+l0Dm7 +2ZBbi2SF8FgZVcQy0WD01ir2raSODo124dMrq+3aHP77YLbiNEKj+wFoDbndQ1FQ +gtIJBE80FADoqc7LnBrpA20aVlfqhKZqe+leYDSZ+CE1iwlPdvD+RTUxVDs5EfpB +qVOHDlzEfVmcMnddKTV8pNYuo93AG4s0KdrGG9RwSvtLaOoHd2i6RmIs+Yiumbau +mXodMxxAEW/cM7Ita/2QVmk= +-----END CERTIFICATE----- diff --git a/test/lisp/net/network-stream-resources/key.pem b/test/lisp/net/network-stream-resources/key.pem new file mode 100644 index 00000000000..5db58f573ca --- /dev/null +++ b/test/lisp/net/network-stream-resources/key.pem @@ -0,0 +1,28 @@ +-----BEGIN PRIVATE KEY----- +MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDOdpT+5NawaXLQ +V9Yq0VYA3q8apRUk5L4PC1pkQn8Jt12PBGVqjP/BHsebKB+5skZVn1B/3CsW6knG +al6LY9IZT8XUZDOoFoB0vTJpe8J89i2Rrw+T3zH7PsgRygDK6qK7RVwipLB7GCCe +upfYCTJtRuV41oWugmhK/5NmxOTr8NHwdgeLx9DqoScxsnpyTrKV2c9bbZ94d1Au +X2w10vH1DPZPxW4CSsqVq8wdz9dhnDEfd/RbEebKmvJzaAjMPlgc7OF7jOQHfrP1 +LRGmb5rcLy8JnQe3IAhMjMeYGjPevUpaTprsu3Q0wgit5QZegeXYBSr1XAoWMElv +sSc+bXy9AgMBAAECggEAaqHkIiGeoE5V9jTncAXeHWTlmyVX3k4luy9p6A5P/nyt +3YevuXBJRzzWatQ2Tno8yUwXD3Ju7s7ie4/EdMmBYYFJ84AtDctRXPm6Z7B7qn6a +2ntH2F+WOOUb/9QMxMCae44/H8VfQLQdZN2KPxHA8Z+ENPzW3mKL6vBE+PcIJLK2 +kTXQdCEIuUb1v4kxKYfjyyHAQ9yHvocUvZdodGHrpmWOr/2QCrqCjwiKnXyvdJMi +JQ4a3dU+JG5Zwr2hScyeLgS4p+M3A2NY+oIACn2rCcsIKC6uvBK3wAbhssaY8z9c +5kap862oMBNmPCxPuQTIIO7ptla0EWHktpFxnu7GIQKBgQDvKyXt82zGHiOZ9acx +4fV7t3NF2MNd9fOn59NYWYRSs2gaEjit6BnsCgiKZOJJ2YFsggBiQMiWuEzwqIdW +bOH8W5AubTxnE2OjeIpH5r8AXI6I/pKdOedM86oeElbL0p53OZqSqBK6vA5SnE76 +fZwC505h/mqH2E6AdKpcyL7sJwKBgQDc/jc4MkVnqF7xcYoJrYEbnkhwqRxIM+0Y +HY2qXszWQPgjae3NK1rw/PEOATzWrHLvRS/utQ8yeLUAZIGsFY8+c1kjvkvl4ZK2 +OnsEOVLmEwjDqqnq3JFYCVSkXfLBGRD3wGldzkCQljOiGuJ/Co1rGHk7CfBmxX2p +kxdts5OKewKBgQDTRsSc7Zs7cMh2a0GlmTyoa6iTHSeIy4rQ2sQimgGApSfjUBFt +30l28G4XA4O7RT9FwZnhMeWA75JYTigwOsNvkNtPiAQB8mjksclGNxqnkRwA/RI7 +fjlMCzxOkFjIeWivXd2kjIDvIM1uQNKsCWZWUks12e/1zSmb5HPSvyuZpQKBgQDQ +qVgKP604ysmav9HOgXy+Tx2nAoYpxp2/f2gbzZcrVfz1szdN2fnsQWh6CMEhEYMU +WQeBJIRM65w72qp1iYXPOaqZDT0suWiFl4I/4sBbbO2BkssNb2Xs8iJxcCOeH8Td +qVfTssNTwf7OuQPTYGtXC6ysCh5ra13Tl4cvlbdhsQKBgFHXP+919wSncLS+2ySD +waBzG6GyVOgV+FE3DrM3Xp4S6fldWYAndKHQ1HjJVDY8SkC2Tk1D7QSQnmS+ZzYs +YqzcnkPCTHLb6wCErs4ZiW0gn9xJnfxyv6wPujsayL4TMsmsqkj/IAB61UjwaA/a +Z+rUw/WkcNPD59AD1J0eeSZu +-----END PRIVATE KEY----- diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 28686547a44..07eb2823282 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -24,6 +24,8 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'gnutls) (require 'network-stream) ;; The require above is needed for 'open-network-stream' to work, but @@ -136,7 +138,20 @@ (t )))) +(defun network-test--resolve-system-name () + (cl-loop for address in (network-lookup-address-info (system-name)) + when (or (and (= (length address) 5) + ;; IPv4 localhost addresses start with 127. + (= (elt address 0) 127)) + (and (= (length address) 9) + ;; IPv6 localhost address. + (equal address [0 0 0 0 0 0 0 1 0]))) + return t)) + (ert-deftest echo-server-with-dns () + (unless (network-test--resolve-system-name) + (ert-skip "Can't test resolver for (system-name)")) + (let* ((server (make-server (system-name))) (port (aref (process-contact server :local) 4)) (proc (make-network-process :name "foo" @@ -226,16 +241,13 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) -(defconst network-stream-tests--datadir - (expand-file-name "test/data/net" source-directory)) - (defun make-tls-server (port) (start-process "gnutls" (generate-new-buffer "*tls*") "gnutls-serv" "--http" "--x509keyfile" - (concat network-stream-tests--datadir "/key.pem") + (ert-resource-file "key.pem") "--x509certfile" - (concat network-stream-tests--datadir "/cert.pem") + (ert-resource-file "cert.pem") "--port" (format "%s" port))) (ert-deftest connect-to-tls-ipv4-wait () @@ -724,4 +736,56 @@ 44777 (vector :nowait t)))) +(ert-deftest check-network-process-coding-system-bind () + "Check that binding coding-system-for-{read,write} works." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-no-override () + "Check that coding-system-for-{read,write} is not overridden by :coding nil." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding nil + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-override () + "Check that :coding non-nil overrides coding-system-for-{read,write}." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding 'georgian-academy + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'georgian-academy)) + (should (eq (cdr coding) 'georgian-academy)) + (delete-process server))) ;;; network-stream-tests.el ends here diff --git a/test/lisp/net/newsticker-tests.el b/test/lisp/net/newsticker-tests.el index 1a6e11dc512..5552fa8c1a6 100644 --- a/test/lisp/net/newsticker-tests.el +++ b/test/lisp/net/newsticker-tests.el @@ -1,4 +1,4 @@ -;;; newsticker-testsuite.el --- Test suite for newsticker. +;;; newsticker-tests.el --- Test suite for newsticker. -*- lexical-binding:t -*- ;; Copyright (C) 2003-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el new file mode 100644 index 00000000000..e515ebe2635 --- /dev/null +++ b/test/lisp/net/ntlm-tests.el @@ -0,0 +1,52 @@ +;;; ntlm-tests.el --- tests for ntlm.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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/>. + +(require 'ert) +(require 'ntlm) + +;; This is the Lisp bignum implementation of `ntlm--time-to-timestamp', +;; for reference. +(defun ntlm-tests--time-to-timestamp (time) + "Convert TIME to an NTLMv2 timestamp. +Return a unibyte string representing the number of tenths of a +microsecond since January 1, 1601 as a 64-bit little-endian +signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." + (let* ((s (+ (ash (nth 0 time) 16) (nth 1 time))) + (us (nth 2 time)) + (ps (nth 3 time)) + (tenths-of-us-since-jan-1-1601 + (+ (* s 10000000) (* us 10) (/ ps 100000) + ;; tenths of microseconds between 1601-01-01 and 1970-01-01 + 116444736000000000))) + (apply #'unibyte-string + (mapcar (lambda (i) + (logand (ash tenths-of-us-since-jan-1-1601 (* i -8)) + #xff)) + (number-sequence 0 7))))) + +(ert-deftest ntlm-time-to-timestamp () + ;; Verify poor man's bignums in implementation that can run on Emacs < 27.1. + (let ((time '(24471 63910 412962 0))) + (should (equal (ntlm--time-to-timestamp time) + (ntlm-tests--time-to-timestamp time)))) + (let ((time '(397431 65535 999999 999999))) + (should (equal (ntlm--time-to-timestamp time) + (ntlm-tests--time-to-timestamp time))))) + +(provide 'ntlm-tests) diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 9fb2ebb5469..7dac39795b6 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -1,4 +1,4 @@ -;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; -*- +;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. @@ -38,4 +38,25 @@ "Test puny decoding." (should (string= (puny-decode-string "xn--9dbdkw") "חנוך"))) +(ert-deftest puny-test-encode-domain () + (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se"))) + +(ert-deftest puny-test-decode-domain () + (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se"))) + +(ert-deftest puny-highly-restrictive-domain-p () + (should (puny-highly-restrictive-domain-p "foo.bar.org")) + (should (puny-highly-restrictive-domain-p "foo.abcåäö.org")) + (should (puny-highly-restrictive-domain-p "foo.ர.org")) + ;; Disallow unicode character 2044, visually similar to "/". + (should-not (puny-highly-restrictive-domain-p "www.yourbank.com⁄login⁄checkUser.jsp?inxs.ch")) + ;; Disallow mixing scripts. + (should-not (puny-highly-restrictive-domain-p "åர.org")) + ;; Only allowed in moderately restrictive. + (should-not (puny-highly-restrictive-domain-p "Teχ.org")) + (should-not (puny-highly-restrictive-domain-p "HλLF-LIFE.org")) + (should-not (puny-highly-restrictive-domain-p "Ωmega.org")) + ;; Only allowed in unrestricted. + (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) + ;;; puny-tests.el ends here diff --git a/test/lisp/net/rcirc-tests.el b/test/lisp/net/rcirc-tests.el index 8d14378b4ff..285926af9d2 100644 --- a/test/lisp/net/rcirc-tests.el +++ b/test/lisp/net/rcirc-tests.el @@ -2,18 +2,20 @@ ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/net/rfc2104-tests.el b/test/lisp/net/rfc2104-tests.el index 5c1f4410934..e7d5a7f30e5 100644 --- a/test/lisp/net/rfc2104-tests.el +++ b/test/lisp/net/rfc2104-tests.el @@ -1,21 +1,23 @@ -;;; rfc2104-tests.el --- Tests of RFC2104 hashes +;;; rfc2104-tests.el --- Tests of RFC2104 hashes -*- lexical-binding:t -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/net/sasl-scram-rfc-tests.el b/test/lisp/net/sasl-scram-rfc-tests.el index ec283c86f55..09e05b62a25 100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@ -1,4 +1,4 @@ -;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- +;;; sasl-scram-rfc-tests.el --- tests for SCRAM -*- lexical-binding: t; -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -19,7 +19,7 @@ ;;; Commentary: -;; Test cases from RFC 5802. +;; Test cases from RFC 5802 and RFC 7677. ;;; Code: @@ -47,4 +47,26 @@ (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= ")))) +(require 'sasl-scram-sha256) + +(ert-deftest sasl-scram-sha-256-test () + ;; The following strings are taken from section 3 of RFC 7677. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-256")) + "user" + "imap" + "localhost")) + (data "r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,s=W22ZaJ0SNY7soEsUEjb6gQ==,i=4096") + (c-nonce "rOprNGfwEbeRWgbNEkqO") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-256-client-final-message client (vector nil data)) + "c=biws,r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,p=dHzbZapWIk4jUhN+Ute9ytag9zjfMHgsqmmiz7AndVQ=")) + + ;; This should not throw an error: + (sasl-scram-sha-256-authenticate-server client (vector nil "v=6rriTRBi23WpRR/wtup+mMhUZUn/dB5nLTJRsjl95G4=")))) + ;;; sasl-scram-rfc-tests.el ends here diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el index 6d420c4cb17..1e2cf3aef66 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/net/shr-resources/div-div.html b/test/lisp/net/shr-resources/div-div.html new file mode 100644 index 00000000000..1c191ae44d8 --- /dev/null +++ b/test/lisp/net/shr-resources/div-div.html @@ -0,0 +1 @@ +<div>foo</div><div>Bar</div> diff --git a/test/lisp/net/shr-resources/div-div.txt b/test/lisp/net/shr-resources/div-div.txt new file mode 100644 index 00000000000..62715e12513 --- /dev/null +++ b/test/lisp/net/shr-resources/div-div.txt @@ -0,0 +1,2 @@ +foo +Bar diff --git a/test/lisp/net/shr-resources/div-p.html b/test/lisp/net/shr-resources/div-p.html new file mode 100644 index 00000000000..fcbdfc43293 --- /dev/null +++ b/test/lisp/net/shr-resources/div-p.html @@ -0,0 +1 @@ +<div>foo</div><p>Bar</p> diff --git a/test/lisp/net/shr-resources/div-p.txt b/test/lisp/net/shr-resources/div-p.txt new file mode 100644 index 00000000000..859d731da89 --- /dev/null +++ b/test/lisp/net/shr-resources/div-p.txt @@ -0,0 +1,3 @@ +foo + +Bar diff --git a/test/lisp/net/shr-resources/li-div.html b/test/lisp/net/shr-resources/li-div.html new file mode 100644 index 00000000000..eca3c511bd9 --- /dev/null +++ b/test/lisp/net/shr-resources/li-div.html @@ -0,0 +1,10 @@ +<ul> + <li> + <div> + <p >This is the first paragraph of a list item.</div> + <p >This is the second paragraph of a list item.</li> + <li> + <div>This is the first paragraph of a list item.</div> + <div>This is the second paragraph of a list item.</div> + </li> +</ul> diff --git a/test/lisp/net/shr-resources/li-div.txt b/test/lisp/net/shr-resources/li-div.txt new file mode 100644 index 00000000000..9fc54f2bdc6 --- /dev/null +++ b/test/lisp/net/shr-resources/li-div.txt @@ -0,0 +1,6 @@ +* This is the first paragraph of a list item. + + This is the second paragraph of a list item. + +* This is the first paragraph of a list item. + This is the second paragraph of a list item. diff --git a/test/lisp/net/shr-resources/li-empty.html b/test/lisp/net/shr-resources/li-empty.html new file mode 100644 index 00000000000..05cfee7bdd4 --- /dev/null +++ b/test/lisp/net/shr-resources/li-empty.html @@ -0,0 +1 @@ +<ol><li></li><li></li><li></li></ol> diff --git a/test/lisp/net/shr-resources/li-empty.txt b/test/lisp/net/shr-resources/li-empty.txt new file mode 100644 index 00000000000..906fd8df8b3 --- /dev/null +++ b/test/lisp/net/shr-resources/li-empty.txt @@ -0,0 +1,3 @@ +1%20 +2%20 +3%20 diff --git a/test/lisp/net/shr-resources/nonbr.html b/test/lisp/net/shr-resources/nonbr.html new file mode 100644 index 00000000000..56282cf4ca5 --- /dev/null +++ b/test/lisp/net/shr-resources/nonbr.html @@ -0,0 +1 @@ +<div class="gmail_extra">(progn</div><div class="gmail_extra"> (setq minibuffer-prompt-properties '(read-only t cursor-intangible t face minibuffer-prompt))</div><div class="gmail_extra"><br></div><div class="gmail_extra"> (defun turn-on-cursor-intangible-mode ()</div><div class="gmail_extra"> "Turns on cursor-intangible-mode."</div><div class="gmail_extra"> (interactive)</div><div class="gmail_extra"> (cursor-intangible-mode 1))</div><div class="gmail_extra"> (define-globalized-minor-mode global-cursor-intangible-mode cursor-intangible-mode turn-on-cursor-intangible-mode)</div><div class="gmail_extra"><br></div><div class="gmail_extra"> (global-cursor-intangible-mode 1))</div><div class="gmail_extra"><br></div> diff --git a/test/lisp/net/shr-resources/nonbr.txt b/test/lisp/net/shr-resources/nonbr.txt new file mode 100644 index 00000000000..0c3cffa93f9 --- /dev/null +++ b/test/lisp/net/shr-resources/nonbr.txt @@ -0,0 +1,12 @@ +(progn + (setq minibuffer-prompt-properties '(read-only t cursor-intangible t face +minibuffer-prompt)) + + (defun turn-on-cursor-intangible-mode () + "Turns on cursor-intangible-mode." + (interactive) + (cursor-intangible-mode 1)) + (define-globalized-minor-mode global-cursor-intangible-mode +cursor-intangible-mode turn-on-cursor-intangible-mode) + + (global-cursor-intangible-mode 1)) diff --git a/test/lisp/net/shr-resources/ol.html b/test/lisp/net/shr-resources/ol.html new file mode 100644 index 00000000000..f9a15f26409 --- /dev/null +++ b/test/lisp/net/shr-resources/ol.html @@ -0,0 +1,29 @@ +<ol> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> + +<ol start="10"> + <li>ten</li> + <li>eleven</li> + <li>twelve</li> +</ol> + +<ol start="0"> + <li>zero</li> + <li>one</li> + <li>two</li> +</ol> + +<ol start="-5"> + <li>minus five</li> + <li>minus four</li> + <li>minus three</li> +</ol> + +<ol start="notanumber"> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> diff --git a/test/lisp/net/shr-resources/ol.txt b/test/lisp/net/shr-resources/ol.txt new file mode 100644 index 00000000000..0d46e2a8ddb --- /dev/null +++ b/test/lisp/net/shr-resources/ol.txt @@ -0,0 +1,19 @@ +1 one +2 two +3 three + +10 ten +11 eleven +12 twelve + +0 zero +1 one +2 two + +-5 minus five +-4 minus four +-3 minus three + +1 one +2 two +3 three diff --git a/test/lisp/net/shr-resources/ul-empty.html b/test/lisp/net/shr-resources/ul-empty.html new file mode 100644 index 00000000000..e5a75ab9216 --- /dev/null +++ b/test/lisp/net/shr-resources/ul-empty.html @@ -0,0 +1,4 @@ +<ul> +<li></li> +</ul> +Lala diff --git a/test/lisp/net/shr-resources/ul-empty.txt b/test/lisp/net/shr-resources/ul-empty.txt new file mode 100644 index 00000000000..8993555425b --- /dev/null +++ b/test/lisp/net/shr-resources/ul-empty.txt @@ -0,0 +1,3 @@ +* + +Lala
\ No newline at end of file diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index 88a31bcf645..abc4f6a656b 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -23,14 +23,13 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'shr) -(defconst shr-tests--datadir - (expand-file-name "test/data/shr" source-directory)) - (defun shr-test (name) (with-temp-buffer - (insert-file-contents (format (concat shr-tests--datadir "/%s.html") name)) + (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name)) (let ((dom (libxml-parse-html-region (point-min) (point-max))) (shr-width 80) (shr-use-fonts nil)) @@ -39,7 +38,7 @@ (cons (buffer-substring-no-properties (point-min) (point-max)) (with-temp-buffer (insert-file-contents - (format (concat shr-tests--datadir "/%s.txt") name)) + (format (concat (ert-resource-directory) "/%s.txt") name)) (while (re-search-forward "%\\([0-9A-F][0-9A-F]\\)" nil t) (replace-match (string (string-to-number (match-string 1) 16)) t t)) @@ -47,7 +46,7 @@ (ert-deftest rendering () (skip-unless (fboundp 'libxml-parse-html-region)) - (dolist (file (directory-files shr-tests--datadir nil "\\.html\\'")) + (dolist (file (directory-files (ert-resource-directory) nil "\\.html\\'")) (let* ((name (replace-regexp-in-string "\\.html\\'" "" file)) (result (shr-test name))) (unless (equal (car result) (cdr result)) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 95e41a3f03b..97c22fd2feb 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -27,40 +29,74 @@ ;; tests in tramp-tests.el. (require 'ert) +(require 'ert-x) (require 'tramp-archive) (defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) -(defconst tramp-archive-test-resource-directory - (let ((default-directory - (if load-in-progress - (file-name-directory load-file-name) - default-directory))) - (cond - ((file-accessible-directory-p (expand-file-name "resources")) - (expand-file-name "resources")) - ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) - (expand-file-name "tramp-archive-resources")))) - "The resources directory test files are located in.") - -(defconst tramp-archive-test-file-archive - (file-truename - (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) +;; `ert-resource-file' was introduced in Emacs 28.1. +(unless (macrop 'ert-resource-file) + (eval-and-compile + (defvar ert-resource-directory-format "%s-resources/" + "Format for `ert-resource-directory'.") + (defvar ert-resource-directory-trim-left-regexp "" + "Regexp for `string-trim' (left) used by `ert-resource-directory'.") + (defvar ert-resource-directory-trim-right-regexp "\\(-tests?\\)?\\.el" + "Regexp for `string-trim' (right) used by `ert-resource-directory'.") + + (defmacro ert-resource-directory () + "Return absolute file name of the resource directory for this file. + +The path to the resource directory is the \"resources\" directory +in the same directory as the test file. + +If that directory doesn't exist, use the directory named like the +test file but formatted by `ert-resource-directory-format' and trimmed +using `string-trim' with arguments +`ert-resource-directory-trim-left-regexp' and +`ert-resource-directory-trim-right-regexp'. The default values mean +that if called from a test file named \"foo-tests.el\", return +the absolute file name for \"foo-resources\"." + `(let* ((testfile ,(or (bound-and-true-p byte-compile-current-file) + (and load-in-progress load-file-name) + buffer-file-name)) + (default-directory (file-name-directory testfile))) + (file-truename + (if (file-accessible-directory-p "resources/") + (expand-file-name "resources/") + (expand-file-name + (format + ert-resource-directory-format + (string-trim testfile + ert-resource-directory-trim-left-regexp + ert-resource-directory-trim-right-regexp))))))) + + (defmacro ert-resource-file (file) + "Return file name of resource file named FILE. +A resource file is in the resource directory as per +`ert-resource-directory'." + `(expand-file-name ,file (ert-resource-directory))))) + +(defconst tramp-archive-test-file-archive (ert-resource-file "foo.tar.gz") "The test file archive.") +(defun tramp-archive-test-file-archive-hexlified () + "Return hexlified `tramp-archive-test-file-archive'. +Do not hexlify \"/\". This hexlified string is used in `file:///' URLs." + (let* ((url-unreserved-chars (cons ?/ url-unreserved-chars))) + (url-hexify-string tramp-archive-test-file-archive))) + (defconst tramp-archive-test-archive (file-name-as-directory tramp-archive-test-file-archive) "The test archive.") (defconst tramp-archive-test-directory - (file-truename - (expand-file-name "foo.iso" tramp-archive-test-resource-directory)) + (file-truename (ert-resource-file "foo.iso")) "A directory file name, which looks like an archive.") (setq password-cache-expiry nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -175,7 +211,8 @@ variables, so we check the Emacs version directly." (should (string-equal host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (url-hexify-string + (concat "file://" (tramp-archive-test-file-archive-hexlified))))) (should-not port) (should (string-equal localname "/")) (should (string-equal archive tramp-archive-test-file-archive))) @@ -194,7 +231,8 @@ variables, so we check the Emacs version directly." (should (string-equal host - (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (url-hexify-string + (concat "file://" (tramp-archive-test-file-archive-hexlified))))) (should-not port) (should (string-equal localname "/foo")) (should (string-equal archive tramp-archive-test-file-archive))) @@ -238,7 +276,8 @@ variables, so we check the Emacs version directly." ;; archive boundaries. So we must cut the ;; trailing slash ourselves. (substring - (file-name-directory tramp-archive-test-file-archive) + (file-name-directory + (tramp-archive-test-file-archive-hexlified)) 0 -1))) nil "/")) (file-name-nondirectory tramp-archive-test-file-archive))))) @@ -971,4 +1010,5 @@ If INTERACTIVE is non-nil, the tests are run interactively." "^tramp-archive")) (provide 'tramp-archive-tests) + ;;; tramp-archive-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index e42765ba088..b2e8cc19459 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -4,18 +4,20 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -43,6 +45,7 @@ (require 'dired) (require 'ert) (require 'ert-x) +(require 'trace) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -50,14 +53,13 @@ (require 'vc-hg) (declare-function tramp-find-executable "tramp-sh") +(declare-function tramp-get-remote-chmod-h "tramp-sh") (declare-function tramp-get-remote-gid "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") (declare-function tramp-list-tramp-buffers "tramp-cmds") -(declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") -(declare-function tramp-time-diff "tramp") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) (defvar tramp-connection-properties) @@ -68,8 +70,6 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 24. -(defvar inhibit-message) ;; Needed for Emacs 25. (defvar connection-local-criteria-alist) (defvar connection-local-profile-alist) @@ -98,25 +98,29 @@ '("mock" (tramp-login-program "sh") (tramp-login-args (("-i"))) + (tramp-direct-async-args (("-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))) - ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in - ;; batch mode only, therefore. + ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed + ;; in batch mode only, therefore. (unless (and (null noninteractive) (file-directory-p "~/")) (setenv "HOME" temporary-file-directory)) (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") +(defconst tramp-test-vec + (tramp-dissect-file-name tramp-test-temporary-file-directory) + "The used `tramp-file-name' structure.") + (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -144,9 +148,7 @@ being the result.") (when (cdr tramp--test-enabled-checked) ;; Cleanup connection. (ignore-errors - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - nil 'keep-password))) + (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) ;; Return result. (cdr tramp--test-enabled-checked)) @@ -177,38 +179,46 @@ This shall used dynamically bound only.") (defmacro tramp--test-instrument-test-case (verbose &rest body) "Run BODY with `tramp-verbose' equal VERBOSE. Print the content of the Tramp connection and debug buffers, if -`tramp-verbose' is greater than 3. `should-error' is not handled -properly. BODY shall not contain a timeout." +`tramp-verbose' is greater than 3. Print traces if `tramp-verbose' +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))) - (tramp-message-show-message t) - (debug-ignored-errors - (append - '("^make-symbolic-link not supported$" - "^error with add-name-to-file") - debug-ignored-errors)) - inhibit-message) + `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) + (trace-buffer + (when (> tramp-verbose 10) (generate-new-buffer " *temp*"))) + (debug-ignored-errors + (append + '("^make-symbolic-link not supported$" + "^error with add-name-to-file") + debug-ignored-errors)) + inhibit-message) + (when trace-buffer + (dolist (elt (all-completions "tramp-" obarray 'functionp)) + (trace-function-background (intern elt)))) (unwind-protect (let ((tramp--test-instrument-test-case-p t)) ,@body) ;; Unwind forms. + (when trace-buffer + (untrace-all)) (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) - (dolist (buf (tramp-list-tramp-buffers)) + (dolist + (buf (if trace-buffer + (cons (get-buffer trace-buffer) (tramp-list-tramp-buffers)) + (tramp-list-tramp-buffers))) (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string)))))))) + (message ";; %s\n%s" buf (buffer-string))))) + (when trace-buffer + (kill-buffer trace-buffer))))) (defsubst tramp--test-message (fmt-string &rest arguments) "Emit a message into ERT *Messages*." (tramp--test-instrument-test-case 0 - (apply - #'tramp-message - (tramp-dissect-file-name tramp-test-temporary-file-directory) 0 - fmt-string arguments))) + (apply #'tramp-message tramp-test-vec 0 fmt-string arguments))) (defsubst tramp--test-backtrace () "Dump a backtrace into ERT *Messages*." (tramp--test-instrument-test-case 10 - (tramp-backtrace - (tramp-dissect-file-name tramp-test-temporary-file-directory)))) + (tramp-backtrace tramp-test-vec))) (defmacro tramp--test-print-duration (message &rest body) "Run BODY and print a message with duration, prompted by MESSAGE." @@ -1970,9 +1980,9 @@ properly. BODY shall not contain a timeout." ;; Host names must match rules in case the command template of a ;; method doesn't use them. (dolist (m '("su" "sg" "sudo" "doas" "ksu")) - (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) - tramp-connection-properties tramp-default-proxies-alist) - (ignore-errors (tramp-cleanup-connection vec nil 'keep-password)) + (let (tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors + (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) ;; Single hop. The host name must match `tramp-local-host-regexp'. (should-error (find-file (format "/%s:foo:" m)) @@ -1992,16 +2002,17 @@ properly. BODY shall not contain a timeout." (skip-unless (tramp--test-enabled)) ;; Multi hops are allowed for inline methods only. - (should-error - (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") - :type 'user-error) - (should-error - (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") - :type 'user-error) + (let (non-essential) + (should-error + (expand-file-name "/ssh:user1@host1|method:user2@host2:/path/to/file") + :type 'user-error) + (should-error + (expand-file-name "/method:user1@host1|ssh:user2@host2:/path/to/file") + :type 'user-error)) ;; Samba does not support file names with periods followed by ;; spaces, and trailing periods or spaces. - (when (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (when (tramp--test-smb-p) (dolist (file '("foo." "foo. bar" "foo ")) (should-error (tramp-smb-get-localname @@ -2013,8 +2024,12 @@ properly. BODY shall not contain a timeout." "Check `substitute-in-file-name'." (skip-unless (eq tramp-syntax 'default)) - ;; Suppress method name check. - (let ((tramp-methods (cons '("method") tramp-methods))) + ;; Suppress method name check. We cannot use the string "foo" as + ;; user name, because (substitute-in-string "/~foo") returns + ;; different values depending on the existence of user "foo" (see + ;; Bug#43052). + (let ((tramp-methods (cons '("method") tramp-methods)) + (foo (downcase (md5 (current-time-string))))) (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) (should @@ -2043,39 +2058,43 @@ properly. BODY shall not contain a timeout." "/method:host:/:/path//foo")) ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 24 and Emacs 25, occasionally. No idea what's up. + ;; Emacs 25, occasionally. No idea what's up. (when (tramp--test-emacs26-p) (should - (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) + (string-equal + (substitute-in-file-name (concat "/method:host://~" foo)) + (concat "/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) + (substitute-in-file-name (concat "/method:host:/~" foo)) + (concat "/method:host:/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) + (substitute-in-file-name (concat "/method:host:/path//~" foo)) + (concat "/~" foo))) ;; (substitute-in-file-name "/path/~foo") expands only for a local ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. (should (string-equal - (substitute-in-file-name "/method:host:/path/~foo") - "/method:host:/path/~foo")) + (substitute-in-file-name (concat "/method:host:/path/~" foo)) + (concat "/method:host:/path/~" foo))) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/://~foo") - "/method:host:/://~foo")) + (substitute-in-file-name (concat "/method:host:/://~" foo)) + (concat "/method:host:/://~" foo))) (should (string-equal - (substitute-in-file-name - "/method:host:/:/~foo") "/method:host:/:/~foo")) + (substitute-in-file-name (concat "/method:host:/:/~" foo)) + (concat "/method:host:/:/~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//~foo") - "/method:host:/:/path//~foo")) + (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) + (concat "/method:host:/:/path//~" foo))) (should (string-equal - (substitute-in-file-name "/method:host:/:/path/~foo") - "/method:host:/:/path/~foo"))) + (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) + (concat "/method:host:/:/path/~" foo)))) (let (process-environment) (should @@ -2215,11 +2234,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Bug#10085. (when (tramp--test-enabled) ;; Packages like tramp-gvfs.el might be disabled. - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) ;; We must clear `tramp-default-method'. On hydra, it is "ftp", ;; which ruins the tests. - (let ((non-essential n-e) - (tramp-default-method + (let ((tramp-default-method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host))) (dolist @@ -2235,7 +2253,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-as-directory file) - (if (tramp-completion-mode-p) + (if non-essential file (concat file (if (tramp--test-ange-ftp-p) "/" "./"))))) (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) @@ -2250,7 +2268,28 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) (delete-file tmp-name) - (should-not (file-exists-p tmp-name))))) + (should-not (file-exists-p tmp-name)) + + ;; Trashing files doesn't work for crypted remote files. + (unless (tramp--test-crypt-p) + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (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 + (or (file-exists-p + (expand-file-name + (file-name-nondirectory tmp-name) trash-directory)) + ;; Gdrive. + (file-symlink-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'." @@ -2293,16 +2332,25 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foo")) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foofoo")) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) + (goto-char (1+ (point))) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "ffoooo")) + (should (= point (point)))) ;; Insert partly. - (insert-file-contents tmp-name nil 1 3) - (should (string-equal (buffer-string) "oofoofoo")) + (let ((point (point))) + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "foofoooo")) + (should (= point (point)))) ;; Replace. - (insert-file-contents tmp-name nil nil nil 'replace) - (should (string-equal (buffer-string) "foo")) + (let ((point (point))) + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) ;; Error case. (delete-file tmp-name) (should-error @@ -2380,7 +2428,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Check message. ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1. (with-no-warnings (when (symbol-plist 'ert-with-message-capture) - (let ((tramp-message-show-message t)) + (let (inhibit-message) (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) (dolist (visit '(nil t "string" no-message)) @@ -2406,7 +2454,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (cl-letf (((symbol-function #'y-or-n-p) #'ignore) ;; Ange-FTP. - ((symbol-function 'yes-or-no-p) 'ignore)) + ((symbol-function #'yes-or-no-p) #'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) :type 'file-already-exists) (should-error @@ -2738,7 +2786,53 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (delete-directory tmp-name1) :type 'file-error) (delete-directory tmp-name1 'recursive) - (should-not (file-directory-p tmp-name1))))) + (should-not (file-directory-p tmp-name1)) + + ;; Trashing directories works only since Emacs 27.1. It doesn't + ;; work for crypted remote directories and for ange-ftp. + (when (and (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) + (tramp--test-emacs27-p)) + (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) + (delete-by-moving-to-trash t)) + (make-directory trash-directory) + ;; Delete empty directory. + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (delete-directory tmp-name1 nil 'trash) + (should-not (file-directory-p tmp-name1)) + (should + (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)) + ;; Delete non-empty directory. + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + (write-region "foo" nil (expand-file-name "bla" tmp-name1)) + (should (file-exists-p (expand-file-name "bla" tmp-name1))) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (write-region "foo" nil (expand-file-name "bla" tmp-name2)) + (should (file-exists-p (expand-file-name "bla" tmp-name2))) + (should-error + (delete-directory tmp-name1 nil 'trash) + ;; tramp-rclone.el calls the local `delete-directory'. + ;; This raises another error. + :type (if (tramp--test-rclone-p) 'error 'file-error)) + (delete-directory tmp-name1 'recursive 'trash) + (should-not (file-directory-p tmp-name1)) + (should + (file-exists-p + (format + "%s/%s/bla" trash-directory (file-name-nondirectory tmp-name1)))) + (should + (file-exists-p + (format + "%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))))))) (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." @@ -2838,7 +2932,15 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." '("bla" "foo"))) (should (equal (directory-files tmp-name1 'full directory-files-no-dot-files-regexp) - `(,tmp-name2 ,tmp-name3)))) + `(,tmp-name2 ,tmp-name3))) + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (should + (equal + (directory-files + tmp-name1 nil directory-files-no-dot-files-regexp nil 1) + '("bla")))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -2915,6 +3017,9 @@ 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 crypted 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) '(nil t) '(nil))) (let* ((tmp-name1 @@ -2985,6 +3090,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) + ;; Wildcards are not supported in tramp-crypt.el. + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) @@ -3134,8 +3241,7 @@ This tests also `access-file', `file-readable-p', (setq test-file-ownership-preserved-p (= (tramp-compat-file-attribute-group-id (file-attributes tmp-name1)) - (tramp-get-remote-gid - (tramp-dissect-file-name tmp-name1) 'integer))) + (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) (should-error @@ -3352,7 +3458,14 @@ They might differ only in time attributes or directory size." (file-attributes (car elt)) (cdr elt)))) (setq attr (directory-files-and-attributes tmp-name2 nil "\\`b")) - (should (equal (mapcar #'car attr) '("bar" "boz")))) + (should (equal (mapcar #'car attr) '("bar" "boz"))) + + ;; Check the COUNT arg. It exists since Emacs 28. + (when (tramp--test-emacs28-p) + (with-no-warnings + (setq attr (directory-files-and-attributes + tmp-name2 nil "\\`b" nil nil 1)) + (should (equal (mapcar #'car attr) '("bar")))))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3370,25 +3483,80 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name nil quoted))) + (unwind-protect (progn - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (set-file-modes tmp-name #o777) - (should (= (file-modes tmp-name) #o777)) - (should (file-executable-p tmp-name)) - (should (file-writable-p tmp-name)) - (set-file-modes tmp-name #o444) - (should (= (file-modes tmp-name) #o444)) - (should-not (file-executable-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (set-file-modes tmp-name1 #o777) + (should (= (file-modes tmp-name1) #o777)) + (should (file-executable-p tmp-name1)) + (should (file-writable-p tmp-name1)) + (set-file-modes tmp-name1 #o444) + (should (= (file-modes tmp-name1) #o444)) + (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name))) - (should-not (file-writable-p tmp-name)))) + (file-attributes tmp-name1))) + (should-not (file-writable-p tmp-name1))) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-modes tmp-name1 #o222 'nofollow) + (should (= (file-modes tmp-name1 'nofollow) #o222))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name)))))) + (ignore-errors (delete-file tmp-name1))) + + ;; Check the NOFOLLOW arg. It exists since Emacs 28. It is + ;; implemented for tramp-gvfs.el and tramp-sh.el. However, + ;; tramp-gvfs,el does not support creating symbolic links. And + ;; in tramp-sh.el, we must ensure that the remote chmod command + ;; supports the "-h" argument. + (when (and (tramp--test-emacs28-p) (tramp--test-sh-p) + (tramp-get-remote-chmod-h tramp-test-vec)) + (unwind-protect + (with-no-warnings + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should + (string-equal + (funcall + (if quoted #'tramp-compat-file-name-unquote #'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + ;; Both report the modes of `tmp-name1'. + (should + (= (file-modes tmp-name1) (file-modes tmp-name2))) + ;; `tmp-name1' is a regular file. NOFOLLOW doesn't matter. + (should + (= (file-modes tmp-name1) (file-modes tmp-name1 'nofollow))) + ;; `tmp-name2' is a symbolic link. It has different permissions. + (should-not + (= (file-modes tmp-name2) (file-modes tmp-name2 'nofollow))) + (should-not + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + ;; Change permissions. + (set-file-modes tmp-name1 #o200) + (set-file-modes tmp-name2 #o200) + (should + (= (file-modes tmp-name1) (file-modes tmp-name2) #o200)) + ;; Change permissions with NOFOLLOW. + (set-file-modes tmp-name1 #o300 'nofollow) + (set-file-modes tmp-name2 #o300 'nofollow) + (should + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + (should-not (= (file-modes tmp-name1) (file-modes tmp-name2)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))))) ;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error. (defmacro tramp--test-ignore-add-name-to-file-error (&rest body) @@ -3472,7 +3640,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `tmp-name3' is a local file name. Therefore, the link ;; target remains unchanged, even if quoted. ;; `make-symbolic-link' might not be permitted on w32 systems. - (unless (tramp--test-windows-nt) + (unless (tramp--test-windows-nt-p) (make-symbolic-link tmp-name1 tmp-name3) (should (string-equal tmp-name1 (file-symlink-p tmp-name3)))) @@ -3586,7 +3754,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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) + (unless (tramp--test-windows-nt-p) (make-symbolic-link tmp-name1 tmp-name3) (should (file-symlink-p tmp-name3)) (should-not (string-equal tmp-name3 (file-truename tmp-name3))) @@ -3647,7 +3815,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) - (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (if (tramp--test-smb-p) ;; The symlink command of `smbclient' detects the ;; cycle already. (should-error @@ -3710,7 +3878,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-newer-than-file-p tmp-name2 tmp-name1)) ;; `tmp-name3' does not exist. (should (file-newer-than-file-p tmp-name2 tmp-name3)) - (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) + (should + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + (seconds-to-time 1))))))) ;; Cleanup. (ignore-errors @@ -3750,6 +3928,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check that `file-acl' and `set-file-acl' work proper." (skip-unless (tramp--test-enabled)) (skip-unless (file-acl tramp-test-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) (tramp--test-emacs27-p)) @@ -3828,6 +4007,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (equal (file-selinux-context tramp-test-temporary-file-directory) '(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) (tramp--test-emacs27-p)) @@ -3971,7 +4151,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (when (not (memq system-type '(cygwin windows-nt))) (let ((method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host)) - (vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) (orig-syntax tramp-syntax)) (when (and (stringp host) (string-match tramp-host-with-port-regexp host)) (setq host (match-string 1 host))) @@ -3984,7 +4163,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used ;; for completion. We must refill the cache. - (tramp-set-connection-property vec "property" nil) + (tramp-set-connection-property tramp-test-vec "property" nil) (let ;; This is needed for the `simplified' syntax. ((method-marker @@ -4040,10 +4219,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (tramp-change-syntax orig-syntax)))) - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((non-essential n-e) - (tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4133,6 +4311,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4211,6 +4390,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) @@ -4229,9 +4409,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4250,7 +4428,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-equal (buffer-string) "foo"))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4272,9 +4450,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4282,7 +4458,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; PTY. (unwind-protect (with-temp-buffer - (if (not (tramp--test-sh-p)) + ;; It works only for tramp-sh.el, and not direct async processes. + (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error (start-file-process "test4" (current-buffer) nil) :type 'wrong-type-argument) @@ -4296,13 +4473,37 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc)))))) +(defmacro tramp--test--deftest-direct-async-process + (test docstring &optional unstable) + "Define ert test `TEST-direct-async' for direct async processes. +If UNSTABLE is non-nil, the test is tagged as `:unstable'." + (declare (indent 1)) + `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () + ,docstring + :tags (if ,unstable '(:expensive-test :unstable) '(:expensive-test)) + (skip-unless (tramp--test-enabled)) + (let ((default-directory tramp-test-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. + (cl-letf (((symbol-function #'tramp--test-enabled) (lambda nil t))) + (file-truename tramp-test-temporary-file-directory) + (funcall (ert-test-body ert-test)))))) + +(tramp--test--deftest-direct-async-process tramp-test29-start-file-process + "Check direct async `start-file-process'.") + (ert-deftest tramp-test30-make-process () "Check `make-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - ;; `make-process' has been inserted in Emacs 25.1. It supports file - ;; name handlers since Emacs 27. + (skip-unless (not (tramp--test-crypt-p))) + ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -4328,9 +4529,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4351,7 +4550,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) (while (accept-process-output proc 0 nil t)))) - (should (string-equal (buffer-string) "foo"))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors @@ -4377,9 +4576,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-timeout (10 (tramp--test-timeout-handler)) (while (not (string-match "foo" (buffer-string))) (while (accept-process-output proc 0 nil t)))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should (string-match "\\`foo" (buffer-string)))) + (should (string-match "foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) @@ -4403,75 +4600,74 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) (while (accept-process-output proc 0 nil t))) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. And a remote macOS sends - ;; a slightly modified string. On MS Windows, - ;; `delete-process' sends an unknown signal. - (should - (string-match - (if (eq system-type 'windows-nt) - "unknown signal\n\\'" "killed.*\n\\'") - (buffer-string)))) + ;; On some MS Windows systems, it returns "unknown signal". + (should (string-match "unknown signal\\|killed" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) ;; Process with stderr buffer. - (let ((stderr (generate-new-buffer "*stderr*"))) - (unwind-protect - (with-temp-buffer - (setq proc - (with-no-warnings - (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/does-not-exist") - :stderr stderr - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc 0 nil t))) - (delete-process proc) - (with-current-buffer stderr - (should - (string-match - "cat:.* No such file or directory" (buffer-string))))) + (unless (tramp-direct-async-process-p) + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test5" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr stderr + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (delete-process proc) + (with-current-buffer stderr + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (kill-buffer stderr)))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (kill-buffer stderr))))) ;; Process with stderr file. - (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) - (unwind-protect - (with-temp-buffer - (setq proc - (with-no-warnings - (make-process - :name "test6" :buffer (current-buffer) - :command '("cat" "/does-not-exist") - :stderr tmpfile - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil t))) - (delete-process proc) + (unless (tramp-direct-async-process-p) + (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) + (unwind-protect (with-temp-buffer - (insert-file-contents tmpfile) - (should - (string-match - "cat:.* No such file or directory" (buffer-string))))) + (setq proc + (with-no-warnings + (make-process + :name "test6" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr tmpfile + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc nil nil t))) + (delete-process proc) + (with-temp-buffer + (insert-file-contents tmpfile) + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmpfile))))))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmpfile)))))))) + +(tramp--test--deftest-direct-async-process tramp-test30-make-process + "Check direct async `make-process'.") (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (boundp 'interrupt-process-functions)) @@ -4532,6 +4728,7 @@ INPUT, if non-nil, is a string sent to the process." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4625,6 +4822,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. (skip-unless (tramp--test-emacs27-p)) @@ -4748,6 +4946,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string '(;; Synchronously. @@ -4760,67 +4959,71 @@ INPUT, if non-nil, is a string sent to the process." (envvar (concat "VAR_" (upcase (md5 (current-time-string))))) kill-buffer-query-functions) - (unwind-protect - ;; Set a value. - (let ((process-environment - (cons (concat envvar "=foo") process-environment))) - ;; Default value. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))))) - - (unwind-protect - ;; Set the empty value. - (let ((process-environment - (cons (concat envvar "=") process-environment))) - ;; Value is null. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is set. - (should - (string-match - (regexp-quote envvar) - (funcall this-shell-command-to-string "set"))))) + ;; Check INSIDE_EMACS. + (setenv "INSIDE_EMACS") + (should + (string-equal + (format "%s,tramp:%s\n" emacs-version tramp-version) + (funcall this-shell-command-to-string "echo ${INSIDE_EMACS:-bla}"))) + (let ((process-environment + (cons (format "INSIDE_EMACS=%s,foo" emacs-version) + process-environment))) + (should + (string-equal + (format "%s,foo,tramp:%s\n" emacs-version tramp-version) + (funcall + this-shell-command-to-string "echo ${INSIDE_EMACS:-bla}")))) + + ;; Set a value. + (let ((process-environment + (cons (concat envvar "=foo") process-environment))) + ;; Default value. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo ${%s:-bla}" envvar))))) + + ;; Set the empty value. + (let ((process-environment + (cons (concat envvar "=") process-environment))) + ;; Value is null. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string (format "echo ${%s:-bla}" envvar)))) + ;; Variable is set. + (should + (string-match + (regexp-quote envvar) + (funcall this-shell-command-to-string "set")))) ;; We force a reconnect, in order to have a clean environment. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) - (unwind-protect - ;; Unset the variable. - (let ((tramp-remote-process-environment - (cons (concat envvar "=foo") - tramp-remote-process-environment))) - ;; Set the initial value, we want to unset below. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - (let ((process-environment - (cons envvar process-environment))) - ;; Variable is unset. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is unset. - (should-not - (string-match - (regexp-quote envvar) - ;; We must remove PS1, the output is truncated otherwise. - (funcall - this-shell-command-to-string "printenv | grep -v PS1"))))))))) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + ;; Unset the variable. + (let ((tramp-remote-process-environment + (cons (concat envvar "=foo") tramp-remote-process-environment))) + ;; Set the initial value, we want to unset below. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo ${%s:-bla}" envvar)))) + (let ((process-environment (cons envvar process-environment))) + ;; Variable is unset. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string (format "echo ${%s:-bla}" envvar)))) + ;; Variable is unset. + (should-not + (string-match + (regexp-quote envvar) + ;; We must remove PS1, the output is truncated otherwise. + (funcall + this-shell-command-to-string "printenv | grep -v PS1")))))))) ;; This test is inspired by Bug#27009. (ert-deftest tramp-test33-environment-variables-and-port-numbers () @@ -4829,6 +5032,7 @@ INPUT, if non-nil, is a string sent to the process." ;; We test it only for the mock-up connection; otherwise there might ;; be problems with the used ports. (skip-unless (and (eq tramp-syntax 'default) (tramp--test-mock-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; We force a reconnect, in order to have a clean environment. (dolist (dir `(,tramp-test-temporary-file-directory @@ -4851,7 +5055,7 @@ INPUT, if non-nil, is a string sent to the process." (should (string-match (number-to-string port) - (shell-command-to-string (format "echo -n $%s" envvar)))))) + (shell-command-to-string (format "echo $%s" envvar)))))) ;; Cleanup. (dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:")) @@ -4933,6 +5137,7 @@ INPUT, if non-nil, is a string sent to the process." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -4989,6 +5194,7 @@ INPUT, if non-nil, is a string sent to the process." "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -5032,6 +5238,7 @@ INPUT, if non-nil, is a string sent to the process." "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)) @@ -5039,23 +5246,20 @@ INPUT, if non-nil, is a string sent to the process." (default-directory tramp-test-temporary-file-directory) (orig-exec-path (with-no-warnings (exec-path))) (tramp-remote-path tramp-remote-path) - (orig-tramp-remote-path tramp-remote-path)) + (orig-tramp-remote-path tramp-remote-path) + 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-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (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-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path))) (setq tramp-remote-path orig-tramp-remote-path) @@ -5067,26 +5271,30 @@ INPUT, if non-nil, is a string sent to the process." (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) (should (file-directory-p dir)) (setq tramp-remote-path - (cons (file-remote-p dir 'localname) tramp-remote-path) + (append + tramp-remote-path `(,(file-remote-p dir 'localname))) orig-exec-path - (cons (file-remote-p dir 'localname) orig-exec-path)))) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (append + (butlast orig-exec-path) + `(,(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 - (string-equal - ;; Ignore trailing newline. - (substring (shell-command-to-string "echo $PATH") nil -1) + ;; Ignore trailing newline. + (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) + ;; The shell doesn't handle such long strings. + (unless (<= (length path) + (tramp-get-connection-property + tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. - (mapconcat #'identity (butlast orig-exec-path) ":"))) + (should + (string-equal + path (mapconcat #'identity (butlast orig-exec-path) ":")))) ;; The shell "sh" shall always exist. (should (apply #'executable-find '("sh" remote)))) ;; Cleanup. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (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))))) @@ -5095,6 +5303,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in @@ -5123,8 +5332,7 @@ INPUT, if non-nil, is a string sent to the process." tramp-remote-process-environment)) ;; We must force a reconnect, in order to activate $BZR_HOME. (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + tramp-test-vec 'keep-debug 'keep-password) '(Bzr)) (t nil)))) ;; Suppress nasty messages. @@ -5150,13 +5358,9 @@ INPUT, if non-nil, is a string sent to the process." (error (ert-skip "`vc-create-repo' not supported"))) ;; The structure of VC-FILESET is not documented. Let's ;; hope it won't change. - (condition-case nil - (vc-register - (list (car vc-handled-backends) - (list (file-name-nondirectory tmp-name2)))) - ;; `vc-register' has changed its arguments in Emacs - ;; 25.1. Let's skip it for older Emacsen. - (error (skip-unless (tramp--test-emacs25-p)))) + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) ;; vc-git uses an own process sentinel, Tramp's sentinel ;; for flushing the cache isn't used. (dired-uncache (concat (file-remote-p default-directory) "/")) @@ -5413,12 +5617,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-emacs25-p () - "Check for Emacs version >= 25.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 25)) - (defun tramp--test-emacs26-p () "Check for Emacs version >= 26.1. Some semantics has been changed for there, w/o new functions or @@ -5454,6 +5652,10 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-crypt-p () + "Check, whether the remote directory is crypted" + (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -5509,9 +5711,8 @@ This does not support special file names." (defun tramp--test-sh-p () "Check, whether the remote host runs a based method from tramp-sh.el." - (eq - (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) - 'tramp-sh-file-name-handler)) + (tramp-sh-file-name-handler-p + (tramp-dissect-file-name tramp-test-temporary-file-directory))) (defun tramp--test-share-p () "Check, whether the method needs a share." @@ -5524,11 +5725,11 @@ This does not support special file names." "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) -(defun tramp--test-windows-nt () +(defun tramp--test-windows-nt-p () "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) -(defun tramp--test-windows-nt-and-batch () +(defun tramp--test-windows-nt-and-batch-p () "Check, whether the locale host runs MS Windows in batch mode. This does not support special characters." (and (eq system-type 'windows-nt) noninteractive)) @@ -5545,7 +5746,12 @@ This does not support utf8 based file transfer." "Check, whether the locale or remote host runs MS Windows. This requires restrictions of file name syntax." (or (eq system-type 'windows-nt) - (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + (tramp--test-smb-p))) + +(defun tramp--test-smb-p () + "Check, whether the locale or remote host runs MS Windows. +This requires restrictions of file name syntax." + (tramp-smb-file-name-p tramp-test-temporary-file-directory)) (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." @@ -5669,8 +5875,7 @@ This requires restrictions of file name syntax." ;; It does not work in the "smb" case, only relative ;; symlinks to existing files are shown there. (tramp--test-ignore-make-symbolic-link-error - (unless - (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (unless (tramp--test-smb-p) (make-symbolic-link file2 file3) (should (file-symlink-p file3)) (should @@ -5697,6 +5902,7 @@ This requires restrictions of file name syntax." ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) @@ -5830,7 +6036,7 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (let ((tramp-connection-properties @@ -5864,18 +6070,28 @@ Use the `ls' command." "银河系漫游指南系列" "Автостопом по гала́ктике" ;; Use codepoints without a name. See Bug#31272. - "bung") + "bung" + ;; Use codepoints from Supplementary Multilingual Plane (U+10000 + ;; to U+1FFFF). + "🌈🍒👋") (when (tramp--test-expensive-test) (delete-dups (mapcar - ;; Use all available language specific snippets. Filter out - ;; strings which use unencodable characters. + ;; Use all available language specific snippets. (lambda (x) (and (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) - (not (unencodable-char-position - 0 (length x) file-name-coding-system nil x)) + ;; Filter out strings which use unencodable characters. + (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) + (unencodable-char-position + 0 (length x) file-name-coding-system nil x))) + ;; Filter out not displayable characters. + (setq x (mapconcat + (lambda (y) + (and (char-displayable-p y) (char-to-string y))) + x "")) + (not (string-empty-p x)) ;; ?\n and ?/ shouldn't be part of any file name. ?\t, ;; ?. and ?? do not work for "smb" method. (replace-regexp-in-string "[\t\n/.?]" "" x))) @@ -5886,9 +6102,10 @@ Use the `ls' command." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (tramp--test-utf8)) @@ -5900,9 +6117,10 @@ Use the `stat' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -5921,9 +6139,10 @@ Use the `perl' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -5945,9 +6164,10 @@ Use the `ls' command." (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-batch))) + (skip-unless (not (tramp--test-windows-nt-and-batch-p))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (let ((tramp-connection-properties (append @@ -6029,6 +6249,7 @@ process sentinels. They shall not disturb each other." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-timeout (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) @@ -6038,7 +6259,7 @@ process sentinels. They shall not disturb each other." (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) ;; It doesn't work on w32 systems. (watchdog - (unless (tramp--test-windows-nt) + (unless (tramp--test-windows-nt-p) (start-process-shell-command "*watchdog*" nil (format @@ -6089,10 +6310,7 @@ process sentinels. They shall not disturb each other." 0 timer-repeat (lambda () (tramp--test-with-proper-process-name-and-buffer - (get-buffer-process - (tramp-get-buffer - (tramp-dissect-file-name - tramp-test-temporary-file-directory))) + (get-buffer-process (tramp-get-buffer tramp-test-vec)) (when (> (- (time-to-seconds) (time-to-seconds timer-start)) tramp--test-asynchronous-requests-timeout) (tramp--test-timeout-handler)) @@ -6360,12 +6578,14 @@ Since it unloads Tramp, it shall be the last test to run." (and (or (and (boundp x) (null (local-variable-if-set-p x))) (and (functionp x) (null (autoloadp (symbol-function x))))) (string-match "^tramp" (symbol-name x)) + ;; `tramp-completion-mode' is autoloaded in Emacs < 28.1. + (not (eq 'tramp-completion-mode x)) (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) (not (string-match "unload-hook$" (symbol-name x))) (ert-fail (format "`%s' still bound" x))))) ;; The defstruct `tramp-file-name' and all its internal functions - ;; shall be purged. `cl--find-class' must be protected in Emacs 24. - (with-no-warnings (should-not (cl--find-class 'tramp-file-name))) + ;; shall be purged. + (should-not (cl--find-class 'tramp-file-name)) (mapatoms (lambda (x) (and (functionp x) @@ -6397,6 +6617,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p +;; * tramp-get-remote-gid +;; * tramp-get-remote-uid ;; * tramp-set-file-uid-gid ;; * Work on skipped tests. Make a comment, when it is impossible. @@ -6405,9 +6627,11 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' ;; do not work properly for `nextcloud'. -;; * Implement `tramp-test31-interrupt-process' for `adb'. +;; * Implement `tramp-test31-interrupt-process' for `adb' and for +;; direct async processes. ;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. A remote ;; file name operation cannot run in the timer. Remove `:unstable' tag? (provide 'tramp-tests) + ;;; tramp-tests.el ends here diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el new file mode 100644 index 00000000000..47569c948f5 --- /dev/null +++ b/test/lisp/net/webjump-tests.el @@ -0,0 +1,73 @@ +;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'webjump) + +(ert-deftest webjump-tests-builtin () + (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org"))) + +(ert-deftest webjump-tests-builtin-check-args () + (should (webjump-builtin-check-args [1 2 3] "Foo" 2)) + (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3))) + +(ert-deftest webjump-tests-mirror-default () + (should (equal (webjump-mirror-default + '("https://ftp.gnu.org/pub/gnu/" + "https://ftpmirror.gnu.org")) + "https://ftp.gnu.org/pub/gnu/"))) + +(ert-deftest webjump-tests-null-or-blank-string-p () + (should (webjump-null-or-blank-string-p nil)) + (should (webjump-null-or-blank-string-p "")) + (should (webjump-null-or-blank-string-p " ")) + (should-not (webjump-null-or-blank-string-p " . "))) + +(ert-deftest webjump-tests-url-encode () + (should (equal (webjump-url-encode "") "")) + (should (equal (webjump-url-encode "a b c") "a+b+c")) + (should (equal (webjump-url-encode "foo?") "foo%3F")) + (should (equal (webjump-url-encode "/foo\\") "/foo%5C")) + (should (equal (webjump-url-encode "f&o") "f%26o"))) + +(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 "ftp.x.org") "ftp://ftp.x.org/")) + (should (equal (webjump-url-fix "https://gnu.org") + "https://gnu.org/"))) + +(ert-deftest webjump-tests-url-fix-trailing-slash () + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org") + "https://gnu.org/")) + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/") + "https://gnu.org/"))) + +(provide 'webjump-tests) +;;; webjump-tests.el ends here diff --git a/test/lisp/nxml/nxml-mode-tests.el b/test/lisp/nxml/nxml-mode-tests.el index 624e5c8866d..54d3bd8d132 100644 --- a/test/lisp/nxml/nxml-mode-tests.el +++ b/test/lisp/nxml/nxml-mode-tests.el @@ -132,5 +132,26 @@ <sub/> </t>")))) +(ert-deftest nxml-mode-test-comment-bug-17264 () + "Test for Bug#17264." + (with-temp-buffer + (nxml-mode) + (let ((data "<?xml version=\"1.0\" encoding=\"UTF-8\"?> +<spocosy version=\"1.0\" responsetime=\"2011-03-15 13:53:12\" exec=\"0.171\"> + <!-- + <query-response requestid=\"\" service=\"objectquery\"> + <sport name=\"Soccer\" enetSportCode=\"s\" del=\"no\" n=\"1\" ut=\"2009-12-29 + 15:36:24\" id=\"1\"> + </sport> + </query-response> + --> +</spocosy> +")) + (insert data) + (goto-char (point-min)) + (search-forward "<query-response") + ;; Inside comment + (should (eq (nth 4 (syntax-ppss)) t))))) + (provide 'nxml-mode-tests) ;;; nxml-mode-tests.el ends here diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el index 37061df0a7a..3f3fda3638e 100644 --- a/test/lisp/obsolete/cl-tests.el +++ b/test/lisp/obsolete/cl-tests.el @@ -21,7 +21,8 @@ ;;; Code: -(require 'cl) +(with-no-warnings + (require 'cl)) (require 'ert) diff --git a/test/lisp/org/org-tests.el b/test/lisp/org/org-tests.el index 918d79b8dcd..6e91dd28649 100644 --- a/test/lisp/org/org-tests.el +++ b/test/lisp/org/org-tests.el @@ -1,4 +1,4 @@ -;;; org-tests.el --- tests for org/org.el +;;; org-tests.el --- tests for org/org.el -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/password-cache-tests.el b/test/lisp/password-cache-tests.el index 01f4358fc59..55ebbfce7fe 100644 --- a/test/lisp/password-cache-tests.el +++ b/test/lisp/password-cache-tests.el @@ -28,31 +28,31 @@ (ert-deftest password-cache-tests-add-and-remove () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (eq (password-in-cache-p "foo") t)) (password-cache-remove "foo") (should (not (password-in-cache-p "foo"))))) (ert-deftest password-cache-tests-read-from-cache () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (equal (password-read-from-cache "foo") "bar")) (should (not (password-read-from-cache nil))))) (ert-deftest password-cache-tests-in-cache-p () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (password-in-cache-p "foo")) (should (not (password-read-from-cache nil))))) (ert-deftest password-cache-tests-read () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (equal (password-read nil "foo") "bar")))) (ert-deftest password-cache-tests-reset () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (password-reset) (should (not (password-in-cache-p "foo"))))) @@ -60,14 +60,14 @@ :tags '(:expensive-test) (let ((password-data (copy-hash-table password-data)) (password-cache-expiry 0.01)) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (sit-for 0.1) (should (not (password-in-cache-p "foo"))))) (ert-deftest password-cache-tests-no-password-cache () (let ((password-data (copy-hash-table password-data)) (password-cache nil)) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (not (password-in-cache-p "foo"))) (should (not (password-read-from-cache "foo"))))) diff --git a/test/lisp/pcmpl-linux-resources/fs/ext4/.keep b/test/lisp/pcmpl-linux-resources/fs/ext4/.keep new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/pcmpl-linux-resources/fs/ext4/.keep diff --git a/test/lisp/pcmpl-linux-resources/mtab b/test/lisp/pcmpl-linux-resources/mtab new file mode 100644 index 00000000000..ea33abd7b0a --- /dev/null +++ b/test/lisp/pcmpl-linux-resources/mtab @@ -0,0 +1,11 @@ +/dev/sdb1 / ext3 rw,relatime,errors=remount-ro 0 0 +proc /proc proc rw,noexec,nosuid,nodev 0 0 +/sys /sys sysfs rw,noexec,nosuid,nodev 0 0 +varrun /var/run tmpfs rw,noexec,nosuid,nodev,mode=0755 0 0 +varlock /var/lock tmpfs rw,noexec,nosuid,nodev,mode=1777 0 0 +udev /dev tmpfs rw,mode=0755 0 0 +devshm /dev/shm tmpfs rw 0 0 +devpts /dev/pts devpts rw,gid=5,mode=620 0 0 +lrm /lib/modules/2.6.24-16-generic/volatile tmpfs rw 0 0 +securityfs /sys/kernel/security securityfs rw 0 0 +gvfs-fuse-daemon /home/alice/.gvfs fuse.gvfs-fuse-daemon rw,nosuid,nodev,user=alice 0 0 diff --git a/test/lisp/pcmpl-linux-tests.el b/test/lisp/pcmpl-linux-tests.el new file mode 100644 index 00000000000..91a9965483a --- /dev/null +++ b/test/lisp/pcmpl-linux-tests.el @@ -0,0 +1,43 @@ +;;; pcmpl-linux-tests.el --- Tests for pcmpl-linux.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'ert-x) +(require 'pcmpl-linux) + +(ert-deftest pcmpl-linux-test-fs-types () + (let ((pcmpl-linux-fs-modules-path-format (ert-resource-file "fs"))) + ;; FIXME: Shouldn't return "." and ".." + (should (equal (pcmpl-linux-fs-types) + '("." ".." "ext4"))))) + +(ert-deftest pcmpl-linux-test-mounted-directories () + (let ((pcmpl-linux-mtab-file (ert-resource-file "mtab"))) + (should (equal (pcmpl-linux-mounted-directories) + '("/" "/dev" "/dev/pts" "/dev/shm" "/home/alice/.gvfs" + "/lib/modules/2.6.24-16-generic/volatile" "/proc" "/sys" + "/sys/kernel/security" "/var/lock" "/var/run"))))) + +(provide 'pcmpl-linux-tests) + +;;; pcmpl-linux-tests.el ends here diff --git a/test/lisp/play/animate-tests.el b/test/lisp/play/animate-tests.el new file mode 100644 index 00000000000..7c41d3b7761 --- /dev/null +++ b/test/lisp/play/animate-tests.el @@ -0,0 +1,56 @@ +;;; animate-tests.el --- Tests for animate.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'animate) + +(ert-deftest animate-test-birthday-present () + (unwind-protect + (save-window-excursion + (cl-letf (((symbol-function 'sit-for) (lambda (_) nil))) + (animate-birthday-present "foo") + (should (equal (buffer-string) + " + + + + + + Happy Birthday, + Foo + + + You are my sunshine, + My only sunshine. + I'm awful sad that + You've moved away. + + Let's talk together + And love more deeply. + Please bring back + my sunshine + to stay!")))) + (kill-buffer "*A-Present-for-Foo*"))) + +(provide 'animate-tests) +;;; animate-tests.el ends here diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el new file mode 100644 index 00000000000..e8d903109fc --- /dev/null +++ b/test/lisp/play/dissociate-tests.el @@ -0,0 +1,38 @@ +;;; dissociate-tests.el --- Tests for dissociate.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'dissociate) + +(ert-deftest dissociate-tests-dissociated-press () + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) + ((symbol-function 'random) (lambda (_) 10))) + (save-window-excursion + (with-temp-buffer + (insert "Lorem ipsum dolor sit amet") + (dissociated-press) + (should (string-match-p "dolor sit ametdolor sit amdolor sit amdolor sit am" + (buffer-string))))))) + +(provide 'dissociate-tests) +;;; dissociate-tests.el ends here diff --git a/test/lisp/play/fortune-resources/fortunes b/test/lisp/play/fortune-resources/fortunes new file mode 100644 index 00000000000..f1ddc512d00 --- /dev/null +++ b/test/lisp/play/fortune-resources/fortunes @@ -0,0 +1,11 @@ +Embarrassed +Manual-Writer +Accused of +Communist +Subversion +% +Embarrassingly +Mundane +Advertising +Cuts +Sales diff --git a/test/lisp/play/fortune-tests.el b/test/lisp/play/fortune-tests.el new file mode 100644 index 00000000000..97263405e8a --- /dev/null +++ b/test/lisp/play/fortune-tests.el @@ -0,0 +1,41 @@ +;;; fortune-tests.el --- Tests for fortune.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) +(require 'ert-x) +(require 'fortune) + +(defvar fortune-tests--regexp + (rx (| "Embarrassed" "Embarrassingly"))) + +(ert-deftest test-fortune () + (skip-unless (executable-find "fortune")) + (unwind-protect + (let ((fortune-file (ert-resource-file "fortunes"))) + (fortune) + (goto-char (point-min)) + (should (looking-at fortune-tests--regexp))) + (kill-buffer fortune-buffer-name))) + +(provide 'fortune-tests) +;;; fortune-tests.el ends here diff --git a/test/lisp/play/life-tests.el b/test/lisp/play/life-tests.el new file mode 100644 index 00000000000..38726bbc416 --- /dev/null +++ b/test/lisp/play/life-tests.el @@ -0,0 +1,80 @@ +;;; life-tests.el --- Tests for life.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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 'life) + +(ert-deftest test-life () + (let ((life--max-width 5) + (life--max-height 3) + (life-patterns [(" @ " + " @" + "@@@")]) + (generations '(" + + @ + @ + @@@ +" " + + + @ @ + @@ + @ +" " + + + @ + @ @ + @@ +" " + + + @ + @@ + @@ +" " + + + @ + @ + @@@ +" +))) + (life-setup) + ;; Test initial state. + (goto-char (point-min)) + (dolist (generation generations) + ;; Hack to test buffer contents without trailing whitespace, + ;; while also not modifying the "*Life*" buffer. + (let ((str (buffer-string)) + (delete-trailing-lines t)) + (with-temp-buffer + (insert str) + (delete-trailing-whitespace) + (should (equal (buffer-string) generation)))) + (life--tick)))) + +(provide 'life-tests) + +;;; life-tests.el ends here diff --git a/test/lisp/progmodes/autoconf-tests.el b/test/lisp/progmodes/autoconf-tests.el new file mode 100644 index 00000000000..63cf2889ee2 --- /dev/null +++ b/test/lisp/progmodes/autoconf-tests.el @@ -0,0 +1,55 @@ +;;; autoconf-tests.el --- Tests for autoconf.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'autoconf) +(require 'ert) + +(ert-deftest autoconf-tests-current-defun-function-define () + (with-temp-buffer + (insert "AC_DEFINE(HAVE_RSVG, 1, [Define to 1 if using librsvg.])") + (goto-char (point-min)) + (should-not (autoconf-current-defun-function)) + (forward-char 10) + (should (equal (autoconf-current-defun-function) "HAVE_RSVG")))) + +(ert-deftest autoconf-tests-current-defun-function-subst () + (with-temp-buffer + (insert "AC_SUBST(srcdir)") + (goto-char (point-min)) + (should-not (autoconf-current-defun-function)) + (forward-char 9) + (should (equal (autoconf-current-defun-function) "srcdir")))) + +(ert-deftest autoconf-tests-autoconf-mode-comment-syntax () + (with-temp-buffer + (autoconf-mode) + (insert "dnl Autoconf script for GNU Emacs") + (should (nth 4 (syntax-ppss))))) + +(provide 'autoconf-tests) +;;; autoconf-tests.el ends here diff --git a/test/lisp/progmodes/cc-mode-tests.el b/test/lisp/progmodes/cc-mode-tests.el index 0729841ce6f..64d52a952b6 100644 --- a/test/lisp/progmodes/cc-mode-tests.el +++ b/test/lisp/progmodes/cc-mode-tests.el @@ -40,7 +40,7 @@ (insert content) (setq mode nil) (c-or-c++-mode) - (unless(eq expected mode) + (unless (eq expected mode) (ert-fail (format "expected %s but got %s when testing '%s'" expected mode content))))) @@ -53,11 +53,18 @@ (funcall do-test (concat " * " content) 'c-mode)) '("using \t namespace \t std;" "using \t std::string;" + "using Foo = Bar;" "namespace \t {" "namespace \t foo \t {" - "class \t Blah_42 \t {" + "namespace \t foo::bar \t {" + "inline namespace \t foo \t {" + "inline namespace \t foo::bar \t {" "class \t Blah_42 \t \n" + "class \t Blah_42;" + "class \t Blah_42 \t final {" + "struct \t Blah_42 \t final {" "class \t _42_Blah:public Foo {" + "struct \t _42_Blah:public Foo {" "template \t < class T >" "template< class T >" "#include <string>" @@ -67,6 +74,7 @@ (mapc (lambda (content) (funcall do-test content 'c-mode)) '("struct \t Blah_42 \t {" "struct template {" + "struct Blah;" "#include <string.h>"))))) (ert-deftest c-mode-macro-comment () @@ -78,4 +86,25 @@ (insert macro-string) (c-mode)))) +(ert-deftest c-lineup-ternary-bodies () + "Test for c-lineup-ternary-bodies function" + (with-temp-buffer + (c-mode) + (let* ((common-prefix "int value = condition ") + (expected-column (length common-prefix))) + (dolist (test '(("? a : \n b" . nil) + ("? a \n ::b" . nil) + ("a \n : b" . nil) + ("? a \n : b" . t) + ("? ::a \n : b" . t) + ("? (p ? q : r) \n : b" . t) + ("? p ?: q \n : b" . t) + ("? p ? : q \n : b" . t) + ("? p ? q : r \n : b" . t))) + (delete-region (point-min) (point-max)) + (insert common-prefix (car test)) + (should (equal + (and (cdr test) (vector expected-column)) + (c-lineup-ternary-bodies '(statement-cont . 1)))))))) + ;;; cc-mode-tests.el ends here diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 75962566f14..0288cba789e 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -35,311 +35,358 @@ ;; what's reported in the string. The end column numbers are for ;; the character after, so it matches what's reported in the string. '(;; absoft - ("Error on line 3 of t.f: Execution error unclassifiable statement" + (absoft + "Error on line 3 of t.f: Execution error unclassifiable statement" 1 nil 3 "t.f") - ("Line 45 of \"foo.c\": bloofle undefined" + (absoft "Line 45 of \"foo.c\": bloofle undefined" 1 nil 45 "foo.c") - ("error on line 19 of fplot.f: spelling error?" + (absoft "error on line 19 of fplot.f: spelling error?" 1 nil 19 "fplot.f") - ("warning on line 17 of fplot.f: data type is undefined for variable d" + (absoft + "warning on line 17 of fplot.f: data type is undefined for variable d" 1 nil 17 "fplot.f") ;; Ada & Mpatrol - ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + (gnu "foo.adb:61:11: [...] in call to size declared at foo.ads:11" 1 11 61 "foo.adb") - ("foo.adb:61:11: [...] in call to size declared at foo.ads:11" + (ada "foo.adb:61:11: [...] in call to size declared at foo.ads:11" 52 nil 11 "foo.ads") - (" 0x8008621 main+16 at error.c:17" + (ada " 0x8008621 main+16 at error.c:17" 23 nil 17 "error.c") ;; aix - ("****** Error number 140 in line 8 of file errors.c ******" + (aix "****** Error number 140 in line 8 of file errors.c ******" 25 nil 8 "errors.c") ;; ant - ("[javac] /src/DataBaseTestCase.java:27: unreported exception ..." + (ant "[javac] /src/DataBaseTestCase.java:27: unreported exception ..." 13 nil 27 "/src/DataBaseTestCase.java" 2) - ("[javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally" + (ant "[javac] /src/DataBaseTestCase.java:49: warning: finally clause cannot complete normally" 13 nil 49 "/src/DataBaseTestCase.java" 1) - ("[jikes] foo.java:3:5:7:9: blah blah" + (ant "[jikes] foo.java:3:5:7:9: blah blah" 14 (5 . 10) (3 . 7) "foo.java" 2) - ("[javac] c:/cygwin/Test.java:12: error: foo: bar" + (ant "[javac] c:/cygwin/Test.java:12: error: foo: bar" 9 nil 12 "c:/cygwin/Test.java" 2) - ("[javac] c:\\cygwin\\Test.java:87: error: foo: bar" + (ant "[javac] c:\\cygwin\\Test.java:87: error: foo: bar" 9 nil 87 "c:\\cygwin\\Test.java" 2) ;; Checkstyle error, but ant reports a warning (note additional ;; severity level after task name) - ("[checkstyle] [ERROR] /src/Test.java:38: warning: foo" + (ant "[checkstyle] [ERROR] /src/Test.java:38: warning: foo" 22 nil 38 "/src/Test.java" 1) ;; bash - ("a.sh: line 1: ls-l: command not found" + (bash "a.sh: line 1: ls-l: command not found" 1 nil 1 "a.sh") ;; borland - ("Error ping.c 15: Unable to open include file 'sys/types.h'" + (borland "Error ping.c 15: Unable to open include file 'sys/types.h'" 1 nil 15 "ping.c") - ("Warning pong.c 68: Call to function 'func' with no prototype" + (borland "Warning pong.c 68: Call to function 'func' with no prototype" 1 nil 68 "pong.c") - ("Error E2010 ping.c 15: Unable to open include file 'sys/types.h'" + (borland "Error E2010 ping.c 15: Unable to open include file 'sys/types.h'" 1 nil 15 "ping.c") - ("Warning W1022 pong.c 68: Call to function 'func' with no prototype" + (borland + "Warning W1022 pong.c 68: Call to function 'func' with no prototype" 1 nil 68 "pong.c") ;; caml - ("File \"foobar.ml\", lines 5-8, characters 20-155: blah blah" + (python-tracebacks-and-caml + "File \"foobar.ml\", lines 5-8, characters 20-155: blah blah" 1 (20 . 156) (5 . 8) "foobar.ml") - ("File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26: unused variable equ." + (python-tracebacks-and-caml + "File \"F:\\ocaml\\sorting.ml\", line 65, characters 2-145:\nWarning 26: unused variable equ." 1 (2 . 146) 65 "F:\\ocaml\\sorting.ml") - ("File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in add_children" + (python-tracebacks-and-caml + "File \"/usr/share/gdesklets/display/TargetGauge.py\", line 41, in add_children" 1 nil 41 "/usr/share/gdesklets/display/TargetGauge.py") - ("File \\lib\\python\\Products\\PythonScripts\\PythonScript.py, line 302, in _exec" + (python-tracebacks-and-caml + "File \\lib\\python\\Products\\PythonScripts\\PythonScript.py, line 302, in _exec" 1 nil 302 "\\lib\\python\\Products\\PythonScripts\\PythonScript.py") - ("File \"/tmp/foo.py\", line 10" + (python-tracebacks-and-caml + "File \"/tmp/foo.py\", line 10" 1 nil 10 "/tmp/foo.py") ;; clang-include - ("In file included from foo.cpp:2:" + (clang-include "In file included from foo.cpp:2:" 1 nil 2 "foo.cpp" 0) ;; cmake cmake-info - ("CMake Error at CMakeLists.txt:23 (hurz):" + (cmake "CMake Error at CMakeLists.txt:23 (hurz):" 1 nil 23 "CMakeLists.txt") - ("CMake Warning at cmake/modules/UseUG.cmake:73 (find_package):" + (cmake "CMake Warning at cmake/modules/UseUG.cmake:73 (find_package):" 1 nil 73 "cmake/modules/UseUG.cmake") - (" cmake/modules/DuneGridMacros.cmake:19 (include)" + (cmake-info " cmake/modules/DuneGridMacros.cmake:19 (include)" 1 nil 19 "cmake/modules/DuneGridMacros.cmake") ;; comma - ("\"foo.f\", line 3: Error: syntax error near end of statement" + (comma "\"foo.f\", line 3: Error: syntax error near end of statement" 1 nil 3 "foo.f") - ("\"vvouch.c\", line 19.5: 1506-046 (S) Syntax error." + (comma "\"vvouch.c\", line 19.5: 1506-046 (S) Syntax error." 1 5 19 "vvouch.c") - ("\"foo.c\", line 32 pos 1; (E) syntax error; unexpected symbol: \"lossage\"" + (comma "\"foo.c\", line 32 pos 1; (E) syntax error; unexpected symbol: \"lossage\"" 1 1 32 "foo.c") - ("\"foo.adb\", line 2(11): warning: file name does not match ..." + (comma "\"foo.adb\", line 2(11): warning: file name does not match ..." 1 11 2 "foo.adb") - ("\"src/swapping.c\", line 30.34: 1506-342 (W) \"/*\" detected in comment." + (comma + "\"src/swapping.c\", line 30.34: 1506-342 (W) \"/*\" detected in comment." 1 34 30 "src/swapping.c") ;; cucumber - ("Scenario: undefined step # features/cucumber.feature:3" + (cucumber "Scenario: undefined step # features/cucumber.feature:3" 29 nil 3 "features/cucumber.feature") - (" /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" + (gnu " /home/gusev/.rvm/foo/bar.rb:500:in `_wrap_assertion'" 1 nil 500 "/home/gusev/.rvm/foo/bar.rb") ;; edg-1 edg-2 - ("build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" + (edg-1 "build/intel/debug/../../../struct.cpp(42): error: identifier \"foo\" is undefined" 1 nil 42 "build/intel/debug/../../../struct.cpp") - ("build/intel/debug/struct.cpp(44): warning #1011: missing return statement at end of" + (edg-1 "build/intel/debug/struct.cpp(44): warning #1011: missing return statement at end of" 1 nil 44 "build/intel/debug/struct.cpp") - ("build/intel/debug/iptr.h(302): remark #981: operands are evaluated in unspecified order" + (edg-1 "build/intel/debug/iptr.h(302): remark #981: operands are evaluated in unspecified order" 1 nil 302 "build/intel/debug/iptr.h") - (" detected during ... at line 62 of \"build/intel/debug/../../../trace.h\"" + (edg-2 " detected during ... at line 62 of \"build/intel/debug/../../../trace.h\"" 31 nil 62 "build/intel/debug/../../../trace.h") ;; epc - ("Error 24 at (2:progran.f90) : syntax error" + (epc "Error 24 at (2:progran.f90) : syntax error" 1 nil 2 "progran.f90") ;; ftnchek - (" Dummy arg W in module SUBA line 8 file arrayclash.f is array" + (ftnchek " Dummy arg W in module SUBA line 8 file arrayclash.f is array" 32 nil 8 "arrayclash.f") - (" L4 used at line 55 file test/assign.f; never set" + (ftnchek " L4 used at line 55 file test/assign.f; never set" 16 nil 55 "test/assign.f") - ("Warning near line 10 file arrayclash.f: Module contains no executable" + (ftnchek + "Warning near line 10 file arrayclash.f: Module contains no executable" 1 nil 10 "arrayclash.f") - ("Nonportable usage near line 31 col 9 file assign.f: mixed default and explicit" + (ftnchek "Nonportable usage near line 31 col 9 file assign.f: mixed default and explicit" 24 9 31 "assign.f") ;; iar - ("\"foo.c\",3 Error[32]: Error message" + (iar "\"foo.c\",3 Error[32]: Error message" 1 nil 3 "foo.c") - ("\"foo.c\",3 Warning[32]: Error message" + (iar "\"foo.c\",3 Warning[32]: Error message" 1 nil 3 "foo.c") ;; ibm - ("foo.c(2:0) : informational EDC0804: Function foo is not referenced." + (ibm "foo.c(2:0) : informational EDC0804: Function foo is not referenced." 1 0 2 "foo.c") - ("foo.c(3:8) : warning EDC0833: Implicit return statement encountered." + (ibm "foo.c(3:8) : warning EDC0833: Implicit return statement encountered." 1 8 3 "foo.c") - ("foo.c(5:5) : error EDC0350: Syntax error." + (ibm "foo.c(5:5) : error EDC0350: Syntax error." 1 5 5 "foo.c") ;; irix - ("ccom: Error: foo.c, line 2: syntax error" + (irix "ccom: Error: foo.c, line 2: syntax error" 1 nil 2 "foo.c") - ("cc: Severe: /src/Python-2.3.3/Modules/_curses_panel.c, line 17: Cannot find file <panel.h> ..." + (irix "cc: Severe: /src/Python-2.3.3/Modules/_curses_panel.c, line 17: Cannot find file <panel.h> ..." 1 nil 17 "/src/Python-2.3.3/Modules/_curses_panel.c") - ("cc: Info: foo.c, line 27: ..." + (irix "cc: Info: foo.c, line 27: ..." 1 nil 27 "foo.c") - ("cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ..." + (irix + "cfe: Warning 712: foo.c, line 2: illegal combination of pointer and ..." 1 nil 2 "foo.c") - ("cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ..." + (irix + "cfe: Warning 600: xfe.c: 170: Not in a conditional directive while ..." 1 nil 170 "xfe.c") - ("/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah" + (irix "/usr/lib/cmplrs/cc/cfe: Error: foo.c: 1: blah blah" 1 nil 1 "foo.c") - ("/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah" + (irix "/usr/lib/cmplrs/cc/cfe: warning: foo.c: 1: blah blah" 1 nil 1 "foo.c") - ("foo bar: baz.f, line 27: ..." + (irix "foo bar: baz.f, line 27: ..." 1 nil 27 "baz.f") ;; java - ("\tat org.foo.ComponentGateway.doGet(ComponentGateway.java:172)" + (java "\tat org.foo.ComponentGateway.doGet(ComponentGateway.java:172)" 5 nil 172 "ComponentGateway.java") - ("\tat javax.servlet.http.HttpServlet.service(HttpServlet.java:740)" + (java "\tat javax.servlet.http.HttpServlet.service(HttpServlet.java:740)" 5 nil 740 "HttpServlet.java") - ("==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217)" + (java "==1332== at 0x4040743C: System::getErrorString() (../src/Lib/System.cpp:217)" 13 nil 217 "../src/Lib/System.cpp") - ("==1332== by 0x8008621: main (vtest.c:180)" + (java "==1332== by 0x8008621: main (vtest.c:180)" 13 nil 180 "vtest.c") + ;; javac + (javac + "/src/Test.java:5: ';' expected\n foo foo\n ^\n" + 1 16 5 "/src/Test.java" 2) + (javac + "e:\\src\\Test.java:7: warning: ';' expected\n foo foo\n ^\n" + 1 11 7 "e:\\src\\Test.java" 1) ;; jikes-file jikes-line - ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" + (jikes-file + "Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" 1 nil nil "../javax/swing/BorderFactory.java") - ("Issued 1 semantic warning compiling \"java/awt/Toolkit.java\":" + (jikes-file "Issued 1 semantic warning compiling \"java/awt/Toolkit.java\":" 1 nil nil "java/awt/Toolkit.java") ;; gcc-include - ("In file included from /usr/include/c++/3.3/backward/warn.h:4," + (gcc-include "In file included from /usr/include/c++/3.3/backward/warn.h:4," 1 nil 4 "/usr/include/c++/3.3/backward/warn.h") - (" from /usr/include/c++/3.3/backward/iostream.h:31:0," + (gcc-include + " from /usr/include/c++/3.3/backward/iostream.h:31:0," 1 0 31 "/usr/include/c++/3.3/backward/iostream.h") - (" from test_clt.cc:1:" + (gcc-include " from test_clt.cc:1:" 1 nil 1 "test_clt.cc") ;; gmake - ("make: *** [Makefile:20: all] Error 2" 12 nil 20 "Makefile" 0) - ("make[4]: *** [sub/make.mk:19: all] Error 127" 15 nil 19 "sub/make.mk" 0) - ("gmake[4]: *** [sub/make.mk:19: all] Error 2" 16 nil 19 "sub/make.mk" 0) - ("gmake-4.3[4]: *** [make.mk:1119: all] Error 2" 20 nil 1119 "make.mk" 0) - ("Make-4.3: *** [make.INC:1119: dir/all] Error 2" 16 nil 1119 "make.INC" 0) + (gmake "make: *** [Makefile:20: all] Error 2" 12 nil 20 "Makefile" 0) + (gmake "make[4]: *** [sub/make.mk:19: all] Error 127" 15 nil 19 + "sub/make.mk" 0) + (gmake "gmake[4]: *** [sub/make.mk:19: all] Error 2" 16 nil 19 + "sub/make.mk" 0) + (gmake "gmake-4.3[4]: *** [make.mk:1119: all] Error 2" 20 nil 1119 + "make.mk" 0) + (gmake "Make-4.3: *** [make.INC:1119: dir/all] Error 2" 16 nil 1119 + "make.INC" 0) ;; gnu - ("foo.c:8: message" 1 nil 8 "foo.c") - ("../foo.c:8: W: message" 1 nil 8 "../foo.c") - ("/tmp/foo.c:8:warning message" 1 nil 8 "/tmp/foo.c") - ("foo/bar.py:8: FutureWarning message" 1 nil 8 "foo/bar.py") - ("foo.py:8: RuntimeWarning message" 1 nil 8 "foo.py") - ("foo.c:8:I: message" 1 nil 8 "foo.c") - ("foo.c:8.23: note: message" 1 23 8 "foo.c") - ("foo.c:8.23: info: message" 1 23 8 "foo.c") - ("foo.c:8:23:information: message" 1 23 8 "foo.c") - ("foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c") - ("foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + (gnu "foo.c:8: message" 1 nil 8 "foo.c") + (gnu "../foo.c:8: W: message" 1 nil 8 "../foo.c") + (gnu "/tmp/foo.c:8:warning message" 1 nil 8 "/tmp/foo.c") + (gnu "foo/bar.py:8: FutureWarning message" 1 nil 8 "foo/bar.py") + (gnu "foo.py:8: RuntimeWarning message" 1 nil 8 "foo.py") + (gnu "foo.c:8:I: message" 1 nil 8 "foo.c") + (gnu "foo.c:8.23: note: message" 1 23 8 "foo.c") + (gnu "foo.c:8.23: info: message" 1 23 8 "foo.c") + (gnu "foo.c:8:23:information: message" 1 23 8 "foo.c") + (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 46) (8 . nil) "foo.c") + (gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c") ;; The next one is not in the GNU standards AFAICS. ;; Here we seem to interpret it as LINE1-LINE2.COL2. - ("foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c") - ("foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c") - ("jade:dbcommon.dsl:133:17:E: missing argument for function call" + (gnu "foo.c:8-45.3: message" 1 (nil . 4) (8 . 45) "foo.c") + (gnu "foo.c:8.23-9.1: message" 1 (23 . 2) (8 . 9) "foo.c") + (gnu "jade:dbcommon.dsl:133:17:E: missing argument for function call" 1 17 133 "dbcommon.dsl") - ("G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + (gnu "G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." 1 nil 54 "G:/cygwin/dev/build-myproj.xml") - ("file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." + (gnu "file:G:/cygwin/dev/build-myproj.xml:54: Compiler Adapter 'javac' can't be found." 1 nil 54 "G:/cygwin/dev/build-myproj.xml") - ("{standard input}:27041: Warning: end of file not at end of a line; newline inserted" + (gnu "{standard input}:27041: Warning: end of file not at end of a line; newline inserted" 1 nil 27041 "{standard input}") - ("boost/container/detail/flat_tree.hpp:589:25: [ skipping 5 instantiation contexts, use -ftemplate-backtrace-limit=0 to disable ]" + (gnu "boost/container/detail/flat_tree.hpp:589:25: [ skipping 5 instantiation contexts, use -ftemplate-backtrace-limit=0 to disable ]" 1 25 589 "boost/container/detail/flat_tree.hpp" 0) ;; gradle-kotlin - ("e: /src/Test.kt: (34, 15): foo: bar" 4 15 34 "/src/Test.kt" 2) - ("w: /src/Test.kt: (11, 98): foo: bar" 4 98 11 "/src/Test.kt" 1) - ("e: e:/cygwin/src/Test.kt: (34, 15): foo: bar" 4 15 34 "e:/cygwin/src/Test.kt" 2) - ("w: e:/cygwin/src/Test.kt: (11, 98): foo: bar" 4 98 11 "e:/cygwin/src/Test.kt" 1) - ("e: e:\\src\\Test.kt: (34, 15): foo: bar" 4 15 34 "e:\\src\\Test.kt" 2) - ("w: e:\\src\\Test.kt: (11, 98): foo: bar" 4 98 11 "e:\\src\\Test.kt" 1) + (gradle-kotlin + "e: /src/Test.kt: (34, 15): foo: bar" 4 15 34 "/src/Test.kt" 2) + (gradle-kotlin + "w: /src/Test.kt: (11, 98): foo: bar" 4 98 11 "/src/Test.kt" 1) + (gradle-kotlin + "e: e:/cygwin/src/Test.kt: (34, 15): foo: bar" + 4 15 34 "e:/cygwin/src/Test.kt" 2) + (gradle-kotlin + "w: e:/cygwin/src/Test.kt: (11, 98): foo: bar" + 4 98 11 "e:/cygwin/src/Test.kt" 1) + (gradle-kotlin + "e: e:\\src\\Test.kt: (34, 15): foo: bar" 4 15 34 "e:\\src\\Test.kt" 2) + (gradle-kotlin + "w: e:\\src\\Test.kt: (11, 98): foo: bar" 4 98 11 "e:\\src\\Test.kt" 1) ;; Guile - ("In foo.scm:\n" 1 nil nil "foo.scm") - (" 63:4 [call-with-prompt prompt0 ...]" 1 4 63 nil) - ("1038: 1 [main (\"gud-break.scm\")]" 1 1 1038 nil) + (guile-file "In foo.scm:\n" 1 nil nil "foo.scm") + (guile-line " 63:4 [call-with-prompt prompt0 ...]" 1 4 63 nil) + (guile-line "1038: 1 [main (\"gud-break.scm\")]" 1 1 1038 nil) ;; lcc - ("E, file.cc(35,52) Illegal operation on pointers" 1 52 35 "file.cc") - ("W, file.cc(36,52) blah blah" 1 52 36 "file.cc") + (lcc "E, file.cc(35,52) Illegal operation on pointers" 1 52 35 "file.cc") + (lcc "W, file.cc(36,52) blah blah" 1 52 36 "file.cc") ;; makepp - ("makepp: Scanning `/foo/bar.c'" 19 nil nil "/foo/bar.c") - ("makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h'" 27 nil nil "/foo/bar.c") - ("makepp: bla bla `/foo/Makeppfile:12' bla" 18 nil 12 "/foo/Makeppfile") - ("makepp: bla bla `/foo/bar.c' and `/foo/bar.h'" 35 nil nil "/foo/bar.h") + (makepp "makepp: Scanning `/foo/bar.c'" 19 nil nil "/foo/bar.c") + (makepp "makepp: warning: bla bla `/foo/bar.c' and `/foo/bar.h'" + 27 nil nil "/foo/bar.c") + (makepp "makepp: bla bla `/foo/Makeppfile:12' bla" + 18 nil 12 "/foo/Makeppfile") + (nil "makepp: bla bla `/foo/bar.c' and `/foo/bar.h'" + 35 nil nil "/foo/bar.h") ;; maven - ("FooBar.java:[111,53] no interface expected here" + (maven "FooBar.java:[111,53] no interface expected here" 1 53 111 "FooBar.java" 2) - ("[ERROR] /Users/cinsk/hello.java:[651,96] ';' expected" + (maven "[ERROR] /Users/cinsk/hello.java:[651,96] ';' expected" 15 96 651 "/Users/cinsk/hello.java" 2) ;Bug#11517. - ("[WARNING] /foo/bar/Test.java:[27,43] unchecked conversion" + (maven "[WARNING] /foo/bar/Test.java:[27,43] unchecked conversion" 11 43 27 "/foo/bar/Test.java" 1) ;Bug#20556 ;; mips-1 mips-2 - ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + (mips-1 "TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" 11 nil 255 "solomon.c") - ("TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" + (mips-1 "TrimMask (255) in solomon.c may be indistinguishable from TrimMasks (93) in solomo.c due to truncation" 70 nil 93 "solomo.c") - ("name defined but never used: LinInt in cmap_calc.c(199)" + (mips-2 "name defined but never used: LinInt in cmap_calc.c(199)" 40 nil 199 "cmap_calc.c") ;; msft - ("keyboard handler.c(537) : warning C4005: 'min' : macro redefinition" + (msft "keyboard handler.c(537) : warning C4005: 'min' : macro redefinition" 1 nil 537 "keyboard handler.c") - ("d:\\tmp\\test.c(23) : error C2143: syntax error : missing ';' before 'if'" + (msft + "d:\\tmp\\test.c(23) : error C2143: syntax error : missing ';' before 'if'" 1 nil 23 "d:\\tmp\\test.c") - ("d:\\tmp\\test.c(1145) : see declaration of 'nsRefPtr'" + (msft "d:\\tmp\\test.c(1145) : see declaration of 'nsRefPtr'" 1 nil 1145 "d:\\tmp\\test.c") - ("1>test_main.cpp(29): error C2144: syntax error : 'int' should be preceded by ';'" + (msft "1>test_main.cpp(29): error C2144: syntax error : 'int' should be preceded by ';'" 3 nil 29 "test_main.cpp") - ("1>test_main.cpp(29): error C4430: missing type specifier - int assumed. Note: C++ does not support default-int" + (msft "1>test_main.cpp(29): error C4430: missing type specifier - int assumed. Note: C++ does not support default-int" 3 nil 29 "test_main.cpp") + (msft "C:\\tmp\\test.cpp(101,11): error C4101: 'bias0123': unreferenced local variable [C:\\tmp\\project.vcxproj]" + 1 11 101 "C:\\tmp\\test.cpp") ;; watcom - ("..\\src\\ctrl\\lister.c(109): Error! E1009: Expecting ';' but found '{'" + (watcom + "..\\src\\ctrl\\lister.c(109): Error! E1009: Expecting ';' but found '{'" 1 nil 109 "..\\src\\ctrl\\lister.c") - ("..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" + (watcom "..\\src\\ctrl\\lister.c(120): Warning! W201: Unreachable code" 1 nil 120 "..\\src\\ctrl\\lister.c") ;; omake - (" alpha.c:5:15: error: expected ';' after expression" + ;; FIXME: This doesn't actually test the omake rule. + (gnu " alpha.c:5:15: error: expected ';' after expression" 1 15 5 "alpha.c") ;; oracle - ("Semantic error at line 528, column 5, file erosacqdb.pc:" + (oracle "Semantic error at line 528, column 5, file erosacqdb.pc:" 1 5 528 "erosacqdb.pc") - ("Error at line 41, column 10 in file /usr/src/sb/ODBI_BHP.hpp" + (oracle "Error at line 41, column 10 in file /usr/src/sb/ODBI_BHP.hpp" 1 10 41 "/usr/src/sb/ODBI_BHP.hpp") - ("PCC-02150: error at line 49, column 27 in file /usr/src/sb/ODBI_dxfgh.pc" + (oracle + "PCC-02150: error at line 49, column 27 in file /usr/src/sb/ODBI_dxfgh.pc" 1 27 49 "/usr/src/sb/ODBI_dxfgh.pc") - ("PCC-00003: invalid SQL Identifier at column name in line 12 of file /usr/src/sb/ODBI_BHP.hpp" + (oracle "PCC-00003: invalid SQL Identifier at column name in line 12 of file /usr/src/sb/ODBI_BHP.hpp" 1 nil 12 "/usr/src/sb/ODBI_BHP.hpp") - ("PCC-00004: mismatched IF/ELSE/ENDIF block at line 27 in file /usr/src/sb/ODBI_BHP.hpp" + (oracle "PCC-00004: mismatched IF/ELSE/ENDIF block at line 27 in file /usr/src/sb/ODBI_BHP.hpp" 1 nil 27 "/usr/src/sb/ODBI_BHP.hpp") - ("PCC-02151: line 21 column 40 file /usr/src/sb/ODBI_BHP.hpp:" + (oracle "PCC-02151: line 21 column 40 file /usr/src/sb/ODBI_BHP.hpp:" 1 40 21 "/usr/src/sb/ODBI_BHP.hpp") ;; perl - ("syntax error at automake line 922, near \"':'\"" + (perl "syntax error at automake line 922, near \"':'\"" 14 nil 922 "automake") - ("Died at test.pl line 27." + (perl "Died at test.pl line 27." 6 nil 27 "test.pl") - ("store::odrecall('File_A', 'x2') called at store.pm line 90" + (perl "store::odrecall('File_A', 'x2') called at store.pm line 90" 40 nil 90 "store.pm") - ("\t(in cleanup) something bad at foo.pl line 3 during global destruction." + (perl + "\t(in cleanup) something bad at foo.pl line 3 during global destruction." 29 nil 3 "foo.pl") - ("GLib-GObject-WARNING **: /build/buildd/glib2.0-2.14.5/gobject/gsignal.c:1741: instance `0x8206790' has no handler with id `1234' at t-compilation-perl-gtk.pl line 3." + (perl "GLib-GObject-WARNING **: /build/buildd/glib2.0-2.14.5/gobject/gsignal.c:1741: instance `0x8206790' has no handler with id `1234' at t-compilation-perl-gtk.pl line 3." 130 nil 3 "t-compilation-perl-gtk.pl") ;; php - ("Parse error: parse error, unexpected $ in main.php on line 59" + (php "Parse error: parse error, unexpected $ in main.php on line 59" 1 nil 59 "main.php") - ("Fatal error: Call to undefined function: mysql_pconnect() in db.inc on line 66" + (php "Fatal error: Call to undefined function: mysql_pconnect() in db.inc on line 66" 1 nil 66 "db.inc") - ;; ruby - ("plain-exception.rb:7:in `fun': unhandled exception" + ;; ruby (uses gnu) + (gnu "plain-exception.rb:7:in `fun': unhandled exception" 1 nil 7 "plain-exception.rb") - ("\tfrom plain-exception.rb:3:in `proxy'" 2 nil 3 "plain-exception.rb") - ("\tfrom plain-exception.rb:12" 2 nil 12 "plain-exception.rb") + (gcc-include + "\tfrom plain-exception.rb:3:in `proxy'" 2 nil 3 "plain-exception.rb") + (gcc-include "\tfrom plain-exception.rb:12" 2 nil 12 "plain-exception.rb") ;; ruby-Test::Unit ;; FIXME - (" [examples/test-unit.rb:28:in `here_is_a_deep_assert'" + (ruby-Test::Unit " [examples/test-unit.rb:28:in `here_is_a_deep_assert'" 5 nil 28 "examples/test-unit.rb") - (" examples/test-unit.rb:19:in `test_a_deep_assert']:" + (ruby-Test::Unit " examples/test-unit.rb:19:in `test_a_deep_assert']:" 6 nil 19 "examples/test-unit.rb") - ("examples/test-unit.rb:10:in `test_assert_raise'" + (gnu "examples/test-unit.rb:10:in `test_assert_raise'" 1 nil 10 "examples/test-unit.rb") ;; rxp - ("Error: Mismatched end tag: expected </geroup>, got </group>\nin unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml" + (rxp "Error: Mismatched end tag: expected </geroup>, got </group>\nin unnamed entity at line 71 char 8 of file:///home/reto/test/group.xml" 1 8 71 "/home/reto/test/group.xml") - ("Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml" + (rxp "Warning: Start tag for undeclared element geroup\nin unnamed entity at line 4 char 8 of file:///home/reto/test/group.xml" 1 8 4 "/home/reto/test/group.xml") + ;; shellcheck + (shellcheck "In autogen.sh line 48:" + 1 nil 48 "autogen.sh") ;; sparc-pascal-file sparc-pascal-line sparc-pascal-example - ("Thu May 14 10:46:12 1992 mom3.p:" + (sparc-pascal-file "Thu May 14 10:46:12 1992 mom3.p:" 1 nil nil "mom3.p") ;; sun - ("cc-1020 CC: REMARK File = CUI_App.h, Line = 735" + (sun "cc-1020 CC: REMARK File = CUI_App.h, Line = 735" 13 nil 735 "CUI_App.h") - ("cc-1070 cc: WARNING File = linkl.c, Line = 38" + (sun "cc-1070 cc: WARNING File = linkl.c, Line = 38" 13 nil 38 "linkl.c") - ("cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3" + (sun "cf90-113 f90comp: ERROR NSE, File = Hoved.f90, Line = 16, Column = 3" 18 3 16 "Hoved.f90") ;; sun-ada - ("/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: \",\" inserted" + (sun-ada "/home3/xdhar/rcds_rc/main.a, line 361, char 6:syntax error: \",\" inserted" 1 6 361 "/home3/xdhar/rcds_rc/main.a") ;; 4bsd - ("/usr/src/foo/foo.c(8): warning: w may be used before set" + (edg-1 "/usr/src/foo/foo.c(8): warning: w may be used before set" 1 nil 8 "/usr/src/foo/foo.c") - ("/usr/src/foo/foo.c(9): error: w is used before set" + (edg-1 "/usr/src/foo/foo.c(9): error: w is used before set" 1 nil 9 "/usr/src/foo/foo.c") - ("strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8)" + (4bsd "strcmp: variable # of args. llib-lc(359) :: /usr/src/foo/foo.c(8)" 44 nil 8 "/usr/src/foo/foo.c") - ("bloofle defined( /users/wolfgang/foo.c(4) ), but never used" + (4bsd "bloofle defined( /users/wolfgang/foo.c(4) ), but never used" 18 nil 4 "/users/wolfgang/foo.c") ;; perl--Pod::Checker ;; FIXME @@ -347,21 +394,21 @@ ;; *** ERROR: =over on line 37 without closing =back at line EOF in file bar.pm ;; *** ERROR: =over on line 1 without closing =back (at head1) at line 3 in file x.pod ;; perl--Test - ("# Failed test 1 in foo.t at line 6" + (perl--Test "# Failed test 1 in foo.t at line 6" 1 nil 6 "foo.t") ;; perl--Test::Harness - ("NOK 1# Test 1 got: \"1234\" (t/foo.t at line 46)" + (perl--Test2 "NOK 1# Test 1 got: \"1234\" (t/foo.t at line 46)" 1 nil 46 "t/foo.t") ;; weblint - ("index.html (13:1) Unknown element <fdjsk>" + (weblint "index.html (13:1) Unknown element <fdjsk>" 1 1 13 "index.html")) "List of tests for `compilation-error-regexp-alist'. -Each element has the form (STR POS COLUMN LINE FILENAME [TYPE]), -where STR is an error string, POS is the position of the error in -STR, COLUMN and LINE are the reported column and line numbers (or -nil) for that error, FILENAME is the reported filename, and TYPE -is 0 for an information message, 1 for a warning, and 2 for an -error. +Each element has the form (RULE STR POS COLUMN LINE FILENAME +[TYPE]), where RULE is the rule (as a symbol), STR is an error +string, POS is the position of the error in STR, COLUMN and LINE +are the reported column and line numbers (or nil) for that error, +FILENAME is the reported filename, and TYPE is 0 for an +information message, 1 for a warning, and 2 for an error. LINE can also be of the form (LINE . END-LINE) meaning a range of lines. COLUMN can also be of the form (COLUMN . END-COLUMN) @@ -371,11 +418,14 @@ any message type is accepted.") (defconst compile-tests--grep-regexp-testcases ;; Bug#32051. - '(("c:/Users/my.name/src/project\\src\\kbhit.hpp\0\ 29:#include <termios.h>" + '((nil + "c:/Users/my.name/src/project\\src\\kbhit.hpp\0\ 29:#include <termios.h>" 1 nil 29 "c:/Users/my.name/src/project\\src\\kbhit.hpp") - ("d:/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" + (nil + "d:/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" 1 nil 214 "d:/gnu/emacs/branch/src/callproc.c") - ("/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" + (nil + "/gnu/emacs/branch/src/callproc.c\0\ 214:#ifdef DOS_NT" 1 nil 214 "/gnu/emacs/branch/src/callproc.c")) "List of tests for `grep-regexp-list'. The format is the same as `compile-tests--test-regexps-data', but @@ -384,43 +434,51 @@ with colon.") (defconst compile-tests--grep-regexp-tricky-testcases ;; Bug#7378. - '(("./x11-libs---nx/3.4.0:0:C.30253.1289557929.792611.C/nx-3.4.0.exheres-0\0\ 42:some text" + '((nil + "./x11-libs---nx/3.4.0:0:C.30253.1289557929.792611.C/nx-3.4.0.exheres-0\0\ 42:some text" 1 nil 42 "./x11-libs---nx/3.4.0:0:C.30253.1289557929.792611.C/nx-3.4.0.exheres-0") - ("2011-08-31_11:57:03_1\0\ 7:Date: Wed, 31 Aug 2011 11:57:03 +0000" + (nil + "2011-08-31_11:57:03_1\0\ 7:Date: Wed, 31 Aug 2011 11:57:03 +0000" 1 nil 7 "2011-08-31_11:57:03_1")) "List of tricky tests for `grep-regexp-list'. Same as `compile-tests--grep-regexp-testcases', but these cases can only work with the NUL byte to disambiguate colons.") (defun compile--test-error-line (test) - (erase-buffer) - (setq compilation-locs (make-hash-table)) - (insert (car test)) - (compilation-parse-errors (point-min) (point-max)) - (let ((msg (get-text-property (nth 1 test) 'compilation-message))) - (should msg) - (let ((loc (compilation--message->loc msg)) - (col (nth 2 test)) - (line (nth 3 test)) - (file (nth 4 test)) - (type (nth 5 test)) - end-col end-line) - (if (consp col) - (setq end-col (cdr col) col (car col))) - (if (consp line) - (setq end-line (cdr line) line (car line))) - (should (equal (compilation--loc->col loc) col)) - (should (equal (compilation--loc->line loc) line)) - (when file - (should (equal (caar (compilation--loc->file-struct loc)) file))) - (when end-col - (should (equal (car (cadr (nth 2 (compilation--loc->file-struct loc)))) - end-col))) - (should (equal (car (nth 2 (compilation--loc->file-struct loc))) - (or end-line line))) - (when type - (should (equal type (compilation--message->type msg))))) - msg)) + (ert-info ((format "%S" test) :prefix "testcase: ") + (erase-buffer) + (setq compilation-locs (make-hash-table)) + (let ((rule (nth 0 test)) + (str (nth 1 test)) + (pos (nth 2 test)) + (col (nth 3 test)) + (line (nth 4 test)) + (file (nth 5 test)) + (type (nth 6 test))) + (insert str) + (compilation-parse-errors (point-min) (point-max)) + (let ((msg (get-text-property pos 'compilation-message))) + (should msg) + (let ((loc (compilation--message->loc msg)) + end-col end-line) + (if (consp col) + (setq end-col (cdr col) col (car col))) + (if (consp line) + (setq end-line (cdr line) line (car line))) + (should (equal (compilation--loc->col loc) col)) + (should (equal (compilation--loc->line loc) line)) + (when file + (should (equal (caar (compilation--loc->file-struct loc)) file))) + (when end-col + (should (equal + (car (cadr (nth 2 (compilation--loc->file-struct loc)))) + end-col))) + (should (equal (car (nth 2 (compilation--loc->file-struct loc))) + (or end-line line))) + (when type + (should (equal type (compilation--message->type msg)))) + (should (equal rule (compilation--message->rule msg)))) + msg)))) (ert-deftest compile-test-error-regexps () "Test the `compilation-error-regexp-alist' regexps. @@ -431,9 +489,9 @@ The test data is in `compile-tests--test-regexps-data'." (compilation-num-warnings-found 0) (compilation-num-infos-found 0)) (mapc #'compile--test-error-line compile-tests--test-regexps-data) - (should (eq compilation-num-errors-found 93)) - (should (eq compilation-num-warnings-found 36)) - (should (eq compilation-num-infos-found 26))))) + (should (eq compilation-num-errors-found 96)) + (should (eq compilation-num-warnings-found 35)) + (should (eq compilation-num-infos-found 28))))) (ert-deftest compile-test-grep-regexps () "Test the `grep-regexp-alist' regexps. @@ -444,16 +502,15 @@ The test data is in `compile-tests--grep-regexp-testcases'." (font-lock-mode -1) (dolist (testcase compile-tests--grep-regexp-testcases) (let (msg1 msg2) - (setq msg1 (ert-info ((format "%S" testcase) :prefix "testcase: ") - (compile--test-error-line testcase))) + (setq msg1 (compile--test-error-line testcase)) ;; Make sure replacing the NUL character with a colon still matches. - (setf (car testcase) (replace-regexp-in-string "\0" ":" (car testcase))) - (setq msg2 (ert-info ((format "%S" testcase) :prefix "testcase: ") - (compile--test-error-line testcase))) + (let ((testcase2 (copy-sequence testcase))) + (setf (nth 1 testcase2) + (string-replace "\0" ":" (nth 1 testcase2))) + (setq msg2 (compile--test-error-line testcase2))) (should (equal msg1 msg2)))) (dolist (testcase compile-tests--grep-regexp-tricky-testcases) - (ert-info ((format "%S" testcase) :prefix "testcase: ") - (compile--test-error-line testcase))) + (compile--test-error-line testcase)) (should (eq compilation-num-errors-found 8)))) ;;; compile-tests.el ends here diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-19709.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-19709.pl new file mode 100644 index 00000000000..f7c51a2ce57 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-19709.pl @@ -0,0 +1,25 @@ +# -------- bug#19709: input -------- +my $a = func1( + Module::test() + ); + +my $b = func2( + test() +); + +my $c = func3( + Module::test(), +); +# -------- bug#19709: expected output -------- +my $a = func1( + Module::test() +); + +my $b = func2( + test() +); + +my $c = func3( + Module::test(), +); +# -------- bug#19709: end -------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-26850.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-26850.pl new file mode 100644 index 00000000000..a02ea29fe9d --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-26850.pl @@ -0,0 +1,16 @@ +sub interesting { + $_ = shift; + return + />Today is .+\'s birthday\.</ + || / like[ds]? your post in </ + || /like[ds] your new subscription\. </ + || / likes? that you're interested in </ + || /> likes? your comment: / + || /&birthdays=.*birthdays?\.<\/a>/; +} + +sub boring { + return + / likes? your post in </ + || / likes? that you're interested in </ +} diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-bug-30393.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-30393.pl new file mode 100644 index 00000000000..01db7b5206c --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-bug-30393.pl @@ -0,0 +1,19 @@ +# -------- bug#30393: input -------- +# + my $sql = "insert into jobs (id, priority) values (1, 2);"; + my $sth = $dbh->prepare($sql) or die "bother"; + + my $sql = "insert into jobs +(id, priority) +values (1, 2);"; + my $sth = $dbh->prepare($sql) or die "bother"; +# -------- bug#30393: expected output -------- +# +my $sql = "insert into jobs (id, priority) values (1, 2);"; +my $sth = $dbh->prepare($sql) or die "bother"; + +my $sql = "insert into jobs +(id, priority) +values (1, 2);"; +my $sth = $dbh->prepare($sql) or die "bother"; +# -------- bug#30393: end -------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-indent-exp.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-indent-exp.pl new file mode 100644 index 00000000000..8c1883a10f1 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-indent-exp.pl @@ -0,0 +1,52 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use 5.020; + +# This file contains test input and expected output for the tests in +# cperl-mode-tests.el, cperl-mode-test-indent-exp. The code is +# syntactically valid, but doesn't make much sense. + +# -------- for loop: input -------- +for my $foo (@ARGV) +{ +...; +} +# -------- for loop: expected output -------- +for my $foo (@ARGV) { + ...; +} +# -------- for loop: end -------- + +# -------- while loop: input -------- +{ +while (1) +{ +say "boring loop"; +} +continue +{ +last; +} +} +# -------- while loop: expected output -------- +{ + while (1) { + say "boring loop"; + } continue { + last; + } +} +# -------- while loop: end -------- + +# -------- if-then-else: input -------- +if (my $foo) { bar() } elsif (quux()) { baz() } else { quuux } +# -------- if-then-else: expected output -------- +if (my $foo) { + bar(); +} elsif (quux()) { + baz(); +} else { + quuux; +} +# -------- if-then-else: end -------- diff --git a/test/lisp/progmodes/cperl-mode-resources/cperl-indent-styles.pl b/test/lisp/progmodes/cperl-mode-resources/cperl-indent-styles.pl new file mode 100644 index 00000000000..371b19b7309 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/cperl-indent-styles.pl @@ -0,0 +1,54 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use 5.020; + +# This file contains test input and expected output for the tests in +# cperl-mode-tests.el, cperl-mode-test-indent-exp. The code is +# syntactically valid, but doesn't make much sense. + +# -------- PBP indent: input -------- +for my $foo (@ARGV) +{ +...; +} +# -------- PBP indent: expected output -------- +for my $foo (@ARGV) { + ...; +} +# -------- PBP indent: end -------- + +# -------- PBP uncuddle else: input -------- +{ +if (1 < 2) +{ +say "Seems ok"; +} elsif (1 == 2) { +say "Strange things are happening"; +} else { +die "This world is backwards"; +} +} +# -------- PBP uncuddle else: expected output -------- +{ + if (1 < 2) { + say "Seems ok"; + } + elsif (1 == 2) { + say "Strange things are happening"; + } + else { + die "This world is backwards"; + } +} +# -------- PBP uncuddle else: end -------- + +# -------- PBP closing paren offset: input -------- +my $a = func1( + Module::test() + ); +# -------- PBP closing paren offset: expected output -------- +my $a = func1( + Module::test() +); +# -------- PBP closing paren offset: end -------- diff --git a/test/lisp/progmodes/cperl-mode-resources/fontify-punctuation-vars.pl b/test/lisp/progmodes/cperl-mode-resources/fontify-punctuation-vars.pl new file mode 100644 index 00000000000..fa328438cb1 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-resources/fontify-punctuation-vars.pl @@ -0,0 +1,20 @@ +# The following Perl punctiation variables contain characters which +# are classified as string delimiters in the syntax table. The mode +# should not be confused by these. +# The corresponding tests check that two consecutive '#' characters +# are seen as comments, not as strings. +my $pre = $`; ## $PREMATCH, use another ` # to balance out +my $pos = $'; ## $POSTMATCH, use another ' # to balance out +my $lsp = $"; ## $LIST_SEPARATOR use another " # to balance out + +# In the second level, we use the reference constructor \ on these +# variables. The backslash is an escape character *only* in strings. +my $ref = \$`; ## \$PREMATCH, use another ` # to balance out +my $rif = \$'; ## \$POSTMATCH, use another ' # to balance out +my $raf = \$"; ## \$LIST_SEPARATOR use another " # to balance out + +my $opt::s = 0; ## s is no substitution here +my $opt_s = 0; ## s is no substitution here +my %opt = (s => 0); ## s is no substitution here +$opt{s} = 0; ## s is no substitution here +$opt_s =~ /\s+.../ ## s is no substitution here diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el new file mode 100644 index 00000000000..896160bb883 --- /dev/null +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -0,0 +1,315 @@ +;;; cperl-mode-tests --- Test for cperl-mode -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Harald Jörg <haj@posteo.de> +;; Maintainer: Harald Jörg +;; Keywords: internal +;; Homepage: https://github.com/HaraldJoerg/cperl-mode + +;; 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 is a collection of tests for CPerl-mode. + +;;; Code: + +(defvar cperl-test-mode #'cperl-mode) + +(require 'cperl-mode) +(require 'ert) +(require 'ert-x) + +;;; Utilities + +(defun cperl-test-ppss (text regexp) + "Return the `syntax-ppss' of the first character matched by REGEXP in TEXT." + (interactive) + (with-temp-buffer + (insert text) + (funcall cperl-test-mode) + (goto-char (point-min)) + (re-search-forward regexp) + (syntax-ppss))) + +(defmacro cperl--run-test-cases (file &rest body) + "Run all test cases in FILE with BODY. +This macro helps with tests which reformat Perl code, e.g. when +indenting or rearranging flow control. It extracts source code +snippets and corresponding expected results from a resource file, +runs BODY on the snippets, and compares the resulting buffer with +the expected results. + +Test cases in FILE are formatted like this: + +# -------- NAME: input -------- +Your input to the test case comes here. +Both input and expected output may span several lines. +# -------- NAME: expected output -------- +The expected output from running BODY on the input goes here. +# -------- NAME: end -------- + +You can have many of these blocks in one test file. You can +chose a NAME for each block, which is passed to the 'should' +clause for easy identification of the first test case that +failed (if any). Text outside these the blocks is ignored by the +tests, so you can use it to document the test cases if you wish." + `(with-temp-buffer + (insert-file-contents ,file) + (goto-char (point-min)) + (while (re-search-forward + (concat "^# ?-+ \\_<\\(?1:.+?\\)\\_>: input ?-+\n" + "\\(?2:\\(?:.*\n\\)+?\\)" + "# ?-+ \\1: expected output ?-+\n" + "\\(?3:\\(?:.*\n\\)+?\\)" + "# ?-+ \\1: end ?-+") + nil t) + (let ((name (match-string 1)) + (code (match-string 2)) + (expected (match-string 3)) + got) + (with-temp-buffer + (insert code) + (goto-char (point-min)) + (funcall cperl-test-mode) + ,@body + (setq expected (concat "test case " name ":\n" expected)) + (setq got (concat "test case " name ":\n" (buffer-string))) + (should (equal got expected))))))) + +;;; Indentation tests + +(ert-deftest cperl-test-indent-exp () + "Run various tests for `cperl-indent-exp' edge cases. +These exercise some standard blocks and also the special +treatment for Perl expressions where a closing paren isn't the +end of the statement." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (cperl--run-test-cases + (ert-resource-file "cperl-indent-exp.pl") + (cperl-indent-exp))) ; here we go! + +(ert-deftest cperl-test-indent-styles () + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (cperl--run-test-cases + (ert-resource-file "cperl-indent-styles.pl") + (cperl-set-style "PBP") + (indent-region (point-min) (point-max)) ; here we go! + (cperl-set-style-back))) + +;;; Fontification tests + +(ert-deftest cperl-test-fontify-punct-vars () + "Test fontification of Perl's punctiation variables. +Perl has variable names containing unbalanced quotes for the list +separator $\" and pre- and postmatch $` and $'. A reference to +these variables, for example \\$\", should not cause the dollar +to be escaped, which would then start a string beginning with the +quote character. This used to be broken in cperl-mode at some +point in the distant past, and is still broken in perl-mode. " + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((file (ert-resource-file "fontify-punctuation-vars.pl"))) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (funcall cperl-test-mode) + (while (search-forward "##" nil t) + ;; The third element of syntax-ppss is true if in a string, + ;; which would indicate bad interpretation of the quote. The + ;; fourth element is true if in a comment, which should be the + ;; case. + (should (equal (nth 3 (syntax-ppss)) nil)) + (should (equal (nth 4 (syntax-ppss)) t)))))) + +;;; Tests for issues reported in the Bug Tracker + +(defun cperl-test--run-bug-10483 () + "Runs a short program, intended to be under timer scrutiny. +This function is intended to be used by an Emacs subprocess in +batch mode. The message buffer is used to report the result of +running `cperl-indent-exp' for a very simple input. The result +is expected to be different from the input, to verify that +indentation actually takes place.." + (let ((code "poop ('foo', \n'bar')")) ; see the bug report + (message "Test Bug#10483 started") + (with-temp-buffer + (insert code) + (funcall cperl-test-mode) + (goto-char (point-min)) + (search-forward "poop") + (cperl-indent-exp) + (message "%s" (buffer-string))))) + +(ert-deftest cperl-test-bug-10483 () + "Check that indenting certain perl code does not loop forever. +This verifies that indenting a piece of code that ends in a paren +without a statement terminator on the same line does not loop +forever. The test starts an asynchronous Emacs batch process +under timeout control." + :tags '(:expensive-test) + (interactive) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; FIXME times out + (skip-unless (not (< emacs-major-version 28))) ; times out in older Emacsen + (let* ((emacs (concat invocation-directory invocation-name)) + (test-function 'cperl-test--run-bug-10483) + (test-function-name (symbol-name test-function)) + (test-file (symbol-file test-function 'defun)) + (ran-out-of-time nil) + (process-connection-type nil) + runner) + (with-temp-buffer + (with-timeout (2 + (delete-process runner) + (setq ran-out-of-time t)) + (setq runner (start-process "speedy" + (current-buffer) + emacs + "-batch" + "--quick" + "--load" test-file + "--funcall" test-function-name)) + (while (accept-process-output runner))) + (should (equal ran-out-of-time nil)) + (goto-char (point-min)) + ;; just a very simple test for indentation: This should + ;; be rather robust with regard to indentation defaults + (should (string-match + "poop ('foo', \n 'bar')" (buffer-string)))))) + +(ert-deftest cperl-test-bug-16368 () + "Verify that `cperl-forward-group-in-re' doesn't hide errors." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((code "/(\\d{4})(?{2}/;") ; the regex from the bug report + (result)) + (with-temp-buffer + (insert code) + (goto-char 9) + (setq result (cperl-forward-group-in-re)) + (should (equal (car result) 'scan-error)) + (should (equal (nth 1 result) "Unbalanced parentheses")) + (should (= (point) 9)))) ; point remains unchanged on error + (let ((code "/(\\d{4})(?{2})/;") ; here all parens are balanced + (result)) + (with-temp-buffer + (insert code) + (goto-char 9) + (setq result (cperl-forward-group-in-re)) + (should (equal result nil)) + (should (= (point) 15))))) ; point has skipped the group + +(ert-deftest cperl-test-bug-19709 () + "Verify that indentation of closing paren works as intended. +Note that Perl mode has no setting for close paren offset, per +documentation it does the right thing anyway." + (cperl--run-test-cases + (ert-resource-file "cperl-bug-19709.pl") + ;; settings from the bug report + (setq-local cperl-indent-level 4) + (setq-local cperl-indent-parens-as-block t) + (setq-local cperl-close-paren-offset -4) + ;; same, adapted for per-mode + (setq-local perl-indent-level 4) + (setq-local perl-indent-parens-as-block t) + (while (null (eobp)) + (cperl-indent-command) + (forward-line 1)))) + +(ert-deftest cperl-test-bug-28650 () + "Verify that regular expressions are recognized after 'return'. +The test uses the syntax property \"inside a string\" for the +text in regular expressions, which is non-nil for both cperl-mode +and perl-mode." + (with-temp-buffer + (insert-file-contents (ert-resource-file "cperl-bug-26850.pl")) + (goto-char (point-min)) + (re-search-forward "sub interesting {[^}]*}") + (should-not (equal (nth 3 (cperl-test-ppss (match-string 0) "Today")) + nil)) + (re-search-forward "sub boring {[^}]*}") + (should-not (equal (nth 3 (cperl-test-ppss (match-string 0) "likes\\?")) + nil)))) + +(ert-deftest cperl-test-bug-30393 () + "Verify that indentation is not disturbed by an open paren in col 0. +Perl is not Lisp: An open paren in column 0 does not start a function." + (cperl--run-test-cases + (ert-resource-file "cperl-bug-30393.pl") + (while (null (eobp)) + (cperl-indent-command) + (forward-line 1)))) + +(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 +missing." + ;; The actual fix for this bug is in simple.el, which is not + ;; backported to older versions of Emacs. Therefore we skip this + ;; test if we're running Emacs 27 or older. + (skip-unless (< 27 emacs-major-version)) + ;; Part one: Regex is ok, no messages + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "$_ =~ /(./;") + (funcall cperl-test-mode) + (goto-char (point-min)) + (search-forward ".") + (let ((last-command-event ?\)) + ;; Don't emit "Matches ..." even if not visible (e.g. in batch). + (blink-matching-paren 'jump-offscreen)) + (self-insert-command 1) + ;; `self-insert-command' doesn't call `blink-matching-open' in + ;; batch mode, so we need to call it explicitly. + (blink-matching-open)) + (syntax-propertize (point-max))) + (should (string-equal collected-messages ""))) + ;; part two: Regex terminator missing -> message + (when (eq cperl-test-mode #'cperl-mode) + ;; This test is only run in `cperl-mode' because only cperl-mode + ;; emits a message to warn about such unclosed REs. + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "$_ =~ /(..;") + (goto-char (point-min)) + (funcall cperl-test-mode) + (search-forward ".") + (let ((last-command-event ?\))) + (self-insert-command 1)) + (syntax-propertize (point-max))) + (should (string-match "^End of .* string/RE" + collected-messages))))) + +(ert-deftest cperl-test-bug-42168 () + "Verify that '/' is a division after ++ or --, not a regexp. +Reported in https://github.com/jrockway/cperl-mode/issues/45. +If seen as regular expression, then the slash is displayed using +font-lock-constant-face. If seen as a division, then it doesn't +have a face property." + :tags '(:fontification) + ;; The next two Perl expressions have divisions. Perl "punctuation" + ;; operators don't get a face. + (let ((code "{ $a++ / $b }")) + (should (equal (nth 8 (cperl-test-ppss code "/")) nil))) + (let ((code "{ $a-- / $b }")) + (should (equal (nth 8 (cperl-test-ppss code "/")) nil))) + ;; The next two Perl expressions have regular expressions. The + ;; delimiter of a RE is fontified with font-lock-constant-face. + (let ((code "{ $a+ / $b } # /")) + (should (equal (nth 8 (cperl-test-ppss code "/")) 7))) + (let ((code "{ $a- / $b } # /")) + (should (equal (nth 8 (cperl-test-ppss code "/")) 7)))) + +;;; cperl-mode-tests.el ends here diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 2ba00656862..6c30e4f664b 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -194,7 +194,7 @@ (dotimes (i 3) (should (equal (elisp-mode-tests--face-propertized-string - (elisp--highlight-function-argument 'foo "(A B C)" (1+ i) "foo: ")) + (elisp--highlight-function-argument 'foo "(A B C)" (1+ i))) (propertize (nth i '("A" "B" "C")) 'face 'eldoc-highlight-function-argument))))) @@ -206,7 +206,7 @@ (cl-flet ((bold-arg (i) (elisp-mode-tests--face-propertized-string (elisp--highlight-function-argument - 'foo "(PROMPT LST &key A B C)" i "foo: ")))) + 'foo "(PROMPT LST &key A B C)" i)))) (should-not (bold-arg 0)) (progn (forward-sexp) (forward-char)) (should (equal (bold-arg 1) "PROMPT")) @@ -226,7 +226,7 @@ (cl-flet ((bold-arg (i) (elisp-mode-tests--face-propertized-string (elisp--highlight-function-argument - 'foo "(X &key A B C)" i "foo: ")))) + 'foo "(X &key A B C)" i)))) (should-not (bold-arg 0)) ;; The `:b' specifies positional arg `X'. (progn (forward-sexp) (forward-char)) @@ -810,5 +810,17 @@ to (xref-elisp-test-descr-to-target xref)." (insert "?\\N{HEAVY CHECK MARK}") (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) +(ert-deftest elisp-indent-basic () + (with-temp-buffer + (emacs-lisp-mode) + (let ((orig "(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff))))")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index f7a5ac4870c..79368cd193f 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -1,4 +1,4 @@ -;;; etags-tests.el --- Test suite for etags.el. +;;; etags-tests.el --- Test suite for etags.el. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/f90-tests.el b/test/lisp/progmodes/f90-tests.el index b6fbac351dc..b8a3f7e8401 100644 --- a/test/lisp/progmodes/f90-tests.el +++ b/test/lisp/progmodes/f90-tests.el @@ -1,8 +1,9 @@ -;;; f90-tests.el --- tests for progmodes/f90.el +;;; f90-tests.el --- tests for progmodes/f90.el -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. ;; Author: Glenn Morris <rgm@gnu.org> +;; Maintainer: emacs-devel@gnu.org ;; This file is part of GNU Emacs. diff --git a/test/lisp/progmodes/gdb-mi-tests.el b/test/lisp/progmodes/gdb-mi-tests.el new file mode 100644 index 00000000000..64b7a266635 --- /dev/null +++ b/test/lisp/progmodes/gdb-mi-tests.el @@ -0,0 +1,46 @@ +;;; gdb-mi-tests.el --- tests for gdb-mi.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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/>. + +(require 'ert) +(require 'gdb-mi) + +(ert-deftest gdb-mi-parse-value () + ;; Test the GDB/MI result/value parser. + (should (equal + (gdb-mi--from-string + "alpha=\"ab\\ncd\",beta=[\"x\",{gamma=\"y\",delta=[]}]") + '((alpha . "ab\ncd") + (beta . ("x" ((gamma . "y") (delta . ()))))))) + (should (equal + (gdb-mi--from-string + "alpha=\"ab\\ncd\",beta=[\"x\",{gamma=\"y\",delta=[]}]" + 'gamma) + '((alpha . "ab\ncd") + (beta . ("x" ("y" (delta . ()))))))) + + (let ((gdb-mi-decode-strings nil)) + (let ((ref `((alpha . ,(string-to-multibyte "a\303\245b"))))) + (should (equal (gdb-mi--from-string "alpha=\"a\\303\\245b\"") + ref)))) + (let ((gdb-mi-decode-strings 'utf-8)) + (should (equal (gdb-mi--from-string "alpha=\"a\\303\\245b\"") + '((alpha . "aåb"))))) + ) + +(provide 'gdb-mi-tests) diff --git a/test/lisp/progmodes/glasses-tests.el b/test/lisp/progmodes/glasses-tests.el new file mode 100644 index 00000000000..277a9cc1927 --- /dev/null +++ b/test/lisp/progmodes/glasses-tests.el @@ -0,0 +1,101 @@ +;;; glasses-tests.el --- Tests for glasses.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'glasses) +(require 'seq) + +(ert-deftest glasses-tests-parenthesis-exception-p () + (with-temp-buffer + (insert "public OnClickListener menuListener() {}") + (let ((glasses-separate-parentheses-exceptions '("^Listen"))) + (should-not (glasses-parenthesis-exception-p 1 (point-max))) + (should (glasses-parenthesis-exception-p 15 (point-max))) + (should-not (glasses-parenthesis-exception-p 24 (point-max))) + (should (glasses-parenthesis-exception-p 28 (point-max)))))) + +(ert-deftest glasses-tests-overlay-p () + (should + (glasses-overlay-p (glasses-make-overlay (point-min) (point-max)))) + (should-not + (glasses-overlay-p (make-overlay (point-min) (point-max))))) + +(ert-deftest glasses-tests-make-overlay-p () + (let ((o (glasses-make-overlay (point-min) (point-max)))) + (should (eq (overlay-get o 'category) 'glasses))) + (let ((o (glasses-make-overlay (point-min) (point-max) 'foo))) + (should (eq (overlay-get o 'category) 'foo)))) + +(ert-deftest glasses-tests-make-readable () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (glasses-make-readable (point-min) (point-max)) + (pcase-let ((`(,o1 ,o2 ,o3) + (sort (overlays-in (point-min) (point-max)) + (lambda (o1 o2) + (< (overlay-start o1) (overlay-start o2)))))) + (should (= (overlay-start o1) 7)) + (should (equal (overlay-get o1 'before-string) + glasses-separator)) + (should (= (overlay-start o2) 17)) + (should (equal (overlay-get o2 'before-string) + glasses-separator)) + (should (= (overlay-start o3) 25)) + (should (equal (overlay-get o3 'before-string) " "))))) + +(ert-deftest glasses-tests-make-readable-dont-separate-parentheses () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (let ((glasses-separate-parentheses-p nil)) + (glasses-make-readable (point-min) (point-max)) + (should-not (overlays-at 25))))) + +(ert-deftest glasses-tests-make-unreadable () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (glasses-make-readable (point-min) (point-max)) + (should (seq-some #'glasses-overlay-p + (overlays-in (point-min) (point-max)))) + (glasses-make-unreadable (point-min) (point-max)) + (should-not (seq-some #'glasses-overlay-p + (overlays-in (point-min) (point-max)))))) + +(ert-deftest glasses-tests-convert-to-unreadable () + (with-temp-buffer + (insert "set_Background_Resource(R.button_right);") + (let ((glasses-convert-on-write-p nil)) + (should-not (glasses-convert-to-unreadable)) + (should (equal (buffer-string) + "set_Background_Resource(R.button_right);"))) + (let ((glasses-convert-on-write-p t)) + (should-not (glasses-convert-to-unreadable)) + (should (equal (buffer-string) + "setBackgroundResource(R.button_right);"))))) + +(provide 'glasses-tests) +;;; glasses-tests.el ends here diff --git a/test/lisp/progmodes/js-resources/js-chain.js b/test/lisp/progmodes/js-resources/js-chain.js new file mode 100644 index 00000000000..2a290294026 --- /dev/null +++ b/test/lisp/progmodes/js-resources/js-chain.js @@ -0,0 +1,29 @@ +// Normal chaining. +let x = svg.mumble() + .zzz; + +// Chaining with an intervening line comment. +let x = svg.mumble() // line comment + .zzz; + +// Chaining with multiple dots. +let x = svg.selectAll().something() + .zzz; + +// Nested chaining. +let x = svg.selectAll(d3.svg.something() + .zzz); + +// Nothing to chain to. +let x = svg() + .zzz; + +// Nothing to chain to. +let x = svg().mumble.x() + 73 + .zzz; + +// Local Variables: +// indent-tabs-mode: nil +// js-chain-indent: t +// js-indent-level: 2 +// End: diff --git a/test/lisp/progmodes/js-resources/js-indent-align-list-continuation-nil.js b/test/lisp/progmodes/js-resources/js-indent-align-list-continuation-nil.js new file mode 100644 index 00000000000..383b2539a26 --- /dev/null +++ b/test/lisp/progmodes/js-resources/js-indent-align-list-continuation-nil.js @@ -0,0 +1,20 @@ +const funcAssignment = function (arg1, + arg2, + arg3) { + return { test: this, + which: "would", + align: "as well with the default setting" + }; +} + +function funcDeclaration(arg1, + arg2 +) { + return [arg1, + arg2]; +} + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-align-list-continuation: nil +// End: diff --git a/test/lisp/progmodes/js-resources/js-indent-init-dynamic.js b/test/lisp/progmodes/js-resources/js-indent-init-dynamic.js new file mode 100644 index 00000000000..536a976e86e --- /dev/null +++ b/test/lisp/progmodes/js-resources/js-indent-init-dynamic.js @@ -0,0 +1,30 @@ +var foo = function() { + return 7; +}; + +var foo = function() { + return 7; + }, + bar = 8; + +var foo = function() { + return 7; + }, + bar = function() { + return 8; + }; + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// js-indent-first-init: dynamic +// End: + +// The following test intentionally produces a scan error and should +// be placed below all other tests to prevent awkward indentation. +// (It still thinks it's within the body of a function.) + +var foo = function() { + return 7; + , + bar = 8; diff --git a/test/lisp/progmodes/js-resources/js-indent-init-t.js b/test/lisp/progmodes/js-resources/js-indent-init-t.js new file mode 100644 index 00000000000..bb755420ba7 --- /dev/null +++ b/test/lisp/progmodes/js-resources/js-indent-init-t.js @@ -0,0 +1,21 @@ +var foo = function() { + return 7; + }; + +var foo = function() { + return 7; + }, + bar = 8; + +var foo = function() { + return 7; + }, + bar = function() { + return 8; + }; + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// js-indent-first-init: t +// End: diff --git a/test/lisp/progmodes/js-resources/js.js b/test/lisp/progmodes/js-resources/js.js new file mode 100644 index 00000000000..9658c95701c --- /dev/null +++ b/test/lisp/progmodes/js-resources/js.js @@ -0,0 +1,171 @@ +var a = 1; +b = 2; + +let c = 1, + d = 2; + +var e = 100500, + + 1; + +// Don't misinterpret "const" +/const/ + +function test () +{ + return /[/]/.test ('/') // (bug#19397) +} + +var f = bar('/protocols/') +baz(); + +var h = 100500 +1; + +const i = 1, + j = 2; + +var k = 1, + l = [ + 1, 2, + 3, 4 + ], + m = 5; + +var n = function() { + return 7; +}, + o = 8; + +foo(bar, function() { + return 2; +}); + +switch (b) { +case "a": + 2; +default: + 3; +} + +var p = { + case: 'zzzz', + default: 'donkey', + tee: 'ornery' +}; + +var evens = [e for each (e in range(0, 21)) + if (ed % 2 == 0)]; + +var funs = [ + function() { + for (;;) { + } + }, + function(){}, +]; + +!b + !=b + !==b + +a++ +b += + c + +var re = /some value/ +str.match(re) + +baz(`http://foo.bar/${tee}`) + .qux(); + +`multiline string + contents + are kept + unchanged!` + +class A { + * x() { + return 1 + * a(2); + } + + *[Symbol.iterator]() { + yield "Foo"; + yield "Bar"; + } +} + +if (true) + 1 +else + 2 + +Foobar + .find() + .catch((err) => { + return 2; + }) + .then((num) => { + console.log(num); + }); + +var z = [ + ...iterableObj, + 4, + 5 +] + +var arr = [ + -1, 2, + -3, 4 + + -5 +]; + +// Regression test for bug#15582. +if (x > 72 && + y < 85) { // found + do_something(); +} + +// Test that chaining doesn't happen when js-chain-indent is nil. +let x = svg.mumble() + .zzz; + +// https://github.com/mooz/js2-mode/issues/405 +if (1) { + isSet + ? (isEmpty ? 2 : 3) + : 4 +} + +// Regexp is not a continuation +bar( + "string arg1", + /abc/ +) + +// No infloop inside js--re-search-backward-inner +let b = { + a : ` + //1 + ` +} + +// bug#25904 +foo.bar.baz(very => // A comment + very +).biz(([baz={a: [123]}, boz]) => + baz +).snarf((snorf) => /* Another comment */ + snorf +); + +// Continuation of bug#25904; support broken arrow as N+1th arg +map(arr, (val) => + val +) + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: diff --git a/test/lisp/progmodes/js-resources/jsx-align-gt-with-lt.jsx b/test/lisp/progmodes/js-resources/jsx-align-gt-with-lt.jsx new file mode 100644 index 00000000000..8eb1d6d718c --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-align-gt-with-lt.jsx @@ -0,0 +1,12 @@ +<element + attr="" + > +</element> +<input + /> + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// js-jsx-align->-with-<: nil +// End: diff --git a/test/lisp/progmodes/js-resources/jsx-comment-string.jsx b/test/lisp/progmodes/js-resources/jsx-comment-string.jsx new file mode 100644 index 00000000000..cae023e7288 --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-comment-string.jsx @@ -0,0 +1,23 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following tests go below any comments to avoid including +// misindented comments among the erroring lines. + +// The JSX-like text in comments/strings should be treated like the enclosing +// syntax, not like JSX. + +// <Foo> +void 0 + +"<Bar>" +void 0 + +<Chicken> + {/* <Pork> */} + <Beef attr="<Turkey>"> + Yum! + </Beef> +</Chicken> diff --git a/test/lisp/progmodes/js-resources/jsx-indent-level.jsx b/test/lisp/progmodes/js-resources/jsx-indent-level.jsx new file mode 100644 index 00000000000..0a84b9eb77a --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-indent-level.jsx @@ -0,0 +1,13 @@ +return ( + <element> + <element> + Hello World! + </element> + </element> +) + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 4 +// js-jsx-indent-level: 2 +// End: diff --git a/test/lisp/progmodes/js-resources/jsx-quote.jsx b/test/lisp/progmodes/js-resources/jsx-quote.jsx new file mode 100644 index 00000000000..1b2c6528734 --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-quote.jsx @@ -0,0 +1,16 @@ +// JSX text node values should be strings, but only JS string syntax +// is considered, so quote marks delimit strings like normal, with +// disastrous results (https://github.com/mooz/js2-mode/issues/409). +function Bug() { + return <div>C'est Montréal</div>; +} +function Test(foo = /'/, + bar = 123) {} + +// This test is in a separate file because it can break other tests +// when indenting the whole buffer (not sure why). + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: diff --git a/test/lisp/progmodes/js-resources/jsx-self-closing.jsx b/test/lisp/progmodes/js-resources/jsx-self-closing.jsx new file mode 100644 index 00000000000..f8ea7a138ad --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-self-closing.jsx @@ -0,0 +1,13 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following test goes below any comments to avoid including +// misindented comments among the erroring lines. + +// Properly parse/indent code with a self-closing tag inside the +// attribute of another self-closing tag. +<div> + <div attr={() => <div attr="" />} /> +</div> diff --git a/test/lisp/progmodes/js-resources/jsx-unclosed-1.jsx b/test/lisp/progmodes/js-resources/jsx-unclosed-1.jsx new file mode 100644 index 00000000000..1f5c3fba8da --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-unclosed-1.jsx @@ -0,0 +1,13 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following test goes below any comments to avoid including +// misindented comments among the erroring lines. + +return ( + <div> + {array.map(function () { + return { + a: 1 diff --git a/test/lisp/progmodes/js-resources/jsx-unclosed-2.jsx b/test/lisp/progmodes/js-resources/jsx-unclosed-2.jsx new file mode 100644 index 00000000000..fb665b96a43 --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx-unclosed-2.jsx @@ -0,0 +1,65 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following tests go below any comments to avoid including +// misindented comments among the erroring lines. + +// Don’t misinterpret inequality operators as JSX. +for (; i < length;) void 0 +if (foo > bar) void 0 + +// Don’t misintrepet inequalities within JSX, either. +<div> + {foo < bar} +</div> + +// Don’t even misinterpret unary operators as JSX. +if (foo < await bar) void 0 +while (await foo > bar) void 0 + +<div> + {foo < await bar} +</div> + +// Allow unary keyword names as null-valued JSX attributes. +// (As if this will EVER happen…) +<Foo yield> + <Bar void> + <Baz + zorp + typeof> + <Please do_n0t delete this_stupidTest > + How would we ever live without unary support + </Please> + </Baz> + </Bar> +</Foo> + +// “-” is not allowed in a JSXBoundaryElement’s name. +<ABC /> + <A-B-C /> // Weirdly-indented “continued expression.” + +// “-” may be used in a JSXAttribute’s name. +<Foo a-b-c="" + x-y-z="" /> + +// Weird spaces should be tolerated. +< div > + < div > + < div + attr="" + / > + < div + attr="" + / > + < / div> +< / div > + +// Non-ASCII identifiers are acceptable. +<Über> + <Québec διακριτικός sueño=""> + Guten Tag! + </Québec> +</Über> diff --git a/test/lisp/progmodes/js-resources/jsx.jsx b/test/lisp/progmodes/js-resources/jsx.jsx new file mode 100644 index 00000000000..c200979df8c --- /dev/null +++ b/test/lisp/progmodes/js-resources/jsx.jsx @@ -0,0 +1,314 @@ +var foo = <div></div>; + +return ( + <div> + </div> + <div> + <div></div> + <div> + <div></div> + </div> + </div> +); + +React.render( + <div> + <div></div> + </div>, + { + a: 1 + }, + <div> + <div></div> + </div> +); + +return ( + // Sneaky! + <div></div> +); + +return ( + <div></div> + // Sneaky! +); + +React.render( + <input + />, + { + a: 1 + } +); + +return ( + <div> + {array.map(function () { + return { + a: 1 + }; + })} + </div> +); + +return ( + <div attribute={array.map(function () { + return { + a: 1 + }; + + return { + a: 1 + }; + + return { + a: 1 + }; + })}> + </div> +); + +return ( + <div attribute={{ + a: 1, // Indent relative to “attribute” column. + b: 2 + } && { // Dedent to “attribute” column. + a: 1, + b: 2 + }} /> // Also dedent. +); + +return ( + <div attribute= + { // Indent properly on another line, too. + { + a: 1, + b: 2, + } && ( + // Indent other forms, too. + a ? b : + c ? d : + e + ) + } /> +) + +// JSXMemberExpression names are parsed/indented: +<Foo.Bar> + <div> + <Foo.Bar> + Hello World! + </Foo.Bar> + <Foo.Bar> + <div> + </div> + </Foo.Bar> + </div> +</Foo.Bar> + +// JSXOpeningFragment and JSXClosingFragment are parsed/indented: +<> + <div> + <> + Hello World! + </> + <> + <div> + </div> + </> + </div> +</> + +// Indent void expressions (no need for contextual parens / commas) +// (https://github.com/mooz/js2-mode/issues/140#issuecomment-166250016). +<div className="class-name"> + <h2>Title</h2> + {array.map(() => { + return <Element />; + })} + {message} +</div> +// Another example of above issue +// (https://github.com/mooz/js2-mode/issues/490). +<App> + <div> + {variable1} + <Component/> + </div> +</App> + +// Comments and arrows can break indentation (Bug#24896 / +// https://github.com/mooz/js2-mode/issues/389). +const Component = props => ( + <FatArrow a={e => c} + b={123}> + </FatArrow> +); +const Component = props => ( + <NoFatArrow a={123} + b={123}> + </NoFatArrow> +); +const Component = props => ( // Parse this comment, please. + <FatArrow a={e => c} + b={123}> + </FatArrow> +); +const Component = props => ( // Parse this comment, please. + <NoFatArrow a={123} + b={123}> + </NoFatArrow> +); +// Another example of above issue (Bug#30225). +class { + render() { + return ( + <select style={{paddingRight: "10px"}} + onChange={e => this.setState({value: e.target.value})} + value={this.state.value}> + <option>Hi</option> + </select> + ); + } +} + +// JSX attributes of an arrow function’s expression body’s JSX +// expression should be indented with respect to the JSX opening +// element (Bug#26001 / +// https://github.com/mooz/js2-mode/issues/389#issuecomment-271869380). +class { + render() { + const messages = this.state.messages.map( + message => <Message key={message.id} + text={message.text} + mine={message.mine} /> + ); return messages; + } + render() { + const messages = this.state.messages.map(message => + <Message key={message.timestamp} + text={message.text} + mine={message.mine} /> + ); return messages; + } +} + +// Users expect tag closers to align with the tag’s start; this is the +// style used in the React docs, so it should be the default. +// - https://github.com/mooz/js2-mode/issues/389#issuecomment-390766873 +// - https://github.com/mooz/js2-mode/issues/482 +// - Bug#32158 +const foo = (props) => ( + <div> + <input + cat={i => i} + /> + <button + className="square" + > + {this.state.value} + </button> + </div> +); + +// Embedded JSX in parens breaks indentation +// (https://github.com/mooz/js2-mode/issues/411). +let a = ( + <div> + {condition && <Component/>} + {condition && <Component/>} + <div/> + </div> +) +let b = ( + <div> + {condition && (<Component/>)} + <div/> + </div> +) +let c = ( + <div> + {condition && (<Component/>)} + {condition && "something"} + </div> +) +let d = ( + <div> + {(<Component/>)} + {condition && "something"} + </div> +) +// Another example of the above issue (Bug#27000). +function testA() { + return ( + <div> + <div> { ( <div/> ) } </div> + </div> + ); +} +function testB() { + return ( + <div> + <div> { <div/> } </div> + </div> + ); +} +// Another example of the above issue +// (https://github.com/mooz/js2-mode/issues/451). +class Classy extends React.Component { + render () { + return ( + <div> + <ul className="tocListRoot"> + { this.state.list.map((item) => { + return (<div />) + })} + </ul> + </div> + ) + } +} + +// Self-closing tags should be indented properly +// (https://github.com/mooz/js2-mode/issues/459). +export default ({ stars }) => ( + <div className='overlay__container'> + <div className='overlay__header overlay--text'> + Congratulations! + </div> + <div className='overlay__reward'> + <Icon {...createIconProps(stars > 0)} size='large' /> + <div className='overlay__reward__bottom'> + <Icon {...createIconProps(stars > 1)} size='small' /> + <Icon {...createIconProps(stars > 2)} size='small' /> + </div> + </div> + <div className='overlay__description overlay--text'> + You have created <large>1</large> reminder + </div> + </div> +) + +// JS expressions should not break indentation +// (https://github.com/mooz/js2-mode/issues/462). +// +// In the referenced issue, the user actually wanted indentation which +// was simply different than Emacs’ SGML attribute indentation. +// Nevertheless, his issue highlighted our inability to properly +// indent code with JSX inside JSXExpressionContainers inside JSX. +return ( + <Router> + <Bar> + <Route exact path="/foo" + render={() => ( + <div>nothing</div> + )} /> + <Route exact path="/bar" /> + </Bar> + </Router> +) + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: diff --git a/test/lisp/progmodes/js-tests.el b/test/lisp/progmodes/js-tests.el index 0d53c0681bf..6c3a618b949 100644 --- a/test/lisp/progmodes/js-tests.el +++ b/test/lisp/progmodes/js-tests.el @@ -1,4 +1,4 @@ -;;; js-tests.el --- Test suite for js-mode +;;; js-tests.el --- Test suite for js-mode -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'js) (require 'syntax) @@ -196,6 +197,46 @@ if (!/[ (:,='\"]/.test(value)) { ;; The bug was a hang. (should t))) +;;;; Indentation tests. + +(defun js-tests--remove-indentation () + "Remove all indentation in the current buffer." + (goto-char (point-min)) + (while (re-search-forward (rx bol (+ (in " \t"))) nil t) + (let ((syntax (save-match-data (syntax-ppss)))) + (unless (nth 3 syntax) ; Avoid multiline string literals. + (replace-match ""))))) + +(defmacro js-deftest-indent (file) + `(ert-deftest ,(intern (format "js-indent-test/%s" file)) () + :tags '(:expensive-test) + (let ((buf (find-file-noselect (ert-resource-file ,file)))) + (unwind-protect + (with-current-buffer buf + (let ((orig (buffer-string))) + (js-tests--remove-indentation) + ;; Indent and check that we get the original text. + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig)) + ;; Verify idempotency. + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig)))) + (kill-buffer buf))))) + +(js-deftest-indent "js-chain.js") +(js-deftest-indent "js-indent-align-list-continuation-nil.js") +(js-deftest-indent "js-indent-init-dynamic.js") +(js-deftest-indent "js-indent-init-t.js") +(js-deftest-indent "js.js") +(js-deftest-indent "jsx-align-gt-with-lt.jsx") +(js-deftest-indent "jsx-comment-string.jsx") +(js-deftest-indent "jsx-indent-level.jsx") +(js-deftest-indent "jsx-quote.jsx") +(js-deftest-indent "jsx-self-closing.jsx") +(js-deftest-indent "jsx-unclosed-1.jsx") +(js-deftest-indent "jsx-unclosed-2.jsx") +(js-deftest-indent "jsx.jsx") + (provide 'js-tests) ;;; js-tests.el ends here diff --git a/test/lisp/progmodes/opascal-tests.el b/test/lisp/progmodes/opascal-tests.el new file mode 100644 index 00000000000..70a4ebfa70d --- /dev/null +++ b/test/lisp/progmodes/opascal-tests.el @@ -0,0 +1,45 @@ +;;; opascal-tests.el --- tests for opascal.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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/>. + +(require 'ert) +(require 'opascal) + +(ert-deftest opascal-indent-bug-36348 () + (with-temp-buffer + (opascal-mode) + (let ((orig "{ -*- opascal -*- } + +procedure Toto (); +begin + for i := 0 to 1 do + Write (str.Chars[i]); + + // bug#36348 + for var i := 0 to 1 do + Write (str.Chars[i]); + +end; +")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + +(provide 'opascal-tests) + +;;; opascal-tests.el ends here diff --git a/test/lisp/progmodes/pascal-tests.el b/test/lisp/progmodes/pascal-tests.el new file mode 100644 index 00000000000..ed4c6fb03e0 --- /dev/null +++ b/test/lisp/progmodes/pascal-tests.el @@ -0,0 +1,63 @@ +;;; pascal-tests.el --- tests for pascal.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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/>. + +(require 'ert) +(require 'pascal) + +(ert-deftest pascal-completion () + ;; Bug#41740: completion functions must preserve point. + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; var") + (let* ((point-before (point)) + (completions (pascal-completion "var" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after))))) + + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; function f(x : i") + (let* ((point-before (point)) + (completions (pascal-completion "i" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after))))) + + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; function f(x : integer) : real") + (let* ((point-before (point)) + (completions (pascal-completion "real" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after)))))) + +(ert-deftest pascal-beg-of-defun () + (with-temp-buffer + (pascal-mode) + (insert "program test; procedure p(") + (forward-char -1) + (pascal-beg-of-defun) + (should (equal (point) 15)))) + +(provide 'pascal-tests) diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el new file mode 100644 index 00000000000..a2ea972c103 --- /dev/null +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -0,0 +1,33 @@ +;;; perl-mode-tests --- Test for perl-mode -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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 'perl-mode) + +;;;; Re-use cperl-mode tests + +(defvar cperl-test-mode) +(setq cperl-test-mode #'perl-mode) +(load-file (expand-file-name "cperl-mode-tests.el" + (file-truename + (file-name-directory (or load-file-name + buffer-file-name))))) + +;;; perl-mode-tests.el ends here diff --git a/test/lisp/progmodes/ps-mode-tests.el b/test/lisp/progmodes/ps-mode-tests.el index a47abebe6e4..61cf4c62511 100644 --- a/test/lisp/progmodes/ps-mode-tests.el +++ b/test/lisp/progmodes/ps-mode-tests.el @@ -1,4 +1,4 @@ -;;; ps-mode-tests.el --- Test suite for ps-mode +;;; ps-mode-tests.el --- Test suite for ps-mode -*- lexical-binding:t -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. @@ -43,6 +43,30 @@ (should (equal (buffer-string) "foo\\220\\221\\222bar")))) +(ert-deftest ps-mode-test-indent () + ;; Converted from manual test. + (with-temp-buffer + (ps-mode) + ;; TODO: Should some of these be fontification tests as well? + (let ((orig "%!PS-2.0 + +<< 23 45 >> %dictionary +< 23 > %hex string +<~a>a%a~> %base85 string +(%)s +(sf\\(g>a)sdg) + +/foo { + << + hello 2 + 3 + >> +} def +")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + (provide 'ps-mode-tests) ;;; ps-mode-tests.el ends here diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index f57150c397e..64626333c44 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -1,4 +1,4 @@ -;;; python-tests.el --- Test suite for python.el +;;; python-tests.el --- Test suite for python.el -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -118,7 +118,6 @@ Argument MIN and MAX delimit the region to be returned and default to `point-min' and `point-max' respectively." (let* ((min (or min (point-min))) (max (or max (point-max))) - (buffer (current-buffer)) (buffer-contents (buffer-substring-no-properties min max)) (overlays (sort (overlays-in min max) @@ -154,7 +153,7 @@ The name of this directory depends on `system-type'." sed do eiusmod tempor incididunt ut labore et dolore magna aliqua." (let ((expected (save-excursion - (dotimes (i 3) + (dotimes (_ 3) (re-search-forward "et" nil t)) (forward-char -2) (point)))) @@ -163,7 +162,7 @@ aliqua." ;; one should be returned. (should (= (python-tests-look-at "et" 6 t) expected)) ;; If already looking at STRING, it should skip it. - (dotimes (i 2) (re-search-forward "et")) + (dotimes (_ 2) (re-search-forward "et")) (forward-char -2) (should (= (python-tests-look-at "et") expected))))) @@ -178,7 +177,7 @@ aliqua." (re-search-forward "et" nil t) (forward-char -2) (point)))) - (dotimes (i 3) + (dotimes (_ 3) (re-search-forward "et" nil t)) (should (= (python-tests-look-at "et" -3 t) expected)) (should (= (python-tests-look-at "et" -6 t) expected))))) @@ -205,7 +204,7 @@ aliqua." ;;; Indentation -;; See: http://www.python.org/dev/peps/pep-0008/#indentation +;; See: https://www.python.org/dev/peps/pep-0008/#indentation (ert-deftest python-indent-pep8-1 () "First pep8 case." @@ -340,7 +339,7 @@ def func(arg): # I don't do much return arg # This comment is badly indented because the user forced so. - # At this line python.el wont dedent, user is always right. + # At this line python.el won't dedent, user is always right. comment_wins_over_ender = True @@ -359,7 +358,7 @@ comment_wins_over_ender = True ;; The return keyword do make indentation lose a level... (should (= (python-indent-calculate-indentation) 0)) ;; ...but the current indentation was forced by the user. - (python-tests-look-at "# At this line python.el wont dedent") + (python-tests-look-at "# At this line python.el won't dedent") (should (eq (car (python-indent-context)) :after-comment)) (should (= (python-indent-calculate-indentation) 4)) ;; Should behave the same for blank lines: potentially a comment. @@ -2642,7 +2641,7 @@ if x: (ert-deftest python-shell-calculate-process-environment-2 () "Test `python-shell-extra-pythonpaths' modification." (let* ((process-environment process-environment) - (original-pythonpath (setenv "PYTHONPATH" "/path0")) + (_original-pythonpath (setenv "PYTHONPATH" "/path0")) (python-shell-extra-pythonpaths '("/path1" "/path2")) (process-environment (python-shell-calculate-process-environment))) (should (equal (getenv "PYTHONPATH") diff --git a/test/lisp/progmodes/ruby-mode-resources/ruby.rb b/test/lisp/progmodes/ruby-mode-resources/ruby.rb new file mode 100644 index 00000000000..95928030396 --- /dev/null +++ b/test/lisp/progmodes/ruby-mode-resources/ruby.rb @@ -0,0 +1,477 @@ +if something_wrong? # ruby-move-to-block-skips-heredoc + ActiveSupport::Deprecation.warn(<<-eowarn) + boo hoo + end + eowarn + foo + + foo(<<~squiggly) + end + squiggly +end + +def foo + %^bar^ +end + +# Percent literals. +b = %Q{This is a "string"} +c = %w!foo + bar + baz! +d = %(hello (nested) world) + +# Don't propertize percent literals inside strings. +"(%s, %s)" % [123, 456] + +"abc/#{ddf}ghi" +"abc\#{ddf}ghi" + +# Or inside comments. +x = # "tot %q/to"; = + y = 2 / 3 + +# Regexp after whitelisted method. +"abc".sub /b/, 'd' + +# Don't mismatch "sub" at the end of words. +a = asub / aslb + bsub / bslb; + +# Highlight the regexp after "if". +x = toto / foo if /do bar/ =~ "dobar" + +# Regexp options are highlighted. + +/foo/xi != %r{bar}mo.tee + +foo { /"tee/ + bar { |qux| /'fee"/ } # bug#20026 +} + +bar(class: XXX) do # ruby-indent-keyword-label + foo +end +bar + +foo = [1, # ruby-deep-indent + 2] + +foo = { # ruby-deep-indent-disabled + a: b +} + +foo = { a: b, + a1: b1 + } + +foo({ # bug#16118 + a: b, + c: d + }) + +bar = foo( + a, [ + 1, + ], + :qux => [ + 3 + ]) + +foo( + [ + { + a: b + }, + ], + { + c: d + } +) + +foo([{ + a: 2 + }, + { + b: 3 + }, + 4 + ]) + +foo = [ # ruby-deep-indent-disabled + 1 +] + +foo( # ruby-deep-indent-disabled + a +) + +# Multiline regexp. +/bars + tees # toots + nfoos/ + +def test1(arg) + puts "hello" +end + +def test2 (arg) + a = "apple" + + if a == 2 + puts "hello" + else + puts "there" + end + + if a == 2 then + puts "hello" + elsif a == 3 + puts "hello3" + elsif a == 3 then + puts "hello3" + else + puts "there" + end + + b = case a + when "a" + 6 + # Support for this syntax was removed in Ruby 1.9, so we + # probably don't need to handle it either. + # when "b" : + # 7 + # when "c" : 2 + when "d" then 4 + else 5 + end +end + +# Some Cucumber code: +Given /toto/ do + print "hello" +end + +# Bug#15208 +if something == :== + do_something + + return false unless method == :+ + x = y + z # Bug#16609 + + a = 1 ? 2 :( + 2 + 3 + ) +end + +# Bug#17097 +if x == :!= + something +end + +qux :+, + bar, + :[]=, + bar, + :a + +b = $: +c = ?? + +# Example from http://www.ruby-doc.org/docs/ProgrammingRuby/html/language.html +d = 4 + 5 + # no '\' needed + 6 + 7 + +# Example from http://www.ruby-doc.org/docs/ProgrammingRuby/html/language.html +e = 8 + 9 \ + + 10 # '\' needed + +foo = obj.bar { |m| tee(m) } + + obj.qux { |m| hum(m) } + +begin + foo +ensure + bar +end + +# Bug#15369 +MSG = 'Separate every 3 digits in the integer portion of a number' \ + 'with underscores(_).' + +class C + def foo + self.end + D.new.class + end + + def begin + end +end + +a = foo(j, k) - + bar_tee + +while a < b do # "do" is optional + foo +end + +desc "foo foo" \ + "bar bar" + +foo. + bar + +# https://github.com/rails/rails/blob/17f5d8e062909f1fcae25351834d8e89967b645e/activesupport/lib/active_support/time_with_zone.rb#L206 +foo # comment intended to confuse the tokenizer + .bar + +z = { + foo: { + a: "aaa", + b: "bbb" + } +} + +foo if + bar + +fail "stuff" \ + unless all_fine? + +if foo? + bar +end + +method arg1, # bug#15594 + method2 arg2, + arg3 + +method? arg1, + arg2 + +method! arg1, + arg2 + +method !arg1, + arg2 + +method [], + arg2 + +method :foo, + :bar + +method (a + b), + c, :d => :e, + f: g + +desc "abc", + defg + +it "is a method call with block" do |asd| + foo +end + +it("is too!") { + bar + .qux +} + +and_this_one(has) { |block, parameters| + tee +} + +if foo && + bar +end + +foo + + bar + +foo and + bar + +foo > bar && + tee < qux + +zux do + foo == bar && + tee == qux + + a = 3 and + b = 4 +end + +foo + bar == + tee + qux + +1 .. 2 && + 3 + +3 < 4 + + 5 + +10 << 4 ^ + 20 + +100 + 2 >> + 3 + +2 ** 10 / + 2 + +foo ^ + bar + +foo_bar_tee(1, 2, 3) + .qux&.bar + .tee.bar + &.tee + +foo do + bar + .tee +end + +def bar + foo + .baz +end + +abc(foo + .bar, + tee + .qux) + +# https://stackoverflow.com/questions/17786563/emacs-ruby-mode-if-expressions-indentation +tee = if foo + bar + else + tee + end + +a = b { + c +} + +aa = bb do + cc +end + +foo :bar do + qux +end + +foo do |*args| + tee +end + +bar do |&block| + tee +end + +foo = [1, 2, 3].map do |i| + i + 1 +end + +bar.foo do + bar +end + +bar.foo(tee) do + bar +end + +bar.foo(tee) { + bar +} + +bar 1 do + foo 2 do + tee + end +end + +foo | + bar + +def qux + foo ||= begin + bar + tee + rescue + oomph + end +end + +private def foo + bar +end + +%^abc^ +ddd + +qux = foo.fee ? + bar : + tee + +zoo.keep.bar!( + {x: y, + z: t}) + +zoo + .lose( + q, p) + +a.records().map(&:b).zip( + foo) + +foo1 = + subject.update( + 1 + ) + +foo2 = + subject. + update( + 2 + ) + +# FIXME: This is not consistent with the example below it, but this +# offset only happens if the colon is at eol, which wouldn't be often. +# Tokenizing `bar:' as `:bar =>' would be better, but it's hard to +# distinguish from a variable reference inside a ternary operator. +foo(bar: + tee) + +foo(:bar => + tee) + +regions = foo( + OpenStruct.new(id: 0, name: "foo") => [ + 10 + ] +) + +{'a' => { + 'b' => 'c', + 'd' => %w(e f) + } +} + +# Bug#17050 + +return render json: { + errors: { base: [message] }, + copying: copying + }, + status: 400 + +top test( + some, + top, + test) + +foo bar, { + tee: qux + } diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index 6bdc7651ff1..97ac1e1ecd9 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -1,4 +1,4 @@ -;;; ruby-mode-tests.el --- Test suite for ruby-mode +;;; ruby-mode-tests.el --- Test suite for ruby-mode -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ruby-mode) (defmacro ruby-with-temp-buffer (contents &rest body) @@ -711,7 +712,7 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby-with-temp-buffer ruby-sexp-test-example (goto-char (point-min)) (forward-line 1) - (ruby-forward-sexp) + (forward-sexp) (should (= 8 (line-number-at-pos))))) (ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () @@ -719,7 +720,7 @@ VALUES-PLIST is a list with alternating index and value elements." (goto-char (point-min)) (forward-line 7) (end-of-line) - (ruby-backward-sexp) + (backward-sexp) (should (= 2 (line-number-at-pos))))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-no-args () @@ -728,7 +729,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |end") (search-backward "do\n") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-backward-sexp-jumps-do-end-block-with-no-args () @@ -737,7 +738,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |end") (goto-char (point-max)) - (ruby-backward-sexp) + (backward-sexp) (should (looking-at "do$")))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-empty-args () @@ -746,7 +747,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do || |end") (search-backward "do ") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-backward-sexp-jumps-do-end-block-with-empty-args () @@ -755,7 +756,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do || |end") (goto-char (point-max)) - (ruby-backward-sexp) + (backward-sexp) (should (looking-at "do ")))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-args () @@ -764,7 +765,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |a,b| |end") (search-backward "do ") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-backward-sexp-jumps-do-end-block-with-args () @@ -773,7 +774,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |a,b| |end") (goto-char (point-max)) - (ruby-backward-sexp) + (backward-sexp) (should (looking-at "do ")))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-any-args () @@ -782,7 +783,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |*| |end") (search-backward "do ") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-expanded-one-arg () @@ -791,7 +792,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |a,| |end") (search-backward "do ") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-forward-sexp-jumps-do-end-block-with-one-and-any-args () @@ -800,7 +801,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |a,*| |end") (search-backward "do ") - (ruby-forward-sexp) + (forward-sexp) (should (eobp)))) (ert-deftest ruby-backward-sexp-jumps-do-end-block-with-one-and-any-args () @@ -809,7 +810,7 @@ VALUES-PLIST is a list with alternating index and value elements." "proc do |a,*| |end") (goto-char (point-max)) - (ruby-backward-sexp) + (backward-sexp) (should (looking-at "do ")))) (ert-deftest ruby-toggle-string-quotes-quotes-correctly () @@ -842,6 +843,16 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby--insert-coding-comment "utf-8") (should (string= "# encoding: utf-8\n\n" (buffer-string)))))) +(ert-deftest ruby--indent/converted-from-manual-test () + :tags '(:expensive-test) + ;; Converted from manual test. + (let ((buf (find-file-noselect (ert-resource-file "ruby.rb")))) + (unwind-protect + (with-current-buffer buf + (let ((orig (buffer-string))) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig)))) + (kill-buffer buf)))) (provide 'ruby-mode-tests) diff --git a/test/lisp/progmodes/scheme-tests.el b/test/lisp/progmodes/scheme-tests.el new file mode 100644 index 00000000000..e3736bd411e --- /dev/null +++ b/test/lisp/progmodes/scheme-tests.el @@ -0,0 +1,50 @@ +;;; scheme-tests.el --- Test suite for scheme.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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) +(require 'scheme) + +(ert-deftest scheme-test-indent () + ;; FIXME: Look into what is the expected indent here and fix it. + :expected-result :failed + ;; Converted from manual test. + (with-temp-buffer + (scheme-mode) + ;; TODO: Should some of these be fontification tests as well? + (let ((orig "#!/usr/bin/scheme is this a comment? + +;; This one is a comment +(a) +#| and this one as #|well|# as this! |# +(b) +(cons #;(this is a + comment) + head tail) +")) + (insert orig) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + +(provide 'scheme-tests) + +;;; scheme-tests.el ends here diff --git a/test/lisp/progmodes/subword-tests.el b/test/lisp/progmodes/subword-tests.el index 00168c01e13..6aeee76110b 100644 --- a/test/lisp/progmodes/subword-tests.el +++ b/test/lisp/progmodes/subword-tests.el @@ -1,22 +1,24 @@ -;;; subword-tests.el --- Testing the subword rules +;;; subword-tests.el --- Testing the subword rules -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el index 75409a62723..fb5a19d3d0c 100644 --- a/test/lisp/progmodes/tcl-tests.el +++ b/test/lisp/progmodes/tcl-tests.el @@ -1,4 +1,4 @@ -;;; tcl-tests.el --- Test suite for tcl-mode +;;; tcl-tests.el --- Test suite for tcl-mode -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/xref-resources/file1.txt b/test/lisp/progmodes/xref-resources/file1.txt new file mode 100644 index 00000000000..5d7cc544443 --- /dev/null +++ b/test/lisp/progmodes/xref-resources/file1.txt @@ -0,0 +1,2 @@ +foo foo +bar diff --git a/test/lisp/progmodes/xref-resources/file2.txt b/test/lisp/progmodes/xref-resources/file2.txt new file mode 100644 index 00000000000..9f075f26004 --- /dev/null +++ b/test/lisp/progmodes/xref-resources/file2.txt @@ -0,0 +1,2 @@ + +bar diff --git a/test/lisp/progmodes/xref-tests.el b/test/lisp/progmodes/xref-tests.el index 9c7a9e69658..038f9d0e304 100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@ -1,4 +1,4 @@ -;;; xref-tests.el --- tests for xref +;;; xref-tests.el --- tests for xref -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. @@ -23,13 +23,14 @@ ;;; Code: +(require 'ert) (require 'xref) (require 'cl-lib) (defvar xref-tests-data-dir - (expand-file-name "../../../data/xref/" - (or load-file-name - buffer-file-name))) + (expand-file-name "xref-resources/" + (file-name-directory + (or load-file-name buffer-file-name)))) (ert-deftest xref-matches-in-directory-finds-none-for-some-regexp () (should (null (xref-matches-in-directory "zzz" "*" xref-tests-data-dir nil)))) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index af765fbe3fa..aed14c33572 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -1,4 +1,4 @@ -;;; replace-tests.el --- tests for replace.el. +;;; replace-tests.el --- tests for replace.el. -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. @@ -546,4 +546,46 @@ Return the last evalled form in BODY." ?q (string= expected (buffer-string)))))) +(defmacro replace-tests-with-highlighted-occurrence (highlight-locus &rest body) + "Helper macro to test the highlight of matches when navigating occur buffer. + +Eval BODY with `next-error-highlight' and `next-error-highlight-no-select' +bound to HIGHLIGHT-LOCUS." + (declare (indent 1) (debug (form body))) + `(let ((regexp "foo") + (next-error-highlight ,highlight-locus) + (next-error-highlight-no-select ,highlight-locus) + (buffer (generate-new-buffer "test")) + (inhibit-message t)) + (unwind-protect + ;; Local bind to disable the deletion of `occur-highlight-overlay' + (cl-letf (((symbol-function 'occur-goto-locus-delete-o) (lambda ()))) + (with-current-buffer buffer (dotimes (_ 3) (insert regexp ?\n))) + (pop-to-buffer buffer) + (occur regexp) + (pop-to-buffer "*Occur*") + (occur-next) + ,@body) + (kill-buffer buffer) + (kill-buffer "*Occur*")))) + +(ert-deftest occur-highlight-occurrence () + "Test for https://debbugs.gnu.org/39121 ." + (let ((alist '((nil . nil) (0.5 . t) (t . t) (fringe-arrow . nil))) + (check-overlays + (lambda (has-ov) + (eq has-ov (not (null (overlays-in (point-min) (point-max)))))))) + (pcase-dolist (`(,highlight-locus . ,has-overlay) alist) + ;; Visiting occurrences + (replace-tests-with-highlighted-occurrence highlight-locus + (occur-mode-goto-occurrence) + (should (funcall check-overlays has-overlay))) + ;; Displaying occurrences + (replace-tests-with-highlighted-occurrence highlight-locus + (occur-mode-display-occurrence) + (with-current-buffer (marker-buffer + (get-text-property (point) 'occur-target)) + (should (funcall check-overlays has-overlay))))))) + + ;;; replace-tests.el ends here diff --git a/test/lisp/saveplace-resources/saveplace b/test/lisp/saveplace-resources/saveplace new file mode 100644 index 00000000000..3f3f6d501d6 --- /dev/null +++ b/test/lisp/saveplace-resources/saveplace @@ -0,0 +1,4 @@ +;;; -*- coding: utf-8 -*- +(("/home/skangas/.emacs.d/cache/recentf" . 1306) + ("/home/skangas/wip/emacs/" + (dired-filename . "/home/skangas/wip/emacs/COPYING"))) diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el new file mode 100644 index 00000000000..8d31e282180 --- /dev/null +++ b/test/lisp/saveplace-tests.el @@ -0,0 +1,99 @@ +;;; saveplace-tests.el --- Tests for saveplace.el -*- lexical-binding:t -*- + +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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: + +(require 'ert) +(require 'ert-x) +(require 'saveplace) + +(ert-deftest saveplace-test-save-place-to-alist/dir () + (save-place-mode) + (let* ((save-place-alist nil) + (save-place-loaded t) + (loc (ert-resource-directory))) + (save-window-excursion + (dired loc) + (save-place-to-alist) + (should (equal save-place-alist + `((,loc + (dired-filename . ,(concat loc "saveplace"))))))))) + +(ert-deftest saveplace-test-save-place-to-alist/file () + (save-place-mode) + (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) + (tmpfile (file-truename tmpfile)) + (save-place-alist nil) + (save-place-loaded t) + (loc tmpfile) + (pos 4)) + (unwind-protect + (save-window-excursion + (find-file loc) + (insert "abc") ; must insert something + (save-place-to-alist) + (should (equal save-place-alist (list (cons tmpfile pos))))) + (delete-file tmpfile)))) + +(ert-deftest saveplace-test-forget-unreadable-files () + (save-place-mode) + (let* ((save-place-loaded t) + (tmpfile (make-temp-file "emacs-test-saveplace-")) + (alist-orig (list (cons "/this/file/does/not/exist" 10) + (cons tmpfile 1917))) + (save-place-alist alist-orig)) + (unwind-protect + (progn + (save-place-forget-unreadable-files) + (should (equal save-place-alist (cdr alist-orig)))) + (delete-file tmpfile)))) + +(ert-deftest saveplace-test-place-alist-to-file () + (save-place-mode) + (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) + (tmpfile2 (make-temp-file "emacs-test-saveplace-")) + (save-place-file tmpfile) + (save-place-alist (list (cons tmpfile2 99)))) + (unwind-protect + (progn (save-place-alist-to-file) + (setq save-place-alist nil) + (save-window-excursion + (find-file save-place-file) + (unwind-protect + (should (string-match tmpfile2 (buffer-string))) + (kill-buffer)))) + (delete-file tmpfile) + (delete-file tmpfile2)))) + +(ert-deftest saveplace-test-load-alist-from-file () + (save-place-mode) + (let ((save-place-loaded nil) + (save-place-file + (ert-resource-file "saveplace")) + (save-place-alist nil)) + (load-save-place-alist-from-file) + (should (equal save-place-alist + '(("/home/skangas/.emacs.d/cache/recentf" . 1306) + ("/home/skangas/wip/emacs/" + (dired-filename . "/home/skangas/wip/emacs/COPYING"))))))) + +(provide 'saveplace-tests) +;;; saveplace-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 650782bc53c..eed9cb534b1 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -1,21 +1,23 @@ -;;; shadowfile-tests.el --- Tests of shadowfile +;;; shadowfile-tests.el --- Tests of shadowfile -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -70,7 +72,6 @@ (setq password-cache-expiry nil shadow-debug (getenv "EMACS_HYDRA_CI") tramp-verbose 0 - tramp-message-show-message nil ;; On macOS, `temporary-file-directory' is a symlinked directory. temporary-file-directory (file-truename temporary-file-directory) shadow-test-remote-temporary-file-directory @@ -126,6 +127,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-unless (file-remote-p shadow-test-remote-temporary-file-directory)) @@ -139,9 +141,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -256,9 +258,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -609,9 +611,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -670,9 +672,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -866,6 +868,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-unless (file-remote-p shadow-test-remote-temporary-file-directory)) (skip-unless (file-writable-p shadow-test-remote-temporary-file-directory)) @@ -924,7 +927,7 @@ guaranteed by the originator of a cluster definition." ;; action. (add-function :before (symbol-function #'write-region) - (lambda (&rest args) + (lambda (&rest _args) (when (and (buffer-file-name) mocked-input) (should (equal (buffer-file-name) (pop mocked-input))))) '((name . "write-region-mock"))) diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index dad54cb408e..786dd1647aa 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -4,18 +4,20 @@ ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -39,6 +41,13 @@ (with-no-warnings (simple-test--buffer-substrings)))) +;;; `count-words' +(ert-deftest simple-test-count-words-bug-41761 () + (with-temp-buffer + (dotimes (_i 10) (insert (propertize "test " 'field (cons nil nil)))) + (should (= (count-words (point-min) (point-max)) 10)))) + + ;;; `transpose-sexps' (defmacro simple-test--transpositions (&rest body) (declare (indent 0) @@ -392,6 +401,48 @@ See bug#35036." (should (equal ?\s (char-syntax ?\n)))))) +;;; undo tests + +(defun simple-tests--exec (cmds) + (dolist (cmd cmds) + (setq last-command this-command) + (setq this-command cmd) + (run-hooks 'pre-command-hook) + (command-execute cmd) + (run-hooks 'post-command-hook) + (undo-boundary))) + +(ert-deftest simple-tests--undo () + (with-temp-buffer + (buffer-enable-undo) + (dolist (x '("a" "b" "c" "d" "e")) + (insert x) + (undo-boundary)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo)) + (should (equal (buffer-string) "abcd")) + (simple-tests--exec '(undo)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(backward-char undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo)) + (should (equal (buffer-string) "abcd")) + (simple-tests--exec '(undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-only undo-only)) + (should (equal (buffer-string) "a")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abcde")) + )) + ;;; undo auto-boundary tests (ert-deftest undo-auto-boundary-timer () (should @@ -427,7 +478,7 @@ See bug#35036." (with-temp-buffer (switch-to-buffer (current-buffer)) (setq buffer-undo-list nil) - (insert "a\nb\n\c\n") + (insert "a\nb\nc\n") (goto-char (point-max)) ;; We use a keyboard macro because it adds undo events in the same ;; way as if a user were involved. diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index ffffe070ba6..b72ee2fd612 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -181,7 +181,7 @@ ;; The various 'window change functions' are now invoked by the ;; redisplay, and redisplay does nothing at all in batch mode, ;; so we cannot test under this revised behavior. Refer to: - ;; https://lists.gnu.org/archive/html/emacs-devel/2019-10/msg00971.html + ;; https://lists.gnu.org/r/emacs-devel/2019-10/msg00971.html ;; For interactive (non-batch) test runs, calling `redisplay' ;; does do the trick; so do that first. (redisplay) diff --git a/test/lisp/sort-tests.el b/test/lisp/sort-tests.el index 21f483a23af..9033745e0d4 100644 --- a/test/lisp/sort-tests.el +++ b/test/lisp/sort-tests.el @@ -4,18 +4,20 @@ ;; Author: Artur Malabarba <bruce.connor.am@gmail.com> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 059d52b1b6f..035c064d75c 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1,4 +1,4 @@ -;;; subr-tests.el --- Tests for subr.el +;;; subr-tests.el --- Tests for subr.el -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -172,27 +172,28 @@ (should (equal (version-to-list "6.9.30Beta") '(6 9 30 -2))) (should (equal (version-to-list "6.9.30_Beta") '(6 9 30 -2))) - (should (equal - (error-message-string (should-error (version-to-list "OTP-18.1.5"))) - "Invalid version syntax: `OTP-18.1.5' (must start with a number)")) - (should (equal - (error-message-string (should-error (version-to-list ""))) - "Invalid version syntax: `' (must start with a number)")) - (should (equal - (error-message-string (should-error (version-to-list "1.0..7.5"))) - "Invalid version syntax: `1.0..7.5'")) - (should (equal - (error-message-string (should-error (version-to-list "1.0prepre2"))) - "Invalid version syntax: `1.0prepre2'")) - (should (equal - (error-message-string (should-error (version-to-list "22.8X3"))) - "Invalid version syntax: `22.8X3'")) - (should (equal - (error-message-string (should-error (version-to-list "beta22.8alpha3"))) - "Invalid version syntax: `beta22.8alpha3' (must start with a number)")) - (should (equal - (error-message-string (should-error (version-to-list "honk"))) - "Invalid version syntax: `honk' (must start with a number)")) + (let ((text-quoting-style 'grave)) + (should (equal + (error-message-string (should-error (version-to-list "OTP-18.1.5"))) + "Invalid version syntax: `OTP-18.1.5' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list ""))) + "Invalid version syntax: `' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "1.0..7.5"))) + "Invalid version syntax: `1.0..7.5'")) + (should (equal + (error-message-string (should-error (version-to-list "1.0prepre2"))) + "Invalid version syntax: `1.0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22.8alpha3"))) + "Invalid version syntax: `beta22.8alpha3' (must start with a number)")) + (should (equal + (error-message-string (should-error (version-to-list "honk"))) + "Invalid version syntax: `honk' (must start with a number)"))) (should (equal (error-message-string (should-error (version-to-list 9))) "Version must be a string")) @@ -231,18 +232,40 @@ (should (equal (version-to-list "6_9_30.Beta") '(6 9 30 -2))) (should (equal (version-to-list "6_9_30Beta") '(6 9 30 -2))) - (should (equal - (error-message-string (should-error (version-to-list "1_0__7_5"))) - "Invalid version syntax: `1_0__7_5'")) - (should (equal - (error-message-string (should-error (version-to-list "1_0prepre2"))) - "Invalid version syntax: `1_0prepre2'")) - (should (equal - (error-message-string (should-error (version-to-list "22.8X3"))) - "Invalid version syntax: `22.8X3'")) - (should (equal - (error-message-string (should-error (version-to-list "beta22_8alpha3"))) - "Invalid version syntax: `beta22_8alpha3' (must start with a number)")))) + (let ((text-quoting-style 'grave)) + (should (equal + (error-message-string (should-error (version-to-list "1_0__7_5"))) + "Invalid version syntax: `1_0__7_5'")) + (should (equal + (error-message-string (should-error (version-to-list "1_0prepre2"))) + "Invalid version syntax: `1_0prepre2'")) + (should (equal + (error-message-string (should-error (version-to-list "22.8X3"))) + "Invalid version syntax: `22.8X3'")) + (should (equal + (error-message-string (should-error (version-to-list "beta22_8alpha3"))) + "Invalid version syntax: `beta22_8alpha3' (must start with a number)"))))) + +(ert-deftest subr-test-version-list-< () + (should (version-list-< '(0) '(1))) + (should (version-list-< '(0 9) '(1 0))) + (should (version-list-< '(1 -1) '(1 0))) + (should (version-list-< '(1 -2) '(1 -1))) + (should (not (version-list-< '(1) '(0)))) + (should (not (version-list-< '(1 1) '(1 0)))) + (should (not (version-list-< '(1) '(1 0)))) + (should (not (version-list-< '(1 0) '(1 0 0))))) + +(ert-deftest subr-test-version-list-= () + (should (version-list-= '(1) '(1))) + (should (version-list-= '(1 0) '(1))) + (should (not (version-list-= '(0) '(1))))) + +(ert-deftest subr-test-version-list-<= () + (should (version-list-<= '(0) '(1))) + (should (version-list-<= '(1) '(1))) + (should (version-list-<= '(1 0) '(1))) + (should (not (version-list-<= '(1) '(0))))) (defun subr-test--backtrace-frames-with-backtrace-frame (base) "Reference implementation of `backtrace-frames'." @@ -417,5 +440,49 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-error (ignore-error foo (read "")))) +(ert-deftest string-replace () + (should (equal (string-replace "foo" "bar" "zot") + "zot")) + (should (equal (string-replace "foo" "bar" "foozot") + "barzot")) + (should (equal (string-replace "foo" "bar" "barfoozot") + "barbarzot")) + (should (equal (string-replace "zot" "bar" "barfoozot") + "barfoobar")) + (should (equal (string-replace "z" "bar" "barfoozot") + "barfoobarot")) + (should (equal (string-replace "zot" "bar" "zat") + "zat")) + (should (equal (string-replace "azot" "bar" "zat") + "zat")) + (should (equal (string-replace "azot" "bar" "azot") + "bar")) + + (should (equal (string-replace "azot" "bar" "foozotbar") + "foozotbar")) + + (should (equal (string-replace "fo" "bar" "lafofofozot") + "labarbarbarzot")) + + (should (equal (string-replace "\377" "x" "a\377b") + "axb")) + (should (equal (string-replace "\377" "x" "a\377ø") + "axø")) + (should (equal (string-replace (string-to-multibyte "\377") "x" "a\377b") + "axb")) + (should (equal (string-replace (string-to-multibyte "\377") "x" "a\377ø") + "axø")) + + (should (equal (string-replace "ana" "ANA" "ananas") "ANAnas")) + + (should (equal (string-replace "a" "" "") "")) + (should (equal (string-replace "a" "" "aaaaa") "")) + (should (equal (string-replace "ab" "" "ababab") "")) + (should (equal (string-replace "ab" "" "abcabcabc") "ccc")) + (should (equal (string-replace "a" "aa" "aaa") "aaaaaa")) + (should (equal (string-replace "abc" "defg" "abc") "defg")) + + (should-error (string-replace "" "x" "abc"))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index bc41b863da7..f05389df60f 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -29,7 +29,8 @@ (cons 420 "rw-r--r--") (cons 292 "r--r--r--") (cons 512 "--------T") - (cons 1024 "-----S---")))) + (cons 1024 "-----S---") + (cons 2048 "--S------")))) (dolist (x alist) (should (equal (cdr x) (tar-grind-file-mode (car x))))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index 0dd310b8531..bfe475910da 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -216,6 +216,45 @@ (tempo-complete-tag) (should (equal (buffer-string) "Hello, World!")))) +(ert-deftest tempo-define-tag-globally-test () + "Testing usage of a template tag defined from another buffer." + (tempo-define-template "test" '("Hello, World!") "hello") + + (with-temp-buffer + ;; Use a tag in buffer 1 + (insert "hello") + (tempo-complete-tag) + (should (equal (buffer-string) "Hello, World!")) + (erase-buffer) + + ;; Collection should not be dirty + (should-not tempo-dirty-collection) + + ;; Define a tag on buffer 2 + (with-temp-buffer + (tempo-define-template "test2" '("Now expanded.") "mytag")) + + ;; I should be able to use this template back in buffer 1 + (insert "mytag") + (tempo-complete-tag) + (should (equal (buffer-string) "Now expanded.")))) + +(ert-deftest tempo-overwrite-tag-test () + "Testing ability to reassign templates to tags." + (with-temp-buffer + ;; Define a tag and use it + (tempo-define-template "test-tag-1" '("abc") "footag") + (insert "footag") + (tempo-complete-tag) + (should (equal (buffer-string) "abc")) + (erase-buffer) + + ;; Define a new template with the same tag + (tempo-define-template "test-tag-2" '("xyz") "footag") + (insert "footag") + (tempo-complete-tag) + (should (equal (buffer-string) "xyz")))) + (ert-deftest tempo-expand-partial-tag-test () "Testing expansion of a template with a tag, with a partial match." (with-temp-buffer diff --git a/test/lisp/textmodes/bibtex-tests.el b/test/lisp/textmodes/bibtex-tests.el new file mode 100644 index 00000000000..56bd54efb74 --- /dev/null +++ b/test/lisp/textmodes/bibtex-tests.el @@ -0,0 +1,57 @@ +;;; bibtex-tests.el --- Test suite for bibtex. -*- lexical-binding:t -*- + +;; Copyright (C) 2013-2020 Free Software Foundation, Inc. + +;; Keywords: bibtex + +;; 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 'bibtex) + +(ert-deftest bibtex-test-set-dialect () + "Tests if `bibtex-set-dialect' is executed." + (with-temp-buffer + (insert "@article{someID, + author = {some author}, + title = {some title}, +}") + (bibtex-mode) + (should-not (null bibtex-dialect)) + (should-not (null bibtex-entry-type)) + (should-not (null bibtex-entry-head)) + (should-not (null bibtex-reference-key)) + (should-not (null bibtex-entry-head)) + (should-not (null bibtex-entry-maybe-empty-head)) + (should-not (null bibtex-any-valid-entry-type)))) + +(ert-deftest bibtex-test-parse-buffers-stealthily () + "Tests if `bibtex-parse-buffers-stealthily' can be executed." + (with-temp-buffer + (insert "@article{someID, + author = {some author}, + title = {some title}, +}") + (bibtex-mode) + (should (progn (bibtex-parse-buffers-stealthily) t)))) + +(provide 'bibtex-tests) + +;;; bibtex-tests.el ends here diff --git a/test/lisp/textmodes/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el index 814cb06b960..7e094e8a7c2 100644 --- a/test/lisp/textmodes/conf-mode-tests.el +++ b/test/lisp/textmodes/conf-mode-tests.el @@ -7,18 +7,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -162,7 +162,7 @@ image/tiff tiff tif (ert-deftest conf-test-toml-mode () ;; From `conf-toml-mode' docstring. (with-temp-buffer - (insert "\[entry] + (insert "[entry] value = \"some string\"") (goto-char (point-min)) (conf-toml-mode) diff --git a/test/lisp/textmodes/css-mode-resources/test-indent.css b/test/lisp/textmodes/css-mode-resources/test-indent.css new file mode 100644 index 00000000000..041aeec1b15 --- /dev/null +++ b/test/lisp/textmodes/css-mode-resources/test-indent.css @@ -0,0 +1,100 @@ +/* asdfasdf */ + +.xxx +{ +} + +article[role="main"] { + width: 60%; +} + +a, b:hover, c { + color: black !important; +} + +a, b:hover { /* bug:20282 */ + c { + color: black; + } + color: black; +} + +a.b:c,d.e:f,g[h]:i,j[k]:l,.m.n:o,.p.q:r,.s[t]:u,.v[w]:x { /* bug:20282 */ + background-color: white; +} + +/* asdfasdf */ +@foo x2 { + bla:toto; +} +.x2 +{ + /* foo: bar; */ foo2: bar2; + bar1: url("http://toto/titi"); + bar2: url('http://toto/titi'); + bar3: url(http://toto/titi); +} + +div.x3 +{ +} + +article:hover +{ + color: black; +} + +/* bug:13425 */ +div:first-child, +div:last-child, +div[disabled], +div::before { + font: 15px "Helvetica Neue", + Helvetica, + Arial, + "Nimbus Sans L", + sans-serif; + font: 15px "Helvetica Neue", Helvetica, Arial, + "Nimbus Sans L", sans-serif; + background: no-repeat right + 5px center; + transform: matrix(1.0, 2.0, + 3.0, 4.0, + 5.0, 6.0); + transform: matrix( + 1.0, 2.0, + 3.0, 4.0, + 5.0, 6.0 + ); +} + +/* Multi-line selector including both a pseudo-class and + parenthesis. */ +.form-group:not(.required) label, +.birth-date .row > * { + &::after { + display: inline; + font-weight: normal; + } +} + +@font-face { + src: url("Sans-Regular.eot") format("eot"), + url("Sans-Regular.woff") format("woff"), + url("Sans-Regular.ttf") format("truetype"); +} + +@font-face { + src: + url("Sans-Regular.eot") format("eot"), + url("Sans-Regular.woff") format("woff"); +} + +.foo-bar--baz { + --foo-variable: 5px; + --_variable_with_underscores: #fff; + --_variable-starting-with-underscore: none; + margin: var(--foo-variable); + color: var(--_variable_with_underscores); + display: var(--_variable-starting-with-underscore); +} diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index b57bbd8a9ef..476fd326e66 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -7,18 +7,20 @@ ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -26,6 +28,7 @@ (require 'css-mode) (require 'ert) +(require 'ert-x) (require 'seq) (ert-deftest css-test-property-values () @@ -409,5 +412,12 @@ (point)) "black"))))) +(ert-deftest css-mode-test-indent () + (with-current-buffer + (find-file-noselect (ert-resource-file "test-indent.css")) + (let ((orig (buffer-string))) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) orig))))) + (provide 'css-mode-tests) ;;; css-mode-tests.el ends here diff --git a/test/lisp/textmodes/mhtml-mode-tests.el b/test/lisp/textmodes/mhtml-mode-tests.el index aa5f19efdaa..1840e8b4016 100644 --- a/test/lisp/textmodes/mhtml-mode-tests.el +++ b/test/lisp/textmodes/mhtml-mode-tests.el @@ -1,4 +1,4 @@ -;;; mhtml-mode-tests.el --- Tests for mhtml-mode +;;; mhtml-mode-tests.el --- Tests for mhtml-mode -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/textmodes/paragraphs-tests.el b/test/lisp/textmodes/paragraphs-tests.el index fc839fe7d95..0b264e7e184 100644 --- a/test/lisp/textmodes/paragraphs-tests.el +++ b/test/lisp/textmodes/paragraphs-tests.el @@ -50,8 +50,8 @@ (goto-char (point-min)) (mark-paragraph) (should mark-active) - (should (equal (mark) 7))) - (should-error (mark-paragraph 0))) + (should (equal (mark) 7)))) +;;; (should-error (mark-paragraph 0))) (ert-deftest paragraphs-tests-kill-paragraph () (with-temp-buffer diff --git a/test/lisp/textmodes/po-tests.el b/test/lisp/textmodes/po-tests.el new file mode 100644 index 00000000000..a098290ce15 --- /dev/null +++ b/test/lisp/textmodes/po-tests.el @@ -0,0 +1,68 @@ +;;; po-tests.el --- Tests for po.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@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 'po) +(require 'ert) + +(defconst po-tests--buffer-string + "# Norwegian bokmål translation of the GIMP. +# Copyright (C) 1999-2001 Free Software Foundation, Inc. +# +msgid \"\" +msgstr \"\" +\"Project-Id-Version: gimp 2.8.5\\n\" +\"Report-Msgid-Bugs-To: https://gitlab.gnome.org/GNOME/gimp/issues\\n\" +\"POT-Creation-Date: 2013-05-27 14:57+0200\\n\" +\"PO-Revision-Date: 2013-05-27 15:21+0200\\n\" +\"Language: nb\\n\" +\"MIME-Version: 1.0\\n\" +\"Content-Type: text/plain; charset=UTF-8\\n\" +\"Content-Transfer-Encoding: 8bit\\n\" +\"Plural-Forms: nplurals=2; plural=(n != 1);\\n\" + +#: ../desktop/gimp.desktop.in.in.h:1 ../app/about.h:26 +msgid \"GNU Image Manipulation Program\" +msgstr \"GNU bildebehandlingsprogram\" +") + +(ert-deftest po-tests-find-charset () + (with-temp-buffer + (insert po-tests--buffer-string) + (should (equal (po-find-charset (cons nil (current-buffer))) + "UTF-8")))) + +(ert-deftest po-tests-find-file-coding-system-guts () + (with-temp-buffer + (insert po-tests--buffer-string) + (should (equal (po-find-file-coding-system-guts + 'insert-file-contents + (cons "*tmp*" (current-buffer))) + '(utf-8 . nil))))) + +(provide 'po-tests) +;;; po-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index 2350326c14c..42a060b395e 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -153,24 +153,23 @@ edition = {17th}, note = {Updated for Emacs Version 24.2} }") - (check (function - (lambda (parsed) - (should (string= (reftex-get-bib-field "&key" parsed) - "Stallman12")) - (should (string= (reftex-get-bib-field "&type" parsed) - "book")) - (should (string= (reftex-get-bib-field "author" parsed) - "Richard Stallman et al.")) - (should (string= (reftex-get-bib-field "title" parsed) - "The Emacs Editor")) - (should (string= (reftex-get-bib-field "publisher" parsed) - "GNU Press")) - (should (string= (reftex-get-bib-field "year" parsed) - "2012")) - (should (string= (reftex-get-bib-field "edition" parsed) - "17th")) - (should (string= (reftex-get-bib-field "note" parsed) - "Updated for Emacs Version 24.2")))))) + (check (lambda (parsed) + (should (string= (reftex-get-bib-field "&key" parsed) + "Stallman12")) + (should (string= (reftex-get-bib-field "&type" parsed) + "book")) + (should (string= (reftex-get-bib-field "author" parsed) + "Richard Stallman et al.")) + (should (string= (reftex-get-bib-field "title" parsed) + "The Emacs Editor")) + (should (string= (reftex-get-bib-field "publisher" parsed) + "GNU Press")) + (should (string= (reftex-get-bib-field "year" parsed) + "2012")) + (should (string= (reftex-get-bib-field "edition" parsed) + "17th")) + (should (string= (reftex-get-bib-field "note" parsed) + "Updated for Emacs Version 24.2"))))) (funcall check (reftex-parse-bibtex-entry entry)) (with-temp-buffer (insert entry) diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el index f0b93e24d2c..a4457307b35 100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@ -1,4 +1,4 @@ -;;; sgml-mode-tests.el --- Tests for sgml-mode +;;; sgml-mode-tests.el --- Tests for sgml-mode -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 4edf75edba6..f02aeaeef6a 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -1,4 +1,4 @@ -;;; thingatpt.el --- tests for thing-at-point. +;;; thingatpt.el --- tests for thing-at-point. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/lisp/time-resources/non-empty b/test/lisp/time-resources/non-empty new file mode 100644 index 00000000000..86f5704d8ee --- /dev/null +++ b/test/lisp/time-resources/non-empty @@ -0,0 +1 @@ +This file should be non-empty. diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index d229fddc48d..e75e84b0221 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -38,9 +38,7 @@ (cl-letf (((symbol-function 'time-stamp-conv-warn) (lambda (old-format _new) (ert-fail - (format "Unexpected format warning for '%s'" old-format)))) - ((symbol-function 'system-name) - (lambda () "test-system-name.example.org"))) + (format "Unexpected format warning for '%s'" old-format))))) ;; Not all reference times are used in all tests; ;; suppress the byte compiler's "unused" warning. (list ref-time1 ref-time2 ref-time3) @@ -56,6 +54,13 @@ (apply orig-time-stamp-string-fn ts-format ,reference-time nil)))) ,@body)) +(defmacro with-time-stamp-system-name (name &rest body) + "Force (system-name) to return NAME while evaluating BODY." + (declare (indent defun)) + `(cl-letf (((symbol-function 'system-name) + (lambda () ,name))) + ,@body)) + (defmacro time-stamp-should-warn (form) "Similar to `should' but verifies that a format warning is generated." `(let ((warning-count 0)) @@ -170,6 +175,20 @@ ;; triggering the tests above. (time-stamp))))))) +(ert-deftest time-stamp-custom-format-tabs-expand () + "Test that Tab characters expand in the format but not elsewhere." + (with-time-stamp-test-env + (let ((time-stamp-start "Updated in: <\t") + ;; Tabs in the format should expand + (time-stamp-format "\t%Y\t") + (time-stamp-end "\t>")) + (with-time-stamp-test-time ref-time1 + (with-temp-buffer + (insert "Updated in: <\t\t>") + (time-stamp) + (should (equal (buffer-string) + "Updated in: <\t 2006 \t>"))))))) + (ert-deftest time-stamp-custom-inserts-lines () "Test that time-stamp inserts lines or not, as directed." (with-time-stamp-test-env @@ -194,19 +213,46 @@ (time-stamp) (should (equal (buffer-string) buffer-expected-2line))))))) +(ert-deftest time-stamp-custom-end () + "Test that time-stamp finds the end pattern on the correct line." + (with-time-stamp-test-env + (let ((time-stamp-start "Updated on: <") + (time-stamp-format "%Y-%m-%d") + (time-stamp-end ">") ;changed later in the test + (buffer-original-contents "Updated on: <\n>\n") + (buffer-expected-time-stamped "Updated on: <2006-01-02\n>\n")) + (with-time-stamp-test-time ref-time1 + (with-temp-buffer + (insert buffer-original-contents) + ;; time-stamp-end is not on same line, should not be seen + (time-stamp) + (should (equal (buffer-string) buffer-original-contents)) + + ;; add a newline to time-stamp-end, so it starts on same line + (setq time-stamp-end "\n>") + (time-stamp) + (should (equal (buffer-string) buffer-expected-time-stamped))))))) + (ert-deftest time-stamp-custom-count () "Test that time-stamp updates no more than time-stamp-count templates." (with-time-stamp-test-env (let ((time-stamp-start "TS: <") (time-stamp-format "%Y-%m-%d") - (time-stamp-count 1) ;changed later in the test + (time-stamp-count 0) ;changed later in the test (buffer-expected-once "TS: <2006-01-02>\nTS: <>") (buffer-expected-twice "TS: <2006-01-02>\nTS: <2006-01-02>")) (with-time-stamp-test-time ref-time1 (with-temp-buffer (insert "TS: <>\nTS: <>") (time-stamp) + ;; even with count = 0, expect one time stamp + (should (equal (buffer-string) buffer-expected-once))) + (with-temp-buffer + (setq time-stamp-count 1) + (insert "TS: <>\nTS: <>") + (time-stamp) (should (equal (buffer-string) buffer-expected-once)) + (setq time-stamp-count 2) (time-stamp) (should (equal (buffer-string) buffer-expected-twice))))))) @@ -488,26 +534,35 @@ (ert-deftest time-stamp-format-non-date-conversions () "Test time-stamp formats for non-date items." (with-time-stamp-test-env - ;; implemented and documented since 1995 - (should (equal (time-stamp-string "%%" ref-time1) "%")) ;% last char - (should (equal (time-stamp-string "%%P" ref-time1) "%P")) ;% not last char - (should (equal (time-stamp-string "%f" ref-time1) "time-stamped-file")) - (should - (equal (time-stamp-string "%F" ref-time1) "/emacs/test/time-stamped-file")) - (should (equal (time-stamp-string "%h" ref-time1) "test-mail-host-name")) - ;; documented 1995-2019 - (should (equal - (time-stamp-string "%s" ref-time1) "test-system-name.example.org")) - (should (equal (time-stamp-string "%U" ref-time1) "100%d Tester")) - (should (equal (time-stamp-string "%u" ref-time1) "test-logname")) - ;; implemented since 2001, documented since 2019 - (should (equal (time-stamp-string "%L" ref-time1) "100%d Tester")) - (should (equal (time-stamp-string "%l" ref-time1) "test-logname")) - ;; implemented since 2007, documented since 2019 - (should (equal - (time-stamp-string "%Q" ref-time1) "test-system-name.example.org")) - (should (equal - (time-stamp-string "%q" ref-time1) "test-system-name")))) + (with-time-stamp-system-name "test-system-name.example.org" + ;; implemented and documented since 1995 + (should (equal (time-stamp-string "%%" ref-time1) "%")) ;% last char + (should (equal (time-stamp-string "%%P" ref-time1) "%P")) ;% not last char + (should (equal (time-stamp-string "%f" ref-time1) "time-stamped-file")) + (should (equal (time-stamp-string "%F" ref-time1) + "/emacs/test/time-stamped-file")) + (with-temp-buffer + (should (equal (time-stamp-string "%f" ref-time1) "(no file)")) + (should (equal (time-stamp-string "%F" ref-time1) "(no file)"))) + (should (equal (time-stamp-string "%h" ref-time1) "test-mail-host-name")) + (let ((mail-host-address nil)) + (should (equal (time-stamp-string "%h" ref-time1) + "test-system-name.example.org"))) + ;; documented 1995-2019 + (should (equal (time-stamp-string "%s" ref-time1) + "test-system-name.example.org")) + (should (equal (time-stamp-string "%U" ref-time1) "100%d Tester")) + (should (equal (time-stamp-string "%u" ref-time1) "test-logname")) + ;; implemented since 2001, documented since 2019 + (should (equal (time-stamp-string "%L" ref-time1) "100%d Tester")) + (should (equal (time-stamp-string "%l" ref-time1) "test-logname")) + ;; implemented since 2007, documented since 2019 + (should (equal (time-stamp-string "%Q" ref-time1) + "test-system-name.example.org")) + (should (equal (time-stamp-string "%q" ref-time1) "test-system-name"))) + (with-time-stamp-system-name "sysname-no-dots" + (should (equal (time-stamp-string "%Q" ref-time1) "sysname-no-dots")) + (should (equal (time-stamp-string "%q" ref-time1) "sysname-no-dots"))))) (ert-deftest time-stamp-format-ignored-modifiers () "Test additional args allowed (but ignored) to allow for future expansion." @@ -538,6 +593,13 @@ ;;; Tests of helper functions +(ert-deftest time-stamp-helper-string-defaults () + "Test that time-stamp-string defaults its format to time-stamp-format." + (with-time-stamp-test-env + (should (equal (time-stamp-string nil ref-time1) + (time-stamp-string time-stamp-format ref-time1))) + (should (equal (time-stamp-string 'not-a-string ref-time1) nil)))) + (ert-deftest time-stamp-helper-zone-type-p () "Test time-stamp-zone-type-p." (should (time-stamp-zone-type-p t)) diff --git a/test/lisp/time-tests.el b/test/lisp/time-tests.el new file mode 100644 index 00000000000..2d327b959cc --- /dev/null +++ b/test/lisp/time-tests.el @@ -0,0 +1,79 @@ +;;; time-tests.el --- Tests for time.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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: + +(require 'ert) +(require 'ert-x) +(require 'time) + +(ert-deftest time-tests-display-time-mail-check-directory () + (let ((display-time-mail-directory (ert-resource-directory))) + (should (display-time-mail-check-directory)))) + +(ert-deftest time-tests-display-time-update--load () + (let ((display-time-load-average 1) + (display-time-load-average-threshold 0)) + (display-time-next-load-average) + (should (string-match (rx string-start " " + (+ (| digit ".")) + string-end) + (display-time-update--load)))) + (let (display-time-load-average) + (should (equal (display-time-update--load) "")))) + +(ert-deftest time-tests-display-time-update () + (let ((display-time-load-average 1) + (display-time-load-average-threshold 0) + display-time-string) + (display-time-update) + (should (string-match (rx string-start + (? digit) digit ":" digit digit + (? (| "AM" "PM")) + " " (+ (| digit ".")) + (? " Mail") + string-end) + display-time-string)))) + +(ert-deftest time-tests-display-time-file-nonempty-p () + (should (display-time-file-nonempty-p (ert-resource-file "non-empty"))) + (should-not (display-time-file-nonempty-p "/non/existent"))) + +(ert-deftest time-tests-world-clock () + (save-window-excursion + (world-clock) + (should (equal (buffer-name) world-clock-buffer-name)) + (should (string-match "New York" (buffer-string))))) + +(ert-deftest time-tests-world-clock/revert-buffer-works () + (save-window-excursion + (world-clock) + (revert-buffer) + (should (string-match "New York" (buffer-string))))) + +(ert-deftest time-tests-emacs-uptime () + (should (string-match "^[0-9.]+ seconds?$" (emacs-uptime "%S")))) + +(ert-deftest time-tests-emacs-init-time () + (should (string-match "^[0-9.]+ seconds?$" (emacs-init-time)))) + +(provide 'time-tests) +;;; time-tests.el ends here diff --git a/test/lisp/url/url-auth-tests.el b/test/lisp/url/url-auth-tests.el index c574f3d373b..d3acdef8535 100644 --- a/test/lisp/url/url-auth-tests.el +++ b/test/lisp/url/url-auth-tests.el @@ -1,4 +1,4 @@ -;;; url-auth-tests.el --- Test suite for url-auth. +;;; url-auth-tests.el --- Test suite for url-auth. -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-domsuf-tests.el b/test/lisp/url/url-domsuf-tests.el new file mode 100644 index 00000000000..a4fffb06311 --- /dev/null +++ b/test/lisp/url/url-domsuf-tests.el @@ -0,0 +1,51 @@ +;;; url-domsuf-tests.el --- Tests for url-domsuf.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 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 'url-domsuf) +(require 'ert) + +(defun url-domsuf-tests--run () + (should-not (url-domsuf-cookie-allowed-p "com")) + (should (url-domsuf-cookie-allowed-p "foo.bar.bd")) + (should-not (url-domsuf-cookie-allowed-p "bar.bd")) + (should-not (url-domsuf-cookie-allowed-p "co.uk")) + (should (url-domsuf-cookie-allowed-p "foo.bar.hokkaido.jo")) + (should-not (url-domsuf-cookie-allowed-p "bar.yokohama.jp")) + (should (url-domsuf-cookie-allowed-p "city.yokohama.jp"))) + +(ert-deftest url-domsuf-test-cookie-allowed-p () + "Run the domsuf tests without need for parsing a file." + (let ((url-domsuf-domains '(("com") + ("bar.bd") + ("co.uk") + ("bar.yokohama.jp")))) + (url-domsuf-tests--run))) + +(ert-deftest url-domsuf-test-cookie-allowed-p/and-parse () + "Run the domsuf tests, but also parse the file." + :tags '(:expensive-test) + (url-domsuf-tests--run)) + +(provide 'url-domsuf-tests) + +;;; url-domsuf-tests.el ends here diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el index 553bcf67bd2..3b0b6fbd41a 100644 --- a/test/lisp/url/url-expand-tests.el +++ b/test/lisp/url/url-expand-tests.el @@ -1,4 +1,4 @@ -;;; url-expand-tests.el --- Test suite for relative URI/URL resolution. +;;; url-expand-tests.el --- Test suite for relative URI/URL resolution. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -100,6 +100,13 @@ (should (equal (url-expand-file-name "foo#bar" "http://host/foobar") "http://host/foo#bar")) (should (equal (url-expand-file-name "foo#bar" "http://host/foobar/") "http://host/foobar/foo#bar"))) +(ert-deftest url-expand-file-name/relative-resolution-file-url () + "RFC 3986, Section 5.4 Reference Resolution Examples / Section 5.4.1. Normal Examples" + (should (equal (url-expand-file-name "bar.html" "file:///a/b/c/foo.html") "file:///a/b/c/bar.html")) + (should (equal (url-expand-file-name "bar.html" "file:///a/b/c/") "file:///a/b/c/bar.html")) + (should (equal (url-expand-file-name "../d/bar.html" "file:///a/b/c/") "file:///a/b/d/bar.html")) + (should (equal (url-expand-file-name "../d/bar.html" "file:///a/b/c/foo.html") "file:///a/b/d/bar.html"))) + (provide 'url-expand-tests) ;;; url-expand-tests.el ends here diff --git a/test/lisp/url/url-file-tests.el b/test/lisp/url/url-file-tests.el index e4a45fb9c82..810504faf2c 100644 --- a/test/lisp/url/url-file-tests.el +++ b/test/lisp/url/url-file-tests.el @@ -23,18 +23,11 @@ (require 'url-file) (require 'ert) - -(defconst url-file-tests-data-directory - (expand-file-name "lisp/url/url-file-resources" - (or (getenv "EMACS_TEST_DIRECTORY") - (expand-file-name "../../.." - (or load-file-name - buffer-file-name)))) - "Directory for url-file test files.") +(require 'ert-x) (ert-deftest url-file () "Test reading file via file:/// URL." - (let* ((file (expand-file-name "file.txt" url-file-tests-data-directory)) + (let* ((file (ert-resource-file "file.txt")) (uri-prefix (if (eq (aref file 0) ?/) "file://" "file:///"))) (should (equal (with-current-buffer diff --git a/test/lisp/url/url-future-tests.el b/test/lisp/url/url-future-tests.el index 2c5d45d62b2..a07730a2be6 100644 --- a/test/lisp/url/url-future-tests.el +++ b/test/lisp/url/url-future-tests.el @@ -1,4 +1,4 @@ -;;; url-future-tests.el --- Test suite for url-future. +;;; url-future-tests.el --- Test suite for url-future. -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. @@ -25,31 +25,33 @@ (require 'ert) (require 'url-future) +(defvar url-future-tests--saver) + (ert-deftest url-future-tests () - (let* (saver + (let* (url-future-tests--saver (text "running future") (good (make-url-future :value (lambda () (format text)) - :callback (lambda (f) (set 'saver f)))) + :callback (lambda (f) (set 'url-future-tests--saver f)))) (bad (make-url-future :value (lambda () (/ 1 0)) - :errorback (lambda (&rest d) (set 'saver d)))) + :errorback (lambda (&rest d) (set 'url-future-tests--saver d)))) (tocancel (make-url-future :value (lambda () (/ 1 0)) - :callback (lambda (f) (set 'saver f)) + :callback (lambda (f) (set 'url-future-tests--saver f)) :errorback (lambda (&rest d) - (set 'saver d))))) + (set 'url-future-tests--saver d))))) (should (equal good (url-future-call good))) - (should (equal good saver)) + (should (equal good url-future-tests--saver)) (should (equal text (url-future-value good))) (should (url-future-completed-p good)) (should-error (url-future-call good)) - (setq saver nil) + (setq url-future-tests--saver nil) (should (equal bad (url-future-call bad))) (should-error (url-future-call bad)) - (should (equal saver (list bad '(arith-error)))) + (should (equal url-future-tests--saver (list bad '(arith-error)))) (should (url-future-errored-p bad)) - (setq saver nil) + (setq url-future-tests--saver nil) (should (equal (url-future-cancel tocancel) tocancel)) (should-error (url-future-call tocancel)) - (should (null saver)) + (should (null url-future-tests--saver)) (should (url-future-cancelled-p tocancel)))) (provide 'url-future-tests) diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-test.el index bf574fcc1a5..57692e53a70 100644 --- a/test/lisp/url/url-handlers-test.el +++ b/test/lisp/url/url-handlers-test.el @@ -4,18 +4,20 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el index 98e6dcb9aed..6ec46479a6f 100644 --- a/test/lisp/url/url-parse-tests.el +++ b/test/lisp/url/url-parse-tests.el @@ -1,4 +1,4 @@ -;;; url-parse-tests.el --- Test suite for URI/URL parsing. +;;; url-parse-tests.el --- Test suite for URI/URL parsing. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-tramp-tests.el b/test/lisp/url/url-tramp-tests.el index d6f830afcf2..965b9ea0888 100644 --- a/test/lisp/url/url-tramp-tests.el +++ b/test/lisp/url/url-tramp-tests.el @@ -1,4 +1,4 @@ -;;; url-tramp-tests.el --- Test suite for Tramp / URL conversion. +;;; url-tramp-tests.el --- Test suite for Tramp / URL conversion. -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el index fd3a8d6e108..0416331b032 100644 --- a/test/lisp/url/url-util-tests.el +++ b/test/lisp/url/url-util-tests.el @@ -1,4 +1,4 @@ -;;; url-util-tests.el --- Test suite for url-util. +;;; url-util-tests.el --- Test suite for url-util. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/vc/add-log-tests.el b/test/lisp/vc/add-log-tests.el index fc928b02c3b..f256945ee42 100644 --- a/test/lisp/vc/add-log-tests.el +++ b/test/lisp/vc/add-log-tests.el @@ -1,4 +1,4 @@ -;;; add-log-tests.el --- Test suite for add-log. +;;; add-log-tests.el --- Test suite for add-log. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -25,12 +25,12 @@ (require 'ert) (require 'add-log) -(defmacro add-log-current-defun-deftest (name doc major-mode +(defmacro add-log-current-defun-deftest (name doc mode content marker expected-defun) "Generate an ert test for mode-own `add-log-current-defun-function'. -Run `add-log-current-defun' at the point where MARKER specifies in a -buffer which content is CONTENT under MAJOR-MODE. Then it compares the -result with EXPECTED-DEFUN." +Run `add-log-current-defun' at the point where MARKER specifies +in a buffer which content is CONTENT under major mode MODE. Then +it compares the result with EXPECTED-DEFUN." (let ((xname (intern (concat "add-log-current-defun-test-" (symbol-name name) )))) @@ -39,7 +39,7 @@ result with EXPECTED-DEFUN." (with-temp-buffer (insert ,content) (goto-char (point-min)) - (funcall ',major-mode) + (funcall ',mode) (should (equal (when (search-forward ,marker nil t) (replace-match "" nil t) (add-log-current-defun)) diff --git a/test/lisp/vc/diff-mode-resources/hello_emacs.c b/test/lisp/vc/diff-mode-resources/hello_emacs.c new file mode 100644 index 00000000000..c7ed7538c3a --- /dev/null +++ b/test/lisp/vc/diff-mode-resources/hello_emacs.c @@ -0,0 +1,6 @@ +#include <stdio.h> +int main() +{ + printf("Hello, Emacs!\n"); + return 0; +} diff --git a/test/lisp/vc/diff-mode-resources/hello_emacs_1.c b/test/lisp/vc/diff-mode-resources/hello_emacs_1.c new file mode 100644 index 00000000000..62145a6b44a --- /dev/null +++ b/test/lisp/vc/diff-mode-resources/hello_emacs_1.c @@ -0,0 +1 @@ +int main() { printf("Hello, Emacs!\n"); return 0; }
\ No newline at end of file diff --git a/test/lisp/vc/diff-mode-resources/hello_world.c b/test/lisp/vc/diff-mode-resources/hello_world.c new file mode 100644 index 00000000000..dcbe06c6012 --- /dev/null +++ b/test/lisp/vc/diff-mode-resources/hello_world.c @@ -0,0 +1,6 @@ +#include <stdio.h> +int main() +{ + printf("Hello, World!\n"); + return 0; +} diff --git a/test/lisp/vc/diff-mode-resources/hello_world_1.c b/test/lisp/vc/diff-mode-resources/hello_world_1.c new file mode 100644 index 00000000000..606afb371cb --- /dev/null +++ b/test/lisp/vc/diff-mode-resources/hello_world_1.c @@ -0,0 +1 @@ +int main() { printf("Hello, World!\n"); return 0; }
\ No newline at end of file diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 26e9f26fe24..b25836405cc 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -1,3 +1,5 @@ +;;; diff-mode-tests.el --- Tests for diff-mode.el -*- lexical-binding:t -*- + ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. ;; Author: Dima Kogan <dima@secretsauce.net> @@ -20,12 +22,11 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'diff-mode) (require 'diff) -(defconst diff-mode-tests--datadir - (expand-file-name "test/data/vc/diff-mode" source-directory)) - (ert-deftest diff-mode-test-ignore-trailing-dashes () "Check to make sure we successfully ignore trailing -- made by 'git format-patch'. This is bug #9597" @@ -204,9 +205,14 @@ youthfulness (ert-deftest diff-mode-test-font-lock () "Check font-locking of diff hunks." + ;; See comments in diff-hunk-file-names about nonascii. + ;; In such cases, the diff-font-lock-syntax portion of this fails. + :expected-result (if (string-match-p "[[:nonascii:]]" + (ert-resource-directory)) + :failed :passed) (skip-unless (executable-find shell-file-name)) (skip-unless (executable-find diff-command)) - (let ((default-directory diff-mode-tests--datadir) + (let ((default-directory (ert-resource-directory)) (old "hello_world.c") (new "hello_emacs.c") (diff-buffer (get-buffer-create "*Diff*")) @@ -242,6 +248,7 @@ youthfulness 111 124 (face diff-context) 124 127 (face diff-context)))) + ;; Test diff-font-lock-syntax. (should (equal (mapcar (lambda (o) (list (- (overlay-start o) diff-beg) (- (overlay-end o) diff-beg) @@ -265,9 +272,12 @@ youthfulness (ert-deftest diff-mode-test-font-lock-syntax-one-line () "Check diff syntax highlighting for one line with no newline at end." + :expected-result (if (string-match-p "[[:nonascii:]]" + (ert-resource-directory)) + :failed :passed) (skip-unless (executable-find shell-file-name)) (skip-unless (executable-find diff-command)) - (let ((default-directory diff-mode-tests--datadir) + (let ((default-directory (ert-resource-directory)) (old "hello_world_1.c") (new "hello_emacs_1.c") (diff-buffer (get-buffer-create "*Diff*")) diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index ab44e23033c..15270d68cb5 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -1,21 +1,23 @@ -;;; ediff-ptch-tests.el --- Tests for ediff-ptch.el +;;; ediff-ptch-tests.el --- Tests for ediff-ptch.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. ;; Author: Tino Calancha <tino.calancha@gmail.com> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/vc/smerge-mode-tests.el b/test/lisp/vc/smerge-mode-tests.el index c76fc172402..5b15a0931d1 100644 --- a/test/lisp/vc/smerge-mode-tests.el +++ b/test/lisp/vc/smerge-mode-tests.el @@ -1,3 +1,5 @@ +;;; smerge-mode-tests.el --- Tests for smerge-mode.el -*- lexical-binding:t -*- + ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index b68a6945129..bd26f7979dc 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -1,4 +1,4 @@ -;;; vc-bzr.el --- tests for vc/vc-bzr.el +;;; vc-bzr.el --- tests for vc/vc-bzr.el -*- lexical-binding: t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. @@ -37,7 +37,7 @@ ;; commands (eg `bzr status') want to access ~/.bazaar, and will ;; abort if they cannot. I could not figure out how to stop bzr ;; doing that, so just give it a temporary homedir for the duration. - ;; http://bugs.launchpad.net/bzr/+bug/137407 ? + ;; https://bugs.launchpad.net/bzr/+bug/137407 ? ;; ;; Note that with bzr 2.x, this works: ;; mkdir /tmp/bzr @@ -131,7 +131,6 @@ (make-directory bzrdir) (expand-file-name "foo.el" bzrdir))) (default-directory (file-name-as-directory bzrdir)) - (generated-autoload-file (expand-file-name "loaddefs.el" bzrdir)) (process-environment (cons (format "HOME=%s" homedir) process-environment))) (unwind-protect @@ -148,7 +147,9 @@ ;; causes bzr status to fail. This simulates a broken bzr ;; installation. (delete-file ".bzr/checkout/dirstate") - (should (progn (update-directory-autoloads default-directory) + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) t))) (delete-directory homedir t)))) diff --git a/test/lisp/vc/vc-hg-tests.el b/test/lisp/vc/vc-hg-tests.el index 01d197574fc..e4a20bbf2da 100644 --- a/test/lisp/vc/vc-hg-tests.el +++ b/test/lisp/vc/vc-hg-tests.el @@ -1,4 +1,4 @@ -;;; vc-hg-tests.el --- tests for vc/vc-hg.el +;;; vc-hg-tests.el --- tests for vc/vc-hg.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 43d24486ed1..7b88b8d531a 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -1,21 +1,23 @@ -;;; vc-tests.el --- Tests of different backends of vc.el +;;; vc-tests.el --- Tests of different backends of vc.el -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> -;; This program is free software: you can redistribute it and/or +;; 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. ;; -;; This program is distributed in the hope that it will be useful, but +;; 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 this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -224,11 +226,10 @@ For backends which don't support it, `vc-not-supported' is signaled." (defmacro vc-test--run-maybe-unsupported-function (func &rest args) "Run FUNC with ARGS as arguments. Catch the `vc-not-supported' error." - `(let (err) - (condition-case err - (funcall ,func ,@args) - (vc-not-supported 'vc-not-supported) - (t (signal (car err) (cdr err)))))) + `(condition-case err + (funcall ,func ,@args) + (vc-not-supported 'vc-not-supported) + (t (signal (car err) (cdr err))))) (defun vc-test--register (backend) "Register and unregister a file. @@ -555,7 +556,8 @@ This checks also `vc-backend' and `vc-responsible-backend'." (defvar vc-svn-program) (defun vc-test--svn-enabled () - (executable-find vc-svn-program)) + (and (executable-find "svnadmin") + (executable-find vc-svn-program))) (defun vc-test--sccs-enabled () (executable-find "sccs")) diff --git a/test/lisp/version-tests.el b/test/lisp/version-tests.el new file mode 100644 index 00000000000..8fbd4a19fc5 --- /dev/null +++ b/test/lisp/version-tests.el @@ -0,0 +1,31 @@ +;;; version-tests.el --- Tests for version.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 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) + +(ert-deftest test-emacs-version () + (should (string-match emacs-version (emacs-version))) + (should (string-match system-configuration (emacs-version)))) + +(provide 'version-tests) +;;; version-tests.el ends here diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 5b01c54cf24..f876967bf98 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: @@ -106,7 +106,6 @@ only the name before the link arrow." "Test editing a file name without saving the change. Finding the new name should be possible while still in wdired-mode." - :expected-result (if (< emacs-major-version 27) :failed :passed) (let* ((test-dir (make-temp-file "test-dir-" t)) (test-file (concat (file-name-as-directory test-dir) "foo.c")) (replace "bar") @@ -143,6 +142,7 @@ wdired-get-filename before and after editing." (let* ((test-dir (make-temp-file "test-dir-" t)) (server-socket-dir test-dir) (dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) (buf (find-file-noselect test-dir))) (unwind-protect (progn @@ -178,6 +178,22 @@ wdired-get-filename before and after editing." (server-force-delete) (delete-directory test-dir t)))) +(ert-deftest wdired-test-bug39280 () + "Test for https://debbugs.gnu.org/39280." + (let* ((test-dir (make-temp-file "test-dir" 'dir)) + (fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf)) + (delete-directory test-dir t))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el index 2ddb656fa9e..1bd429736ea 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -113,4 +113,192 @@ (should (eq (current-column) (widget-get grandchild :indent))))))) +(ert-deftest widget-test-character-widget-value () + "Check that we get the character widget's value correctly." + (with-temp-buffer + (let ((wid (widget-create '(character :value ?\n)))) + (goto-char (widget-get wid :from)) + (should (string= (widget-apply wid :value-get) "\n")) + (should (char-equal (widget-value wid) ?\n)) + (should-not (widget-apply wid :validate))))) + +(ert-deftest widget-test-editable-field-widget-value () + "Test that we get the editable field widget's value correctly." + (with-temp-buffer + (let ((wid (widget-create '(editable-field :value "")))) + (widget-insert "And some non-widget text.") + (should (string= (widget-apply wid :value-get) ""))))) + +(ert-deftest widget-test-moving-editable-list-item () + "Check that we can move an editable list item up or down, via delete+insert." + (with-temp-buffer + (widget-insert "Testing editable-list.\n\n") + (let ((lst (widget-create 'editable-list + :value '("beg" "end" "middle") + '(editable-field :value "unknown")))) + (use-local-map widget-keymap) + (widget-setup) + ;; Go to the DEL button for the 2nd element and action it. + (goto-char (widget-get (nth 2 (widget-get lst :buttons)) :from)) + (widget-apply-action (widget-at)) + ;; Go to the INS button and action it. + (goto-char (widget-get lst :to)) + (widget-backward 1) + (widget-apply-action (widget-at)) + ;; Check that we effectively moved the item to the last position. + (should (equal (widget-value lst) '("beg" "middle" "end")))))) + +(ert-deftest widget-test-choice-match-no-inline () + "Test that a no-inline choice widget can match its values." + (let* ((choice '(choice (const nil) (const t) string function)) + (widget (widget-convert choice))) + (should (widget-apply widget :match nil)) + (should (widget-apply widget :match t)) + (should (widget-apply widget :match "")) + (should (widget-apply widget :match 'ignore)))) + +(ert-deftest widget-test-choice-match-all-inline () + "Test that a choice widget with all inline members can match its values." + (let* ((lst '(list (choice (list :inline t symbol number) + (list :inline t symbol regexp)))) + (widget (widget-convert lst))) + (should-not (widget-apply widget :match nil)) + (should (widget-apply widget :match '(:test 2))) + (should (widget-apply widget :match '(:test ".*"))) + (should-not (widget-apply widget :match '(:test ignore))))) + +(ert-deftest widget-test-choice-match-some-inline () + "Test that a choice widget with some inline members can match its values." + (let* ((lst '(list string + (choice (const t) + (list :inline t symbol number) + (list :inline t symbol regexp)))) + (widget (widget-convert lst))) + (should-not (widget-apply widget :match nil)) + (should (widget-apply widget :match '("" t))) + (should (widget-apply widget :match '("" :test 2))) + (should (widget-apply widget :match '("" :test ".*"))) + (should-not (widget-apply widget :match '(:test ignore))))) + +(ert-deftest widget-test-inline-p () + "Test `widget-inline-p'. +For widgets without an :inline t property, `widget-inline-p' has to return nil. +But if the widget is a choice widget, it has to return nil if passed nil as +the bubblep argument, or non-nil if one of the members of the choice widget has +an :inline t property and we pass a non-nil bubblep argument. If no members of +the choice widget have an :inline t property, then `widget-inline-p' has to +return nil, even with a non-nil bubblep argument." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'repeat + :value '(nil) + '(choice (const nil) (const t) + (list :inline t symbol number)) + '(choice (const nil) (const t) + (list function string)))) + (children (widget-get widget :children)) + (child-1 (car children)) + (child-2 (cadr children))) + (should-not (widget-inline-p widget)) + (should-not (widget-inline-p child-1)) + (should (widget-inline-p child-1 'bubble)) + (should-not (widget-inline-p child-2)) + (should-not (widget-inline-p child-2 'bubble))))) + +(ert-deftest widget-test-repeat-can-handle-choice () + "Test that we can create a repeat widget with a choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'repeat + :entry-format "%i %d %v" + :value '((:test 2)) + '(choice (const nil) (const t) + (list symbol number)))) + (child (car (widget-get widget :children)))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '((:test 2))))))) + +(ert-deftest widget-test-repeat-can-handle-inlinable-choice () + "Test that we can create a repeat widget with an inlinable choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'repeat + :entry-format "%i %d %v" + :value '(:test 2) + '(choice (const nil) (const t) + (list :inline t symbol number)))) + (child (widget-get widget :children))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '(:test 2)))))) + +(ert-deftest widget-test-list-can-handle-choice () + "Test that we can create a list widget with a choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'list + :value '((1 "One")) + '(choice string + (list number string)))) + (child (car (widget-get widget :children)))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '((1 "One"))))))) + +(ert-deftest widget-test-list-can-handle-inlinable-choice () + "Test that we can create a list widget with an inlinable choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'list + :value '(1 "One") + '(choice string + (list :inline t number string)))) + (child (car (widget-get widget :children)))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '(1 "One")))))) + +(ert-deftest widget-test-option-can-handle-choice () + "Test that we can create a option widget with a choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'repeat + :value '(("foo")) + '(list (option + (choice string + (list :inline t + number string)))))) + (child (car (widget-get widget :children)))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '(("foo"))))))) + +(ert-deftest widget-test-option-can-handle-inlinable-choice () + "Test that we can create a option widget with an inlinable choice correctly." + (with-temp-buffer + (widget-insert "Testing.\n\n") + (let* ((widget (widget-create 'repeat + :value '((1 "One")) + '(list (option + (choice string + (list :inline t + number string)))))) + (child (car (widget-get widget :children)))) + (widget-insert "\n") + (use-local-map widget-keymap) + (widget-setup) + (should child) + (should (equal (widget-value widget) '((1 "One"))))))) + ;;; wid-edit-tests.el ends here diff --git a/test/lisp/xdg-resources/l10n.desktop b/test/lisp/xdg-resources/l10n.desktop new file mode 100644 index 00000000000..42da83910da --- /dev/null +++ b/test/lisp/xdg-resources/l10n.desktop @@ -0,0 +1,5 @@ +# localized strings +[Desktop Entry] +Comment=Cheers +Comment[en_US@piglatin]=Eerschay +Comment[sv]=Skål diff --git a/test/lisp/xdg-resources/malformed.desktop b/test/lisp/xdg-resources/malformed.desktop new file mode 100644 index 00000000000..144a3f719d5 --- /dev/null +++ b/test/lisp/xdg-resources/malformed.desktop @@ -0,0 +1,4 @@ +# unacceptable key=value format +[Desktop Entry] +Key=value +aowef faoweif of diff --git a/test/lisp/xdg-resources/mimeapps.list b/test/lisp/xdg-resources/mimeapps.list new file mode 100644 index 00000000000..27fbd94b16b --- /dev/null +++ b/test/lisp/xdg-resources/mimeapps.list @@ -0,0 +1,9 @@ +[Default Applications] +x-test/foo=a.desktop + +[Added Associations] +x-test/foo=b.desktop +x-test/baz=a.desktop + +[Removed Associations] +x-test/foo=c.desktop;d.desktop diff --git a/test/lisp/xdg-resources/mimeinfo.cache b/test/lisp/xdg-resources/mimeinfo.cache new file mode 100644 index 00000000000..6e54f604fa0 --- /dev/null +++ b/test/lisp/xdg-resources/mimeinfo.cache @@ -0,0 +1,4 @@ +[MIME Cache] +x-test/foo=c.desktop;d.desktop +x-test/bar=a.desktop;c.desktop +x-test/baz=b.desktop;d.desktop diff --git a/test/lisp/xdg-resources/test.desktop b/test/lisp/xdg-resources/test.desktop new file mode 100644 index 00000000000..b848cef5b0f --- /dev/null +++ b/test/lisp/xdg-resources/test.desktop @@ -0,0 +1,5 @@ +# this is a comment +[Desktop Entry] +Name=Test +[Another Section] +Exec=frobnicate diff --git a/test/lisp/xdg-resources/wrong.desktop b/test/lisp/xdg-resources/wrong.desktop new file mode 100644 index 00000000000..e0b4c221cf9 --- /dev/null +++ b/test/lisp/xdg-resources/wrong.desktop @@ -0,0 +1,2 @@ +# the first section must be "Desktop Entry" +[Why] diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el index 294996af5f8..c2a16006c35 100644 --- a/test/lisp/xdg-tests.el +++ b/test/lisp/xdg-tests.el @@ -25,26 +25,20 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'xdg) -(defconst xdg-tests-data-dir - (expand-file-name "test/data/xdg" source-directory)) - (ert-deftest xdg-desktop-parsing () "Test `xdg-desktop-read-file' parsing of .desktop files." - (let ((tab1 (xdg-desktop-read-file - (expand-file-name "test.desktop" xdg-tests-data-dir))) - (tab2 (xdg-desktop-read-file - (expand-file-name "test.desktop" xdg-tests-data-dir) + (let ((tab1 (xdg-desktop-read-file (ert-resource-file "test.desktop"))) + (tab2 (xdg-desktop-read-file (ert-resource-file "test.desktop") "Another Section"))) (should (equal (gethash "Name" tab1) "Test")) (should (eq 'default (gethash "Exec" tab1 'default))) (should (equal "frobnicate" (gethash "Exec" tab2)))) (should-error - (xdg-desktop-read-file - (expand-file-name "malformed.desktop" xdg-tests-data-dir))) - (let ((tab (xdg-desktop-read-file - (expand-file-name "l10n.desktop" xdg-tests-data-dir))) + (xdg-desktop-read-file (ert-resource-file "malformed.desktop"))) + (let ((tab (xdg-desktop-read-file (ert-resource-file "l10n.desktop"))) (env (getenv "LC_MESSAGES"))) (unwind-protect (progn @@ -67,8 +61,8 @@ (ert-deftest xdg-mime-associations () "Test reading MIME associations from files." - (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir)) - (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir)) + (let* ((apps (ert-resource-file "mimeapps.list")) + (cache (ert-resource-file "mimeinfo.cache")) (fs (list apps cache))) (should (equal (xdg-mime-collect-associations "x-test/foo" fs) '("a.desktop" "b.desktop"))) diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index 895b68f79af..d09336c0080 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -1,4 +1,4 @@ -;;; xml-parse-tests.el --- Test suite for XML parsing. +;;; xml-parse-tests.el --- Test suite for XML parsing. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -164,6 +164,37 @@ Parser is called with and without 'symbol-qnames argument.") (should (equal (cdr xml-parse-test--namespace-attribute-qnames) (xml-parse-region nil nil nil nil 'symbol-qnames))))) +(ert-deftest xml-print-invalid-cdata () + "Check that Bug#41094 is fixed." + (with-temp-buffer + (should (equal (should-error (xml-print '((foo () "\0"))) + :type 'xml-invalid-character) + '(xml-invalid-character 0 1))) + (should (equal (should-error (xml-print '((foo () "\u00FF \xFF"))) + :type 'xml-invalid-character) + '(xml-invalid-character #x3FFFFF 3))))) + +(defvar xml-tests--data-with-comments + `(;; simple case + ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" + . ((foo ((baz . "true")) "bar"))) + ;; toplevel comments -- first document child must not get lost + (,(concat "<?xml version=\"1.0\"?><foo>bar</foo><!--comment-1-->" + "<!--comment-2-->") + . ((foo nil "bar"))) + (,(concat "<?xml version=\"1.0\"?><!--comment-a--><foo a=\"b\">" + "<bar>blub</bar></foo><!--comment-b--><!--comment-c-->") + . ((foo ((a . "b")) (bar nil "blub"))))) + "Alist of XML strings and their expected parse trees for discarded comments.") + +(ert-deftest xml-remove-comments () + (dolist (test xml-tests--data-with-comments) + (erase-buffer) + (insert (car test)) + (xml-remove-comments (point-min) (point-max)) + (should (equal (cdr test) + (xml-parse-region (point-min) (point-max)))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/xt-mouse-tests.el b/test/lisp/xt-mouse-tests.el index 61bd7590183..12840df13fe 100644 --- a/test/lisp/xt-mouse-tests.el +++ b/test/lisp/xt-mouse-tests.el @@ -53,9 +53,9 @@ (ert-deftest xt-mouse-tracking-basic () (should (equal (xterm-mouse-tracking-enable-sequence) - "\e[?1000h\e[?1002h\e[?1006h")) + "\e[?1000h\e[?1003h\e[?1006h")) (should (equal (xterm-mouse-tracking-disable-sequence) - "\e[?1006l\e[?1002l\e[?1000l")) + "\e[?1006l\e[?1003l\e[?1000l")) (with-xterm-mouse-mode (should xterm-mouse-mode) (should (terminal-parameter nil 'xterm-mouse-mode)) @@ -73,9 +73,9 @@ (ert-deftest xt-mouse-tracking-utf-8 () (let ((xterm-mouse-utf-8 t)) (should (equal (xterm-mouse-tracking-enable-sequence) - "\e[?1000h\e[?1002h\e[?1005h\e[?1006h")) + "\e[?1000h\e[?1003h\e[?1005h\e[?1006h")) (should (equal (xterm-mouse-tracking-disable-sequence) - "\e[?1006l\e[?1005l\e[?1002l\e[?1000l")) + "\e[?1006l\e[?1005l\e[?1003l\e[?1000l")) (with-xterm-mouse-mode (should xterm-mouse-mode) (should (terminal-parameter nil 'xterm-mouse-mode)) |