diff options
Diffstat (limited to 'test/lisp')
143 files changed, 4614 insertions, 901 deletions
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..22ca7e2ec55 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -28,7 +28,7 @@ (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) 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..ec3e4bb77ba 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -59,8 +59,7 @@ 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.") 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-tests.el b/test/lisp/bookmark-tests.el index 7e0384b7241..b9c6ff9c542 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -25,6 +25,7 @@ (require 'ert) (require 'bookmark) +(require 'cl-lib) (defvar bookmark-tests-data-dir (file-truename @@ -339,21 +340,21 @@ testing `bookmark-bmenu-list'." ,@body) (kill-buffer bookmark-bmenu-buffer))))) -(ert-deftest bookmark-bmenu.enu-edit-annotation/show-annotation () +(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) @@ -362,5 +363,73 @@ testing `bookmark-bmenu-list'." (should (equal (buffer-name (current-buffer)) bookmark-bmenu-buffer)) (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) + (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-unmark () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (goto-char (point-min)) + (bookmark-bmenu-unmark) + (beginning-of-line) + (should (looking-at "^ ")))) + +(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-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/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 6db5426ff6d..c8cb97a8bca 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -345,6 +345,58 @@ 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 () + (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))) + (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-tests.el b/test/lisp/calendar/icalendar-tests.el index 986255250dc..d496878205b 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. @@ -419,11 +419,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 +465,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) @@ -886,7 +885,7 @@ During import test the timezone is set to Central European Time." (icalendar-tests--do-test-import input expected-american))))) (setenv "TZ" timezone)))) -(defun icalendar-tests--do-test-import (input expected-output) +(defun icalendar-tests--do-test-import (_input expected-output) "Actually perform import test. Argument INPUT input icalendar string. Argument EXPECTED-OUTPUT expected diary string." @@ -2347,7 +2346,7 @@ END:VCALENDAR (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) (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/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 4c8f18a7a95..3eecc67eb53 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -31,7 +31,9 @@ (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-not (= (date-days-in-month 1900 3) 28)) + (should-error (date-days-in-month 2020 15)) + (should-error (date-days-in-month 2020 'foo))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) 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..e537871528c 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. @@ -537,10 +537,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 +563,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 +573,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 +591,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 +756,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..3419b18afb5 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,6 +52,7 @@ 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." (save-excursion diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 4dd64e2ea8c..63c33a3c440 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. diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 9c27a92d2bf..132fe875f72 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. 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/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/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 56d1bdb110e..67f474cbd52 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -547,6 +547,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..14f95a8bf80 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -96,4 +96,20 @@ (dest-ip . [192 168 1 100])))))) +(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 a16adfedfb8..c235dd43fcc 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. @@ -347,7 +347,12 @@ ((eq x 't) 99) (t 999)))) '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c) - (t c) (x "a") (x "c") (x c) (x d) (x e)))) + (t c) (x "a") (x "c") (x c) (x d) (x e))) + + ;; `substring' bytecode generation (bug#39709). + (substring "abcdef") + (substring "abcdef" 2) + (substring "abcdef" 3 2)) "List of expression for test. Each element will be executed by interpreter and with bytecompiled code, and their results compared.") @@ -358,10 +363,10 @@ bytecompiled code, and their results compared.") (byte-compile-warnings nil) (v0 (condition-case nil (eval pat) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error 'bytecomp-check-error)))) (equal v0 v1))) (put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) @@ -369,10 +374,10 @@ bytecompiled code, and their results compared.") (defun bytecomp-explain-1 (pat) (let ((v0 (condition-case nil (eval pat) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error 'bytecomp-check-error)))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -397,10 +402,10 @@ Subtests signal errors if something goes wrong." (dolist (pat byte-opt-testsuite-arith-data) (condition-case nil (setq v0 (eval pat)) - (error (setq v0 nil))) + (error (setq v0 'bytecomp-check-error))) (condition-case nil (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 nil))) + (error (setq v1 'bytecomp-check-error))) (insert (format "%s" pat)) (indent-to-column 65) (if (equal v0 v1) @@ -556,11 +561,11 @@ bytecompiled code, and their results compared.") (byte-compile-warnings nil) (v0 (condition-case nil (eval pat t) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (let ((lexical-binding t)) (byte-compile `(lambda nil ,pat)))) - (error nil)))) + (error 'bytecomp-check-error)))) (equal v0 v1))) (put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) @@ -568,11 +573,11 @@ bytecompiled code, and their results compared.") (defun bytecomp-lexbind-explain-1 (pat) (let ((v0 (condition-case nil (eval pat t) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (let ((lexical-binding t)) (byte-compile (list 'lambda nil pat)))) - (error nil)))) + (error 'bytecomp-check-error)))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -615,17 +620,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 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-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/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/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-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index e910329c201..b760f8c7869 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. 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..4bad36080a1 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. 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-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/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 0d325f1485a..9b1a573ea6a 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -26,6 +26,8 @@ (require 'ert) (require 'cl-lib) +;;; Code: + (defun generator-list-subrs () (cl-loop for x being the symbols when (and (fboundp x) @@ -38,8 +40,7 @@ `cps-testcase' defines an ERT testcase called NAME that evaluates BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce -identical output. -" +identical output." `(progn (ert-deftest ,name () (should @@ -302,3 +303,14 @@ identical output. (lambda (it) (- it)) (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..7a8402be074 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)) @@ -137,6 +138,24 @@ (should (equal (buffer-string) "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) +(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' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). 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/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/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..cb06dd4cce3 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-test.el --- Tests for the Emacs package system -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -143,8 +143,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) @@ -175,9 +175,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 @@ -352,48 +351,122 @@ 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) @@ -537,6 +610,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))) @@ -577,8 +651,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)) 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/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 0fece4004bd..0e6f27836ea 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -63,6 +63,7 @@ (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,6 +128,10 @@ "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) "[][:lower:][:upper:]][^][:lower:][:upper:]]")) + ;; 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" "--/*--")) "[*-/acf]")) (should (equal (rx (any "]-a" ?-) (not (any "]-a" ?-))) @@ -140,6 +145,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) 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/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 220ce0c08f0..c702fdff6f1 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el index 26b89b72312..549c90d20d8 100644 --- a/test/lisp/emacs-lisp/text-property-search-tests.el +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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/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..16a04647723 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -170,6 +170,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/ffap-tests.el b/test/lisp/ffap-tests.el index eaf39680e48..30c8f794577 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -74,7 +74,7 @@ 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"))))) (provide 'ffap-tests) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index e9dc7532d59..42d86ee1538 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -200,8 +200,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 +219,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.") @@ -772,9 +772,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 +865,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) @@ -929,17 +929,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 +954,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)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index ac56a7732f2..4b902fd82ae 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -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 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-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/help-fns-tests.el b/test/lisp/help-fns-tests.el index 4c808d8372e..d2dc3d24aec 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -56,28 +56,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 +123,41 @@ Return first line of the output of (describe-function-1 FUNC)." (goto-char (point-min)) (should (looking-at "^font-lock-comment-face is ")))) + +;;; 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")))) + ;;; 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/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index dd2c28053a0..59f3e73b17d 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -48,5 +48,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..66098fa0116 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -67,6 +67,6 @@ (gravatar-force-default nil) (gravatar-size nil)) (should (equal (gravatar-build-url "foo") "\ -https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) +https://seccdn.libravatar.org/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..9277d0162e8 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. diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 91e3c2279f0..5f8e653d7c2 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -48,6 +48,27 @@ (append (kbd "C-x RET c u t f - 8 RET C-u C-u c a b RET") nil))) (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..cc199bd4972 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. @@ -81,4 +81,4 @@ (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/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..a0e8c87c7b3 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -1,4 +1,4 @@ -;;; 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. @@ -21,11 +21,16 @@ (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 +38,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 +159,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 +405,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 +528,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 +931,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/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/man-tests.el b/test/lisp/man-tests.el index fba4d748ce1..8267d8e4f6a 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. @@ -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/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/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 68f69f62b56..45c98513653 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1,4 +1,4 @@ -;;; 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. @@ -176,8 +176,8 @@ This includes initialization and closing the bus." (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..07e30b64642 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. 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/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 28686547a44..7a982548ae1 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -724,4 +724,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/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/rfc2104-tests.el b/test/lisp/net/rfc2104-tests.el index 5c1f4410934..90535898382 100644 --- a/test/lisp/net/rfc2104-tests.el +++ b/test/lisp/net/rfc2104-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 95e41a3f03b..8c75d91bb58 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -60,7 +60,6 @@ (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) @@ -971,4 +970,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 544bdb5c058..34782e7f151 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,6 +43,7 @@ (require 'dired) (require 'ert) (require 'ert-x) +(require 'trace) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -50,6 +51,8 @@ (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") @@ -67,13 +70,14 @@ (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) ;; Needed for Emacs 26. (defvar async-shell-command-width) +;; Needed for Emacs 27. +(defvar process-file-return-signal-string) +(defvar shell-command-dont-erase-buffer) ;; Beautify batch mode. (when noninteractive @@ -100,19 +104,22 @@ (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) @@ -140,9 +147,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)) @@ -173,38 +178,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." @@ -1966,9 +1979,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)) @@ -1997,7 +2010,7 @@ properly. BODY shall not contain a timeout." ;; 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 @@ -2039,7 +2052,7 @@ 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")) @@ -2151,7 +2164,7 @@ properly. BODY shall not contain a timeout." ;; These are the methods the test doesn't fail. (when (or (tramp--test-adb-p) (tramp--test-ange-ftp-p) (tramp--test-gvfs-p) (tramp--test-rclone-p) - (tramp-smb-file-name-p tramp-test-temporary-file-directory)) + (tramp--test-smb-p)) (setf (ert-test-expected-result-type (ert-get-test 'tramp-test05-expand-file-name-relative)) :passed)) @@ -2218,11 +2231,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 @@ -2238,7 +2250,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) ""))))))) @@ -2296,16 +2308,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 @@ -2357,7 +2378,14 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region nil nil tmp-name 3)) (with-temp-buffer (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foobaz")))) + (should (string-equal (buffer-string) "foobaz"))) + (delete-file tmp-name) + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")))) ;; Write string. (write-region "foo" nil tmp-name) @@ -2376,7 +2404,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)) @@ -2393,14 +2421,14 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)) + (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (cl-letf (((symbol-function 'y-or-n-p) 'ignore) + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) @@ -2911,6 +2939,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 @@ -2981,6 +3012,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)) @@ -3115,22 +3148,37 @@ This tests also `access-file', `file-readable-p', (file-remote-p tmp-name1) (replace-regexp-in-string "/" "//" (file-remote-p tmp-name1 'localname)))) + ;; `file-ownership-preserved-p' is implemented only in tramp-sh.el. + (test-file-ownership-preserved-p (tramp--test-sh-p)) attr) (unwind-protect (progn + ;; A sticky bit could damage the `file-ownership-preserved-p' test. + (when + (and test-file-ownership-preserved-p + (zerop (logand + #o1000 + (file-modes tramp-test-temporary-file-directory)))) + (write-region "foo" nil tmp-name1) + (setq test-file-ownership-preserved-p + (= (tramp-compat-file-attribute-group-id + (file-attributes tmp-name1)) + (tramp-get-remote-gid tramp-test-vec 'integer))) + (delete-file tmp-name1)) + (should-error (access-file tmp-name1 "error") :type tramp-file-missing) ;; `file-ownership-preserved-p' should return t for - ;; non-existing files. It is implemented only in tramp-sh.el. - (when (tramp--test-sh-p) + ;; non-existing files. + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) ;; We do not test inodes and device numbers. @@ -3160,16 +3208,16 @@ This tests also `access-file', `file-readable-p', (should (stringp (tramp-compat-file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error - (should-error - (access-file tmp-name2 "error") - :type tramp-file-missing) - (when (tramp--test-sh-p) + (should-error + (access-file tmp-name2 "error") + :type tramp-file-missing) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) (should (file-exists-p tmp-name2)) (should (file-symlink-p tmp-name2)) (should-not (access-file tmp-name2 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (setq attr (file-attributes tmp-name2)) (should @@ -3200,7 +3248,7 @@ This tests also `access-file', `file-readable-p', (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (delete-file tmp-name1) (make-directory tmp-name1) @@ -3208,7 +3256,7 @@ This tests also `access-file', `file-readable-p', (should (file-readable-p tmp-name1)) (should-not (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) (should (eq (tramp-compat-file-attribute-type attr) t))) @@ -3350,25 +3398,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) @@ -3420,11 +3523,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3496,11 +3599,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -3627,7 +3730,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 @@ -3690,7 +3793,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 @@ -3730,6 +3843,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)) @@ -3808,6 +3922,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)) @@ -3951,7 +4066,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))) @@ -3964,7 +4078,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 @@ -4020,10 +4134,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 @@ -4113,6 +4226,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)) @@ -4126,6 +4240,28 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (zerop (process-file "true"))) (should-not (zerop (process-file "false"))) (should-not (zerop (process-file "binary-does-not-exist"))) + ;; Return exit code. + (should (= 42 (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "exit 42"))) + ;; Return exit code in case the process is interrupted, + ;; and there's no indication for a signal describing string. + (let (process-file-return-signal-string) + (should + (= (+ 128 2) + (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "kill -2 $$")))) + ;; Return string in case the process is interrupted and + ;; there's an indication for a signal describing string. + (let ((process-file-return-signal-string t)) + (should + (string-equal + "Interrupt" + (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "kill -2 $$")))) + (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) @@ -4169,6 +4305,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) @@ -4181,7 +4318,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq proc (start-file-process "test1" (current-buffer) "cat")) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4224,7 +4361,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-process-filter proc (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4242,13 +4379,14 @@ 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))) - ;; `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))) (let ((default-directory tramp-test-temporary-file-directory) - (tmp-name (tramp--test-make-temp-name nil quoted)) + (tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name 'local quoted)) kill-buffer-query-functions proc) (with-no-warnings (should-not (make-process))) @@ -4262,7 +4400,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4278,13 +4416,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Simple process using a file. (unwind-protect (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) (setq proc (with-no-warnings (make-process :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name)) + :command `("cat" ,(file-name-nondirectory tmp-name1)) :file-handler t))) (should (processp proc)) ;; Read output. @@ -4296,7 +4434,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc) - (delete-file tmp-name))) + (delete-file tmp-name1))) ;; Process filter. (unwind-protect @@ -4311,7 +4449,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4337,7 +4475,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) (delete-process proc) ;; Read output. @@ -4345,42 +4483,74 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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. - (should (string-match "killed.*\n\\'" (buffer-string)))) + ;; 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)))) ;; Cleanup. (ignore-errors (delete-process proc))) - ;; Process with stderr. tramp-adb.el doesn't support it (yet). - (unless (tramp--test-adb-p) - (let ((stderr (generate-new-buffer "*stderr*"))) - (unwind-protect + ;; 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))))) + + ;; 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) (with-temp-buffer - (setq proc - (with-no-warnings - (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/") - :stderr stderr - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-current-buffer stderr - (with-timeout (10 (tramp--test-timeout-handler)) - (while (= (point-min) (point-max)) - (while (accept-process-output proc 0 nil t)))) - (should - (string-match "^cat:.* Is a directory" (buffer-string))))) + (insert-file-contents tmpfile) + (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 (delete-file tmpfile))))))) (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)) @@ -4388,10 +4558,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; order to establish the connection prior running an asynchronous ;; process. (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) kill-buffer-query-functions proc) (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test" (current-buffer) "sleep" "10")) + (setq proc (start-file-process-shell-command + "test" (current-buffer) + "trap 'echo boom; exit 1' 2; sleep 100")) (should (processp proc)) (should (process-live-p proc)) (should (equal (process-status proc) 'run)) @@ -4399,7 +4572,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (interrupt-process proc)) ;; Let the process accept the interrupt. (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil 0))) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) (should-not (process-live-p proc)) ;; An interrupted process cannot be interrupted, again. (should-error @@ -4409,14 +4583,24 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))))) +(defun tramp--test-async-shell-command + (command output-buffer &optional error-buffer input) + "Like `async-shell-command', reading the output. +INPUT, if non-nil, is a string sent to the process." + (async-shell-command command output-buffer error-buffer) + (let ((proc (get-buffer-process output-buffer)) + (delete-exited-processes t)) + (when (stringp input) + (process-send-string proc input)) + (with-timeout + ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) + (while (or (accept-process-output proc nil nil t) (process-live-p proc)))) + (accept-process-output proc nil nil t))) + (defun tramp--test-shell-command-to-string-asynchronously (command) "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer - (async-shell-command command (current-buffer)) - (with-timeout - ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) + (tramp--test-async-shell-command command (current-buffer)) (buffer-substring-no-properties (point-min) (point-max)))) (ert-deftest tramp-test32-shell-command () @@ -4427,6 +4611,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; 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)) @@ -4435,111 +4620,295 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (inhibit-message t) kill-buffer-query-functions) - ;; Test ordinary `shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - (should - (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) - (buffer-string)))) + (dolist (this-shell-command + '(;; Synchronously. + shell-command + ;; Asynchronously. + tramp--test-async-shell-command)) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `shell-command' with error buffer. - (let ((stderr (generate-new-buffer "*stderr*"))) + ;; Test ordinary `{async-}shell-command'. (unwind-protect (with-temp-buffer - (shell-command "error" (current-buffer) stderr) - (should (= (point-min) (point-max))) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (funcall + this-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) + (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while + (re-search-forward tramp-display-escape-sequence-regexp nil t) + (replace-match "" nil nil)) (should - (string-match - "error:.+not found" - (with-current-buffer stderr (buffer-string))))) + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) + (buffer-string)))) ;; Cleanup. - (ignore-errors (kill-buffer stderr)))) + (ignore-errors (delete-file tmp-name))) - ;; Test ordinary `async-shell-command'. + ;; Test `{async-}shell-command' with error buffer. + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (funcall + this-shell-command + "echo foo >&2; echo bar" (current-buffer) stderr) + (should (string-equal "bar\n" (buffer-string))) + ;; Check stderr. + (with-current-buffer stderr + (should (string-equal "foo\n" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (kill-buffer stderr))))) + + ;; Test sending string to `async-shell-command'. (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (async-shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) (should (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) + ;; tramp-adb.el echoes, so we must add the string. + (if (tramp--test-adb-p) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) (buffer-string)))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) + (ignore-errors (delete-file tmp-name))))) - ;; Test sending string to `async-shell-command'. + ;; Test `async-shell-command-width'. It exists since Emacs 26.1, + ;; but seems to work since Emacs 27.1 only. + (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (let* ((async-shell-command-width 1024) + (default-directory tramp-test-temporary-file-directory) + (cols (ignore-errors + (read (tramp--test-shell-command-to-string-asynchronously + "tput cols"))))) + (when (natnump cols) + (should (= cols async-shell-command-width)))))) + +;; This test is inspired by Bug#39067. +(ert-deftest tramp-test32-shell-command-dont-erase-buffer () + "Check `shell-command-dont-erase-buffer'." + :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))) + ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. + (skip-unless (tramp--test-emacs27-p)) + + ;; We check both the local and remote case, in order to guarantee + ;; that they behave similar. + (dolist (default-directory + `(,temporary-file-directory ,tramp-test-temporary-file-directory)) + (let ((buffer (generate-new-buffer "foo")) + ;; Suppress nasty messages. + (inhibit-message t) + point kill-buffer-query-functions) (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (async-shell-command "read line; ls $line" (current-buffer)) - (process-send-string - (get-buffer-process (current-buffer)) - (format "%s\n" (file-name-nondirectory tmp-name))) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should - (string-match - (format "\\`%s" (regexp-quote (file-name-nondirectory tmp-name))) - (buffer-string)))) + (progn + ;; Don't erase if buffer is the current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if the buffer is not current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "baz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if buffer is the current one, but + ;; `shell-command-dont-erase-buffer' is set to `erase'. + ;; There is no point to check point. + (let ((shell-command-dont-erase-buffer 'erase)) + (with-temp-buffer + (insert "bar") + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "baz\n" (buffer-string))) + ;; In the local case, point is not moved after the + ;; inserted text. + (should (= (point) + (if (file-remote-p default-directory) + (point-max) (point-min)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-temp-buffer + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "babaz\nr" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + ;; This does not work as expected. Therefore, we + ;; use the "wrong" string. + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max))))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `async-shell-command-width'. Since Emacs 27.1. - (when (ignore-errors - (and (boundp 'async-shell-command-width) - (zerop (call-process "tput" nil nil nil "cols")) - (zerop (process-file "tput" nil nil nil "cols")))) - (let (async-shell-command-width) - (should - (string-equal - (format "%s\n" (car (process-lines "tput" "cols"))) - (tramp--test-shell-command-to-string-asynchronously - "tput cols"))) - (setq async-shell-command-width 1024) - (should - (string-equal - "1024\n" - (tramp--test-shell-command-to-string-asynchronously - "tput cols")))))))) + (ignore-errors (kill-buffer buffer)))))) ;; This test is inspired by Bug#23952. (ert-deftest tramp-test33-environment-variables () @@ -4547,6 +4916,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :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. @@ -4559,67 +4929,72 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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" emacs-version tramp-version) + (funcall this-shell-command-to-string "echo -n ${INSIDE_EMACS:-bla}"))) + (let ((process-environment + (cons (format "INSIDE_EMACS=%s,foo" emacs-version) + process-environment))) + (should + (string-equal + (format "%s,foo,tramp:%s" emacs-version tramp-version) + (funcall + this-shell-command-to-string "echo -n ${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 -n ${%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 -n ${%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 -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")))))))) ;; This test is inspired by Bug#27009. (ert-deftest tramp-test33-environment-variables-and-port-numbers () @@ -4628,6 +5003,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; 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 @@ -4732,6 +5108,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; 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))) @@ -4788,6 +5165,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "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)) @@ -4831,6 +5209,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "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)) @@ -4838,23 +5217,20 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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) @@ -4866,26 +5242,30 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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))))) @@ -4894,6 +5274,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :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 @@ -4922,8 +5303,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." 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. @@ -4949,13 +5329,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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) "/")) @@ -5212,12 +5588,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (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 @@ -5230,6 +5600,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 27)) +(defun tramp--test-emacs28-p () + "Check for Emacs version >= 28.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 28)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -5247,6 +5623,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)." @@ -5331,7 +5711,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." @@ -5455,8 +5840,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 @@ -5483,6 +5867,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)))) @@ -5650,18 +6035,22 @@ 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))) ;; ?\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))) @@ -5675,6 +6064,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (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)) @@ -5689,6 +6079,7 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (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))) @@ -5710,6 +6101,7 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (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))) @@ -5734,6 +6126,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (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 @@ -5753,7 +6146,7 @@ Use the `ls' command." ;; Since Emacs 27.1. (skip-unless (fboundp 'file-system-info)) - ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; `file-system-info' exists since Emacs 27.1. We don't want to see ;; compiler warnings for older Emacsen. (let ((fsi (with-no-warnings (file-system-info tramp-test-temporary-file-directory)))) @@ -5815,6 +6208,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)) @@ -5875,10 +6269,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)) @@ -6146,12 +6537,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) @@ -6183,6 +6576,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. @@ -6191,11 +6586,10 @@ 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'. -;; * Fix `tramp-test29-start-file-process' and -;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). ;; * Implement `tramp-test31-interrupt-process' for `adb'. ;; * 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/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/play/animate-tests.el b/test/lisp/play/animate-tests.el new file mode 100644 index 00000000000..8af1517ffa4 --- /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/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..cd736497e66 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -176,6 +176,9 @@ 13 nil 217 "../src/Lib/System.cpp") ("==1332== by 0x8008621: main (vtest.c:180)" 13 nil 180 "vtest.c") + ;; javac + ("/src/Test.java:5: ';' expected\n foo foo\n ^\n" 1 15 5 "/src/Test.java" 2) + ("e:\\src\\Test.java:7: warning: ';' expected\n foo foo\n ^\n" 1 10 7 "e:\\src\\Test.java" 1) ;; jikes-file jikes-line ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" 1 nil nil "../javax/swing/BorderFactory.java") @@ -431,8 +434,8 @@ 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-errors-found 94)) + (should (eq compilation-num-warnings-found 37)) (should (eq compilation-num-infos-found 26))))) (ert-deftest compile-test-grep-regexps () diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 2ba00656862..2de533e5eb9 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)) 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..5115f8ef67e 100644 --- a/test/lisp/progmodes/f90-tests.el +++ b/test/lisp/progmodes/f90-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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/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/ps-mode-tests.el b/test/lisp/progmodes/ps-mode-tests.el index a47abebe6e4..d565b321fdd 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. diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index f57150c397e..6b3e63653be 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))))) @@ -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-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index 6bdc7651ff1..9d677a2c27a 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. diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 65ed76bfb5d..91805ab7251 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -187,7 +187,13 @@ Perform ACTION and validate results" (sql-add-product 'xyz "XyzDb") (should (equal (pp-to-string (assoc 'xyz sql-product-alist)) - "(xyz :name \"XyzDb\")\n")))) + "(xyz :name \"XyzDb\")\n"))) + + (sql-test-product-feature-harness + (sql-add-product 'stu "StuDb" :X 1 :Y "2") + + (should (equal (pp-to-string (assoc 'stu sql-product-alist)) + "(stu :name \"StuDb\" :X 1 :Y \"2\")\n")))) (ert-deftest sql-test-add-existing-product () "Add a product that already exists." diff --git a/test/lisp/progmodes/subword-tests.el b/test/lisp/progmodes/subword-tests.el index 00168c01e13..86e905c8696 100644 --- a/test/lisp/progmodes/subword-tests.el +++ b/test/lisp/progmodes/subword-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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-tests.el b/test/lisp/progmodes/xref-tests.el index 9c7a9e69658..a4980b2acb1 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. 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/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 650782bc53c..03c62de1fd6 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -1,4 +1,4 @@ -;;; shadowfile-tests.el --- Tests of shadowfile +;;; shadowfile-tests.el --- Tests of shadowfile -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. @@ -70,7 +70,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 @@ -139,9 +138,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 +255,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 +608,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 +669,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) @@ -924,7 +923,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 c8b913b3f1c..4adcacb279b 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -392,6 +392,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 +469,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/subr-tests.el b/test/lisp/subr-tests.el index 059d52b1b6f..e2761a96f86 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. @@ -244,6 +244,27 @@ (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'." (let ((idx 0) 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/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el index 814cb06b960..7e870269959 100644 --- a/test/lisp/textmodes/conf-mode-tests.el +++ b/test/lisp/textmodes/conf-mode-tests.el @@ -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/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/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/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-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/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-expand-tests.el b/test/lisp/url/url-expand-tests.el index 553bcf67bd2..6e0ce869502 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. 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-tests.el b/test/lisp/vc/diff-mode-tests.el index 26e9f26fe24..e497ed204df 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> diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index ab44e23033c..a3a592bb623 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -1,4 +1,4 @@ -;;; 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. 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-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..8e5cc95ec94 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -1,4 +1,4 @@ -;;; 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. @@ -224,11 +224,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. 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/xml-tests.el b/test/lisp/xml-tests.el index 895b68f79af..72c78d00e3e 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,16 @@ 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))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: |