diff options
Diffstat (limited to 'test/src')
33 files changed, 1466 insertions, 431 deletions
diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 04c7eea62b1..967833e1903 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -30,7 +30,7 @@ (require 'cl-lib) (ert-deftest finalizer-object-type () - (should (equal (type-of (make-finalizer nil)) 'finalizer))) + (should (equal (type-of (make-finalizer #'ignore)) 'finalizer))) (ert-deftest record-1 () (let ((x (record 'foo 1 2 3))) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 908bff91a0b..c1e5d0ebed3 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -19,6 +19,8 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'cl-lib) (ert-deftest overlay-modification-hooks-message-other-buf () @@ -99,7 +101,7 @@ with parameters from the *Messages* buffer modification." ;; | Overlay test setup ;; +==========================================================================+ -(eval-when-compile +(eval-and-compile (defun buffer-tests--make-test-name (fn x y) (intern (format "buffer-tests--%s-%s-%s" fn x y)))) @@ -145,7 +147,7 @@ with parameters from the *Messages* buffer modification." (defmacro deftest-overlayp-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) () (with-temp-buffer (should (equal ,should-expr (overlayp ,arg-expr)))))) @@ -434,14 +436,14 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 I 10 (point-max) (10 10)) (deftest-next-overlay-change-1 J 20 (point-max) (10 10)) ;; 2 non-empty, non-intersecting -(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50)) -(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50)) -(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50)) +(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35)) -(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35)) +(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35)) +(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35)) (deftest-next-overlay-change-1 K 23 25 (20 30) (25 35)) (deftest-next-overlay-change-1 L 25 30 (20 30) (25 35)) (deftest-next-overlay-change-1 M 28 30 (20 30) (25 35)) @@ -471,11 +473,11 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) (deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting at end -(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30)) -(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) -(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30)) +(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting in the middle (deftest-next-overlay-change-1 m 10 20 (25 25) (20 30)) (deftest-next-overlay-change-1 n 20 25 (25 25) (20 30)) @@ -522,14 +524,14 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 I 10 1 (10 10)) (deftest-previous-overlay-change-1 J 20 10 (10 10)) ;; 2 non-empty, non-intersecting -(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50)) -(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50)) -(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50)) -(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50)) -(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50)) +(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50)) +(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50)) +(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50)) +(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50)) +(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35)) -(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35)) (deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35)) @@ -619,28 +621,28 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40)) ;; 2 non-empty overlays intersecting -(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40)) ;; 2 non-empty overlays continuous -(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30)) -(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30)) ;; overlays-at never returns empty overlays. -(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50)) @@ -1107,7 +1109,7 @@ with parameters from the *Messages* buffer modification." (should (eq ov (car (overlays-in 1 1))))))))) ;; properties -(ert-deftest test-buffer-swap-text-1 () +(ert-deftest test-buffer-swap-text-2 () (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer other (overlay-put (make-overlay 1 1) 'buffer 'other)) @@ -1421,66 +1423,63 @@ with parameters from the *Messages* buffer modification." (should (= (length (overlays-in (point-min) (point-max))) 0)))) (ert-deftest test-kill-buffer-auto-save-default () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) (ert-deftest test-kill-buffer-auto-save-delete () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - (setq kill-buffer-delete-auto-save-files t) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should delete the auto-save file. - (kill-buffer (current-buffer)) - (should-not (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))) - ;; Answer no to deletion. - (cl-letf (((symbol-function #'yes-or-no-p) - (lambda (prompt) - (not (string-search "Delete auto-save file" prompt))))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should not delete the auto-save file. - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + (should (file-exists-p file)) + (setq kill-buffer-delete-auto-save-files t) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should delete the auto-save file. + (kill-buffer (current-buffer)) + (should-not (file-exists-p auto-save))) + (ignore-errors (delete-file file)) + (when auto-save + (ignore-errors (delete-file auto-save))))) + ;; Answer no to deletion. + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (not (string-search "Delete auto-save file" prompt))))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should not delete the auto-save file. + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) ;;; buffer-tests.el ends here diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index 19a8aad9ce8..eb096f21129 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -278,4 +278,20 @@ (with-temp-buffer (should-error (upcase-region nil nil t))))) +(ert-deftest casefiddle-turkish () + (skip-unless (member "tr_TR.utf8" (get-locale-names))) + ;; See bug#50752. The point is that unibyte and multibyte strings + ;; are upcased differently in the "dotless i" case in Turkish, + ;; turning ASCII into non-ASCII, which is very unusual. + (with-locale-environment "tr_TR.utf8" + (should (string-equal (downcase "I ı") "ı ı")) + (should (string-equal (downcase "İ i") "i̇ i")) + (should (string-equal (downcase "I") "i")) + (should (string-equal (capitalize "bIte") "Bite")) + (should (string-equal (capitalize "bIté") "Bıté")) + (should (string-equal (capitalize "indIa") "India")) + ;; This does not work -- it produces "Indıa". + ;;(should (string-equal (capitalize "indIá") "İndıa")) + )) + ;;; casefiddle-tests.el ends here diff --git a/test/src/comp-resources/comp-test-45603.el b/test/src/comp-resources/comp-test-45603.el index f1c0dafb68d..65147ee0156 100644 --- a/test/src/comp-resources/comp-test-45603.el +++ b/test/src/comp-resources/comp-test-45603.el @@ -7,7 +7,7 @@ (defvar comp-test-45603-directory) (defvar comp-test-45603-marked-candidates) -(defun comp-test-45603--call-marked (action) +(defun comp-test-45603--call-marked (_action) (let* ((prefix-len (length comp-test-45603-mark-prefix)) (marked-candidates (mapcar @@ -17,7 +17,8 @@ (expand-file-name cand comp-test-45603-directory) cand))) comp-test-45603-marked-candidates)) - (multi-action (comp-test-45603--get-multi-action comp-test-45603-last))))) + (_multi-action (comp-test-45603--get-multi-action comp-test-45603-last))) + marked-candidates)) (defalias 'comp-test-45603--file-local-name (if (fboundp 'file-local-name) diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el index d740a5f8107..0a60f4d6cc4 100644 --- a/test/src/comp-resources/comp-test-funcs.el +++ b/test/src/comp-resources/comp-test-funcs.el @@ -189,7 +189,7 @@ ;; Bnumberp (numberp x)) -(defun comp-tests-discardn-f (x) +(defun comp-tests-discardn-f (_x) ;; BdiscardN (1+ (let ((a 1) (_b) @@ -297,8 +297,8 @@ ;; potentially use all registers and that is modifying local ;; variables inside condition-case. (let ((str-len (length str)) - (str-width 14) - (ellipsis-width 3) + (_str-width 14) + (_ellipsis-width 3) (idx 0) (column 0) (head-padding "") (tail-padding "") @@ -489,7 +489,7 @@ (cl-defun comp-test-46824-1-f () (let ((next-repos '(1))) (while t - (let ((recipe (car next-repos))) + (let ((_recipe (car next-repos))) (cl-block loop (while t (let ((err @@ -640,7 +640,7 @@ (2 2)) 3)))) -(defun comp-test-silly-frame2 (token) +(defun comp-test-silly-frame2 (_token) ;; Check robustness against dead code. (while c (cl-case c @@ -677,7 +677,7 @@ (progn (if (and noninteractive (not byte-compile-verbose)) (message "Compiling %s..." filename)) - (byte-compile-file filename load)) + (byte-compile-file filename)) (when load (load (if (file-exists-p dest) dest filename))) 'no-byte-compile))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 96f2b42c0d7..212d9e999f2 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -28,17 +28,23 @@ (require 'ert) (require 'ert-x) (require 'cl-lib) +(require 'comp) +(require 'comp-cstr) -(defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) +(eval-and-compile + (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) -(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) - -(when (featurep 'native-compile) - (require 'comp) +(when (native-comp-available-p) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) +;; Load the test code here so the compiler can check the function +;; names used in this file. +(require 'comp-test-funcs comp-test-src) +(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! + (defmacro comp-deftest (name args &rest docstring-and-body) "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) @@ -53,30 +59,32 @@ "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." :tags '(:expensive-test :nativecomp) - (let* ((byte+native-compile t) ; FIXME HACK - (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" + (ert-with-temp-file comp1-src + :suffix "-comp-stage1.el" + (ert-with-temp-file comp2-src + :suffix "-comp-stage2.el" + (let* ((byte+native-compile t) ; FIXME HACK + (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" (ert-resource-directory))) - (comp1-src (make-temp-file "stage1-" nil ".el")) - (comp2-src (make-temp-file "stage2-" nil ".el")) - ;; Can't use debug symbols. - (native-comp-debug 0)) - (copy-file comp-src comp1-src t) - (copy-file comp-src comp2-src t) - (let ((load-no-native t)) - (load (concat comp-src "c") nil nil t t)) - (should-not (subr-native-elisp-p (symbol-function #'native-compile))) - (message "Compiling stage1...") - (let* ((t0 (current-time)) - (comp1-eln (native-compile comp1-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (load comp1-eln nil nil t t) - (should (subr-native-elisp-p (symbol-function 'native-compile))) - (message "Compiling stage2...") - (let ((t0 (current-time)) - (comp2-eln (native-compile comp2-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (message "Comparing %s %s" comp1-eln comp2-eln) - (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) + ;; Can't use debug symbols. + (native-comp-debug 0)) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) + (should-not (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage1...") + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))))) (comp-deftest provide () "Testing top level provide." @@ -350,6 +358,8 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) +(declare-function comp-tests-free-fun-f nil) + (comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () @@ -359,7 +369,7 @@ Check that the resulting binaries do not differ." t) (native-compile #'comp-tests-free-fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) (should (string= (documentation #'comp-tests-free-fun-f) "Some doc.")) @@ -367,11 +377,13 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(declare-function comp-tests/free\fun-f nil) + (comp-deftest free-fun-silly-name () "Check we are able to compile a single function." (eval '(defun comp-tests/free\fun-f ()) t) (native-compile #'comp-tests/free\fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f)))) (comp-deftest bug-40187 () "Check function name shadowing. @@ -382,7 +394,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) - (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f)))) (comp-deftest bug-42360 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>." @@ -431,7 +443,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest primitive-redefine () "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) - ((symbol-function #'-) + ((symbol-function '-) (lambda (&rest args) (setq comp-test-primitive-redefine-args args) 'xxx))) @@ -452,11 +464,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-defsubst () ;; Bug#42664, Bug#43280, Bug#44209. - (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f)))) (comp-deftest primitive-redefine-compile-44221 () "Test the compiler still works while primitives are redefined (bug#44221)." - (cl-letf (((symbol-function #'delete-region) + (cl-letf (((symbol-function 'delete-region) (lambda (_ _)))) (should (subr-native-elisp-p (native-compile @@ -492,12 +504,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>" (load (native-compile (ert-resource-file "comp-test-45603.el"))) - (should (fboundp #'comp-test-45603--file-local-name))) + (should (fboundp 'comp-test-45603--file-local-name))) (comp-deftest 46670-1 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>" (should (string= (comp-test-46670-2-f "foo") "foo")) - (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + (should (equal (subr-type (symbol-function 'comp-test-46670-2-f)) '(function (t) t)))) (comp-deftest 46824-1 () @@ -727,7 +739,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist - (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) @@ -784,6 +796,8 @@ Return a list of results." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))))) +(declare-function comp-tests-tco-f nil) + (comp-deftest tco () "Check for tail recursion elimination." (let ((native-comp-speed 3) @@ -798,7 +812,7 @@ Return a list of results." (comp-tests-tco-f (+ a b) a (- count 1)))) t) (native-compile #'comp-tests-tco-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) (defun comp-tests-fw-prop-checker-1 (_) @@ -812,6 +826,8 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) +(declare-function comp-tests-fw-prop-1-f nil) + (comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((native-comp-speed 2) @@ -823,7 +839,7 @@ Return a list of results." (length c))) ; <= has to optimize t) (native-compile #'comp-tests-fw-prop-1-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) (defun comp-tests-check-ret-type-spec (func-form ret-type) @@ -1410,11 +1426,13 @@ folded." (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 comp-tests-pure-checker-2)))) (load (native-compile (ert-resource-file "comp-test-pure.el"))) + (declare-function comp-tests-pure-caller-f nil) + (declare-function comp-tests-pure-fibn-entry-f nil) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f))) (should (= (comp-tests-pure-caller-f) 4)) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) (defvar comp-tests-cond-rw-checked-function nil diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 6de178743e6..7d8535f5f37 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -419,7 +419,7 @@ comparing the subr with a much slower Lisp implementation." "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) -(ert-deftest binding-test-set-constant-nil () +(ert-deftest binding-test-set-constant-itself () "Test setting a keyword to itself." (with-no-warnings (should (setq :keyword :keyword)))) @@ -433,26 +433,27 @@ comparing the subr with a much slower Lisp implementation." ;; More specifically, test the problem seen in bug#41029 where setting ;; the default value of a variable takes time proportional to the ;; number of buffers. - (let* ((fun #'error) - (test (lambda () - (with-temp-buffer - (let ((st (car (current-cpu-time)))) - (dotimes (_ 1000) - (let ((case-fold-search 'data-test)) - ;; Use an indirection through a mutable var - ;; to try and make sure the byte-compiler - ;; doesn't optimize away the let bindings. - (funcall fun))) - ;; FIXME: Handle the wraparound, if any. - (- (car (current-cpu-time)) st))))) - (_ (setq fun #'ignore)) - (time1 (funcall test)) - (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) - (make-list 1000 nil))) - (time2 (funcall test))) - (mapc #'kill-buffer bufs) - ;; Don't divide one time by the other since they may be 0. - (should (< time2 (* time1 5))))) + (when (fboundp 'current-cpu-time) ; silence byte-compiler + (let* ((fun #'error) + (test (lambda () + (with-temp-buffer + (let ((st (car (current-cpu-time)))) + (dotimes (_ 1000) + (let ((case-fold-search 'data-test)) + ;; Use an indirection through a mutable var + ;; to try and make sure the byte-compiler + ;; doesn't optimize away the let bindings. + (funcall fun))) + ;; FIXME: Handle the wraparound, if any. + (- (car (current-cpu-time)) st))))) + (_ (setq fun #'ignore)) + (time1 (funcall test)) + (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) + (make-list 1000 nil))) + (time2 (funcall test))) + (mapc #'kill-buffer bufs) + ;; Don't divide one time by the other since they may be 0. + (should (< time2 (* time1 5)))))) ;; More tests to write - ;; kill-local-variable @@ -690,7 +691,7 @@ comparing the subr with a much slower Lisp implementation." (let ((n (* 2 most-negative-fixnum))) (should (= (logand -1 n) n)))) -(ert-deftest data-tests-logcount () +(ert-deftest data-tests-logcount-2 () (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) (ert-deftest data-tests-logior () diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index b910709183f..47d67b7bda4 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -23,6 +23,8 @@ (require 'ert) +(declare-function zlib-decompress-region "decompress.c") + (defvar zlib-tests-data-directory (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing zlib test data.") diff --git a/test/src/doc-tests.el b/test/src/doc-tests.el new file mode 100644 index 00000000000..ee4f02347ec --- /dev/null +++ b/test/src/doc-tests.el @@ -0,0 +1,43 @@ +;;; doc-tests.el --- tests for doc.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest doc-tests-documentation/c-primitive () + (should (stringp (documentation 'defalias)))) + +(ert-deftest doc-tests-documentation/preloaded () + (should (stringp (documentation 'defun)))) + +(ert-deftest doc-tests-documentation/autoloaded-macro () + (skip-unless noninteractive) + (should (autoloadp (symbol-function 'benchmark-run))) + (should (stringp (documentation 'benchmark-run)))) ; See Bug#52969. + +(ert-deftest doc-tests-documentation/autoloaded-defun () + (skip-unless noninteractive) + (should (autoloadp (symbol-function 'tetris))) + (should (stringp (documentation 'tetris)))) ; See Bug#52969. + +(ert-deftest doc-tests-quoting-style () + (should (memq (text-quoting-style) '(grave straight curve)))) + +;;; doc-tests.el ends here diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index a3dd7bd466a..5fe896fbbd1 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -23,16 +23,16 @@ (ert-deftest format-properties () ;; Bug #23730 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%d" 'face '(:background "red")) 1) #("1" 0 1 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%2d" 'face '(:background "red")) 1) #(" 1" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%02d" 'face '(:background "red")) 1) #("01" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%2d" 'x 'X) (propertize "a" 'a 'A) (propertize "b" 'b 'B)) @@ -40,27 +40,27 @@ #(" 1ab" 0 2 (x X) 2 3 (a A) 3 4 (b B)))) ;; Bug #5306 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "1234567890aaaa" (propertize "12345678901234567890" 'xxx 25))) "1234567890")) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "123456789" (propertize "12345678901234567890" 'xxx 25))) #("1234567891" 9 10 (xxx 25)))) ;; Bug #23859 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%4s" (propertize "hi" 'face 'bold)) #(" hi" 2 4 (face bold)))) ;; Bug #23897 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789" 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) @@ -68,63 +68,63 @@ ;; The last property range is extended to include padding on the ;; right, but the first range is not extended to the left to include ;; padding on the left! - (should (ert-equal-including-properties + (should (equal-including-properties (format "%12s" (concat (propertize "01234" 'face 'bold) "56789")) #(" 0123456789" 2 7 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-12s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789 " 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #(" 012345" 4 6 (face bold) 6 8 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #("012345 " 0 2 (face bold) 2 4 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) (propertize "45" 'face 'italic))) #("012345 " 0 2 (face bold) 2 4 (face underline) 4 10 (face italic)))) ;; Bug #38191 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "‘foo’ %s bar" 'face 'bold) "xxx") #("‘foo’ xxx bar" 0 13 (face bold)))) ;; Bug #32404 - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%s" 'face 'bold) "" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 0 3 (face bold) 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s " (propertize "%s" 'face 'error)) "foo" "bar") #("foo bar" 4 7 (face error)))) ;; Bug #46317 (let ((s (propertize "X" 'prop "val"))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3s/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3S/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3d/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3s/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3S/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3d/" s) 12) #("12 /X" 4 5 (prop "val")))))) @@ -413,4 +413,17 @@ (translate-region-internal (point-min) (point-max) tt) (should (string-equal (buffer-string) "*"))))) +(ert-deftest find-fields () + (with-temp-buffer + (insert "foo" (propertize "bar" 'field 'bar) "zot") + (goto-char (point-min)) + (should (= (field-beginning) (point-min))) + (should (= (field-end) 4)) + (goto-char 5) + (should (= (field-beginning) 4)) + (should (= (field-end) 7)) + (goto-char 8) + (should (= (field-beginning) 7)) + (should (= (field-end) (point-max))))) + ;;; editfns-tests.el ends here diff --git a/test/src/emacs-module-resources/mod-test.c b/test/src/emacs-module-resources/mod-test.c index 015c1efd978..187af821c22 100644 --- a/test/src/emacs-module-resources/mod-test.c +++ b/test/src/emacs-module-resources/mod-test.c @@ -47,8 +47,6 @@ uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); #include <gmp.h> #include <emacs-module.h> -#include "timespec.h" - int plugin_is_GPL_compatible; #if INTPTR_MAX <= 0 @@ -74,9 +72,6 @@ int plugin_is_GPL_compatible; # error "INTPTR_MAX too large" #endif -/* Smoke test to verify that EMACS_LIMB_MAX is defined. */ -_Static_assert (0 < EMACS_LIMB_MAX, "EMACS_LIMB_MAX missing or incorrect"); - /* Always return symbol 't'. */ static emacs_value Fmod_test_return_t (emacs_env *env, ptrdiff_t nargs, emacs_value args[], @@ -422,6 +417,16 @@ signal_errno (emacs_env *env, const char *function) signal_system_error (env, errno, function); } +#ifdef CLOCK_REALTIME + +/* Whether A <= B. */ +static bool +timespec_le (struct timespec a, struct timespec b) +{ + return (a.tv_sec < b.tv_sec + || (a.tv_sec == b.tv_sec && a.tv_nsec <= b.tv_nsec)); +} + /* A long-running operation that occasionally calls `should_quit' or `process_input'. */ @@ -434,11 +439,13 @@ Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args, if (env->non_local_exit_check (env)) return NULL; const bool process_input = env->is_not_nil (env, args[1]); - const struct timespec amount = make_timespec(0, 10000000); + const struct timespec amount = { .tv_nsec = 10000000 }; while (true) { - const struct timespec now = current_timespec (); - if (timespec_cmp (now, until) >= 0) + struct timespec now; + if (clock_gettime (CLOCK_REALTIME, &now) != 0) + return NULL; + if (timespec_le (until, now)) break; if (nanosleep (&amount, NULL) && errno != EINTR) { @@ -452,6 +459,7 @@ Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args, } return env->intern (env, "finished"); } +#endif static emacs_value Fmod_test_add_nanosecond (emacs_env *env, ptrdiff_t nargs, emacs_value *args, @@ -553,6 +561,7 @@ make_big_integer (emacs_env *env, const mpz_t value) return result; } +#ifdef CLOCK_REALTIME static emacs_value Fmod_test_nanoseconds (emacs_env *env, ptrdiff_t nargs, emacs_value *args, void *data) { assert (nargs == 1); @@ -560,11 +569,6 @@ Fmod_test_nanoseconds (emacs_env *env, ptrdiff_t nargs, emacs_value *args, void mpz_t nanoseconds; assert (LONG_MIN <= time.tv_sec && time.tv_sec <= LONG_MAX); mpz_init_set_si (nanoseconds, time.tv_sec); -#ifdef __MINGW32__ - _Static_assert (1000000000 <= ULONG_MAX, "unsupported architecture"); -#else - static_assert (1000000000 <= ULONG_MAX, "unsupported architecture"); -#endif mpz_mul_ui (nanoseconds, nanoseconds, 1000000000); assert (0 <= time.tv_nsec && time.tv_nsec <= ULONG_MAX); mpz_add_ui (nanoseconds, nanoseconds, time.tv_nsec); @@ -572,6 +576,7 @@ Fmod_test_nanoseconds (emacs_env *env, ptrdiff_t nargs, emacs_value *args, void mpz_clear (nanoseconds); return result; } +#endif static emacs_value Fmod_test_double (emacs_env *env, ptrdiff_t nargs, emacs_value *args, @@ -631,7 +636,7 @@ sleep_for_half_second (void) #ifdef WINDOWSNT Sleep (500); #else - const struct timespec sleep = {0, 500000000}; + const struct timespec sleep = { .tv_nsec = 500000000 }; if (nanosleep (&sleep, NULL) != 0) perror ("nanosleep"); #endif @@ -763,6 +768,11 @@ bind_function (emacs_env *env, const char *name, emacs_value Sfun) int emacs_module_init (struct emacs_runtime *ert) { + /* These smoke tests don't use _Static_assert because too many + compilers lack support for _Static_assert. */ + assert (0 < EMACS_LIMB_MAX); + assert (1000000000 <= ULONG_MAX); + /* Check that EMACS_MAJOR_VERSION is defined and an integral constant. */ char dummy[EMACS_MAJOR_VERSION]; @@ -815,9 +825,13 @@ emacs_module_init (struct emacs_runtime *ert) DEFUN ("mod-test-invalid-load", Fmod_test_invalid_load, 0, 0, NULL, NULL); DEFUN ("mod-test-invalid-finalizer", Fmod_test_invalid_finalizer, 0, 0, NULL, NULL); +#ifdef CLOCK_REALTIME DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL); +#endif DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL); +#ifdef CLOCK_REALTIME DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL); +#endif DEFUN ("mod-test-double", Fmod_test_double, 1, 1, NULL, NULL); DEFUN ("mod-test-make-function-with-finalizer", Fmod_test_make_function_with_finalizer, 0, 0, NULL, NULL); diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 57321a951de..1099fd04678 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -32,6 +32,11 @@ (require 'help-fns) (require 'subr-x) +;; Catch information for bug#50902. +(when (getenv "EMACS_EMBA_CI") + (start-process-shell-command + "*timeout*" nil (format "sleep 60; kill -ABRT %d" (emacs-pid)))) + (defconst mod-test-emacs (expand-file-name invocation-name invocation-directory) "File name of the Emacs binary currently running.") @@ -206,20 +211,6 @@ changes." (should (equal (help-function-arglist #'mod-test-sum) '(arg1 arg2)))) -(defmacro module--with-temp-directory (name &rest body) - "Bind NAME to the name of a temporary directory and evaluate BODY. -NAME must be a symbol. Delete the temporary directory after BODY -exits normally or non-locally. NAME will be bound to the -directory name (not the directory file name) of the temporary -directory." - (declare (indent 1)) - (cl-check-type name symbol) - `(let ((,name (file-name-as-directory - (make-temp-file "emacs-module-test" :directory)))) - (unwind-protect - (progn ,@body) - (delete-directory ,name :recursive)))) - (defmacro module--test-assertion (pattern &rest body) "Test that PATTERN matches the assertion triggered by BODY. Run Emacs as a subprocess, load the test module `mod-test-file', @@ -228,7 +219,7 @@ assertion message that matches PATTERN. PATTERN is evaluated and must evaluate to a regular expression string." (declare (indent 1)) ;; To contain any core dumps. - `(module--with-temp-directory tempdir + `(ert-with-temp-directory tempdir (with-temp-buffer (let* ((default-directory tempdir) (status (call-process mod-test-emacs nil t nil @@ -256,6 +247,7 @@ must evaluate to a regular expression string." (ert-deftest module--test-assertions--load-non-live-object () "Check that -module-assertions verify that non-live objects aren't accessed." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -274,6 +266,7 @@ must evaluate to a regular expression string." This differs from `module--test-assertions-load-non-live-object' in that it stows away a global reference. The module assertions should nevertheless detect the invalid load." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -290,6 +283,7 @@ should nevertheless detect the invalid load." (ert-deftest module--test-assertions--call-emacs-from-gc () "Check that -module-assertions prevents calling Emacs functions during garbage collection." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -301,7 +295,8 @@ during garbage collection." (ert-deftest module--test-assertions--globref-invalid-free () "Check that -module-assertions detects invalid freeing of a local reference." - (skip-unless (or (file-executable-p mod-test-emacs) + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) (module--test-assertion @@ -313,7 +308,8 @@ local reference." "Check that Bug#30163 is fixed." (with-temp-buffer (let ((standard-output (current-buffer)) - (text-quoting-style 'grave)) + (text-quoting-style 'grave) + (fill-column 200)) ; prevent line breaks when filling (describe-function-1 #'mod-test-sum) (goto-char (point-min)) (while (re-search-forward "`[^']*/src/emacs-module-resources/" nil t) @@ -340,6 +336,7 @@ Return A + B (ert-deftest mod-test-sleep-until () "Check that `mod-test-sleep-until' either returns normally or quits. Interactively, you can try hitting \\[keyboard-quit] to quit." + (skip-unless (fboundp 'mod-test-sleep-until)) (dolist (arg '(nil t)) ;; Guard against some caller setting `inhibit-quit'. (with-local-quit @@ -394,6 +391,7 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." (ert-deftest mod-test-nanoseconds () "Test truncation when converting to `struct timespec'." + (skip-unless (fboundp 'mod-test-nanoseconds)) (dolist (test-case '((0 . 0) (-1 . -1000000000) ((1 . 1000000000) . 1) @@ -412,6 +410,7 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." (should (= (mod-test-nanoseconds input) expected)))))) (ert-deftest mod-test-double () + (skip-unless (fboundp 'mod-test-double)) (dolist (input (list 0 1 2 -1 42 12345678901234567890 most-positive-fixnum (1+ most-positive-fixnum) most-negative-fixnum (1- most-negative-fixnum))) diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el index 930cc9fa214..52888135c12 100644 --- a/test/src/emacs-tests.el +++ b/test/src/emacs-tests.el @@ -25,6 +25,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-file (require 'rx) (require 'subr-x) @@ -46,22 +47,6 @@ "--seccomp=/does-not-exist.bpf") 0)))) -(cl-defmacro emacs-tests--with-temp-file - (var (prefix &optional suffix text) &rest body) - "Evaluate BODY while a new temporary file exists. -Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT -to `make-temp-file', which see." - (declare (indent 2) (debug (symbolp (form form form) body))) - (cl-check-type var symbol) - ;; Use an uninterned symbol so that the code still works if BODY - ;; changes VAR. - (let ((filename (make-symbol "filename"))) - `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text))) - (unwind-protect - (let ((,var ,filename)) - ,@body) - (delete-file ,filename))))) - (ert-deftest emacs-tests/seccomp/empty-file () (skip-unless (string-match-p (rx bow "SECCOMP" eow) system-configuration-features)) @@ -69,7 +54,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -94,9 +80,9 @@ to `make-temp-file', which see." ;; Either 8 or 16, but 16 should be large enough in all cases. (filter-size 16)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file - filter ("seccomp-too-large-" ".bpf" - (make-string (* (1+ ushort-max) filter-size) ?a)) + (ert-with-temp-file filter + :prefix "seccomp-too-large-" :suffix ".bpf" + :text (make-string (* (1+ ushort-max) filter-size) ?a) ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -117,8 +103,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf" - "123456") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" :text "123456" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 797d5a6f7a6..e4230c10efd 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -86,23 +86,27 @@ Bug#24912." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) (defun eval-tests--exceed-specbind-limit () (defvar eval-tests--var1) @@ -179,12 +183,13 @@ are found on the stack and therefore not garbage collected." "Remove the Lisp reference to the byte-compiled object." (setf (symbol-function #'eval-tests-33014-func) nil)) -(defun eval-tests-19790-backquote-comma-dot-substitution () +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () "Regression test for Bug#19790. Don't handle destructive splicing in backquote expressions (like in Common Lisp). Instead, make sure substitution in backquote expressions works for identifiers starting with period." - (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok))) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok))) (ert-deftest eval-tests/backtrace-in-batch-mode () (let ((emacs (expand-file-name invocation-name invocation-directory))) diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el index ae59d2ddc11..97642669a0d 100644 --- a/test/src/filelock-tests.el +++ b/test/src/filelock-tests.el @@ -28,30 +28,29 @@ (require 'cl-macs) (require 'ert) +(require 'ert-x) (require 'seq) -(defun filelock-tests--fixture (test-function) - "Call TEST-FUNCTION under a test fixture. +(defmacro filelock-tests--fixture (&rest body) + "Call BODY under a test fixture. Create a test directory and a buffer whose `buffer-file-name' and -`buffer-file-truename' are a file within it, then call -TEST-FUNCTION. Finally, delete the buffer and the test -directory." - (let* ((temp-dir (make-temp-file "filelock-tests" t)) - (name (concat (file-name-as-directory temp-dir) - "userfile")) - (create-lockfiles t)) - (unwind-protect - (with-temp-buffer - (setq buffer-file-name name - buffer-file-truename name) - (unwind-protect - (save-current-buffer - (funcall test-function)) - ;; Set `buffer-file-truename' nil to prevent unlocking, - ;; which might prompt the user and/or signal errors. - (setq buffer-file-name nil - buffer-file-truename nil))) - (delete-directory temp-dir t nil)))) +`buffer-file-truename' are a file within it, then call BODY. +Finally, delete the buffer and the test directory." + (declare (debug (body))) + `(ert-with-temp-directory temp-dir + (let ((name (concat (file-name-as-directory temp-dir) + "userfile")) + (create-lockfiles t)) + (with-temp-buffer + (setq buffer-file-name name + buffer-file-truename name) + (unwind-protect + (save-current-buffer + ,@body) + ;; Set `buffer-file-truename' nil to prevent unlocking, + ;; which might prompt the user and/or signal errors. + (setq buffer-file-name nil + buffer-file-truename nil)))))) (defun filelock-tests--make-lock-name (file-name) "Return the lock file name for FILE-NAME. @@ -87,97 +86,132 @@ the case)." (ert-deftest filelock-tests-lock-unlock-no-errors () "Check that locking and unlocking works without error." (filelock-tests--fixture - (lambda () - (should-not (file-locked-p (buffer-file-name))) + (should-not (file-locked-p (buffer-file-name))) - ;; inserting text should lock the buffer's file. - (insert "this locks the buffer's file") - (filelock-tests--should-be-locked) - (unlock-buffer) - (set-buffer-modified-p nil) - (should-not (file-locked-p (buffer-file-name))) + ;; Inserting text should lock the buffer's file. + (insert "this locks the buffer's file") + (filelock-tests--should-be-locked) + (unlock-buffer) + (set-buffer-modified-p nil) + (should-not (file-locked-p (buffer-file-name))) - ;; `set-buffer-modified-p' should lock the buffer's file. - (set-buffer-modified-p t) - (filelock-tests--should-be-locked) - (unlock-buffer) - (should-not (file-locked-p (buffer-file-name))) + ;; `set-buffer-modified-p' should lock the buffer's file. + (set-buffer-modified-p t) + (filelock-tests--should-be-locked) + (unlock-buffer) + (should-not (file-locked-p (buffer-file-name))) - (should-not (file-locked-p (buffer-file-name)))))) + (should-not (file-locked-p (buffer-file-name))))) (ert-deftest filelock-tests-lock-spoiled () - "Check `lock-buffer' ." + "Check `lock-buffer'." (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support (filelock-tests--fixture - (lambda () - (filelock-tests--spoil-lock-file buffer-file-truename) - ;; FIXME: errors when locking a file are ignored; should they be? - (set-buffer-modified-p t) - (filelock-tests--unspoil-lock-file buffer-file-truename) - (should-not (file-locked-p buffer-file-truename))))) + (filelock-tests--spoil-lock-file buffer-file-truename) + ;; FIXME: errors when locking a file are ignored; should they be? + (set-buffer-modified-p t) + (filelock-tests--unspoil-lock-file buffer-file-truename) + (should-not (file-locked-p buffer-file-truename)))) (ert-deftest filelock-tests-file-locked-p-spoiled () "Check that `file-locked-p' fails if the lockfile is \"spoiled\"." (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support (filelock-tests--fixture - (lambda () - (filelock-tests--spoil-lock-file buffer-file-truename) - (let ((err (should-error (file-locked-p (buffer-file-name))))) - (should (equal (seq-subseq err 0 2) + (filelock-tests--spoil-lock-file buffer-file-truename) + (let ((err (should-error (file-locked-p (buffer-file-name))))) + (should (equal (seq-subseq err 0 2) + (if (eq system-type 'windows-nt) + '(permission-denied "Testing file lock") '(file-error "Testing file lock"))))))) (ert-deftest filelock-tests-unlock-spoiled () "Check that `unlock-buffer' fails if the lockfile is \"spoiled\"." (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support (filelock-tests--fixture - (lambda () - ;; Set the buffer modified with file locking temporarily - ;; disabled. - (let ((create-lockfiles nil)) - (set-buffer-modified-p t)) - (should-not (file-locked-p buffer-file-truename)) - (filelock-tests--spoil-lock-file buffer-file-truename) - - ;; Errors from `unlock-buffer' should call - ;; `userlock--handle-unlock-error' (bug#46397). - (let (errors) - (cl-letf (((symbol-function 'userlock--handle-unlock-error) - (lambda (err) (push err errors)))) - (unlock-buffer)) - (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) - (should (equal (length errors) 1)))))) + ;; Set the buffer modified with file locking temporarily disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Errors from `unlock-buffer' should call + ;; `userlock--handle-unlock-error' (bug#46397). + (cl-letf (((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (signal (car err) (cdr err))))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (should-error (unlock-buffer)) 0 2)))))) (ert-deftest filelock-tests-kill-buffer-spoiled () "Check that `kill-buffer' fails if a lockfile is \"spoiled\"." (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support (filelock-tests--fixture - (lambda () - ;; Set the buffer modified with file locking temporarily - ;; disabled. - (let ((create-lockfiles nil)) - (set-buffer-modified-p t)) - (should-not (file-locked-p buffer-file-truename)) - (filelock-tests--spoil-lock-file buffer-file-truename) - - ;; Kill the current buffer. Because the buffer is modified Emacs - ;; will attempt to unlock it. Temporarily bind `yes-or-no-p' to - ;; a function that fakes a "yes" answer for the "Buffer modified; - ;; kill anyway?" prompt. - ;; - ;; File errors from unlocking files should call - ;; `userlock--handle-unlock-error' (bug#46397). - (let (errors) + ;; Set the buffer modified with file locking temporarily disabled. + (let ((create-lockfiles nil)) + (set-buffer-modified-p t)) + (should-not (file-locked-p buffer-file-truename)) + (filelock-tests--spoil-lock-file buffer-file-truename) + + ;; Kill the current buffer. Because the buffer is modified Emacs + ;; will attempt to unlock it. Temporarily bind `yes-or-no-p' to a + ;; function that fakes a "yes" answer for the "Buffer modified; + ;; kill anyway?" prompt. + ;; + ;; File errors from unlocking files should call + ;; `userlock--handle-unlock-error' (bug#46397). + (cl-letf (((symbol-function 'yes-or-no-p) #'always) + ((symbol-function 'userlock--handle-unlock-error) + (lambda (err) (signal (car err) (cdr err))))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (should-error (kill-buffer)) 0 2)))))) + +(ert-deftest filelock-tests-detect-external-change () + "Check that an external file modification is reported." + (skip-unless (not (eq system-type 'ms-dos))) ; no filelock support + (skip-unless (executable-find "touch")) + (skip-unless (executable-find "echo")) + (dolist (cl '(t nil)) + (filelock-tests--fixture + (let ((create-lockfiles cl)) + (write-region "foo" nil (buffer-file-name)) + (revert-buffer nil 'noconfirm) + (should-not (file-locked-p (buffer-file-name))) + + ;; Just changing the file modification on disk doesn't hurt, + ;; because file contents in buffer and on disk look equal. + (shell-command (format "touch %s" (buffer-file-name))) + (insert "bar") + (when cl (filelock-tests--should-be-locked)) + + ;; Bug#53207: with `create-lockfiles' nil, saving the buffer + ;; results in a prompt. (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (&rest _) t)) - ((symbol-function 'userlock--handle-unlock-error) - (lambda (err) (push err errors)))) - (kill-buffer)) - (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) - (should (equal (length errors) 1)))))) + (lambda (_) (ert-fail "Test failed unexpectedly")))) + (save-buffer)) + (should-not (file-locked-p (buffer-file-name))) + + ;; Changing the file contents on disk hurts when buffer is + ;; modified. There shall be a query, which we answer. + ;; *Messages* buffer is checked for prompt. + (shell-command (format "echo bar >>%s" (buffer-file-name))) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (prompt &rest _) (message "%s" prompt) ?y))) + (ert-with-message-capture captured-messages + ;; `ask-user-about-supersession-threat' does not work in + ;; batch mode, let's simulate interactiveness. + (let (noninteractive) + (insert "baz")) + (should (string-match-p + (format + "^%s changed on disk; really edit the buffer\\?" + (file-name-nondirectory (buffer-file-name))) + captured-messages)))) + (when cl (filelock-tests--should-be-locked)))))) (provide 'filelock-tests) ;;; filelock-tests.el ends here diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index d887939c999..aa709e3c2f5 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -21,6 +21,68 @@ (require 'ert) +(ert-deftest floatfns-tests-cos () + (should (= (cos 0) 1.0)) + (should (= (cos float-pi) -1.0))) + +(ert-deftest floatfns-tests-sin () + (should (= (sin 0) 0.0))) + +(ert-deftest floatfns-tests-tan () + (should (= (tan 0) 0.0))) + +(ert-deftest floatfns-tests-isnan () + (should (isnan 0.0e+NaN)) + (should (isnan -0.0e+NaN)) + (should-error (isnan "foo") :type 'wrong-type-argument)) + +(ert-deftest floatfns-tests-exp () + (should (= (exp 0) 1.0))) + +(ert-deftest floatfns-tests-expt () + (should (= (expt 2 8) 256))) + +(ert-deftest floatfns-tests-log () + (should (= (log 1000 10) 3.0))) + +(ert-deftest floatfns-tests-sqrt () + (should (= (sqrt 25) 5))) + +(ert-deftest floatfns-tests-abs () + (should (= (abs 10) 10)) + (should (= (abs -10) 10))) + +(ert-deftest floatfns-tests-logb () + (should (= (logb 10000) 13))) + +(ert-deftest floatfns-tests-ceiling () + (should (= (ceiling 0.5) 1))) + +(ert-deftest floatfns-tests-floor () + (should (= (floor 1.5) 1))) + +(ert-deftest floatfns-tests-round () + (should (= (round 1.49999999999) 1)) + (should (= (round 1.50000000000) 2)) + (should (= (round 1.50000000001) 2))) + +(ert-deftest floatfns-tests-truncate () + (should (= (truncate float-pi) 3))) + +(ert-deftest floatfns-tests-fceiling () + (should (= (fceiling 0.5) 1.0))) + +(ert-deftest floatfns-tests-ffloor () + (should (= (ffloor 1.5) 1.0))) + +(ert-deftest floatfns-tests-fround () + (should (= (fround 1.49999999999) 1.0)) + (should (= (fround 1.50000000000) 2.0)) + (should (= (fround 1.50000000001) 2.0))) + +(ert-deftest floatfns-tests-ftruncate () + (should (= (ftruncate float-pi) 3.0))) + (ert-deftest divide-extreme-sign () (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum))) (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum))) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 4d59f349bab..723ef4c710f 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -23,6 +23,29 @@ (require 'cl-lib) +(ert-deftest fns-tests-identity () + (let ((num 12345)) (should (eq (identity num) num))) + (let ((str "foo")) (should (eq (identity str) str))) + (let ((lst '(11))) (should (eq (identity lst) lst)))) + +(ert-deftest fns-tests-random () + (should (integerp (random))) + (should (>= (random 10) 0)) + (should (< (random 10) 10))) + +(ert-deftest fns-tests-length () + (should (= (length nil) 0)) + (should (= (length '(1 2 3)) 3)) + (should (= (length '[1 2 3]) 3)) + (should (= (length "foo") 3)) + (should-error (length t))) + +(ert-deftest fns-tests-safe-length () + (should (= (safe-length '(1 2 3)) 3))) + +(ert-deftest fns-tests-string-bytes () + (should (= (string-bytes "abc") 3))) + ;; Test that equality predicates work correctly on NaNs when combined ;; with hash tables based on those predicates. This was not the case ;; for eql in Emacs 26. @@ -34,6 +57,33 @@ (puthash nan t h) (should (eq (funcall test nan -nan) (gethash -nan h)))))) +(ert-deftest fns-tests-equal-including-properties () + (should (equal-including-properties "" "")) + (should (equal-including-properties "foo" "foo")) + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k v)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k x)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("b" 0 1 (k v)))) + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)))) + +(ert-deftest fns-tests-equal-including-properties/string-prop-vals () + "Handle string property values. (Bug#6581)" + (should (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "v")))) + (should (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "x")))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("b" 0 1 (k "v"))))) + (ert-deftest fns-tests-reverse () (should-error (reverse)) (should-error (reverse 1)) @@ -268,7 +318,10 @@ (should (equal (base64-encode-string "fooba") "Zm9vYmE=")) (should (equal (base64-encode-string "foobar") "Zm9vYmFy")) (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l+")) - (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/"))) + (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/")) + + (should-error (base64-encode-string "ƒ")) + (should-error (base64-encode-string "ü"))) (ert-deftest fns-test-base64url-encode-region () ;; url variant with padding @@ -310,7 +363,11 @@ (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) - (fns-tests--string-repeat "FPucA9l_" 10)))) + (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (fns-tests--with-region base64url-encode-region "ƒ")) + (should-error (fns-tests--with-region base64url-encode-region "ü"))) + (ert-deftest fns-test-base64url-encode-string () ;; url variant with padding @@ -344,7 +401,10 @@ (should (equal (base64url-encode-string (fns-tests--string-repeat "fooba" 15) t) (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5))) (should (equal (base64url-encode-string (fns-tests--string-repeat "foobar" 15) t) (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy"))) (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) - (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10)))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (base64url-encode-string "ƒ")) + (should-error (base64url-encode-string "ü"))) (ert-deftest fns-tests-base64-decode-string () ;; standard variant RFC2045 @@ -430,6 +490,23 @@ (buffer-hash)) (sha1 "foo")))) +(ert-deftest fns-tests-mapconcat () + (should (string= (mapconcat #'identity '()) "")) + (should (string= (mapconcat #'identity '("a" "b")) "ab")) + (should (string= (mapconcat #'identity '() "_") "")) + (should (string= (mapconcat #'identity '("A") "_") "A")) + (should (string= (mapconcat #'identity '("A" "B") "_") "A_B")) + (should (string= (mapconcat #'identity '("A" "B" "C") "_") "A_B_C")) + ;; non-ASCII strings + (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_") + "Ä_漢字_ø_漢字_☭_漢字_தமிழ்")) + ;; vector + (should (string= (mapconcat #'identity ["a" "b"] "") "ab")) + ;; bool-vector + (should (string= (mapconcat #'identity [nil nil] "") "")) + (should-error (mapconcat #'identity [nil nil t]) + :type 'wrong-type-argument)) + (ert-deftest fns-tests-mapcan () (should-error (mapcan)) (should-error (mapcan #'identity)) @@ -1115,4 +1192,74 @@ (should-error (line-number-at-pos -1)) (should-error (line-number-at-pos 100)))) +(defun fns-tests-concat (&rest args) + ;; Dodge the byte-compiler's partial evaluation of `concat' with + ;; constant arguments. + (apply #'concat args)) + +(ert-deftest fns-concat () + (should (equal (fns-tests-concat) "")) + (should (equal (fns-tests-concat "") "")) + (should (equal (fns-tests-concat nil) "")) + (should (equal (fns-tests-concat []) "")) + (should (equal (fns-tests-concat [97 98]) "ab")) + (should (equal (fns-tests-concat '(97 98)) "ab")) + (should (equal (fns-tests-concat "ab" '(99 100) nil [101 102] "gh") + "abcdefgh")) + (should (equal (fns-tests-concat "Ab" "\200" "cd") "Ab\200cd")) + (should (equal (fns-tests-concat "aB" "\200" "çd") "aB\200çd")) + (should (equal (fns-tests-concat "AB" (string-to-multibyte "\200") "cd") + (string-to-multibyte "AB\200cd"))) + (should (equal (fns-tests-concat "ab" '(#xe5) [255] "cd") "abåÿcd")) + (should (equal (fns-tests-concat '(#x3fffff) [#x3fff80] "xy") "\377\200xy")) + (should (equal (fns-tests-concat '(#x3fffff) [#x3fff80] "xy§") "\377\200xy§")) + (should (equal-including-properties + (fns-tests-concat #("abc" 0 3 (a 1)) #("de" 0 2 (a 1))) + #("abcde" 0 5 (a 1)))) + (should (equal-including-properties + (fns-tests-concat #("abc" 0 3 (a 1)) "§ü" #("çå" 0 2 (b 2))) + #("abc§üçå" 0 3 (a 1) 5 7 (b 2)))) + (should-error (fns-tests-concat "a" '(98 . 99)) + :type 'wrong-type-argument) + (let ((loop (list 66 67))) + (setcdr (cdr loop) loop) + (should-error (fns-tests-concat "A" loop) + :type 'circular-list))) + +(ert-deftest fns-vconcat () + (should (equal (vconcat) [])) + (should (equal (vconcat nil) [])) + (should (equal (vconcat "") [])) + (should (equal (vconcat [1 2 3]) [1 2 3])) + (should (equal (vconcat '(1 2 3)) [1 2 3])) + (should (equal (vconcat "ABC") [65 66 67])) + (should (equal (vconcat "ü§") [252 167])) + (should (equal (vconcat [1 2 3] nil '(4 5) "AB" "å" + "\377" (string-to-multibyte "\377") + (bool-vector t nil nil t nil)) + [1 2 3 4 5 65 66 #xe5 255 #x3fffff t nil nil t nil])) + (should-error (vconcat [1] '(2 . 3)) + :type 'wrong-type-argument) + (let ((loop (list 1 2))) + (setcdr (cdr loop) loop) + (should-error (vconcat [1] loop) + :type 'circular-list))) + +(ert-deftest fns-append () + (should (equal (append) nil)) + (should (equal (append 'tail) 'tail)) + (should (equal (append [1 2 3] nil '(4 5) "AB" "å" + "\377" (string-to-multibyte "\377") + (bool-vector t nil nil t nil) + '(9 10)) + '(1 2 3 4 5 65 66 #xe5 255 #x3fffff t nil nil t nil 9 10))) + (should (equal (append '(1 2) '(3 4) 'tail) + '(1 2 3 4 . tail))) + (should-error (append '(1 . 2) '(3)) + :type 'wrong-type-argument) + (let ((loop (list 1 2))) + (setcdr (cdr loop) loop) + (should-error (append loop '(end)) + :type 'circular-list))) + ;;; fns-tests.el ends here diff --git a/test/src/image-tests.el b/test/src/image-tests.el new file mode 100644 index 00000000000..3885981e0b2 --- /dev/null +++ b/test/src/image-tests.el @@ -0,0 +1,244 @@ +;;; image-tests.el --- Tests for image.c -*- lexical-binding: t -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefan@marxist.se> + +;; 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: + +;; Most of these tests will only run in a GUI session, and not with +;; "make check". Run them manually in an interactive session with +;; `M-x eval-buffer' followed by `M-x ert'. + +;;; Code: + +(require 'ert) + +(defmacro image-skip-unless (format) + `(skip-unless (and (display-images-p) + (image-type-available-p ,format)))) + +;;;; Images + +(defconst image-tests--images + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(find-image '((:file "splash.svg" :type svg)))) + (png . ,(find-image '((:file "splash.png" :type png)))) + (svg . ,(find-image '((:file "splash.pbm" :type pbm)))) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) + (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) + +;;;; image-test-size + +(ert-deftest image-tests-image-size/gif () + (image-skip-unless 'gif) + (pcase (image-size (create-image (cdr (assq 'gif image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/jpeg () + (image-skip-unless 'jpeg) + (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/pbm () + (image-skip-unless 'pbm) + (pcase (image-size (cdr (assq 'pbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/png () + (image-skip-unless 'png) + (pcase (image-size (cdr (assq 'png image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/svg () + (image-skip-unless 'svg) + (pcase (image-size (cdr (assq 'svg image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/tiff () + (image-skip-unless 'tiff) + (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/webp () + (image-skip-unless 'webp) + (pcase (image-size (create-image (cdr (assq 'webp image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xbm () + (image-skip-unless 'xbm) + (pcase (image-size (cdr (assq 'xbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xpm () + (image-skip-unless 'xpm) + (pcase (image-size (cdr (assq 'xpm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-size 'invalid-spec))) + +(ert-deftest image-tests-image-size/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-size 'invalid-spec))) + +;;;; image-mask-p + +(ert-deftest image-tests-image-mask-p/gif () + (image-skip-unless 'gif) + (should-not (image-mask-p (create-image + (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-mask-p (create-image + (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/pbm () + (image-skip-unless 'pbm) + (should-not (image-mask-p (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/png () + (image-skip-unless 'png) + (should-not (image-mask-p (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/svg () + (image-skip-unless 'svg) + (should-not (image-mask-p (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/tiff () + (image-skip-unless 'tiff) + (should-not (image-mask-p (create-image + (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/webp () + (image-skip-unless 'webp) + (should-not (image-mask-p (create-image + (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/xbm () + (image-skip-unless 'xbm) + (should-not (image-mask-p (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/xpm () + (image-skip-unless 'xpm) + (should-not (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-mask-p 'invalid-spec))) + +(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +;;;; image-metadata + +;; TODO: These tests could be expanded with files that actually +;; contain metadata. + +(ert-deftest image-tests-image-metadata/gif () + (image-skip-unless 'gif) + (should-not (image-metadata + (create-image (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-metadata + (create-image (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/pbm () + (image-skip-unless 'pbm) + (should-not (image-metadata (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/png () + (image-skip-unless 'png) + (should-not (image-metadata (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-metadata/svg () + (image-skip-unless 'svg) + (should-not (image-metadata (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-metadata/tiff () + (image-skip-unless 'tiff) + (should-not (image-metadata + (create-image (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/webp () + (image-skip-unless 'webp) + (should-not (image-metadata + (create-image (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/xbm () + (image-skip-unless 'xbm) + (should-not (image-metadata (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/xpm () + (image-skip-unless 'xpm) + (should-not (image-metadata (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/nil-on-invalid-spec () + (skip-unless (display-images-p)) + (should-not (image-metadata 'invalid-spec))) + +(ert-deftest image-tests-image-metadata/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-metadata (cdr (assq 'xpm image-tests--images))))) + +;;;; ImageMagick + +(ert-deftest image-tests-imagemagick-types () + (skip-unless (fboundp 'imagemagick-types)) + (when (fboundp 'imagemagick-types) + (should (listp (imagemagick-types))))) + +;;;; Initialization + +(ert-deftest image-tests-init-image-library () + (skip-unless (fboundp 'init-image-library)) + (should (init-image-library 'pbm)) ; built-in + (should-not (init-image-library 'invalid-image-type))) + +;;; image-tests.el ends here diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el index d9390b638b6..295b184be0e 100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@ -24,9 +24,11 @@ ;;; Code: (require 'ert) +(require 'ert-x) (declare-function inotify-add-watch "inotify.c" (file-name aspect callback)) (declare-function inotify-rm-watch "inotify.c" (watch-descriptor)) +(declare-function inotify-valid-p "inotify.c" (watch-descriptor)) (ert-deftest inotify-valid-p-simple () "Simple tests for `inotify-valid-p'." @@ -37,8 +39,7 @@ ;; (ert-deftest filewatch-file-watch-aspects-check () ;; "Test whether `file-watch' properly checks the aspects." -;; (let ((temp-file (make-temp-file "filewatch-aspects"))) -;; (should (stringp temp-file)) +;; (ert-with-temp-file temp-file ;; (should-error (file-watch temp-file 'wrong nil) ;; :type 'error) ;; (should-error (file-watch temp-file '(modify t) nil) @@ -50,23 +51,21 @@ (ert-deftest inotify-file-watch-simple () "Test if watching a normal file works." - (skip-unless (featurep 'inotify)) - (let ((temp-file (make-temp-file "inotify-simple")) - (events 0)) - (let ((wd - (inotify-add-watch temp-file t (lambda (_ev) - (setq events (1+ events)))))) - (unwind-protect - (progn - (with-temp-file temp-file - (insert "Foo\n")) - (read-event nil nil 5) - (should (> events 0))) - (should (inotify-valid-p wd)) - (inotify-rm-watch wd) - (should-not (inotify-valid-p wd)) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + (let ((events 0)) + (let ((wd + (inotify-add-watch temp-file t (lambda (_ev) + (setq events (1+ events)))))) + (unwind-protect + (progn + (with-temp-file temp-file + (insert "Foo\n")) + (read-event nil nil 5) + (should (> events 0))) + (should (inotify-valid-p wd)) + (inotify-rm-watch wd) + (should-not (inotify-valid-p wd))))))) (provide 'inotify-tests) diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 1dbaf7ef2e7..69aa7238493 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -134,6 +134,45 @@ (define-key map [menu-bar i-bar] 'foo) (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))) +(ert-deftest keymap-lookup-key/mixed-case-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + ;; (downcase "Åäö") => "åäö" + (define-key map [menu-bar åäö bar] 'foo) + (should (eq (lookup-key map [menu-bar åäö bar]) 'foo)) + (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo)) + ;; (downcase "Γ") => "γ" + (define-key map [menu-bar γ bar] 'baz) + (should (eq (lookup-key map [menu-bar γ bar]) 'baz)) + (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz)))) + +(ert-deftest keymap-lookup-key/menu-non-symbol () + "Test for Bug#51527." + (let ((map (make-keymap))) + (define-key map [menu-bar buffer 1] 'foo) + (should (eq (lookup-key map [menu-bar buffer 1]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar foo-bar] 'foo) + (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar åäö-bar] 'foo) + (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env () + "Backwards compatibility behaviour (Bug#50752)." + (let ((lang-env current-language-environment)) + (set-language-environment "Turkish") + (let ((map (make-keymap))) + (define-key map [menu-bar i-bar] 'foo) + (should (eq (lookup-key map [menu-bar I-bar]) 'foo))) + (set-language-environment lang-env))) + (ert-deftest describe-buffer-bindings/header-in-current-buffer () "Header should be inserted into the current buffer. https://debbugs.gnu.org/39149#31" @@ -237,15 +276,11 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (should (equal (where-is-internal 'foo map t) [?y])) (should (equal (where-is-internal 'bar map t) [?y])))) -(defvar keymap-tests-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-2) - map)) +(defvar-keymap keymap-tests-minor-mode-map + "x" 'keymap-tests--command-2) -(defvar keymap-tests-major-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-1) - map)) +(defvar-keymap keymap-tests-major-mode-map + "x" 'keymap-tests--command-1) (define-minor-mode keymap-tests-minor-mode "Test.") @@ -284,12 +319,12 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (with-temp-buffer (help--describe-vector (cadr orig-map) nil #'help--describe-command t shadow-map orig-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " e foo f foo (currently shadowed by `bar') g .. h foo -"))))) +")))))) (ert-deftest help--describe-vector/bug-9293-same-command-does-not-shadow () "Check that a command can't be shadowed by the same command." @@ -310,10 +345,10 @@ g .. h foo (with-temp-buffer (help--describe-vector (cadr range-map) nil #'help--describe-command t shadow-map range-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " 0 .. 3 foo -"))))) +")))))) (ert-deftest keymap--key-description () (should (equal (key-description [right] [?\C-x]) @@ -327,6 +362,62 @@ g .. h foo (should (equal (single-key-description 'C-s-home) "C-s-<home>"))) +(ert-deftest keymap-test-lookups () + (should (eq (lookup-key (current-global-map) "\C-x\C-f") 'find-file)) + (should (eq (lookup-key (current-global-map) [(control x) (control f)]) + 'find-file)) + (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file)) + (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file))) + +(ert-deftest keymap-removal () + ;; Set to nil. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil) + (should (equal map '(keymap (97))))) + ;; Remove. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil t) + (should (equal map '(keymap))))) + +(ert-deftest keymap-removal-inherit () + ;; Set to nil. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil) + (should (eq (lookup-key child [?a]) nil))) + ;; Remove. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil t) + (should (eq (lookup-key child [?a]) 'foo)))) + +(ert-deftest keymap-text-char-description () + (should (equal (text-char-description ?a) "a")) + (should (equal (text-char-description ?\s) " ")) + (should (equal (text-char-description ?\t) "^I")) + (should (equal (text-char-description ?\^C) "^C")) + (should (equal (text-char-description ?\^?) "^?")) + (should (equal (text-char-description #x80) "")) + (should (equal (text-char-description ?å) "å")) + (should (equal (text-char-description ?Ş) "Ş")) + (should (equal (text-char-description ?Ā) "Ā")) + (should-error (text-char-description "c")) + (should-error (text-char-description [?\C-x ?l])) + (should-error (text-char-description ?\M-c)) + (should-error (text-char-description ?\s-c))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el index 0f4bbd3ef62..1829a7ea1f1 100644 --- a/test/src/lcms-tests.el +++ b/test/src/lcms-tests.el @@ -35,6 +35,13 @@ (require 'ert) (require 'color) +(declare-function lcms-jab->jch "lcms.c") +(declare-function lcms-jch->jab "lcms.c") +(declare-function lcms-xyz->jch "lcms.c") +(declare-function lcms-jch->xyz "lcms.c") +(declare-function lcms-temp->white-point "lcms.c") +(declare-function lcms-cam02-ucs "lcms.c") + (defconst lcms-colorspacious-d65 '(0.95047 1.0 1.08883) "D65 white point from colorspacious.") diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index d337563728b..862f6a6595f 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -115,18 +115,14 @@ (should-error (read "#24r") :type 'invalid-read-syntax) (should-error (read "#") :type 'invalid-read-syntax)) +(ert-deftest lread-char-modifiers () + (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) (read "(#1=#s(foo) #1#)")))) -(defmacro lread-tests--with-temp-file (file-name-var &rest body) - (declare (indent 1)) - (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,file-name-var)))) - (defun lread-tests--last-message () (with-current-buffer "*Messages*" (save-excursion @@ -137,7 +133,7 @@ (ert-deftest lread-tests--unescaped-char-literals () "Check that loading warns about unescaped character literals (Bug#20852)." - (lread-tests--with-temp-file file-name + (ert-with-temp-file file-name (write-region "?) ?( ?; ?\" ?[ ?]" nil file-name) (should (equal (load file-name nil :nomessage :nosuffix) t)) (should (equal (lread-tests--last-message) diff --git a/test/src/print-tests.el b/test/src/print-tests.el index 4c7b339e0c6..1ef0caf1a46 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -406,5 +406,16 @@ otherwise, use a different charset." (should (equal printed-nonprints "(55296 57343 778 65535 8194 8204)")))) +(ert-deftest test-unreadable () + (should (equal (prin1-to-string (make-marker)) "#<marker in no buffer>")) + (let ((print-unreadable-function + (lambda (_object _escape) + "hello"))) + (should (equal (prin1-to-string (make-marker)) "hello"))) + (let ((print-unreadable-function + (lambda (_object _escape) + t))) + (should (equal (prin1-to-string (make-marker)) "")))) + (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 14092187e0b..f5908d3cda5 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -25,11 +25,16 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'puny) (require 'subr-x) (require 'dns) (require 'url-http) +(declare-function thread-last-error "thread.c") +(declare-function thread-join "thread.c") +(declare-function make-thread "thread.c") + ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -64,24 +69,22 @@ (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () "Check that Emacs hides CreateProcess deficiency (bug#18745)." - (let (batfile) - (unwind-protect - (progn - ;; CreateProcess will fail when both the bat file and 1st - ;; argument are quoted, so include spaces in both of those - ;; to force quoting. - (setq batfile (make-temp-file "echo args" nil ".bat")) - (with-temp-file batfile - (insert "@echo arg1=%1, arg2=%2\n")) - (with-temp-buffer - (call-process batfile nil '(t t) t "x &y") - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) - (with-temp-buffer - (call-process-shell-command - (mapconcat #'shell-quote-argument (list batfile "x &y") " ") - nil '(t t) t) - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) - (when batfile (delete-file batfile)))))) + (ert-with-temp-file batfile + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + :prefix "echo args" + :suffix ".bat" + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))))) (ert-deftest process-test-stderr-buffer () (skip-unless (executable-find "bash")) @@ -531,18 +534,6 @@ FD_SETSIZE." (delete-process (pop ,processes)) ,@body))))) -(defmacro process-tests--with-temp-directory (var &rest body) - "Bind VAR to the name of a new directory and evaluate BODY. -Afterwards, delete the directory." - (declare (indent 1) (debug (symbolp body))) - (cl-check-type var symbol) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (make-temp-file "emacs-test-" :dir))) - (unwind-protect - (let ((,var ,dir)) - ,@body) - (delete-directory ,dir :recursive))))) - ;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests ;; generate lots of process objects of the various kinds. Running the ;; tests with assertions enabled should not result in any crashes due @@ -630,7 +621,7 @@ FD_SETSIZE file descriptors (Bug#24325)." ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). (skip-unless (not (eq system-type 'cygwin))) (with-timeout (60 (ert-fail "Test timed out")) - (process-tests--with-temp-directory directory + (ert-with-temp-directory directory (process-tests--with-processes processes (let* ((num-clients 10) (socket-name (expand-file-name "socket" directory)) @@ -800,6 +791,7 @@ have written output." (list (list process "finished\n")))))))))) (ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (fboundp 'make-thread)) (with-timeout (60 (ert-fail "Test timed out")) (process-tests--with-processes processes diff --git a/test/src/search-tests.el b/test/src/search-tests.el index c7d6004ce44..2fa23842841 100644 --- a/test/src/search-tests.el +++ b/test/src/search-tests.el @@ -28,7 +28,7 @@ (setq ov-set (make-overlay 3 5)) (overlay-put ov-set 'modification-hooks - (list (lambda (o after &rest _args) + (list (lambda (_o after &rest _args) (when after (let ((inhibit-modification-hooks t)) (save-excursion diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el new file mode 100644 index 00000000000..6e44300f3ad --- /dev/null +++ b/test/src/sqlite-tests.el @@ -0,0 +1,219 @@ +;;; sqlite-tests.el --- Tests for sqlite.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021-2022 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-close "sqlite.c") +(declare-function sqlitep "sqlite.c") +(declare-function sqlite-available-p "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-load-extension "sqlite.c") + +(ert-deftest sqlite-select () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (should (eq (type-of db) 'sqlite)) + (should (sqlitep db)) + (should-not (sqlitep 'foo)) + + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer, col3 float, col4 blob)"))) + + (should-error + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar', 'zot')")) + + (should + (= + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar')") + 1)) + + (should + (equal + (sqlite-select db "select * from test1" nil 'full) + '(("col1" "col2" "col3" "col4") ("foo" 2 9.45 "bar")))))) + +(ert-deftest sqlite-set () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open)) + set) + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer)"))) + + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('foo', 1)") + 1)) + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('bar', 2)") + 1)) + + (setq set (sqlite-select db "select * from test1" nil 'set)) + (should (sqlitep set)) + (should (sqlite-more-p set)) + (should (equal (sqlite-next set) + '("foo" 1))) + (should (equal (sqlite-next set) + '("bar" 2))) + (should-not (sqlite-next set)) + (should-not (sqlite-more-p set)) + (sqlite-finalize set) + (should-error (sqlite-next set)))) + +(ert-deftest sqlite-chars () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test2 (col1 text, col2 integer)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fo', 4)") + (should + (equal (sqlite-select db "select * from test2" nil 'full) + '(("col1" "col2") ("fóo" 3) ("fóo" 3) ("fo" 4)))))) + +(ert-deftest sqlite-numbers () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test3 (col1 integer)") + (let ((big (expt 2 50)) + (small (expt 2 10))) + (sqlite-execute db (format "insert into test3 values (%d)" small)) + (sqlite-execute db (format "insert into test3 values (%d)" big)) + (should + (equal + (sqlite-select db "select * from test3") + (list (list small) (list big))))))) + +(ert-deftest sqlite-param () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test4 (col1 text, col2 number)") + (sqlite-execute db "insert into test4 values (?, ?)" (list "foo" 1)) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" '(1)) + '(("foo" 1)))) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" [1]) + '(("foo" 1)))))) + +(ert-deftest sqlite-binary () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test5 (col1 text, col2 number)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test5 values (?, ?)" (list string 2)) + (let ((out (caar + (sqlite-select db "select col1 from test5 where col2 = 2")))) + (should (equal out string)))))) + +(ert-deftest sqlite-different-dbs () + (skip-unless (sqlite-available-p)) + (let (db1 db2) + (setq db1 (sqlite-open)) + (setq db2 (sqlite-open)) + (sqlite-execute + db1 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db2 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db1 "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db1 "select * from test6")) + (should-not (sqlite-select db2 "select * from test6")))) + +(ert-deftest sqlite-close-dbs () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute db "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db "select * from test6")) + (sqlite-close db) + (should-error (sqlite-select db "select * from test6")))) + +(ert-deftest sqlite-load-extension () + (skip-unless (sqlite-available-p)) + (skip-unless (fboundp 'sqlite-load-extension)) + (let (db) + (setq db (sqlite-open)) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/notpcre.so")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/n")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3")) + (should + (memq + (sqlite-load-extension db "/usr/lib/sqlite3/pcre.so") + '(nil t))) + + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_notcsvtable.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtablen.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable")) + (should + (memq + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so") + '(nil t))))) + +;;; sqlite-tests.el ends here diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el index 3b9f21cde37..751a900a23e 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -506,4 +506,19 @@ the `parse-partial-sexp's are expected to stop. See (should (parse-partial-sexp 1 1)) (should-error (parse-partial-sexp 2 1)))) +(ert-deftest syntax-char-syntax () + ;; Verify that char-syntax behaves identically in interpreted and + ;; byte-compiled code (bug#53260). + (let ((cs (byte-compile (lambda (x) (char-syntax x))))) + ;; Use a unibyte buffer with a syntax table using symbol syntax + ;; for raw byte 128. + (with-temp-buffer + (set-buffer-multibyte nil) + (let ((st (make-syntax-table))) + (modify-syntax-entry (unibyte-char-to-multibyte 128) "_" st) + (set-syntax-table st) + (should (equal (eval '(char-syntax 128) t) ?_)) + (should (equal (funcall cs 128) ?_)))) + (list (char-syntax 128) (funcall cs 128)))) + ;;; syntax-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index d521f89f7df..75d67140a90 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -389,7 +389,33 @@ (should (equal (thread-last-error) '(error "Die, die, die!"))))) (ert-deftest threads-test-bug33073 () + (skip-unless (fboundp 'make-thread)) (let ((th (make-thread 'ignore))) (should-not (equal th main-thread)))) +(defvar threads-test--var 'global) + +(ert-deftest threads-test-bug48990 () + (skip-unless (fboundp 'make-thread)) + (let ((buf1 (generate-new-buffer " thread-test")) + (buf2 (generate-new-buffer " thread-test"))) + (with-current-buffer buf1 + (setq-local threads-test--var 'local1)) + (with-current-buffer buf2 + (setq-local threads-test--var 'local2)) + (let ((seen nil)) + (with-current-buffer buf1 + (should (eq threads-test--var 'local1)) + (make-thread (lambda () (setq seen threads-test--var)))) + (with-current-buffer buf2 + (should (eq threads-test--var 'local2)) + (let ((threads-test--var 'let2)) + (should (eq threads-test--var 'let2)) + (while (not seen) + (thread-yield)) + (should (eq threads-test--var 'let2)) + (should (eq seen 'local1))) + (should (eq threads-test--var 'local2))) + (should (eq threads-test--var 'global))))) + ;;; thread-tests.el ends here diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 2288a9ef613..1b49e0622f5 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -242,4 +242,16 @@ a fixed place on the right and are padded on the left." (should (= xdiv (float-time (time-convert xdiv t)))))) (setq x (* x 2))))) +(ert-deftest time-convert-forms () + ;; These computations involve numbers that should have exact + ;; representations on any Emacs platform. + (dolist (time '(-86400 -1 0 1 86400)) + (dolist (delta '(0 0.0 0.25 3.25 1000 1000.25)) + (let ((time+ (+ time delta)) + (time- (- time delta))) + (dolist (form '(nil t list 4 1000 1000000 1000000000)) + (should (time-equal-p time (time-convert time form))) + (should (time-equal-p time- (time-convert time- form))) + (should (time-equal-p time+ (time-convert time+ form)))))))) + ;;; timefns-tests.el ends here diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 63e7a3f8cb5..c84ed74f0b1 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -46,6 +46,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'facemenu) (ert-deftest undo-test0 () @@ -218,17 +219,14 @@ (ert-deftest undo-test-file-modified () "Test undoing marks buffer visiting file unmodified." - (let ((tempfile (make-temp-file "undo-test"))) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect tempfile) - (insert "1") - (undo-boundary) - (set-buffer-modified-p nil) - (insert "2") - (undo) - (should-not (buffer-modified-p)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p))))) (ert-deftest undo-test-region-not-most-recent () "Test undo in region of an edit not the most recent." diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index c487ba286c8..6ff64d0431a 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -99,4 +99,84 @@ (width-in-chars (/ (car size) char-width))) (should (equal width-in-chars 3))))) +(ert-deftest xdisp-tests--find-directional-overrides-case-1 () + (with-temp-buffer + (insert "\ +int main() { + bool isAdmin = false; + /* }if (isAdmin) begin admins only */ + printf(\"You are an admin.\\n\"); + /* end admins only { */ + return 0; +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 46)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-2 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? 0 : 1 \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-3 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? '#' : '!' \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest test-get-display-property () + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '(height 2.0))) + (should (equal (get-display-property 2 'height) 2.0))) + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '((height 2.0) + (space-width 2.0)))) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 2.0))) + (with-temp-buffer + (insert (propertize "foo bar" 'face 'bold + 'display '[(height 2.0) + (space-width 20)])) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 20)))) + +(ert-deftest test-messages-buffer-name () + (should + (equal + (let ((messages-buffer-name "test-message")) + (message "foo") + (with-current-buffer messages-buffer-name + (buffer-string))) + "foo\n"))) + ;;; xdisp-tests.el ends here diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el index 31c0f021b28..16f16537918 100644 --- a/test/src/xfaces-tests.el +++ b/test/src/xfaces-tests.el @@ -47,7 +47,10 @@ '(0 32768 6554))) (should (equal (color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0") '(66 655 65535))) - (should (equal (color-values-from-color-spec "rgbi:0/0.5/10") nil))) + (should (equal (color-values-from-color-spec "rgbi:0/0.5/10") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/0/ 0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/0x0/0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/+0x1/0") nil))) (provide 'xfaces-tests) diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 62054ce0e3c..6a8290bd0c8 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -27,6 +27,8 @@ (require 'ert) +(declare-function libxml-parse-xml-region "xml.c") + (defvar libxml-tests--data-comments-preserved `(;; simple case ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" |