diff options
| author | Yuuki Harano <masm+github@masm11.me> | 2021-11-11 00:39:53 +0900 |
|---|---|---|
| committer | Yuuki Harano <masm+github@masm11.me> | 2021-11-11 00:39:53 +0900 |
| commit | 4dd1f56f29fc598a8339a345c2f8945250600602 (patch) | |
| tree | af341efedffe027e533b1bcc0dbf270532e48285 /test/lisp | |
| parent | 4c49ec7f865bdad1629d2f125f71f4e506b258f2 (diff) | |
| parent | 810fa21d26453f898de9747ece7205dfe6de9d08 (diff) | |
| download | emacs-4dd1f56f29fc598a8339a345c2f8945250600602.tar.gz emacs-4dd1f56f29fc598a8339a345c2f8945250600602.tar.bz2 emacs-4dd1f56f29fc598a8339a345c2f8945250600602.zip | |
Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs into feature/pgtk
Diffstat (limited to 'test/lisp')
202 files changed, 8499 insertions, 3193 deletions
diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 2a42d5636d3..863806af7b3 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -28,6 +28,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'abbrev) (require 'seq) @@ -106,7 +107,7 @@ (should (abbrev-table-empty-p table)))) (ert-deftest kill-all-abbrevs-test () - "Test undefining all defined abbrevs" + "Test undefining all defined abbrevs." (unless noninteractive (ert-skip "Cannot test kill-all-abbrevs in interactive mode")) @@ -125,14 +126,14 @@ abbrev-table-name-list)))))) (ert-deftest abbrev-table-name-test () - "Test returning name of abbrev-table" + "Test returning name of abbrev-table." (let ((ert-test-abbrevs (setup-test-abbrev-table)) (no-such-table nil)) (should (equal 'ert-test-abbrevs (abbrev-table-name ert-test-abbrevs))) (should (equal nil (abbrev-table-name no-such-table))))) (ert-deftest clear-abbrev-table-test () - "Test clearing single abbrev table" + "Test clearing single abbrev table." (let ((ert-test-abbrevs (setup-test-abbrev-table))) (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) (clear-abbrev-table ert-test-abbrevs) @@ -140,7 +141,7 @@ (should (equal t (abbrev-table-empty-p ert-test-abbrevs))))) (ert-deftest list-abbrevs-test () - "Test generation of abbrev list buffer" + "Test generation of abbrev list buffer." ;; Somewhat redundant as prepare-abbrev-list-buffer is also tested. ;; all abbrevs (let ((abbrev-buffer (prepare-abbrev-list-buffer))) @@ -152,7 +153,7 @@ (kill-buffer abbrev-buffer))) (ert-deftest prepare-abbrev-list-buffer-test () - "Test generation of abbrev list buffer" + "Test generation of abbrev list buffer." ;; all abbrevs (let ((ert-test-abbrevs (setup-test-abbrev-table))) (with-current-buffer (prepare-abbrev-list-buffer) @@ -180,7 +181,7 @@ (kill-buffer "*Abbrevs*")))) (ert-deftest insert-abbrevs-test () - "Test inserting abbrev definitions into buffer" + "Test inserting abbrev definitions into buffer." (with-temp-buffer (insert-abbrevs) (should (progn @@ -188,7 +189,7 @@ (search-forward "global-abbrev-table"))))) (ert-deftest edit-abbrevs-test () - "Test editing abbrevs from buffer" + "Test editing abbrevs from buffer." (defvar ert-edit-abbrevs-test-table nil) (let ((ert-test-abbrevs (setup-test-abbrev-table))) (with-temp-buffer @@ -205,7 +206,7 @@ (abbrev-expansion "e-a-t" ert-edit-abbrevs-test-table)))))) (ert-deftest define-abbrevs-test () - "Test defining abbrevs from buffer" + "Test defining abbrevs from buffer." (defvar ert-bad-abbrev-table nil) (defvar ert-good-abbrev-table nil) (defvar ert-redefine-abbrev-table nil) @@ -235,45 +236,42 @@ (should (equal nil (abbrev-expansion "g-a-t" ert-good-abbrev-table))))) (ert-deftest read-write-abbrev-file-test () - "Test reading and writing abbrevs from file" - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) - (delete-file temp-test-file))) + "Test reading and writing abbrevs from file." + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))))) (ert-deftest read-write-abbrev-file-test-with-props () - "Test reading and writing abbrevs from file" - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table-with-props))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))) - (delete-file temp-test-file))) + "Test reading and writing abbrevs from file." + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table-with-props))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))))) (ert-deftest abbrev-edit-save-to-file-test () - "Test saving abbrev definitions in buffer to file" + "Test saving abbrev definitions in buffer to file." (defvar ert-save-test-table nil) - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (with-temp-buffer - (goto-char (point-min)) - (insert "(ert-save-test-table)\n") - (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") - (should (equal "abbrev-ert-test" - (abbrev-expansion "a-e-t" ert-test-abbrevs))) - ;; clears abbrev tables - (abbrev-edit-save-to-file temp-test-file) - (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "save-abbrevs-test" - (abbrev-expansion "s-a-t" ert-save-test-table))) - (delete-file temp-test-file)))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (with-temp-buffer + (goto-char (point-min)) + (insert "(ert-save-test-table)\n") + (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") + (should (equal "abbrev-ert-test" + (abbrev-expansion "a-e-t" ert-test-abbrevs))) + ;; clears abbrev tables + (abbrev-edit-save-to-file temp-test-file) + (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "save-abbrevs-test" + (abbrev-expansion "s-a-t" ert-save-test-table))))))) (ert-deftest inverse-add-abbrev-skips-trailing-nonword () "Test that adding an inverse abbrev skips trailing nonword characters." diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index 107dc8e400b..14a14ca4f06 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Pablo Barbáchano <pablob@amazon.com> -;; Keywords: ansi ;; This file is part of GNU Emacs. @@ -25,24 +24,154 @@ ;;; Code: (require 'ansi-color) +(eval-when-compile (require 'cl-lib)) -(defvar test-strings '(("\e[33mHello World\e[0m" . "Hello World") - ("\e[1m\e[3m\e[5mbold italics blink\e[0m" . "bold italics blink"))) +(defvar ansi-color-tests--strings + (let ((bright-yellow (face-foreground 'ansi-color-bright-yellow nil 'default)) + (yellow (face-foreground 'ansi-color-yellow nil 'default)) + (custom-color "#87FFFF")) + `(("Hello World" "Hello World") + ("\e[33mHello World\e[0m" "Hello World" + (:foreground ,yellow)) + ("\e[43mHello World\e[0m" "Hello World" + (:background ,yellow)) + ("\e[93mHello World\e[0m" "Hello World" + (:foreground ,bright-yellow)) + ("\e[103mHello World\e[0m" "Hello World" + (:background ,bright-yellow)) + ("\e[1;33mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[33;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[1m\e[33mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[33m\e[1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[1m\e[3m\e[5mbold italics blink\e[0m" "bold italics blink" + (ansi-color-bold ansi-color-italic ansi-color-slow-blink)) + ("\e[10munrecognized\e[0m" "unrecognized") + ("\e[38;5;3;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[48;5;123;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color))) + ("\e[48;2;135;255;255;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color)))))) + +(defun ansi-color-tests-equal-props (o1 o2) + "Return t if two Lisp objects have similar structure and contents. +While `equal-including-properties' compares text properties of +strings with `eq', this function compares them with `equal'." + (or (equal-including-properties o1 o2) + (and (stringp o1) + (equal o1 o2) + (cl-loop for i below (length o1) + always (equal (text-properties-at i o1) + (text-properties-at i o2)))))) (ert-deftest ansi-color-apply-on-region-test () - (dolist (pair test-strings) - (with-temp-buffer - (insert (car pair)) + (pcase-dolist (`(,input ,text ,face) ansi-color-tests--strings) + (with-temp-buffer + (insert input) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (equal (buffer-string) text)) + (should (equal (get-char-property (point-min) 'face) face)) + (when face + (should (overlays-at (point-min))))))) + +(ert-deftest ansi-color-apply-on-region-bold-is-bright-test () + (pcase-dolist (`(,input ,text ,normal-face ,bright-face) + ansi-color-tests--strings) + (with-temp-buffer + (let ((ansi-color-bold-is-bright t) + (face (or bright-face normal-face))) + (insert input) (ansi-color-apply-on-region (point-min) (point-max)) - (should (equal (buffer-string) (cdr pair))) - (should (not (equal (overlays-at (point-min)) nil)))))) + (should (equal (buffer-string) text)) + (should (equal (get-char-property (point-min) 'face) face)) + (when face + (should (overlays-at (point-min)))))))) (ert-deftest ansi-color-apply-on-region-preserving-test () - (dolist (pair test-strings) - (with-temp-buffer - (insert (car pair)) - (ansi-color-apply-on-region (point-min) (point-max) t) - (should (equal (buffer-string) (car pair)))))) + (dolist (pair ansi-color-tests--strings) + (with-temp-buffer + (insert (car pair)) + (ansi-color-apply-on-region (point-min) (point-max) t) + (should (equal (buffer-string) (car pair)))))) + +(ert-deftest ansi-color-incomplete-sequences-test () + (let* ((strs (list "\e[" "2;31m Hello World " + "\e" "[108;5;12" "3m" "Greetings" + "\e[0m\e[35;6m" "Hello")) + (complete-str (apply #'concat strs)) + (filtered-str) + (propertized-str) + (ansi-color-apply-face-function + #'ansi-color-apply-text-property-face) + (ansi-filt (lambda (str) (ansi-color-filter-apply + (copy-sequence str)))) + (ansi-app (lambda (str) (ansi-color-apply + (copy-sequence str))))) + + (with-temp-buffer + (setq filtered-str + (replace-regexp-in-string "\e\\[.*?m" "" complete-str)) + (setq propertized-str (funcall ansi-app complete-str)) + + (should-not (ansi-color-tests-equal-props + filtered-str propertized-str)) + (should (equal filtered-str propertized-str))) + + ;; Tests for `ansi-color-filter-apply' + (with-temp-buffer + (should (equal-including-properties + filtered-str + (funcall ansi-filt complete-str)))) + + (with-temp-buffer + (should (equal-including-properties + filtered-str + (mapconcat ansi-filt strs "")))) + + ;; Tests for `ansi-color-filter-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-filter-region (point-min) (point-max)) + (should (equal-including-properties + filtered-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-filter-region opoint (point)))) + (should (equal-including-properties + filtered-str (buffer-string)))) + + ;; Test for `ansi-color-apply' + (with-temp-buffer + (should (ansi-color-tests-equal-props + propertized-str + (mapconcat ansi-app strs "")))) + + ;; Tests for `ansi-color-apply-on-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-apply-on-region opoint (point)))) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))))) (provide 'ansi-color-tests) diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index 5c6af9b45cf..b05a9629c16 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -48,4 +48,4 @@ (provide 'arc-mode-tests) -;; arc-mode-tests.el ends here +;;; arc-mode-tests.el ends here diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index d050ac5b695..3da6f3e9b7b 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -56,10 +56,10 @@ ("key2" . "please: keep my space after colon")))))) (defvar auth-source-pass--debug-log nil - "Contains a list of all messages passed to `auth-source-do-debug`.") + "Contains a list of all messages passed to `auth-source-do-debug'.") (defun auth-source-pass--have-message-matching (regexp) - "Return non-nil iff at least one `auth-source-do-debug` match REGEXP." + "Return non-nil iff at least one `auth-source-do-debug' match REGEXP." (seq-find (lambda (message) (string-match regexp message)) auth-source-pass--debug-log)) @@ -75,8 +75,8 @@ REGEXP is the same as in `auth-source-pass--have-message-matching'." (put #'auth-source-pass--have-message-matching 'ert-explainer #'auth-source-pass--explain--have-message-matching) (defun auth-source-pass--debug (&rest msg) - "Format MSG and add that to `auth-source-pass--debug-log`. -This function is intended to be set to `auth-source-debug`." + "Format MSG and add that to `auth-source-pass--debug-log'. +This function is intended to be set to `auth-source-debug'." (add-to-list 'auth-source-pass--debug-log (apply #'format msg) t)) (defvar auth-source-pass--parse-log nil) @@ -97,7 +97,8 @@ This function is intended to be set to `auth-source-debug`." (defun auth-source-pass--explain-match-entry-p (entry hostname &optional user port) "Explainer function for `auth-source-pass-match-entry-p'. -ENTRY, HOSTNAME, USER and PORT are the same as in `auth-source-pass-match-entry-p'." +ENTRY, HOSTNAME, USER and PORT are the same as in +`auth-source-pass-match-entry-p'." `(entry ,entry store @@ -122,7 +123,8 @@ HOSTNAME, USER and PORT are passed unchanged to (defun auth-source-pass--explain-includes-sorted-entries (entries hostname &optional user port) "Explainer function for `auth-source-pass--includes-sorted-entries'. -ENTRIES, HOSTNAME, USER and PORT are the same as in `auth-source-pass--includes-sorted-entries'." +ENTRIES, HOSTNAME, USER and PORT are the same as in +`auth-source-pass--includes-sorted-entries'." `(store ,(auth-source-pass-entries) matching-entries diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 1c4bd8d36d4..34c68b421c9 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'cl-lib) (require 'auth-source) (require 'secrets) @@ -247,7 +248,7 @@ (should-not (auth-source-remembered-p '(:host t))))) (ert-deftest auth-source-test-searches () - "Test auth-source searches with various parameters" + "Test auth-source searches with various parameters." :tags '(auth-source auth-source/netrc) (let* ((entries '("machine a1 port a2 user a3 password a4" "machine b1 port b2 user b3 password b4" @@ -277,34 +278,33 @@ "((:host \"a1\" :port \"a2\" :user \"a3\" :secret \"a4\") (:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\") (:host \"c1\" :port \"c2\" :user \"c3\" :secret \"c4\"))" :host t :max 4) ("host b1, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1") ("host b1, port b2, user b3, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1" :port "b2" :user "b3") - )) - - (netrc-file (make-temp-file "auth-source-test" nil nil - (mapconcat 'identity entries "\n"))) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - found found-as-string) - - (dolist (test tests) - (cl-destructuring-bind (testname needed &rest parameters) test - (setq found (apply #'auth-source-search parameters)) - (when (listp found) - (dolist (f found) - (setf f (plist-put f :secret - (let ((secret (plist-get f :secret))) - (if (functionp secret) - (funcall secret) - secret)))))) - - (setq found-as-string (format "%s: %S" testname found)) - ;; (message "With parameters %S found: [%s] needed: [%s]" parameters found-as-string needed) - (should (equal found-as-string (concat testname ": " needed))))) - (delete-file netrc-file))) + ))) + (ert-with-temp-file netrc-file + :text (mapconcat 'identity entries "\n") + (let ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + found found-as-string) + + (dolist (test tests) + (cl-destructuring-bind (testname needed &rest parameters) test + (setq found (apply #'auth-source-search parameters)) + (when (listp found) + (dolist (f found) + (setf f (plist-put f :secret + (let ((secret (plist-get f :secret))) + (if (functionp secret) + (funcall secret) + secret)))))) + + (setq found-as-string (format "%s: %S" testname found)) + ;; (message "With parameters %S found: [%s] needed: [%s]" + ;; parameters found-as-string needed) + (should (equal found-as-string (concat testname ": " needed))))))))) (ert-deftest auth-source-test-secrets-create-secret () (skip-unless secrets-enabled) @@ -312,59 +312,121 @@ ;; Emacs process. Therefore, we don't care to delete it. (let ((auth-sources '((:source (:secrets "session")))) (auth-source-save-behavior t) - (host (md5 (concat (prin1-to-string process-environment) - (current-time-string)))) - (passwd (md5 (concat (prin1-to-string process-environment) - (current-time-string) (current-time-string)))) - auth-info auth-passwd) - ;; Redefine `read-*' in order to avoid interactive input. - (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) - ((symbol-function 'read-string) - (lambda (_prompt &optional _initial _history default - _inherit-input-method) - default))) - (setq auth-info - (car (auth-source-search - :max 1 :host host :require '(:user :secret) :create t)))) - (should (functionp (plist-get auth-info :save-function))) - (funcall (plist-get auth-info :save-function)) - - ;; Check, that the item has been created indeed. - (auth-source-forget+ :host t) - (setq auth-info (car (auth-source-search :host host)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (should (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (string-equal auth-passwd passwd)) - - ;; Cleanup. - ;; Should use `auth-source-delete' when implemented for :secrets backend. - (secrets-delete-item - "session" - (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + (unwind-protect + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd)) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd))))) + + ;; Cleanup. + ;; Should use `auth-source-delete' when implemented for :secrets backend. + (secrets-delete-item + "session" + (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))) + +(ert-deftest auth-source-test-netrc-create-secret () + (ert-with-temp-file netrc-file + :suffix "auth-source-test" + (let* ((auth-sources (list netrc-file)) + (auth-source-save-behavior t) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-source-netrc-cache nil) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (with-temp-buffer + (insert-file-contents netrc-file) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd) + (should-not (search-forward host nil 'noerror))) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd)) + (should (search-forward host nil 'noerror))))))))) (ert-deftest auth-source-delete () - (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ + (ert-with-temp-file netrc-file + :suffix "auth-source-test" :text "\ machine a1 port a2 user a3 password a4 machine b1 port b2 user b3 password b4 -machine c1 port c2 user c3 password c4\n")) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) - (parameters '(:max 1 :host t))) - (unwind-protect - (let ((found (apply #'auth-source-delete parameters))) - (dolist (f found) - (let ((s (plist-get f :secret))) - (setf f (plist-put f :secret - (if (functionp s) (funcall s) s))))) - ;; Note: The netrc backend doesn't delete anything, so - ;; this is actually the same as `auth-source-search'. - (should (equal found expected))) - (delete-file netrc-file)))) +machine c1 port c2 user c3 password c4\n" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) + (parameters '(:max 1 :host t)) + (found (apply #'auth-source-delete parameters))) + (dolist (f found) + (let ((s (plist-get f :secret))) + (setf f (plist-put f :secret + (if (functionp s) (funcall s) s))))) + ;; Note: The netrc backend doesn't delete anything, so + ;; this is actually the same as `auth-source-search'. + (should (equal found expected))))) (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 7ec4bf63791..b264323ca15 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -28,6 +28,7 @@ (require 'autoinsert) (require 'ert) +(require 'ert-x) (ert-deftest autoinsert-tests-auto-insert-skeleton () (let ((auto-insert-alist '((text-mode nil "f" _ "oo"))) @@ -39,16 +40,14 @@ (should (equal (point) (+ (point-min) 1)))))) (ert-deftest autoinsert-tests-auto-insert-file () - (let ((temp-file (make-temp-file "autoinsert-tests" nil nil "foo"))) - (unwind-protect - (let ((auto-insert-alist `((text-mode . ,temp-file))) - (auto-insert-query nil)) - (with-temp-buffer - (text-mode) - (auto-insert) - (should (equal (buffer-string) "foo")))) - (when (file-exists-p temp-file) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + :text "foo" + (let ((auto-insert-alist `((text-mode . ,temp-file))) + (auto-insert-query nil)) + (with-temp-buffer + (text-mode) + (auto-insert) + (should (equal (buffer-string) "foo")))))) (ert-deftest autoinsert-tests-auto-insert-function () (let ((auto-insert-alist '((text-mode . (lambda () (insert "foo"))))) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 3e97e9cfa5b..b9d45324cb7 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -174,42 +174,41 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(60 30 15)) - buf) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (ert-with-message-capture auto-revert--messages - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf)) - (should (string-match "another text" (buffer-string))) - - ;; When the buffer is modified, it shall not be reverted. - (ert-with-message-capture auto-revert--messages - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - ;; Check, that the buffer hasn't been reverted. - (auto-revert--wait-for-revert buf)) - (should-not (string-match "any text" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let ((times '(60 30 15)) + buf) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (ert-with-message-capture auto-revert--messages + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf)) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (ert-with-message-capture auto-revert--messages + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf)) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test00-auto-revert-mode "Check autorevert for a remote file.") @@ -219,63 +218,61 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for several files at once." (skip-unless (executable-find "cp" (file-remote-p temporary-file-directory))) - (with-auto-revert-test - (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) - (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) - (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) - (tmpfile1 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (tmpfile2 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (times '(120 60 30 15)) - buf1 buf2) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) - (setq buf1 (find-file-noselect tmpfile1)) - (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) - (setq buf2 (find-file-noselect tmpfile2)) - - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode))) - - ;; Modify files. We wait for a second, in order to have - ;; another timestamp. - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) - (pop times)) - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) - (pop times)) - ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) - ;; Strange, that `copy-directory' does not work as expected. - ;; The following shell command is not portable on all - ;; platforms, unfortunately. - (shell-command - (format "%s -f %s/* %s" - cp (file-local-name tmpdir2) (file-local-name tmpdir1))) - - ;; Check, that the buffers have been reverted. - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (auto-revert--wait-for-revert buf) - (should (string-match "another text" (buffer-string)))))) - - ;; Exit. - (ignore-errors - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-directory tmpdir1 'recursive)) - (ignore-errors (delete-directory tmpdir2 'recursive)))))) + (ert-with-temp-directory tmpdir1 + (ert-with-temp-directory tmpdir2 + (ert-with-temp-file tmpfile1 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (ert-with-temp-file tmpfile2 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (with-auto-revert-test + (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) + (times '(120 60 30 15)) + buf1 buf2) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) + (setq buf1 (find-file-noselect tmpfile1)) + (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + (pop times)) + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + (pop times)) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command + (format "%s -f %s/* %s" + cp (file-local-name tmpdir2) (file-local-name tmpdir1))) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))))))) (auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files "Check autorevert for several remote files at once.") @@ -285,79 +282,78 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for a deleted file." ;; Repeated unpredictable failures, bug#32645. ;; Unlikely to be hydra-specific? -; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - + ; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + :tags '(:unstable) (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - ;; Try to catch bug#32645. - (auto-revert-debug (getenv "EMACS_HYDRA_CI")) - (file-notify-debug (getenv "EMACS_HYDRA_CI")) - (times '(120 60 30 15)) - buf desc) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor)) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (setq desc auto-revert-notify-watch-descriptor) - - ;; Remove file while reverting. We simulate this by - ;; modifying `before-revert-hook'. - (add-hook - 'before-revert-hook - (lambda () - (when auto-revert-debug - (message "%s deleted" buffer-file-name)) - (delete-file buffer-file-name)) - nil t) - - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer hasn't been reverted. File - ;; notification should be disabled, falling back to - ;; polling. - (should (string-match "any text" (buffer-string))) - ;; With w32notify, and on emba, the `stopped' events are not sent. - (or (eq file-notify--library 'w32notify) - (getenv "EMACS_EMBA_CI") - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor))) - - ;; Once the file has been recreated, the buffer shall be - ;; reverted. - (kill-local-variable 'before-revert-hook) - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-match "another text" (buffer-string))) - ;; When file notification is used, it must be reenabled - ;; after recreation of the file. We cannot expect that - ;; the descriptor is the same, so we just check the - ;; existence. - (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) - - ;; An empty file shall still be reverted. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-equal "" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let (;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) + (times '(120 60 30 15)) + buf desc) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () + (when auto-revert-debug + (message "%s deleted" buffer-file-name)) + (delete-file buffer-file-name)) + nil t) + + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (should (string-match "any text" (buffer-string))) + ;; With w32notify, and on emba, the `stopped' events are not sent. + (or (eq file-notify--library 'w32notify) + (getenv "EMACS_EMBA_CI") + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) + + ;; An empty file shall still be reverted. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file "Check autorevert for a deleted remote file.") @@ -366,34 +362,33 @@ This expects `auto-revert--messages' to be bound by "Check autorevert tail mode." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(30 15)) - buf) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-tail-mode 1) - (should auto-revert-tail-mode) - (erase-buffer) - (insert "modified text\n") - (set-buffer-modified-p nil) - - ;; Modify file. - (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf) - (should - (string-match "modified text\nanother text" (buffer-string))))) - - ;; Exit. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (let ((times '(30 15)) + buf) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. + (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (ignore-errors (kill-buffer buf)))))) (auto-revert--deftest-remote auto-revert-test03-auto-revert-tail-mode "Check remote autorevert tail mode.") @@ -403,46 +398,45 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let* ((tmpfile (make-temp-file "auto-revert-test")) - (name (file-name-nondirectory tmpfile)) - (times '(30)) - buf) - (unwind-protect - (progn - (setq buf (dired-noselect temporary-file-directory)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (should - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Delete file. - (delete-file tmpfile) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should-not - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Make dired buffer modified. Check, that the buffer has - ;; been still reverted. - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should - (string-match name (substring-no-properties (buffer-string)))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let* ((name (file-name-nondirectory tmpfile)) + (times '(30)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Delete file. + (delete-file tmpfile) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired "Check remote autorevert for dired.") @@ -469,86 +463,114 @@ This expects `auto-revert--messages' to be bound by (lambda () (string-equal (auto-revert-test--buffer-string buffer) string)) max-wait)) +(defun auto-revert-test--instrument-kill-buffer-hook (buffer) + "Instrument local `kill-buffer-hook' with messages." + (when auto-revert-debug + (with-current-buffer buffer + (add-hook + 'kill-buffer-hook + (lambda () + (message + "%s killed\n%s" (current-buffer) (with-output-to-string (backtrace)))) + nil 'local)))) + (ert-deftest auto-revert-test05-global-notify () "Test `global-auto-revert-mode' without polling." (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (auto-revert-avoid-polling t) - (was-in-global-auto-revert-mode global-auto-revert-mode) - (file-1 (make-temp-file "global-auto-revert-test-1")) - (file-2 (make-temp-file "global-auto-revert-test-2")) - (file-3 (make-temp-file "global-auto-revert-test-3")) - (file-2b (concat file-2 "-b")) - require-final-newline buf-1 buf-2 buf-3) - (unwind-protect - (progn - (setq buf-1 (find-file-noselect file-1)) - (setq buf-2 (find-file-noselect file-2)) - (auto-revert-test--write-file "1-a" file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "")) - - (global-auto-revert-mode 1) ; Turn it on. - - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2)) - - ;; buf-1 should have been reverted immediately when the mode - ;; was enabled. - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - - ;; Alter a file. - (auto-revert-test--write-file "2-a" file-2) - ;; Allow for some time to handle notification events. - (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - - ;; Visit a file, and modify it on disk. - (setq buf-3 (find-file-noselect file-3)) - ;; Newly opened buffers won't be use notification until the - ;; first poll cycle; wait for it. - (auto-revert-test--wait-for - (lambda () (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert-test--write-file "3-a" file-3) - (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) - (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) - - ;; Delete a visited file, and re-create it with new contents. - (delete-file file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - (auto-revert-test--write-file "1-b" file-1) - (auto-revert-test--wait-for-buffer-text - buf-1 "1-b" (auto-revert--timeout)) - ;; On emba, `buf-1' is a killed buffer. - (when (buffer-live-p buf-1) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1))) - - ;; Write a buffer to a new file, then modify the new file on disk. - (with-current-buffer buf-2 - (write-file file-2b)) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - (auto-revert-test--write-file "2-b" file-2b) - (auto-revert-test--wait-for-buffer-text - buf-2 "2-b" (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2))) - - ;; Clean up. - (unless was-in-global-auto-revert-mode - (global-auto-revert-mode 0)) ; Turn it off. - (dolist (buf (list buf-1 buf-2 buf-3)) - (ignore-errors (kill-buffer buf))) - (dolist (file (list file-1 file-2 file-2b file-3)) - (ignore-errors (delete-file file))) - )))) + (ert-with-temp-file file-1 + (ert-with-temp-file file-2 + (ert-with-temp-file file-3 + (let* ((auto-revert-use-notify t) + (auto-revert-avoid-polling t) + (auto-revert-debug (getenv "EMACS_EMBA_CI")) + (file-notify-debug (getenv "EMACS_EMBA_CI")) + (was-in-global-auto-revert-mode global-auto-revert-mode) + (file-2b (concat file-2 "-b")) + require-final-newline buf-1 buf-2 buf-3) + (unwind-protect + (progn + (setq buf-1 (find-file-noselect file-1)) + (auto-revert-test--instrument-kill-buffer-hook buf-1) + (setq buf-2 (find-file-noselect file-2)) + (auto-revert-test--instrument-kill-buffer-hook buf-2) + (auto-revert-test--write-file "1-a" file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "")) + + (global-auto-revert-mode 1) ; Turn it on. + + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2)) + + ;; buf-1 should have been reverted immediately when the mode + ;; was enabled. + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + + ;; Alter a file. + (auto-revert-test--write-file "2-a" file-2) + ;; Allow for some time to handle notification events. + (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + + ;; Visit a file, and modify it on disk. + (setq buf-3 (find-file-noselect file-3)) + (auto-revert-test--instrument-kill-buffer-hook buf-3) + ;; Newly opened buffers won't be use notification until the + ;; first poll cycle; wait for it. + (auto-revert-test--wait-for + (lambda () (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert-test--write-file "3-a" file-3) + (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) + (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) + + ;; Delete a visited file, and re-create it with new contents. + (when auto-revert-debug (message "Hallo0")) + (delete-file file-1) + (when auto-revert-debug (message "Hallo1")) + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + (when auto-revert-debug (message "Hallo2")) + (auto-revert-test--write-file "1-b" file-1) + (when auto-revert-debug (message "Hallo3")) + (auto-revert-test--wait-for-buffer-text + buf-1 "1-b" (auto-revert--timeout)) + ;; On emba, `buf-1' is a killed buffer. + (when auto-revert-debug + (message + "Hallo4 %s %s %s %s %s %s %s" + buf-1 (buffer-name buf-1) (buffer-live-p buf-1) + file-1 (get-file-buffer file-1) + (buffer-name (get-file-buffer file-1)) + (buffer-live-p (get-file-buffer file-1))) + (with-current-buffer buf-1 + (message "Hallo5\n%s" (buffer-local-variables)))) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (when auto-revert-debug (message "Hallo6")) + + ;; Write a buffer to a new file, then modify the new file on disk. + (with-current-buffer buf-2 + (write-file file-2b)) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + (auto-revert-test--write-file "2-b" file-2b) + (auto-revert-test--wait-for-buffer-text + buf-2 "2-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2))) + + ;; Clean up. + (unless was-in-global-auto-revert-mode + (global-auto-revert-mode 0)) ; Turn it off. + (dolist (buf (list buf-1 buf-2 buf-3)) + (with-current-buffer buf (setq-local kill-buffer-hook nil)) + (ignore-errors (kill-buffer buf))) + (ignore-errors (delete-file file-2b))))))))) (auto-revert--deftest-remote auto-revert-test05-global-notify "Test `global-auto-revert-mode' without polling for remote buffers.") @@ -558,31 +580,30 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (file-1 (make-temp-file "auto-revert-test")) - (file-2 (concat file-1 "-2")) - require-final-newline buf) - (unwind-protect - (progn - (setq buf (find-file-noselect file-1)) - (with-current-buffer buf - (insert "A") - (save-buffer) + (ert-with-temp-file file-1 + (let* ((auto-revert-use-notify t) + (file-2 (concat file-1 "-2")) + require-final-newline buf) + (unwind-protect + (progn + (setq buf (find-file-noselect file-1)) + (with-current-buffer buf + (insert "A") + (save-buffer) - (auto-revert-mode 1) + (auto-revert-mode 1) - (insert "B") - (write-file file-2) + (insert "B") + (write-file file-2) - (auto-revert-test--write-file "C" file-2) - (auto-revert-test--wait-for-buffer-text - buf "C" (auto-revert--timeout)) - (should (equal (buffer-string) "C")))) + (auto-revert-test--write-file "C" file-2) + (auto-revert-test--wait-for-buffer-text + buf "C" (auto-revert--timeout)) + (should (equal (buffer-string) "C")))) - ;; Clean up. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file file-1)) - (ignore-errors (delete-file file-2)))))) + ;; Clean up. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-2))))))) (auto-revert--deftest-remote auto-revert-test06-write-file "Test `write-file' in `auto-revert-mode' for remote buffers.") @@ -591,86 +612,91 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test07-auto-revert-several-buffers () "Check autorevert for several buffers visiting the same file." ;; (with-auto-revert-test - (let ((auto-revert-use-notify t) - (tmpfile (make-temp-file "auto-revert-test")) - (times '(120 60 30 15)) - (num-buffers 10) - require-final-newline buffers) - - (unwind-protect - ;; Check indirect buffers. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (push (find-file-noselect tmpfile) buffers) - (with-current-buffer (car buffers) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode)) - - (dotimes (i num-buffers) - (push (make-indirect-buffer - (car buffers) - (format "%s-%d" (buffer-file-name (car buffers)) i) - 'clone) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert (car buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (setq buffers nil) - (ignore-errors (delete-file tmpfile))) - - ;; Check direct buffers. - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (dotimes (i num-buffers) - (push (generate-new-buffer - (format "%s-%d" (file-name-nondirectory tmpfile) i)) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (insert-file-contents tmpfile 'visit) - (should (string-equal (buffer-string) "any text")) - (auto-revert-mode 1) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffers have been reverted. - (dolist (buf buffers) - (auto-revert--wait-for-revert buf) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-file tmpfile)))));) + (ert-with-temp-file tmpfile + (let ((auto-revert-use-notify t) + (times '(120 60 30 15)) + (num-buffers 10) + require-final-newline buffers) + + (unwind-protect + ;; Check indirect buffers. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (push (find-file-noselect tmpfile) buffers) + (with-current-buffer (car buffers) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode)) + + (dotimes (i num-buffers) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert (car buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (setq buffers nil) + (ignore-errors (delete-file tmpfile))) + + ;; Check direct buffers. + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (dotimes (i num-buffers) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (insert-file-contents tmpfile 'visit) + (should (string-equal (buffer-string) "any text")) + (auto-revert-mode 1) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffers have been reverted. + (dolist (buf buffers) + (auto-revert--wait-for-revert buf) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)))))));) (auto-revert--deftest-remote auto-revert-test07-auto-revert-several-buffers "Check autorevert for several buffers visiting the same remote file.") +;; Mark all tests as unstable on Cygwin (bug#49665). +(when (eq system-type 'cygwin) + (dolist (test (apropos-internal "^auto-revert" #'ert-test-boundp)) + (setf (ert-test-tags (ert-get-test test)) + (cons :unstable (ert-test-tags (ert-get-test test)))))) + (defun auto-revert-test-all (&optional interactive) "Run all tests for \\[auto-revert]." (interactive "p") @@ -679,4 +705,4 @@ This expects `auto-revert--messages' to be bound by (ert-run-tests-batch "^auto-revert-"))) (provide 'auto-revert-tests) -;;; auto-revert-tests.el ends here +;;; autorevert-tests.el ends here diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 9c33a27288a..dc2dec68ee3 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -371,16 +371,14 @@ Same as `with-bookmark-test' but also sets a temporary `bookmark-default-file', evaluates BODY, and then runs the test that saves and then loads the bookmark file." `(with-bookmark-test - (let ((file (make-temp-file "bookmark-tests-"))) - (unwind-protect - (let ((bookmark-default-file file) - (old-alist bookmark-alist)) - ,@body - (bookmark-save nil file t) - (setq bookmark-alist nil) - (bookmark-load file nil t) - (should (equal bookmark-alist old-alist))) - (delete-file file))))) + (ert-with-temp-file file + (let ((bookmark-default-file file) + (old-alist bookmark-alist)) + ,@body + (bookmark-save nil file t) + (setq bookmark-alist nil) + (bookmark-load file nil t) + (should (equal bookmark-alist old-alist)))))) (defvar bookmark-tests-non-ascii-data (concat "Здра́вствуйте!" "中文,普通话,汉语" "åäöøñ" diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el index 18c988656d3..b223a643083 100644 --- a/test/lisp/buff-menu-tests.el +++ b/test/lisp/buff-menu-tests.el @@ -24,19 +24,20 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (ert-deftest buff-menu-24962 () "Test for https://debbugs.gnu.org/24962 ." - (let* ((file (make-temp-file "foo")) - (buf (find-file file))) - (unwind-protect - (progn - (rename-buffer " foo") - (list-buffers) - (with-current-buffer "*Buffer List*" - (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) - (and (buffer-live-p buf) (kill-buffer buf)) - (and (file-exists-p file) (delete-file file))))) + (ert-with-temp-file file + :suffix "foo" + (let ((buf (find-file file))) + (unwind-protect + (progn + (rename-buffer " foo") + (list-buffers) + (with-current-buffer "*Buffer List*" + (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) + (and (buffer-live-p buf) (kill-buffer buf)))))) (provide 'buff-menu-tests) diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el index e0944afa344..2f5ad795df2 100644 --- a/test/lisp/button-tests.el +++ b/test/lisp/button-tests.el @@ -59,6 +59,7 @@ "Test `button--help-echo' with forms." (with-temp-buffer ;; Test text property buttons with dynamic scoping. + (setq lexical-binding nil) (let* ((help (make-symbol "help")) (form `(funcall (let ((,help "lexical form")) (lambda () ,help)))) diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 13dd228d3b3..3eb6b34c132 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -53,7 +53,7 @@ A and B should be calc expressions." (defun calc-tests-simple (fun string &rest args) "Push STRING on the calc stack, then call FUN and return the new top. -The result is a calc (i.e., lisp) expression, not its string representation. +The result is a calc (i.e., Lisp) expression, not its string representation. Also pop the entire stack afterwards. An existing calc stack is reused, otherwise a new one is created." (calc-eval string 'push) @@ -448,7 +448,7 @@ An existing calc stack is reused, otherwise a new one is created." ;; Generalisation for any n, integral k≥0: use falling product (/ (apply '* (number-sequence n (- n (1- k)) -1)) (calc-tests--fac k))) - (t (error "case not covered")))) + (t (error "Case not covered")))) (defun calc-tests--calc-to-number (x) "Convert a Calc object to a Lisp number." @@ -810,6 +810,12 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1)))) (should (equal (calcFunc-test7 3) (* 3 2)))) +(ert-deftest calc-nth-root () + ;; bug#51209 + (let* ((calc-display-working-message nil) + (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6))))) + (should (< (abs (- x (sqrt 2.0))) 1.0e-10)))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calculator-tests.el b/test/lisp/calculator-tests.el index 9551b1a4c61..f24ca97310c 100644 --- a/test/lisp/calculator-tests.el +++ b/test/lisp/calculator-tests.el @@ -48,4 +48,4 @@ (should (equal (calculator-string-to-number str) expected))))))) (provide 'calculator-tests) -;; calculator-tests.el ends here +;;; calculator-tests.el ends here diff --git a/test/lisp/calendar/cal-french-tests.el b/test/lisp/calendar/cal-french-tests.el index ab62c1e6fc1..1de5dea0882 100644 --- a/test/lisp/calendar/cal-french-tests.el +++ b/test/lisp/calendar/cal-french-tests.el @@ -111,3 +111,4 @@ (should (equal (calendar-french-date-string (list m d y)) str)))) (provide 'cal-french-tests) +;;; cal-french-tests.el ends here diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 6973f7e5c95..9e8a8e7b479 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -698,17 +698,18 @@ and ISO style input data must use english month names." "Actually perform export test. Argument INPUT input diary string. Argument EXPECTED-OUTPUT expected iCalendar result string." - (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (ert-with-temp-file temp-file + :suffix "icalendar-tests-ics" (unwind-protect - (progn - (with-temp-buffer - (insert input) - (icalendar-export-region (point-min) (point-max) temp-file)) - (save-excursion - (find-file temp-file) - (goto-char (point-min)) - (cond (expected-output - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 BEGIN:VEVENT @@ -717,23 +718,22 @@ UID:emacs[0-9]+ END:VEVENT END:VCALENDAR \\s-*$" - nil t)) - (should (string-match - (concat "^\\s-*" - (regexp-quote (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - "\\s-*$") - expected-output))) - (t - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 END:VCALENDAR \\s-*$" - nil t)))))) + nil t)))))) ;; cleanup!! - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-export-ordinary-no-time () "Perform export test." @@ -1031,7 +1031,8 @@ During import test the timezone is set to Central European Time." (defun icalendar-tests--do-test-import (expected-output) "Actually perform import test. Argument EXPECTED-OUTPUT file containing expected diary string." - (let ((temp-file (make-temp-file "icalendar-test-diary"))) + (ert-with-temp-file temp-file + :suffix "icalendar-test-diary" ;; Test the Catch-the-mysterious-coding-header logic below. ;; Ruby-mode adds an after-save-hook which inserts the header! ;; (save-excursion @@ -1061,8 +1062,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." (let ((result (buffer-substring-no-properties (point-min) (point-max)))) (should (string= expected-output result))) - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-import-non-recurring () "Perform standard import tests." @@ -1240,35 +1240,33 @@ Argument INPUT icalendar event string." (defun icalendar-tests--do-test-cycle () "Actually perform import/export cycle test." - (let ((temp-diary (make-temp-file "icalendar-test-diary")) - (temp-ics (make-temp-file "icalendar-test-ics")) - (org-input (buffer-substring-no-properties (point-min) (point-max)))) - - (unwind-protect - (progn - ;; step 1: import - (icalendar-import-buffer temp-diary t t) - - ;; step 2: export what was just imported - (save-excursion - (find-file temp-diary) - (icalendar-export-region (point-min) (point-max) temp-ics)) - - ;; compare the output of step 2 with the input of step 1 - (save-excursion - (find-file temp-ics) - (goto-char (point-min)) - ;;(when (re-search-forward "\nUID:.*\n" nil t) - ;;(replace-match "\n")) - (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= org-input cycled))))) - ;; clean up - (kill-buffer (find-buffer-visiting temp-diary)) - (with-current-buffer (find-buffer-visiting temp-ics) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (delete-file temp-diary) - (delete-file temp-ics)))) + (ert-with-temp-file temp-diary + (ert-with-temp-file temp-ics + (let ((org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)))))))) (ert-deftest icalendar-cycle () "Perform cycling tests. @@ -1442,6 +1440,13 @@ RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 SUMMARY:ff birthday (%d years old)") + (icalendar-tests--test-export + nil + nil + "%%(diary-offset '(diary-float t 3 4) 1) asdf" + nil) + + ;; FIXME! ;; export 2004-10-28 monthly, weekly entries @@ -1629,7 +1634,7 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (format-time-string "%FT%T%z" (encode-time time) 0))) (defun icalendar-tests--decode-isodatetime (_ical-string) - "Test icalendar--decode-isodatetime." + "Test `icalendar--decode-isodatetime'." (should (equal (icalendar-test--format "20040917T050910-0200") "2004-09-17T03:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910") diff --git a/test/lisp/calendar/solar-tests.el b/test/lisp/calendar/solar-tests.el index 337deb8ce9a..921be1d2d48 100644 --- a/test/lisp/calendar/solar-tests.el +++ b/test/lisp/calendar/solar-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'solar) @@ -42,3 +44,5 @@ (should (< (abs (- sunset 17.72)) epsilon))))) (provide 'solar-tests) + +;;; solar-tests.el ends here diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 6fa2b9d7c35..79978a2041f 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -35,27 +35,26 @@ "Todo Archive mode test file.") (defmacro with-todo-test (&rest body) - "Set up an isolated todo-mode test environment." + "Set up an isolated `todo-mode' test environment." (declare (debug (body))) - `(let* ((todo-test-home (make-temp-file "todo-test-home-" t)) - ;; Since we change HOME, clear this to avoid a conflict - ;; e.g. if Emacs runs within the user's home directory. - (abbreviated-home-dir nil) - (process-environment (cons (format "HOME=%s" todo-test-home) - process-environment)) - (todo-directory (ert-resource-directory)) - (todo-default-todo-file (todo-short-file-name - (car (funcall todo-files-function))))) - (unwind-protect - (progn ,@body) - ;; Restore pre-test-run state of test files. - (dolist (f (directory-files todo-directory)) - (let ((buf (get-file-buffer f))) - (when buf - (with-current-buffer buf - (restore-buffer-modified-p nil) - (kill-buffer))))) - (delete-directory todo-test-home t)))) + `(ert-with-temp-directory todo-test-home + (let* (;; Since we change HOME, clear this to avoid a conflict + ;; e.g. if Emacs runs within the user's home directory. + (abbreviated-home-dir nil) + (process-environment (cons (format "HOME=%s" todo-test-home) + process-environment)) + (todo-directory (ert-resource-directory)) + (todo-default-todo-file (todo-short-file-name + (car (funcall todo-files-function))))) + (unwind-protect + (progn ,@body) + ;; Restore pre-test-run state of test files. + (dolist (f (directory-files todo-directory)) + (let ((buf (get-file-buffer f))) + (when buf + (with-current-buffer buf + (restore-buffer-modified-p nil) + (kill-buffer))))))))) (defun todo-test--show (num &optional archive) "Display category NUM of test todo file. @@ -567,7 +566,7 @@ The remaining arguments (except _ARG, which is ignored) specify item insertion parameters. This provides a noninteractive API for todo-insert-item for use in automatic testing." (cl-letf (((symbol-function 'read-from-minibuffer) - (lambda (_prompt) item)) + (lambda (_prompt &rest _) item)) ((symbol-function 'read-number) ; For todo-set-item-priority (lambda (_prompt &optional _default) (or priority 1)))) (todo-insert-item--basic nil diary-type date-type time where))) diff --git a/test/lisp/cedet/semantic-utest-c.el b/test/lisp/cedet/semantic-utest-c.el index d08c79cad3e..c5eb5b0ec06 100644 --- a/test/lisp/cedet/semantic-utest-c.el +++ b/test/lisp/cedet/semantic-utest-c.el @@ -60,7 +60,7 @@ (semantic-fetch-tags)))) (when (or (not tags-expected) (not tags-actual)) (message "Tried to find test files in: %s" semantic-utest-c-test-directory) - (error "Failed: Discovered no tags in test files or test file not found.")) + (error "Failed: Discovered no tags in test files or test file not found")) ;; Now that we have the tags, compare them for SPP accuracy. (dolist (tag tags-actual) diff --git a/test/lisp/cedet/semantic-utest-ia.el b/test/lisp/cedet/semantic-utest-ia.el index 122c431d472..6ea4ca1a16a 100644 --- a/test/lisp/cedet/semantic-utest-ia.el +++ b/test/lisp/cedet/semantic-utest-ia.el @@ -489,4 +489,4 @@ tag that contains point, and return that." (provide 'semantic-ia-utest) -;;; semantic-ia-utest.el ends here +;;; semantic-utest-ia.el ends here diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index 172ab62f895..3e4cfb0f0cb 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -29,6 +29,8 @@ (require 'cedet) (require 'semantic) +;;; Code: + (defvar cedet-utest-directory (let* ((C (file-name-directory (locate-library "cedet"))) (D (expand-file-name "../../test/manual/cedet/" C))) @@ -103,7 +105,7 @@ int calc_sv(int); (defvar semantic-utest-C-filename-h (concat (file-name-sans-extension semantic-utest-C-filename) ".h") - "Header file filename for C") + "Header file filename for C.") (defvar semantic-utest-C-name-contents @@ -424,8 +426,7 @@ class aClass { nil (overlay 135 262 "phptest.php")) ) - "Expected results from the PHP Unit test" - ) + "Expected results from the PHP Unit test.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index 93677d6c871..d049f95b4cd 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -124,6 +124,11 @@ gcc version 2.95.2 19991024 (release)" "Test the output parser against the machine currently running Emacs." (skip-unless (executable-find "gcc")) (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v")))) - (semantic-gcc-test-output-parser))) + ;; Some macOS machines run llvm when you type gcc. (!) + ;; We can't even check if it's a symlink; it's a binary placed in + ;; "/usr/bin/gcc". So check the output and just skip this test if + ;; it says "Apple LLVM". + (unless (string-match "Apple LLVM" (car semantic-gcc-test-strings)) + (semantic-gcc-test-output-parser)))) ;;; gcc-tests.el ends here diff --git a/test/lisp/cedet/semantic/fw-tests.el b/test/lisp/cedet/semantic/fw-tests.el index 7b1cd21bd1b..6a5f3c85fc6 100644 --- a/test/lisp/cedet/semantic/fw-tests.el +++ b/test/lisp/cedet/semantic/fw-tests.el @@ -42,4 +42,4 @@ ;; retrieve cached data (should (equal (semantic-get-cache-data 'moose) data))))) -;;; gw-tests.el ends here +;;; fw-tests.el ends here diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 8a9a41f452f..0bd5c1e9d15 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -1,4 +1,4 @@ -;;; comint-tests.el -*- lexical-binding:t -*- +;;; comint-tests.el --- Tests for comint.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. @@ -43,6 +43,11 @@ "PIN for user:" ; Bug#35523 "Password (again):" "Enter password:" + "(user@host) Password: " ; openssh-8.6p1 + "Current password:" ; "passwd" (to change password) in Debian. + "Enter encryption key: " ; ccrypt + "Enter decryption key: " ; ccrypt + "Enter encryption key: (repeat) " ; ccrypt "Enter Auth Password:" ; OpenVPN (Bug#35724) "Verify password: " ; zip -e zipfile.zip ... (Bug#47209) "Mot de Passe :" ; localized (Bug#29729) @@ -94,4 +99,4 @@ password flow if it returns a nil value." ;; no-byte-compile: t ;; End: -;;; comint-testsuite.el ends here +;;; comint-tests.el ends here diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el index 97b3349000c..f7d52834370 100644 --- a/test/lisp/cus-edit-tests.el +++ b/test/lisp/cus-edit-tests.el @@ -37,7 +37,7 @@ ;;;; showing/hiding obsolete options -(defgroup cus-edit-tests nil "test" +(defgroup cus-edit-tests nil "Test." :group 'test-group) (defcustom cus-edit-tests--obsolete-option-tag nil diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index e93c96e1d93..769db6ceab4 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -25,20 +25,9 @@ (require 'wid-edit) (require 'cus-edit) -(defmacro custom-tests--with-temp-dir (&rest body) - "Eval BODY with `temporary-file-directory' bound to a fresh directory. -Ensure the directory is recursively deleted after the fact." - (declare (debug t) (indent 0)) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t)))) - (unwind-protect - (let ((temporary-file-directory ,dir)) - ,@body) - (delete-directory ,dir t))))) - (ert-deftest custom-theme--load-path () "Test `custom-theme--load-path' behavior." - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory ;; Path is empty. (let ((custom-theme-load-path ())) (should (null (custom-theme--load-path)))) @@ -50,28 +39,28 @@ Ensure the directory is recursively deleted after the fact." (should (null (custom-theme--load-path)))) ;; Path comprises existing file. - (let* ((file (make-temp-file "file")) - (custom-theme-load-path (list file))) - (should (file-exists-p file)) - (should (not (file-directory-p file))) - (should (null (custom-theme--load-path)))) + (ert-with-temp-file file + (let* ((custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path))))) ;; Path comprises existing directory. - (let* ((dir (make-temp-file "dir" t)) - (custom-theme-load-path (list dir))) - (should (file-directory-p dir)) - (should (equal (custom-theme--load-path) custom-theme-load-path))) + (ert-with-temp-directory dir + (let* ((custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path)))) ;; Expand `custom-theme-directory' path element. (let ((custom-theme-load-path '(custom-theme-directory))) (let ((custom-theme-directory (make-temp-name temporary-file-directory))) (should (not (file-exists-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "file"))) + (ert-with-temp-file custom-theme-directory (should (file-exists-p custom-theme-directory)) (should (not (file-directory-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "dir" t))) + (ert-with-temp-directory custom-theme-directory (should (file-directory-p custom-theme-directory)) (should (equal (custom-theme--load-path) (list custom-theme-directory))))) @@ -96,7 +85,8 @@ Ensure the directory is recursively deleted after the fact." (ert-deftest custom-tests-require-theme () "Test `require-theme'." - (custom-tests--with-temp-dir + (require 'warnings) + (ert-with-temp-directory temporary-file-directory (let* ((default-directory temporary-file-directory) (custom-theme-load-path (list default-directory)) (load-path ())) diff --git a/test/lisp/dabbrev-tests.el b/test/lisp/dabbrev-tests.el index 0b20dcf9213..d3fe78b6185 100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@ -29,16 +29,15 @@ (ert-deftest dabbrev-expand-test () "Test for bug#1948. -When DABBREV-ELIMINATE-NEWLINES is non-nil (the default), -repeated calls to DABBREV-EXPAND can result in the source of +When `dabbrev-eliminate-newlines' is non-nil (the default), +repeated calls to `dabbrev-expand' can result in the source of first expansion being replaced rather than the destination." (with-temp-buffer (insert "ab x\na\nab y") (goto-char 8) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; M-/ SPC M-/ M-/ - (execute-kbd-macro "\257 \257\257")) + (execute-kbd-macro (kbd "M-/ SPC M-/ M-/"))) (should (string= (buffer-string) "ab x\nab y\nab y")))) (ert-deftest dabbrev-completion-test () @@ -52,8 +51,7 @@ buffers unless a prefix argument is used." (goto-char 6) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; C-M-/ - (execute-kbd-macro [201326639])) + (execute-kbd-macro (kbd "C-M-/"))) (should (string= (buffer-string) "abc\nabc"))))) (ert-deftest dabbrev-completion-test-with-argument () @@ -67,6 +65,7 @@ multiple expansions." (goto-char 6) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; C-u C-u C-M-/ - (execute-kbd-macro [21 21 201326639])) + (execute-kbd-macro (kbd "C-u C-u C-M-/"))) (should (string= (buffer-string) "abc\na"))))) + +;;; dabbrev-tests.el ends here diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el index 2052dc0e38c..715fafa44c3 100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@ -91,4 +91,4 @@ (provide 'descr-text-test) -;;; descr-text-test.el ends here +;;; descr-text-tests.el ends here diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 7f1743f88d7..374164f1f9b 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -19,26 +19,25 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-aux) (eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." (skip-unless (executable-find shell-file-name)) - (let* ((foo (make-temp-file "foo")) - (files (list foo))) - (unwind-protect - (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) - (dired temporary-file-directory) - (dired-goto-file foo) - ;; `dired-do-shell-command' returns nil on success. - (should-error (dired-do-shell-command "ls ? ./?" nil files)) - (should-error (dired-do-shell-command "ls ./? ?" nil files)) - (should-not (dired-do-shell-command "ls ? ?" nil files)) - (should-error (dired-do-shell-command "ls * ./*" nil files)) - (should-not (dired-do-shell-command "ls * *" nil files)) - (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) - (delete-file foo)))) + (ert-with-temp-file foo + (let* ((files (list foo))) + (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) + (dired temporary-file-directory) + (dired-goto-file foo) + ;; `dired-do-shell-command' returns nil on success. + (should-error (dired-do-shell-command "ls ? ./?" nil files)) + (should-error (dired-do-shell-command "ls ./? ?" nil files)) + (should-not (dired-do-shell-command "ls ? ?" nil files)) + (should-error (dired-do-shell-command "ls * ./*" nil files)) + (should-not (dired-do-shell-command "ls * *" nil files)) + (should-not (dired-do-shell-command "ls ? ./`?`" nil files)))))) ;; Auxiliary macro for `dired-test-bug28834': it binds ;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. @@ -47,24 +46,21 @@ (defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) (declare (debug (form symbolp body))) (let ((foo (make-symbol "foo"))) - `(let* ((,foo (make-temp-file "foo" 'dir)) - (dired-create-destination-dirs ,create-dirs)) - (setq from (make-temp-file "from")) - (setq to-cp - (expand-file-name - "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) - (setq to-mv - (expand-file-name - "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) - (unwind-protect - (if ,yes-or-no - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (_prompt) (eq ,yes-or-no 'yes)))) - ,@body) - ,@body) - ;; clean up - (delete-directory ,foo 'recursive) - (delete-file from))))) + `(ert-with-temp-directory ,foo + (ert-with-temp-file from + (let* ((dired-create-destination-dirs ,create-dirs)) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body))))))) (ert-deftest dired-test-bug28834 () "test for https://debbugs.gnu.org/28834 ." @@ -159,4 +155,4 @@ (dired-test--check-highlighting (nth 0 lines) '(8)))) (provide 'dired-aux-tests) -;; dired-aux-tests.el ends here +;;; dired-aux-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index aac78c64c69..ad1bca923d9 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (ert-deftest dired-autoload () @@ -141,116 +142,113 @@ (ert-deftest dired-test-bug27243-01 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ." - (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t))) - (save-pos (lambda () - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (dired-save-positions)))) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; dired-buffers-for-dir. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (should-not (dired-buffers-for-dir test-dir)) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (message "Saved pos: %S" (funcall save-pos)) - ;; Point must be at end-of-buffer. - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (should (eobp))) - (push (dired test-dir) buffers) - (message "Saved pos: %S" (funcall save-pos)) - ;; Previous dired call shouldn't create a new buffer: must visit the one - ;; created by `find-file-noselect' above. - (should (eq 1 (length (dired-buffers-for-dir test-dir)))) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (message "Saved pos: %S" (funcall save-pos)) - (write-region "Test" nil test-file nil 'silent nil 'excl) - (message "Saved pos: %S" (funcall save-pos)) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat test-dir (file-name-as-directory "test-subdir")))) - (message "Saved pos: %S" (funcall save-pos)) - (push (dired-find-file) buffers) - (let ((pt2 (point))) ; Point is on test-file. - (pop-to-buffer-same-window buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) + (ert-with-temp-directory test-dir + (let* ((save-pos (lambda () + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (dired-save-positions)))) + (dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; dired-buffers-for-dir. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (should-not (dired-buffers-for-dir test-dir)) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (message "Saved pos: %S" (funcall save-pos)) + ;; Point must be at end-of-buffer. + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (should (eobp))) + (push (dired test-dir) buffers) + (message "Saved pos: %S" (funcall save-pos)) + ;; Previous dired call shouldn't create a new buffer: must visit the one + ;; created by `find-file-noselect' above. + (should (eq 1 (length (dired-buffers-for-dir test-dir)))) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (message "Saved pos: %S" (funcall save-pos)) + (write-region "Test" nil test-file nil 'silent nil 'excl) + (message "Saved pos: %S" (funcall save-pos)) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat test-dir (file-name-as-directory "test-subdir")))) + (message "Saved pos: %S" (funcall save-pos)) (push (dired-find-file) buffers) - (should (eq (point) pt2)))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (let ((pt2 (point))) ; Point is on test-file. + (pop-to-buffer-same-window buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired-find-file) buffers) + (should (eq (point) pt2)))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-02 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; string comparisons below. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (push (dired test-dir) buffers) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (write-region "Test" nil test-file nil 'silent nil 'excl) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat (file-name-as-directory test-dir) - (file-name-as-directory "test-subdir")))) - (push (dired-find-file) buffers) - ;; Point is on test-file. - (switch-to-buffer buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) - (push (dired test-dir) buffers) - (should (eq (point) pt1))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; string comparisons below. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (push (dired test-dir) buffers) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (write-region "Test" nil test-file nil 'silent nil 'excl) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat (file-name-as-directory test-dir) + (file-name-as-directory "test-subdir")))) + (push (dired-find-file) buffers) + ;; Point is on test-file. + (switch-to-buffer buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired test-dir) buffers) + (should (eq (point) pt1))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-03 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) - allbufs) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect test-dir) - (push (current-buffer) allbufs) - (make-directory "test-subdir1") - (make-directory "test-subdir2") - (let ((test-file1 "test-file1") - (test-file2 "test-file2")) - (with-current-buffer (find-file-noselect "test-subdir1") - (push (current-buffer) allbufs) - (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) - (with-current-buffer (find-file-noselect "test-subdir2") - (push (current-buffer) allbufs) - (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) - ;; Call find-file with a wild card and test point in each file. - (let ((buffers (find-file (concat (file-name-as-directory test-dir) - "*") - t))) - (dolist (buf buffers) - (let ((pt (with-current-buffer buf (point)))) - (switch-to-buffer (find-file-noselect test-dir)) - (find-file (buffer-name buf)) - (should (equal (point) pt)))) - (append buffers allbufs))) - (dolist (buf allbufs) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) + allbufs) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect test-dir) + (push (current-buffer) allbufs) + (make-directory "test-subdir1") + (make-directory "test-subdir2") + (let ((test-file1 "test-file1") + (test-file2 "test-file2")) + (with-current-buffer (find-file-noselect "test-subdir1") + (push (current-buffer) allbufs) + (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) + (with-current-buffer (find-file-noselect "test-subdir2") + (push (current-buffer) allbufs) + (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) + ;; Call find-file with a wild card and test point in each file. + (let ((buffers (find-file (concat (file-name-as-directory test-dir) + "*") + t))) + (dolist (buf buffers) + (let ((pt (with-current-buffer buf (point)))) + (switch-to-buffer (find-file-noselect test-dir)) + (find-file (buffer-name buf)) + (should (equal (point) pt)))) + (append buffers allbufs))) + (dolist (buf allbufs) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug7131 () "Test for https://debbugs.gnu.org/7131 ." @@ -274,22 +272,21 @@ ;; ls-lisp-tests.el and em-ls-tests.el. (skip-unless (and (not (featurep 'ls-lisp)) (not (featurep 'eshell)))) - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." @@ -310,72 +307,69 @@ (ert-deftest dired-test-bug27968 () "Test for https://debbugs.gnu.org/27968 ." - (let* ((top-dir (make-temp-file "top-dir" t)) - (subdir (expand-file-name "subdir" top-dir)) - (header-len-fn (lambda () - (save-excursion - (goto-char 1) - (forward-line 1) - (- (point-at-eol) (point))))) - orig-len len diff pos line-nb) - (make-directory subdir 'parents) - (unwind-protect - (with-current-buffer (dired-noselect subdir) - (setq orig-len (funcall header-len-fn) - pos (point) - line-nb (line-number-at-pos)) - ;; Bug arises when the header line changes its length; this may - ;; happen if the used space has changed: for instance, with the - ;; creation of additional files. - (make-directory "subdir" t) - (dired-revert) - ;; Change the header line. - (save-excursion - (goto-char 1) - (forward-line 1) - (let ((inhibit-read-only t) - (new-header " test-bug27968")) - (delete-region (point) (point-at-eol)) - (when (= orig-len (length new-header)) - ;; Wow lucky guy! I must buy lottery today. - (setq new-header (concat new-header " :-)"))) - (insert new-header))) - (setq len (funcall header-len-fn) - diff (- len orig-len)) - (should-not (zerop diff)) ; Header length has changed. - ;; If diff > 0, then the point moves back. - ;; If diff < 0, then the point moves forward. - ;; If diff = 0, then the point doesn't move. - ;; Sometimes this point movement causes - ;; line-nb != (line-number-at-pos pos), so that we get - ;; an unexpected file at point if we store buffer points. - ;; Note that the line number before/after revert - ;; doesn't change. - (should (= line-nb - (line-number-at-pos) - (line-number-at-pos (+ pos diff)))) - ;; After revert, the point must be in 'subdir' line. - (should (equal "subdir" (dired-get-filename 'local t)))) - (delete-directory top-dir t)))) + (ert-with-temp-directory top-dir + (let* ((subdir (expand-file-name "subdir" top-dir)) + (header-len-fn (lambda () + (save-excursion + (goto-char 1) + (forward-line 1) + (- (point-at-eol) (point))))) + orig-len len diff pos line-nb) + (make-directory subdir 'parents) + (with-current-buffer (dired-noselect subdir) + (setq orig-len (funcall header-len-fn) + pos (point) + line-nb (line-number-at-pos)) + ;; Bug arises when the header line changes its length; this may + ;; happen if the used space has changed: for instance, with the + ;; creation of additional files. + (make-directory "subdir" t) + (dired-revert) + ;; Change the header line. + (save-excursion + (goto-char 1) + (forward-line 1) + (let ((inhibit-read-only t) + (new-header " test-bug27968")) + (delete-region (point) (point-at-eol)) + (when (= orig-len (length new-header)) + ;; Wow lucky guy! I must buy lottery today. + (setq new-header (concat new-header " :-)"))) + (insert new-header))) + (setq len (funcall header-len-fn) + diff (- len orig-len)) + (should-not (zerop diff)) ; Header length has changed. + ;; If diff > 0, then the point moves back. + ;; If diff < 0, then the point moves forward. + ;; If diff = 0, then the point doesn't move. + ;; Sometimes this point movement causes + ;; line-nb != (line-number-at-pos pos), so that we get + ;; an unexpected file at point if we store buffer points. + ;; Note that the line number before/after revert + ;; doesn't change. + (should (= line-nb + (line-number-at-pos) + (line-number-at-pos (+ pos diff)))) + ;; After revert, the point must be in 'subdir' line. + (should (equal "subdir" (dired-get-filename 'local t))))))) (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body) "Helper macro for Bug#27940 test." (declare (indent 1) (debug body)) (let ((dir (make-symbol "dir"))) - `(let* ((,dir (make-temp-file "bug27940" t)) - (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. - (inhibit-message t) - (default-directory ,dir)) - (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) - (unless ,just-empty-dirs - (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) - (make-directory "zeta-empty-dir") - (unwind-protect - (progn - ,@body) - (delete-directory ,dir t) - (kill-buffer (current-buffer)))))) + `(ert-with-temp-directory ,dir + (let* ((dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. + (inhibit-message t) + (default-directory ,dir)) + (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) + (unless ,just-empty-dirs + (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) + (make-directory "zeta-empty-dir") + (unwind-protect + (progn + ,@body) + (kill-buffer (current-buffer))))))) (ert-deftest dired-test-bug27940 () "Test for https://debbugs.gnu.org/27940 ." @@ -518,4 +512,4 @@ (delete-directory testdir t))))) (provide 'dired-tests) -;; dired-tests.el ends here +;;; dired-tests.el ends here diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el index 003923d60fa..fe4b9711d49 100644 --- a/test/lisp/dired-x-tests.el +++ b/test/lisp/dired-x-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-x) @@ -31,23 +32,20 @@ (append (copy-sequence dirs) (delete "c" (copy-sequence files))) #'string<)) - (dir (make-temp-file "Bug25942" 'dir)) (extension "c")) - (unwind-protect - (progn - (dolist (d dirs) - (make-directory (expand-file-name d dir))) - (dolist (f files) - (write-region nil nil (expand-file-name f dir))) - (dired dir) - (dired-mark-extension extension) - (should (equal '("bar.c" "foo.c") - (sort (dired-get-marked-files 'local) #'string<))) - (dired-unmark-all-marks) - (dired-mark-suffix extension) - (should (equal all-but-c - (sort (dired-get-marked-files 'local) #'string<)))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (dolist (d dirs) + (make-directory (expand-file-name d dir))) + (dolist (f files) + (write-region nil nil (expand-file-name f dir))) + (dired dir) + (dired-mark-extension extension) + (should (equal '("bar.c" "foo.c") + (sort (dired-get-marked-files 'local) #'string<))) + (dired-unmark-all-marks) + (dired-mark-suffix extension) + (should (equal all-but-c + (sort (dired-get-marked-files 'local) #'string<)))))) (ert-deftest dired-guess-default () (let ((dired-guess-shell-alist-user nil) @@ -63,4 +61,4 @@ nil)))) (provide 'dired-x-tests) -;; dired-x-tests.el ends here +;;; dired-x-tests.el ends here diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el index 0a0d783b824..b55982c1a15 100644 --- a/test/lisp/dom-tests.el +++ b/test/lisp/dom-tests.el @@ -209,5 +209,13 @@ child results in an error." (dom-pp node t) (should (equal (buffer-string) "(\"foo\" nil)"))))) +(ert-deftest dom-test-search () + (let ((dom '(a nil (b nil (c nil))))) + (should (equal (dom-search dom (lambda (d) (eq (dom-tag d) 'a))) + (list dom))) + (should (equal (dom-search dom (lambda (d) (memq (dom-tag d) '(b c)))) + (list (car (dom-children dom)) + (car (dom-children (car (dom-children dom))))))))) + (provide 'dom-tests) ;;; dom-tests.el ends here diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el new file mode 100644 index 00000000000..974f506a367 --- /dev/null +++ b/test/lisp/edmacro-tests.el @@ -0,0 +1,47 @@ +;;; edmacro-tests.el --- Tests for edmacro.el -*- lexical-binding:t -*- + +;; Copyright (C) 2021 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 'edmacro) + +(ert-deftest edmacro-test-edmacro-parse-keys () + (should (equal (edmacro-parse-keys "") "")) + (should (equal (edmacro-parse-keys "x") "x")) + (should (equal (edmacro-parse-keys "C-a") "\C-a")) + + ;; comments + (should (equal (edmacro-parse-keys ";; foobar") "")) + (should (equal (edmacro-parse-keys ";;;") "")) + (should (equal (edmacro-parse-keys "; ; ;") ";;;")) + (should (equal (edmacro-parse-keys "REM foobar") "")) + (should (equal (edmacro-parse-keys "x ;; foobar") "x")) + (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys "<<goto-line>>") + [134217848 103 111 116 111 45 108 105 110 101 13])) + + ;; repetitions + (should (equal (edmacro-parse-keys "3*x") "xxx")) + (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) + (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + +;;; edmacro-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 235c02f8e8b..1e32dbfb609 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -35,7 +35,8 @@ (defun call-with-saved-electric-modes (fn) (let ((saved-electric (if electric-pair-mode 1 -1)) (saved-layout (if electric-layout-mode 1 -1)) - (saved-indent (if electric-indent-mode 1 -1))) + (saved-indent (if electric-indent-mode 1 -1)) + (blink-paren-function nil)) (electric-pair-mode -1) (electric-layout-mode -1) (electric-indent-mode -1) @@ -53,17 +54,18 @@ expected-point mode bindings fixture-fn &optional doc-string) (with-temp-buffer - (funcall mode) - (insert fixture) - (save-electric-modes - (let ((last-command-event char) - (transient-mark-mode 'lambda)) - (goto-char where) - (funcall fixture-fn) - (cl-progv - (mapcar #'car bindings) - (mapcar #'cdr bindings) - (call-interactively (key-binding `[,last-command-event]))))) + (dlet ((python-indent-guess-indent-offset-verbose nil)) + (funcall mode) + (insert fixture) + (save-electric-modes + (let ((last-command-event char) + (transient-mark-mode 'lambda)) + (goto-char where) + (funcall fixture-fn) + (cl-progv + (mapcar #'car bindings) + (mapcar #'cdr bindings) + (call-interactively (key-binding `[,last-command-event])))))) (when (and doc-string (not @@ -97,21 +99,22 @@ ;; FIXME: avoid `eval' (mapcar #'car (eval bindings)) (mapcar #'cdr (eval bindings)) - (funcall mode) - (insert fixture) - (goto-char (1+ pos)) - (insert char) - (cond ((eq (aref skip-pair-string pos) - ?p) - (insert (cadr (electric-pair-syntax-info char))) - (backward-char 1)) - ((eq (aref skip-pair-string pos) - ?s) - (delete-char -1) - (forward-char 1))) - (list - (buffer-substring-no-properties (point-min) (point-max)) - (point)))) + (dlet ((python-indent-guess-indent-offset-verbose nil)) + (funcall mode) + (insert fixture) + (goto-char (1+ pos)) + (insert char) + (cond ((eq (aref skip-pair-string pos) + ?p) + (insert (cadr (electric-pair-syntax-info char))) + (backward-char 1)) + ((eq (aref skip-pair-string pos) + ?s) + (delete-char -1) + (forward-char 1))) + (list + (buffer-substring-no-properties (point-min) (point-max)) + (point))))) (list expected-string expected-point))) (expected-string (car expected-string-and-point)) (expected-point (cadr expected-string-and-point)) @@ -146,7 +149,7 @@ The buffer's contents should %s: "") char (if (string= fixture expected-string) "stay" "become") - (replace-regexp-in-string "\n" "\\\\n" expected-string) + (string-replace "\n" "\\n" expected-string) expected-point))) `(ert-deftest ,(intern (format "electric-pair-%s-at-point-%s-in-%s%s" name @@ -173,7 +176,7 @@ The buffer's contents should %s: expected-string expected-point bindings - (modes '(quote (ruby-mode js-mode))) + (modes '(quote (ruby-mode js-mode python-mode c-mode))) (test-in-comments t) (test-in-strings t) (test-in-code t) @@ -190,11 +193,13 @@ The buffer's contents should %s: for (prefix suffix extra-desc) in (append (if test-in-comments `((,(with-temp-buffer - (funcall mode) - (insert "z") - (comment-region (point-min) (point-max)) - (buffer-substring-no-properties (point-min) - (1- (point-max)))) + (dlet ((python-indent-guess-indent-offset-verbose + nil)) + (funcall mode) + (insert "z") + (comment-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) + (1- (point-max))))) "" "-in-comments"))) (if test-in-strings @@ -296,7 +301,7 @@ The buffer's contents should %s: ;;; Quotes ;;; (define-electric-pair-test pair-some-quotes-skip-others - " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + " \"\" " "-\"\"-\"---" :skip-pair-string "-ps-p----" :test-in-strings nil :bindings `((electric-pair-text-syntax-table . ,prog-mode-syntax-table))) @@ -423,7 +428,9 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-strings nil :test-in-code nil - :test-in-comments t) + :test-in-comments t + :fixture-fn (lambda () (when (eq major-mode 'c-mode) + (c-toggle-comment-style -1)))) (define-electric-pair-test whitespace-skipping-for-quotes-not-outside " \" \"" "\"-----" :expected-string "\"\" \" \"" @@ -870,8 +877,8 @@ baz\"\"" (local-set-key (vector key) 'self-insert-command))) (defun electric-layout-for-c-style-du-jour (inserted) - "A function to use in `electric-layout-rules'" - (when (memq inserted '(?{ ?})) + "A function to use in `electric-layout-rules'." + (when (memq inserted '(?\{ ?\})) (save-excursion (backward-char 2) (c-point-syntax) (forward-char) ; silly, but needed (c-brace-newlines (c-point-syntax))))) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 7c40f7ebca3..dbc0aa3db42 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-tests.el -*- lexical-binding:t -*- +;;; bytecomp-tests.el --- Tests for bytecomp.el -*- lexical-binding:t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -41,6 +41,24 @@ "Identity, but hidden from some optimisations." x) +(defmacro bytecomp-test-loop (outer1 outer2 inner1 inner2) + "Exercise constant propagation inside `while' loops. +OUTER1, OUTER2, INNER1 and INNER2 are forms placed in the outer and +inner loops respectively." + `(let ((x 1) (i 3) (res nil)) + (while (> i 0) + (let ((y 2) (j 2)) + (setq res (cons (list 'outer x y) res)) + (while (> j 0) + (setq res (cons (list 'inner x y) res)) + ,inner1 + ,inner2 + (setq j (1- j))) + ,outer1 + ,outer2) + (setq i (1- i))) + res)) + (defconst bytecomp-tests--test-cases '( ;; some functional tests @@ -432,6 +450,15 @@ (let ((x 2)) (list (or (bytecomp-test-identity 'a) (setq x 3)) x)) + (mapcar (lambda (b) + (let ((a nil)) + (+ 0 + (progn + (setq a b) + (setq b 1) + a)))) + '(10)) + (let* ((x 1) (y (condition-case x (/ 1 0) @@ -445,6 +472,25 @@ (setq x 10)))) 4) + ;; Loop constprop: set the inner and outer variables in the inner + ;; and outer loops, all combinations. + (bytecomp-test-loop nil nil nil nil ) + (bytecomp-test-loop nil nil nil (setq x 6)) + (bytecomp-test-loop nil nil (setq x 5) nil ) + (bytecomp-test-loop nil nil (setq x 5) (setq x 6)) + (bytecomp-test-loop nil (setq x 4) nil nil ) + (bytecomp-test-loop nil (setq x 4) nil (setq x 6)) + (bytecomp-test-loop nil (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop nil (setq x 4) (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) nil nil nil ) + (bytecomp-test-loop (setq x 3) nil nil (setq x 6)) + (bytecomp-test-loop (setq x 3) nil (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) nil (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) nil nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) nil (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) (setq x 6)) + ;; No error, no success handler. (condition-case x (list 42) @@ -503,6 +549,100 @@ (:success 'good)) (1+ x)))) (funcall f 3)) + + ;; Check `not' in cond switch (bug#49746). + (mapcar (lambda (x) (cond ((equal x "a") 1) + ((member x '("b" "c")) 2) + ((not x) 3))) + '("a" "b" "c" "d" nil)) + + ;; `let' and `let*' optimisations with body being constant or variable + (let* (a + (b (progn (setq a (cons 1 a)) 2)) + (c (1+ b)) + (d (list a c))) + d) + (let ((a nil)) + (let ((b (progn (setq a (cons 1 a)) 2)) + (c (progn (setq a (cons 3 a)))) + (d (list a))) + d)) + (let* ((_a 1) + (_b 2)) + 'z) + (let ((_a 1) + (_b 2)) + 'z) + (let (x y) + y) + (let* (x y) + y) + (let (x y) + 'a) + (let* (x y) + 'a) + + ;; Check empty-list optimisations. + (mapcar (lambda (x) (member x nil)) '("a" 2 nil)) + (mapcar (lambda (x) (memql x nil)) '(a 2 nil)) + (mapcar (lambda (x) (memq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (member (setq n (1+ n)) nil)) '(a "nil")) + n)) + (mapcar (lambda (x) (assoc x nil)) '("a" nil)) + (mapcar (lambda (x) (assq x nil)) '(a nil)) + (mapcar (lambda (x) (rassoc x nil)) '("a" nil)) + (mapcar (lambda (x) (rassq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (assoc (setq n (1+ n)) nil)) '(a "nil")) + n)) + + ;; Exercise variable-aliasing optimisations. + (let ((a (list 1))) + (let ((b a)) + (let ((a (list 2))) + (list a b)))) + + (let ((a (list 1))) + (let ((a (list 2)) + (b a)) + (list a b))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (list a b) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (/ 0) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (list x a))))) + (funcall (car f) 3)) + + (let* ((a (list 1)) + (b a) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -553,24 +693,19 @@ byte-compiled. Run with dynamic binding." (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile))) - (load elfile nil 'nomessage)) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) + (ert-with-temp-file elfile + :suffix ".el" + (ert-with-temp-file elcfile + :suffix ".elc" + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -800,10 +935,9 @@ byte-compiled. Run with dynamic binding." "warn-wide-docstring-define-obsolete-variable-alias.el" "defvaralias .foo. docstring wider than .* characters") -;; TODO: We don't yet issue warnings for defuns. (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than .* characters" 'reverse) + "wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" @@ -877,10 +1011,9 @@ byte-compiled. Run with dynamic binding." (defmacro bytecomp-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"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -1107,25 +1240,25 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't writable (Bug#44631)." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (should (byte-compile-file input-file)) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) (ert-deftest bytecomp-tests--dest-mountpoint () "Test that byte compilation works if the destination file is a @@ -1137,56 +1270,53 @@ mountpoint (Bug#44631)." (skip-unless (not (file-remote-p bwrap))) (skip-unless (file-executable-p emacs)) (skip-unless (not (file-remote-p emacs))) - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (unquoted-file (file-name-unquote output-file)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (should-not (file-remote-p input-file)) - (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (with-temp-buffer - (let ((status (call-process - bwrap nil t nil - "--ro-bind" "/" "/" - "--bind" unquoted-file unquoted-file - emacs "--quick" "--batch" "--load=bytecomp" - (format "--eval=%S" - `(setq byte-compile-dest-file-function - (lambda (_) ,output-file) - byte-compile-error-on-warn t)) - "--funcall=batch-byte-compile" input-file))) - (unless (eql status 0) - (ert-fail `((status . ,status) - (output . ,(buffer-string))))))) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive)))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) (ert-deftest bytecomp-tests--target-file-no-directory () "Check that Bug#45287 is fixed." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((default-directory directory) - (byte-compile-dest-file-function (lambda (_) "test.elc")) - (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) - (should (byte-compile-file "test.el")) - (should (file-regular-p "test.elc")) - (should (cl-plusp (file-attribute-size - (file-attributes "test.elc"))))) - (with-demoted-errors "Error cleaning up directory: %s" - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) (defun bytecomp-tests--get-vars () (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) @@ -1333,9 +1463,33 @@ compiled correctly." (load-file (concat file "c")) (should (equal (bc-test-alpha-f 'a) '(nil a))))) +(ert-deftest bytecomp-tests-byte-compile--wide-docstring-p/func-arg-list () + (should-not (byte-compile--wide-docstring-p "\ +\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \ +[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn CMD FLAGS FIS &key (BUF (cvs-temp-buffer)) DONT-CHANGE-DISC CVSARGS \ +POSTPROC)" fill-column)) + ;; Bug#49007 + (should-not (byte-compile--wide-docstring-p "\ +(fn (THIS rudel-protocol-backend) TRANSPORT \ +INFO INFO-CALLBACK &optional PROGRESS-CALLBACK)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] BODY...)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(make-soap-xs-element &key NAME NAMESPACE-TAG ID TYPE^ OPTIONAL? MULTIPLE? \ +REFERENCE SUBSTITUTION-GROUP ALTERNATIVES IS-GROUP)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn NAME FIXTURE INPUT &key SKIP-PAIR-STRING EXPECTED-STRING \ +EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ +(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \ +(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column))) + + ;; Local Variables: ;; no-byte-compile: t ;; End: (provide 'bytecomp-tests) -;; bytecomp-tests.el ends here. +;;; bytecomp-tests.el ends here diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 5aeed0cc155..4290571735e 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -1,4 +1,4 @@ -;;; cconv-tests.el -*- lexical-binding: t -*- +;;; cconv-tests.el --- Tests for cconv.el -*- lexical-binding: t -*- ;; Copyright (C) 2018-2021 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'cl-lib) @@ -204,4 +206,4 @@ 42))) (provide 'cconv-tests) -;; cconv-tests.el ends here. +;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 9552bf0e397..5c9d847e34a 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -28,6 +28,7 @@ (require 'check-declare) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'subr-x)) (ert-deftest check-declare-tests-locate () @@ -36,62 +37,53 @@ (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) (ert-deftest check-declare-tests-scan () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(declare-function ring-insert \"ring\" (ring item))" - "(let ((foo 'code)) foo)") - "\n"))) - (let ((res (check-declare-scan file))) - (should (= (length res) 1)) - (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) - (should (string-match-p "ring" fnfile)) - (should (equal "ring-insert" fn)) - (should (equal '(ring item) arglist)) - (should-not fileonly)))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) (ert-deftest check-declare-tests-verify () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring item)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should-not - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) (ert-deftest check-declare-tests-verify-mismatch () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should - (equal - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))) - '(("foo.el" "ring-insert" "arglist mismatch"))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) (ert-deftest check-declare-tests-sort () (should-not (check-declare-sort '())) @@ -106,11 +98,11 @@ (let ((res (buffer-string))) ;; Don't care too much about the format of the output, but ;; check that key information is present. - (should (string-match-p "foo-file" res)) - (should (string-match-p "foo-fun" res)) - (should (string-match-p "bar-file" res)) - (should (string-match-p "it wasn't" res)) - (should (string-match-p "999" res)))))) + (should (string-search "foo-file" res)) + (should (string-search "foo-fun" res)) + (should (string-search "bar-file" res)) + (should (string-search "it wasn't" res)) + (should (string-search "999" res)))))) (provide 'check-declare-tests) ;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index 7a7aa9fb3cd..ef49e71599a 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -49,27 +49,27 @@ (with-temp-buffer (emacs-lisp-mode) ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") + (insert "(cl-defmethod foo ((a (eql 'smthg)) (b list)) \"Return A+B.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-qualified-ok () "Checkdoc should be happy with a `cl-defmethod' using qualifiers." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defmethod test :around ((a (eql smthg))) \"Return A.\")") + (insert "(cl-defmethod test :around ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () "Checkdoc should be happy with a :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defmethod foo :extra \"foo\" ((a (eql smthg))) \"Return A.\")") + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun)) (with-temp-buffer (emacs-lisp-mode) (insert - "(cl-defmethod foo :extra \"foo\" :after ((a (eql smthg))) \"Return A.\")") + "(cl-defmethod foo :extra \"foo\" :after ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () @@ -122,4 +122,100 @@ See the comments in Bug#24998." (should (looking-at-p "\"baz\")")) (should-not (checkdoc-next-docstring)))) +(defun checkdoc-tests--abbrev-test (buffer-contents goto-string) + (with-temp-buffer + (emacs-lisp-mode) + (insert buffer-contents) + (goto-char (point-min)) + (re-search-forward goto-string) + (checkdoc-in-abbreviation-p (point)))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/basic-case () + (should (checkdoc-tests--abbrev-test "foo bar e.g. baz" "e.g")) + (should (checkdoc-tests--abbrev-test "behavior/errors etc. that" "etc")) + (should (checkdoc-tests--abbrev-test "foo vs. bar" "vs")) + (should (checkdoc-tests--abbrev-test "spy a.k.a. spy" "a.k.a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-parens () + (should (checkdoc-tests--abbrev-test "foo bar (e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-escaped-parens () + (should (checkdoc-tests--abbrev-test "foo\n\\(e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/single-char () + (should (checkdoc-tests--abbrev-test "a. foo bar" "a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-em-dash () + (should (checkdoc-tests--abbrev-test "foo bar baz---e.g." "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/incorrect-abbreviation () + (should-not (checkdoc-tests--abbrev-test "foo bar a.b.c." "a.b.c"))) + +(defun checkdoc-test-error-format-is-good (msg &optional reverse literal) + (with-temp-buffer + (erase-buffer) + (emacs-lisp-mode) + (let ((standard-output (current-buffer))) + (if literal + (print (format "(error \"%s\")" msg)) + (prin1 `(error ,msg)))) + (goto-char (length "(error \"")) + (if reverse + (should (checkdoc--error-bad-format-p)) + (should-not (checkdoc--error-bad-format-p))))) + +(defun checkdoc-test-error-format-is-bad (msg &optional literal) + (checkdoc-test-error-format-is-good msg t literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p () + (checkdoc-test-error-format-is-good "Foo") + (checkdoc-test-error-format-is-good "Foo: bar baz") + (checkdoc-test-error-format-is-good "some-symbol: Foo") + (checkdoc-test-error-format-is-good "`some-symbol' foo bar") + (checkdoc-test-error-format-is-good "%sfoo") + (checkdoc-test-error-format-is-good "avl-tree-enter:\\ + Updated data does not match existing data" nil 'literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/defined-symbols () + (defvar checkdoc-tests--var-symbol nil) + (checkdoc-test-error-format-is-good "checkdoc-tests--var-symbol foo bar baz") + (defun checkdoc-tests--fun-symbol ()) + (checkdoc-test-error-format-is-good "checkdoc-tests--fun-symbol foo bar baz")) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/not-capitalized () + (checkdoc-test-error-format-is-bad "foo") + (checkdoc-test-error-format-is-bad "some-symbol: foo") + (checkdoc-test-error-format-is-bad "avl-tree-enter:\ + updated data does not match existing data")) + +(ert-deftest checkdoc-tests-fix-y-or-n-p () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo")) ; "foo" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/no-change () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo?")) ; "foo?" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/with-space () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo? ")) ; "foo? " + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo? \")"))))) + ;;; checkdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 9312fb44a1e..dd7511e9afe 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -56,7 +56,14 @@ (should (equal (cl--generic-1 'a nil) '(a))) (should (equal (cl--generic-1 4 nil) '("quatre" 4))) (should (equal (cl--generic-1 5 nil) '("cinq" 5))) - (should (equal (cl--generic-1 6 nil) '("six" a)))) + (should (equal (cl--generic-1 6 nil) '("six" a))) + (defvar cl--generic-fooval 41) + (cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y) + "forty-two") + (cl-defmethod cl--generic-1 (_x (_y (eql 42))) + "FORTY-TWO") + (should (equal (cl--generic-1 42 nil) "forty-two")) + (should (equal (cl--generic-1 nil 42) "FORTY-TWO"))) (cl-defstruct cl-generic-struct-parent a b) (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index a5ec62b9c42..a132d736383 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -417,22 +417,6 @@ (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) (should (string= (cl-nth-value 0 "only lists") "only lists"))) -(ert-deftest cl-test-caaar () - (should (null (cl-caaar '()))) - (should (null (cl-caaar '(() (2))))) - (should (null (cl-caaar '((() (2)) (a b))))) - (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) - (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) - (should (= 1 (cl-caaar '(((1 2) (3 4)))))) - (should (null (cl-caaar '((() (3 4))))))) - -(ert-deftest cl-test-caadr () - (should (null (cl-caadr '()))) - (should (null (cl-caadr '(1)))) - (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) - (should (= 2 (cl-caadr '(1 (2 3))))) - (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) - (ert-deftest cl-test-ldiff () (let ((l '(1 2 3))) (should (null (cl-ldiff '() '()))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f4e2e46a019..033764a7f98 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -637,17 +637,26 @@ collection clause." (/ 1 (logand n 1)) (arith-error (len3 (cdr xs) (1+ n))) (:success (len3 (cdr xs) (+ n k)))) - n))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) (should (equal (len list-42 0) 42)) (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) - (should (equal (len3 list-42k 0) 42000)))) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 2f45050e2eb..9285b2c945c 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -107,27 +107,27 @@ back to the top level.") "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -723,7 +723,7 @@ test and possibly others should be updated." (edebug-on-error nil) error-message (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@" (edebug-tests-should-be-at "format-node" "start") "SPC" (edebug-tests-should-be-at "format-node" "vectorp") @@ -744,7 +744,7 @@ test and possibly others should be updated." (edebug-on-error nil) (error-message "") (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@ SPC SPC SPC SPC SPC" (edebug-tests-should-be-at "try-flavors" "macro") diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index 9f9bb73133c..d1da066dc45 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -22,22 +22,22 @@ ;;; Commentary: ;; -;; Test method invocation order. From the common lisp reference -;; manual: +;; Test method invocation order. From the Common Lisp Reference +;; Manual: ;; ;; QUOTE: ;; - All the :before methods are called, in most-specific-first ;; order. Their values are ignored. An error is signaled if ;; call-next-method is used in a :before method. ;; -;; - The most specific primary method is called. Inside the body of a +;; - The most specific primary method is called. Inside the body of a ;; primary method, call-next-method may be used to call the next -;; most specific primary method. When that method returns, the +;; most specific primary method. When that method returns, the ;; previous primary method can execute more code, perhaps based on -;; the returned value or values. The generic function no-next-method +;; the returned value or values. The generic function no-next-method ;; is invoked if call-next-method is used and there are no more -;; applicable primary methods. The function next-method-p may be -;; used to determine whether a next method exists. If +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If ;; call-next-method is not used, only the most specific primary ;; method is called. ;; @@ -46,12 +46,14 @@ ;; call-next-method is used in a :after method. ;; ;; -;; Also test behavior of `call-next-method'. From clos.org: +;; Also test behavior of `call-next-method'. From clos.org: ;; ;; QUOTE: ;; When call-next-method is called with no arguments, it passes the ;; current method's original arguments to the next method. +;;; Code: + (require 'eieio) (require 'ert) @@ -403,3 +405,5 @@ (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) + +;;; eieio-test-methodinvoke.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index ddbef02c35a..fd044ff3734 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -165,9 +165,9 @@ Assume SLOTVALUE is a symbol of some sort." ((slot1 :initarg :slot1 :initform 1) (slot2 :initform 2)) - "Class for testing persistent saving of an object that isn't -persistent. This class is instead used as a slot value in a -persistent class.") + "Class for testing persistent saving of an object that isn't persistent. +This class is instead used as a slot value in a persistent +class.") (defclass persistent-with-objs-slot (eieio-persistent) ((pnp :initarg :pnp diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 3ec42343443..ba2e5f7be4a 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -48,13 +48,13 @@ :type (or null class-a) :documentation "Test self referencing types.") ) - "Class A") + "Class A.") (defclass class-b () ((land :initform "Sc" :type string :documentation "Detail about land.")) - "Class B") + "Class B.") (defclass class-ab (class-a class-b) ((amphibian :initform "frog" @@ -160,7 +160,7 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function") +(defgeneric generic1 () "First generic function.") (ert-deftest eieio-test-03-generics () (defun anormalfunction () "A plain function for error testing." nil) @@ -901,12 +901,12 @@ Subclasses to override slot attributes.") (defclass opt-test1 () () - "Abstract base class" + "Abstract base class." :abstract t) (defclass opt-test2 (opt-test1) () - "Instantiable child") + "Instantiable child.") (ert-deftest eieio-test-36-build-class-alist () (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) @@ -969,6 +969,18 @@ Subclasses to override slot attributes.") (should (eieio-instance-inheritor-slot-boundp C :b)) (should-not (eieio-instance-inheritor-slot-boundp C :c)))) +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b c) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 5c9696105e9..79576d24032 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -695,49 +695,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-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 (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 @@ -816,6 +807,10 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-test-failed-condition result) '(ert-test-failed "Boo"))))) +(ert-deftest ert-test-deftest-lexical-binding-t () + "Check that `lexical-binding' in `ert-deftest' has the file value." + (should (equal lexical-binding t))) + (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9f40a18d343..9baa9941586 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -90,10 +90,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -166,7 +166,7 @@ "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +175,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -271,6 +271,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el index 3303e7b178d..9fe5fe9218d 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Support file for `faceup-test-basics.el'. This file is used to test +;; Support file for `faceup-test-basics.el'. This file is used to test ;; `faceup-this-file-directory' in various contexts. ;;; Code: diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el index 28a9a7ecda3..987e4047d35 100644 --- a/test/lisp/emacs-lisp/find-func-tests.el +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -26,7 +26,7 @@ ;;; Code: -(require 'ert-x) ;For `ert-run-keys'. +(require 'ert-x) ;For `ert-simulate-keys'. (require 'find-func) (ert-deftest find-func-tests--library-completion () ;bug#43393 diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index a1b9f64fdb1..c81d3d09e7d 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -271,7 +271,7 @@ identical output." (unwind-protect (progn (iter-yield 1) - (error "test") + (error "Test") (iter-yield 2)) (cl-incf nr-unwound)))))) (should (equal (iter-next iter) 1)) diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index b9850eca8b9..6ee274ae10f 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -21,22 +21,21 @@ (require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index d856696da24..88e689c80b8 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -100,4 +100,4 @@ See Bug#24641." `[,(+ .a) ,(+ .a .b .b)]) [1 5]))) -;;; let-alist.el ends here +;;; let-alist-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el new file mode 100644 index 00000000000..d77804fbe60 --- /dev/null +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -0,0 +1,44 @@ +;;; lisp-mnt-tests.el --- Tests for lisp-mnt -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 2020-2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'lisp-mnt) + +(ert-deftest lm--tests-crack-address () + (should (equal (lm-crack-address + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("Bob Weiner" . "rsw@gnu.org") + ("Mats Lidell" . "matsl@gnu.org"))))) + +(ert-deftest lm--tests-lm-website () + (with-temp-buffer + (insert ";; URL: https://example.org/foo") + (should (string= (lm-website) "https://example.org/foo"))) + (with-temp-buffer + (insert ";; X-URL: <https://example.org/foo>") + (should (string= (lm-website) "https://example.org/foo")))) + +(provide 'lisp-mnt-tests) +;;; lisp-mnt-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index a04c6bef02a..afade8e295b 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -85,11 +85,13 @@ Evaluate BODY for each created map." (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () - (let ((map (list (cons "a" 1) (cons "b" 2))) - ;; Make sure to use a non-eq "a", even when compiled. - (noneq-key (string ?a))) - (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil #'equal)))) + (let* ((a (string ?a)) + (map `((,a . 0) (,(string ?b) . 1)))) + (should (= (map-elt map a) 0)) + (should (= (map-elt map "a") 0)) + (should (= (map-elt map (string ?a)) 0)) + (should (= (map-elt map "b") 1)) + (should (= (map-elt map (string ?b)) 1)))) (ert-deftest test-map-elt-with-nil-value () (should-not (map-elt '((a . 1) (b)) 'b 2))) @@ -129,6 +131,19 @@ Evaluate BODY for each created map." (setf (map-elt map size) 'v) (should (eq (map-elt map size) 'v)))))) +(ert-deftest test-map-put!-alist () + "Test `map-put!' test function on alists." + (let ((key (string ?a)) + (val 0) + map) + (should-error (map-put! map key val) :type 'map-not-inplace) + (setq map (list (cons key val))) + (map-put! map key (1- val)) + (should (equal map '(("a" . -1)))) + (map-put! map (string ?a) (1+ val)) + (should (equal map '(("a" . 1)))) + (should-error (map-put! map (string ?a) val #'eq) :type 'map-not-inplace))) + (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -197,6 +212,15 @@ Evaluate BODY for each created map." (with-empty-maps-do map (should (eq map (map-delete map t))))) +(ert-deftest test-map-delete-alist () + "Test `map-delete' test function on alists." + (let* ((a (string ?a)) + (map `((,a) (,(string ?b))))) + (setq map (map-delete map a)) + (should (equal map '(("b")))) + (setq map (map-delete map (string ?b))) + (should-not map))) + (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) (should (eq (map-nested-elt vec '(2 2 0)) 'e))) @@ -446,16 +470,24 @@ Evaluate BODY for each created map." (ert-deftest test-map-merge () "Test `map-merge'." - (should (equal (map-merge 'list '(a 1) '((b . 2) (c . 3)) - #s(hash-table data (c 4))) - '((c . 4) (b . 2) (a . 1))))) + (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + (lambda (x y) (string< (car x) (car y)))) + '((a . 1) (b . 2) (c . 4)))) + (should (equal (map-merge 'list () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'alist () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'plist () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-with () - (should (equal (map-merge-with 'list #'+ - '((1 . 2)) - '((1 . 3) (2 . 4)) - '((1 . 1) (2 . 5) (3 . 0))) - '((3 . 0) (2 . 9) (1 . 6))))) + (should (equal (sort (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + #'car-less-than-car) + '((1 . 6) (2 . 9) (3 . 0)))) + (should (equal (map-merge-with 'list #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'alist #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'plist #'+ () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-empty () "Test merging of empty maps." @@ -513,5 +545,14 @@ Evaluate BODY for each created map." 'value2)) (should (equal (map-elt ht 'key) 'value2)))) +(ert-deftest test-setf-map-with-function () + (let ((num 0) + (map nil)) + (setf (map-elt map 'foo) + (funcall (lambda () + (cl-incf num)))) + ;; Check that the function is only called once. + (should (= num 1)))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/memory-report-tests.el b/test/lisp/emacs-lisp/memory-report-tests.el index da5f4f5700f..d37f09b34f2 100644 --- a/test/lisp/emacs-lisp/memory-report-tests.el +++ b/test/lisp/emacs-lisp/memory-report-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'memory-report) @@ -45,6 +47,7 @@ (should (equal (memory-report-object-size (list 'foo)) 16)) + (should (equal (memory-report-object-size (vector 1 2 3)) 64)) (should (equal (memory-report-object-size (vector 1 2 3 4)) 80)) (should (equal (memory-report-object-size "") 32)) @@ -52,6 +55,29 @@ (should (equal (memory-report-object-size (propertize "a" 'face 'foo)) 81))) +(ert-deftest memory-report-sizes-vectors () + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + ["long string that should be at least 40 bytes"]) + 108)) + (let ((string "long string that should be at least 40 bytes")) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string)) + 108)) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string string)) + 124)))) + +(ert-deftest memory-report-sizes-structs () + (cl-defstruct memory-report-test-struct + (item0 nil) + (item1 nil)) + (let ((s (make-memory-report-test-struct :item0 "hello" :item1 "world"))) + (should (= (memory-report-object-size s) + 90)))) + (provide 'memory-report-tests) ;;; memory-report-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 358d9025ad5..ee33bb0fa40 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -208,4 +208,4 @@ function being an around advice." ;; no-byte-compile: t ;; End: -;;; advice-tests.el ends here. +;;; nadvice-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub index 5e2ebc55d35..99965723baf 100644 --- a/test/lisp/emacs-lisp/package-resources/key.pub +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -1,20 +1,17 @@ -----BEGIN PGP PUBLIC KEY BLOCK----- -mI0EX48EbAEEANrsWXyZ4MRZRjVbLAh5jX/+1+31oB/aJ/q/5DkH1qUHJf0La9LC -sykUSM3H2u5VWLytX/ozrxIRYX13GR2xBxyJlUkDWB209AAVLFrjSp1yUX/Sb5SU -Kb7p421ZAeHiOxfnLRuErFZkTfzY19mUCyw4cdamw430V3mUC9uns/d9ABEBAAG0 -LUouIFJhbmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojO -BBMBCgA4FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJ -CAsCBBYCAwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3 -aDX9jORiNfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQ -rFFiH4IAZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4 -lEPWXW0AycylbdbE7024jQRfjwRsAQQApjTw9kONmSVouCi8ZIQwwYiA9tLzbSZv -CYxbJ6KH0icRhBLfdb1hL/Kn8x3k+xll9A0c/ABVkMxRcbQkY98xsFck7E2GcvnC -sY+w/NdcUUZJYMB3l2MH5ojCbOk5jSAZzxzeFcJhNAhmLqomMHg2LI6KDVey6iYU -FxyIpIQ3SlkAEQEAAYi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+P -BGwCGwwACgkQMKdkJgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKw -wS74Pq407Zv0VD9ual/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYr -YSqWxANyek8otsvppJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOU -Yn923VI= -=NRtx +mQGiBGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBurQnSm9obm55IFJv +Y2tldHMgPGpvaG5ueS5yb2NrZXRzQGdmeS5vcmc+iHgEExECADgWIQRIVz1DPzm4 +REDIXNtltQG5ACv6lwUCYVDINwIbAwULCQgHAgYVCgkICwIEFgIDAQIeAQIXgAAK +CRBltQG5ACv6l4iZAKCqldroRYH7vUzVV0Uv1NcDVcpLngCgmEoLVxGLKSwDEXNq +qjRDzDRpReg= +=/l51 -----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/key.sec b/test/lisp/emacs-lisp/package-resources/key.sec index dbc80f43cb7..5bbac1226ae 100644 --- a/test/lisp/emacs-lisp/package-resources/key.sec +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -1,35 +1,17 @@ -----BEGIN PGP PRIVATE KEY BLOCK----- -lQIGBF+PBGwBBADa7Fl8meDEWUY1WywIeY1//tft9aAf2if6v+Q5B9alByX9C2vS -wrMpFEjNx9ruVVi8rV/6M68SEWF9dxkdsQcciZVJA1gdtPQAFSxa40qdclF/0m+U -lCm+6eNtWQHh4jsX5y0bhKxWZE382NfZlAssOHHWpsON9Fd5lAvbp7P3fQARAQAB -/gcDAngNw4ppSPBe/w734cz++xNEv0TDgwxGBWp2wGSwWao04Nl1U4LkjiIy+dkc -uUPwEZMvxXwMcq10PPH26ifP8Xfi/zANXUoLJ0DsG6rtE3BcSC9MPFe3EJENtcIP -a0jFLsbi72aBzolNEDCZCv93znXFPekaXw/RAeeFLJz8GR2Sx6bHbTJKklXgWPHw -C5Dw6xr/kEZktgjlhjkx280STpLGaFO4jiiGZ4Obp5ePp7kyOzDUzaimdZgJwClT -VbZDNQMTzgQrBOP8doXlo9euW4Wo1IYBIOwgeYieM3ZA9YjJAmp4lFnk/KFYt0Ak -0H9IWzDU8VERcU4B04PSXahzvB1Ii7C7bbHxPyuu6sAfMK8DRkrGjwgAlrhuWNLX -M07acT/E9Pm+mBlDcdkyKB2LfwgaVb9F3C25sfcFSvc5p+sqgZp1Zx7Qg9pOhQjw -U7Ln+96c0bUl+iQKdm3TGjOXAFUHYXbRkx2cJ4gxnMVNj0D68xBtBSm0LUouIFJh -bmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojOBBMBCgA4 -FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJCAsCBBYC -AwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3aDX9jORi -NfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQrFFiH4IA -ZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4lEPWXW0A -ycylbdbE702dAgYEX48EbAEEAKY08PZDjZklaLgovGSEMMGIgPbS820mbwmMWyei -h9InEYQS33W9YS/yp/Md5PsZZfQNHPwAVZDMUXG0JGPfMbBXJOxNhnL5wrGPsPzX -XFFGSWDAd5djB+aIwmzpOY0gGc8c3hXCYTQIZi6qJjB4NiyOig1XsuomFBcciKSE -N0pZABEBAAH+BwMCXeUOBwcOsxb/AY6rnHmgACNTGwIa5vgelw0qfET0ms/YzVrN -ufikyV9dEWVxJyuTKav978wanPu7VcCh0pTjL2nTm2nZWyRJN4gb3UIC0MA1xfB2 -yPLTCmsGeJhVOqi4Af/r06mk+NOQ96ivOA2CJuw1LSpcUtuYxB5t/grGyEojYjRP -s0Htvf2bfN9KbFJ26DGsfYzC8bCxm9szPFHBQjw4NboCigUSAHmkoTW01aWZU9Vq -brY4cWhdmCqHgfmsQgzP3LfaAQ6kJ/bkuKef7z57lz5XmlyjMQGWcZWp5xf2n81p -BV6unaIPyavzkKVAXizVfNiHNJgK9PoVoEOJkPLjRfMxVmFSGN/oF7lVTRWfOIwo -68rtNPhr6UzE4ArGHYv/pK3kijUp5daWmfrySWPcwoVAaR3mIIVs/1rhd9aZrwn6 -Q07Yo5u11rH9b8anZQF3BdTcrnU9pUzLYlFPnfhtyGqhikQILtPTf0iwr8hpG9b2 -Zoi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwwACgkQMKdk -JgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKwwS74Pq407Zv0VD9u -al/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYrYSqWxANyek8otsvp -pJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOUYn923VI= -=2DW8 +lQG7BGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBugAAn0mvGeJi+oSo +5jXAeXBhRiTyI5WPCuK0J0pvaG5ueSBSb2NrZXRzIDxqb2hubnkucm9ja2V0c0Bn +Znkub3JnPoh4BBMRAgA4FiEESFc9Qz85uERAyFzbZbUBuQAr+pcFAmFQyDcCGwMF +CwkIBwIGFQoJCAsCBBYCAwECHgECF4AACgkQZbUBuQAr+peImQCgqpXa6EWB+71M +1VdFL9TXA1XKS54AoJhKC1cRiyksAxFzaqo0Q8w0aUXo +=cyQm -----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el index f43232224af..ad20a3507a6 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el @@ -5,7 +5,7 @@ ;;; Code: (defun macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el index 0533b1bd9c4..6e5e54e54fd 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el @@ -9,11 +9,11 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defun macro-problem-func () - "" + "Description." (macro-problem-1 'a 'b) (macro-aux-1 'a 'b)) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el index 6a55a40e3b4..814d77183ab 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el @@ -5,11 +5,11 @@ ;;; Code: (defmacro macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defmacro macro-aux-3 ( &rest _) - "Description" + "Description." 90) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el index cad4ed93f19..aef5eda7c6c 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el @@ -9,21 +9,21 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,(cadr (car forms)))) (defun macro-problem-func () - "" + "Description." (list (macro-problem-1 '1 'b) (macro-aux-1 'a 'b))) (defmacro macro-problem-3 (&rest _) - "Description" + "Description." 10) (defun macro-problem-10-and-90 () - "" + "Description." (list (macro-problem-3 haha) (macro-aux-3 hehe))) (provide 'macro-problem) diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el index 301993deb30..be6bedf8a1c 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -7,14 +7,14 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;; ;; This is a new, updated version. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday nil @@ -29,7 +29,7 @@ Default changed to nil." ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig Binary files differindex dac168b0e4c..b40620a0e89 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el index ff070c6526f..781077251e9 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-bad nil "Simply a file" +(defgroup signed-bad nil "Simply a file." :group 'lisp) (defcustom signed-bad-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-bad-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-bad) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el index 60b1b8663d9..8a408c1f301 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-good nil "Simply a file" +(defgroup signed-good nil "Simply a file." :group 'lisp) (defcustom signed-good-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-good-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-good) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig Binary files differindex 5b1c721e32a..11092411601 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el index cb003905bb5..f1ee8627610 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el index 9c3f427ff48..459801d78cf 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el index a0a9607350a..8de6141d67a 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-two-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-two-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 29435799555..3b12f57e5ce 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -115,57 +115,55 @@ &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (([&rest form]) body))) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when ,upload-base - (dolist (f '("archive-contents" - "simple-single-1.3.el" - "simple-single-1.4.el" - "simple-single-readme.txt")) - (ignore-errors - (delete-file - (expand-file-name f package-test-archive-upload-base)))) - (delete-directory package-test-archive-upload-base)) - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." @@ -180,7 +178,7 @@ (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir))) (defun package-test-suffix-matches (base suffix-list) - "Return file names matching BASE concatenated with each item in SUFFIX-LIST" + "Return file names matching BASE concatenated with each item in SUFFIX-LIST." (mapcan (lambda (item) (file-expand-wildcards (concat base item))) suffix-list)) @@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)." (declare-function macro-problem-func "macro-problem" ()) (declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) @@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -636,7 +664,7 @@ but with a different end of line convention (bug#48137)." (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) (save-excursion (should (search-forward "Version: 1.3" nil t))) (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) - (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t))) + (save-excursion (should (search-forward "Website: http://doodles.au" nil t))) (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) (save-excursion (should (search-forward "This package provides a minor mode to frobnicate" nil t))) @@ -652,7 +680,7 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'multi-file) (goto-char (point-min)) - (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "Website: http://puddles.li" nil t)) (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) @@ -665,7 +693,7 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "Homepage: http://doodles.au" nil t)) + (should (search-forward "Website: http://doodles.au" nil t)) (should (search-forward "This package provides a minor mode to frobnicate" nil t))))) @@ -678,32 +706,30 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'multi-file) (goto-char (point-min)) - (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "Website: http://puddles.li" nil t)) (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) (defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (concat "HOME=" homedir) - process-environment))) - (require 'epg-config) - (defvar epg-config--program-alist) - (epg-find-configuration - 'OpenPGP nil - ;; By default we require gpg2 2.1+ due to some - ;; practical problems with pinentry. But this - ;; test works fine with 2.0 as well. - (let ((prog-alist (copy-tree epg-config--program-alist))) - (setf (alist-get "gpg2" - (alist-get 'OpenPGP prog-alist) - nil nil #'equal) - "2.0") - prog-alist))) - (delete-directory homedir t)))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 2120139ec18..7ad01e7aef7 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -100,4 +100,61 @@ (should (equal (funcall f 'b1) '(4 5 nil nil))) (should (equal (funcall f 'b2) '(nil nil 8 9))))) +(ert-deftest pcase-tests-cl-type () + (should (equal (pcase 1 + ((cl-type integer) 'integer)) + 'integer)) + (should (equal (pcase 1 + ((cl-type (integer 0 2)) 'integer-0<=n<=2)) + 'integer-0<=n<=2)) + (should-error (pcase 1 + ((cl-type notatype) 'integer)))) + +(ert-deftest pcase-tests-setq () + (should (equal (let (a b) + (pcase-setq `((,a) (,b)) '((1) (2))) + (list a b)) + (list 1 2))) + + (should (equal (list nil nil) + (let ((a 'unset) + (b 'unset)) + (pcase-setq `(head ,a ,b) nil) + (list a b)))) + + (should (equal (let (a b) + (pcase-setq `[,a ,b] [1 2]) + (list a b)) + '(1 2))) + + (should-error (let (a b) + (pcase-setq `[,a ,b] nil) + (list a b))) + + (should (equal (let (a b) + (pcase-setq a 1 b 2) + (list a b)) + '(1 2))) + + (should (= (let (a) + (pcase-setq a 1 `(,a) '(2)) + a) + 2)) + + (should (equal (let (array list-item array-copy) + (pcase-setq (or `(,list-item) array) [1 2 3] + array-copy array + ;; This re-sets `array' to nil. + (or `(,list-item) array) '(4)) + (list array array-copy list-item)) + '(nil [1 2 3] 4))) + + (let ((a nil)) + (should-error (pcase-setq a 1 b) + :type '(wrong-number-of-arguments)) + (should (eq a nil))) + + (should-error (pcase-setq a) + :type '(wrong-number-of-arguments))) + ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..2b2001d0964 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,124 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index b04030cc432..4cae1a73775 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 940feb5e828..65494e20df6 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -66,4 +66,4 @@ (should (equal (regexp-opt-charset '()) regexp-unmatchable))) -;;; regexp-tests.el ends here. +;;; regexp-opt-tests.el ends here diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 4828df0de92..3bc35feb6dd 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'rx) @@ -583,3 +585,5 @@ "\\(?3:.+$\\)"))) (provide 'rx-tests) + +;;; rx-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 05c7fbe781e..8dc0b93b5af 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -336,6 +336,33 @@ Evaluate BODY for each created sequence. (should (same-contents-p list vector)) (should (vectorp vector)))) +(ert-deftest test-seq-union () + (let ((v1 '(1 2 3)) + (v2 '(3 5))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 5)))) + + (let ((v1 '(1 2 3 4 5 6)) + (v2 '(4 5 6 7 8 9))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 7 8 9)))) + + (let ((v1 [1 2 3 4 5]) + (v2 [4 5 6 "a"])) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 "a")))) + + (let ((v1 '("a" "b" "c")) + (v2 '("f" "c" "e" "a"))) + (should (same-contents-p (seq-union v1 v2) + '("a" "b" "c" "f" "e")))) + + (let ((v1 '("a")) + (v2 '("a")) + (testfn #'eq)) + (should (same-contents-p (seq-union v1 v2 testfn) + '("a" "a"))))) + (ert-deftest test-seq-intersection () (let ((v1 [2 3 4 5]) (v2 [1 3 5 6 7])) @@ -383,6 +410,30 @@ Evaluate BODY for each created sequence. (should (null b)) (should (null c))))) +(ert-deftest test-seq-setq () + (with-test-sequences (seq '(1 2 3 4)) + (let (a b c d e) + (seq-setq (a b c d e) seq) + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (let (a b others) + (seq-setq (a b &rest others) seq) + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((a) + (seq '(1 (2 (3 (4)))))) + (seq-setq (_ (_ (_ (a)))) seq) + (should (= a 4))) + (let (seq a b c) + (seq-setq (a b c) seq) + (should (null a)) + (should (null b)) + (should (null c)))) + (ert-deftest test-seq-min-max () (with-test-sequences (seq '(4 5 3 2 0 4)) (should (= (seq-min seq) 0)) diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 3bb3185649b..cfb0b4244bc 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'shortdoc) @@ -43,3 +45,5 @@ (setq props (cddr props)))))))) (provide 'shortdoc-tests) + +;;; shortdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index ef04cde3867..f9cfea888c7 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -455,18 +455,18 @@ "Test `thread-first' wraps single function names." (should (equal (macroexpand '(thread-first 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-first (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-first-expansion () "Test `thread-first' expands correctly." (should (equal (macroexpand '(thread-first - 5 + 5 (+ 20) (/ 25) - @@ -477,13 +477,13 @@ "Test several `thread-first' examples." (should (equal (thread-first (+ 40 2)) 42)) (should (equal (thread-first - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-first - "this-is-a-string" + "this-is-a-string" (split-string "-") (nbutlast 2) (append (list "good"))) @@ -500,18 +500,18 @@ "Test `thread-last' wraps single function names." (should (equal (macroexpand '(thread-last 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-last (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-last-expansion () "Test `thread-last' expands correctly." (should (equal (macroexpand '(thread-last - 5 + 5 (+ 20) (/ 25) - @@ -522,13 +522,13 @@ "Test several `thread-last' examples." (should (equal (thread-last (+ 40 2)) 42)) (should (equal (thread-last - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-last - (list 1 -2 3 -4 5) + (list 1 -2 3 -4 5) (mapcar #'abs) (cl-reduce #'+) (format "abs sum is: %s")) @@ -638,5 +638,43 @@ (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/tabulated-list-test.el b/test/lisp/emacs-lisp/tabulated-list-tests.el index db1ce312586..e376d2f328d 100644 --- a/test/lisp/emacs-lisp/tabulated-list-test.el +++ b/test/lisp/emacs-lisp/tabulated-list-tests.el @@ -1,4 +1,4 @@ -;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- +;;; tabulated-list-tests.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. @@ -56,10 +56,10 @@ (tabulated-list--test-with-buffer ;; Basic printing. (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs - 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) ;; Preserve position. (forward-line 3) (let ((pos (thing-at-point 'line))) @@ -67,16 +67,16 @@ (tabulated-list-print t) (should (equal (thing-at-point 'line) pos)) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) ;; Check the UPDATE argument (pop tabulated-list-entries) (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) (tabulated-list-print t t) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " x x 944 available XX - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) (should (equal (thing-at-point 'line) pos))))) (ert-deftest tabulated-list-sort () @@ -86,25 +86,26 @@ (skip-chars-forward "[:blank:]") (tabulated-list-sort) (let ((text (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files - zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + (should (string= text + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files + zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) (skip-chars-forward "^[:blank:]") (skip-chars-forward "[:blank:]") (should (equal (get-text-property (point) 'tabulated-list-column-name) "name-2")) (tabulated-list-sort) - ;; Check a `t' as the sorting predicate. + ;; Check a t as the sorting predicate. (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) ;; Invert. (tabulated-list-sort 1) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs - mode mode 1128 installed A simple mode for editing Actionscript 3 files - abc-mode abc-mode 944 available Major mode for editing abc music files - 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + mode mode 1128 installed A simple mode for editing Actionscript 3 files + abc-mode abc-mode 944 available Major mode for editing abc music files + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) ;; Again (tabulated-list-sort 1) (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) @@ -114,5 +115,4 @@ (should-error (tabulated-list-sort) :type 'user-error) (should-error (tabulated-list-sort 4) :type 'user-error))) -(provide 'tabulated-list-test) -;;; tabulated-list-test.el ends here +;;; tabulated-list-tests.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 7ced257c6f9..29094526d7e 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -77,12 +77,12 @@ "Testcover doesn't prevent testing of defcustom values." ;; ==== (defgroup testcover-testcase nil - "Test case for testcover" + "Test case for testcover." :group 'lisp :prefix "testcover-testcase-" :version "26.0") (defcustom testcover-testcase-flag t - "Test value used by testcover-tests.el" + "Test value used by testcover-tests.el." :type 'boolean :group 'testcover-testcase) (defun testcover-testcase-get-flag () @@ -111,7 +111,7 @@ "Wrapping a form with noreturn prevents splotching." ;; ==== (defun testcover-testcase-cancel (spacecraft) - (error "no destination for %s" spacecraft)) + (error "No destination for %s" spacecraft)) (defun testcover-testcase-launch (spacecraft planet) (if (null planet) (noreturn (testcover-testcase-cancel spacecraft%%%)) @@ -220,7 +220,7 @@ (defun testcover-testcase-cc (arg) (condition-case nil (if (null arg%%%)%%% - (error "foo") + (error "Foo") "0")!!! (error nil))) (should-not (testcover-testcase-cc nil)) @@ -510,4 +510,4 @@ regarding the odd-looking coverage result for the quoted form." (testcover-testcase-cyc2 1 2) (testcover-testcase-cyc2 1 4) -;; testcases.el ends here. +;;; testcases.el ends here diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 7854e33e77d..a7e055a28b1 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -99,32 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; which can happen if Testcover fails to attach itself - ;; correctly. Note that this will prevent debugging - ;; these tests using Edebug. - (cl-letf (((symbol-function #'edebug-default-enter) - (lambda (&rest _args) - (ert-fail "Debugger invoked during test run")))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) + (lambda (&rest _args) + (ert-fail "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el index b2a48d80675..f0d9b032438 100644 --- a/test/lisp/emacs-lisp/unsafep-tests.el +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -105,7 +105,7 @@ . (variable (x))) ( (let (1) 2) . (variable 1)) - ( (error "asdf") + ( (error "Asdf") . #'error) ( (signal 'error "asdf") . #'signal) diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index 0d999763b61..b8efc87ab70 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -21,7 +21,8 @@ ;;; Code: - +(require 'ert) +(require 'ert-x) (require 'viper) (defun viper-test-undo-kmacro (kmacro) @@ -30,47 +31,42 @@ This function makes as many attempts as possible to clean up after itself, although it will leave a buffer called *viper-test-buffer* if it fails (this is deliberate!)." - (let ( - ;; Viper just turns itself off during batch use. - (noninteractive nil) - ;; Switch off start up message or it will chew the key presses. - (viper-inhibit-startup-message 't) - ;; Select an expert-level for the same reason. - (viper-expert-level 5) - ;; viper loads this even with -q so make sure it's empty! - (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc")) - (before-buffer (current-buffer))) - (unwind-protect - (progn - ;; viper-mode is essentially global, so set it here. - (viper-mode) - ;; We must switch to buffer because we are using a keyboard macro - ;; which appears to not go to the current-buffer but what ever is - ;; currently taking keyboard events. We use a named buffer because - ;; then we can see what it in it if it all goes wrong. - (switch-to-buffer - (get-buffer-create - "*viper-test-buffer*")) - (erase-buffer) - ;; The new buffer fails to enter vi state so set it. - (viper-change-state-to-vi) - ;; Run the macro. - (execute-kbd-macro kmacro) - (let ((rtn - (buffer-substring-no-properties - (point-min) - (point-max)))) - ;; Kill the buffer iff the macro succeeds. - (kill-buffer) - rtn)) - ;; Switch everything off and restore the buffer. - (toggle-viper-mode) - (delete-file viper-custom-file-name) - (switch-to-buffer before-buffer)))) - -(ert-deftest viper-test-go () - "Test that this file is running." - (should t)) + (ert-with-temp-file viper-custom-file-name + ;; viper loads this even with -q so make sure it's empty! + :prefix "emacs-viper-tests" :suffix ".elc" + (let (;; Viper just turns itself off during batch use. + (noninteractive nil) + ;; Switch off start up message or it will chew the key presses. + (viper-inhibit-startup-message 't) + ;; Select an expert-level for the same reason. + (viper-expert-level 5) + (before-buffer (current-buffer))) + (unwind-protect + (progn + ;; viper-mode is essentially global, so set it here. + (viper-mode) + ;; We must switch to buffer because we are using a keyboard macro + ;; which appears to not go to the current-buffer but what ever is + ;; currently taking keyboard events. We use a named buffer because + ;; then we can see what it in it if it all goes wrong. + (switch-to-buffer + (get-buffer-create + "*viper-test-buffer*")) + (erase-buffer) + ;; The new buffer fails to enter vi state so set it. + (viper-change-state-to-vi) + ;; Run the macro. + (execute-kbd-macro kmacro) + (let ((rtn + (buffer-substring-no-properties + (point-min) + (point-max)))) + ;; Kill the buffer iff the macro succeeds. + (kill-buffer) + rtn)) + ;; Switch everything off and restore the buffer. + (toggle-viper-mode) + (switch-to-buffer before-buffer))))) (ert-deftest viper-test-fix () "Test that the viper kmacro fixture is working." diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 741574f0adf..1384221c491 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -58,48 +58,45 @@ (cl-defmacro with-epg-tests ((&optional &key require-passphrase require-public-key require-secret-key) - &rest body) + &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (sexp body))) - `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t)) - (process-environment - (append - (list "GPG_AGENT_INFO" - (format "GNUPGHOME=%s" epg-tests-home-directory)) - process-environment))) - (unwind-protect - ;; GNUPGHOME is needed to find a usable gpg, so we can't - ;; check whether to skip any earlier (Bug#23561). - (let ((epg-config (or (epg-tests-find-usable-gpg-configuration - ,require-passphrase ,require-public-key) - (ert-skip "No usable gpg config"))) - (context (epg-make-context 'OpenPGP))) - (setf (epg-context-program context) - (alist-get 'program epg-config)) - (setf (epg-context-home-directory context) - epg-tests-home-directory) - ,(if require-passphrase - '(with-temp-file (expand-file-name - "gpg-agent.conf" epg-tests-home-directory) - (insert "pinentry-program " - (ert-resource-file "dummy-pinentry") - "\n") - (epg-context-set-passphrase-callback - context - #'epg-tests-passphrase-callback))) - ,(if require-public-key - '(epg-import-keys-from-file - context - (ert-resource-file "pubkey.asc"))) - ,(if require-secret-key - '(epg-import-keys-from-file - context - (ert-resource-file "seckey.asc"))) - (with-temp-buffer - (setq-local epg-tests-context context) - ,@body)) - (when (file-directory-p epg-tests-home-directory) - (delete-directory epg-tests-home-directory t))))) + `(ert-with-temp-directory epg-tests-home-directory + (let* ((process-environment + (append + (list "GPG_AGENT_INFO" + (format "GNUPGHOME=%s" epg-tests-home-directory)) + process-environment))) + ;; GNUPGHOME is needed to find a usable gpg, so we can't + ;; check whether to skip any earlier (Bug#23561). + (let ((epg-config (or (epg-tests-find-usable-gpg-configuration + ,require-passphrase ,require-public-key) + (ert-skip "No usable gpg config"))) + (context (epg-make-context 'OpenPGP))) + (setf (epg-context-program context) + (alist-get 'program epg-config)) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + ,(if require-passphrase + '(with-temp-file (expand-file-name + "gpg-agent.conf" epg-tests-home-directory) + (insert "pinentry-program " + (ert-resource-file "dummy-pinentry") + "\n") + (epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback))) + ,(if require-public-key + '(epg-import-keys-from-file + context + (ert-resource-file "pubkey.asc"))) + ,(if require-secret-key + '(epg-import-keys-from-file + context + (ert-resource-file "seckey.asc"))) + (with-temp-buffer + (setq-local epg-tests-context context) + ,@body))))) (ert-deftest epg-decrypt-1 () :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index d13397274aa..b2dbc1012de 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -24,6 +24,7 @@ (require 'ert) (require 'erc) (require 'erc-ring) +(require 'erc-networks) (ert-deftest erc--read-time-period () (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) @@ -47,6 +48,85 @@ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) (should (equal (erc--read-time-period "foo: ") 86400)))) +(ert-deftest erc-with-all-buffers-of-server () + (let (proc-exnet + proc-onet + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer (get-buffer-create "OtherNet") + (erc-mode) + (setq proc-onet (start-process "sleep" (current-buffer) "sleep" "1") + erc-server-process proc-onet + erc-network 'OtherNet) + (set-process-query-on-exit-flag erc-server-process nil)) + + (with-current-buffer (get-buffer-create "ExampleNet") + (erc-mode) + (setq proc-exnet (start-process "sleep" (current-buffer) "sleep" "1") + erc-server-process proc-exnet + erc-network 'ExampleNet) + (set-process-query-on-exit-flag erc-server-process nil)) + + (with-current-buffer (get-buffer-create "#foo") + (erc-mode) + (setq erc-server-process proc-exnet) + (setq erc-default-recipients '("#foo"))) + + (with-current-buffer (get-buffer-create "#spam") + (erc-mode) + (setq erc-server-process proc-onet) + (setq erc-default-recipients '("#spam"))) + + (with-current-buffer (get-buffer-create "#bar") + (erc-mode) + (setq erc-server-process proc-onet) + (setq erc-default-recipients '("#bar"))) + + (with-current-buffer (get-buffer-create "#baz") + (erc-mode) + (setq erc-server-process proc-exnet) + (setq erc-default-recipients '("#baz"))) + + (should (eq (get-buffer-process "ExampleNet") proc-exnet)) + (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet") + nil + (kill-buffer)) + + (should-not (get-buffer "ExampleNet")) + (should-not (get-buffer "#foo")) + (should-not (get-buffer "#baz")) + (should (get-buffer "OtherNet")) + (should (get-buffer "#bar")) + (should (get-buffer "#spam")) + + (let* ((test (lambda () (not (string= (buffer-name) "#spam")))) + (calls 0) + (get-test (lambda () (cl-incf calls) test))) + + (erc-with-all-buffers-of-server proc-onet + (funcall get-test) + (kill-buffer)) + + (should (= calls 1))) + + (should-not (get-buffer "OtherNet")) + (should-not (get-buffer "#bar")) + (should (get-buffer "#spam")) + (kill-buffer "#spam"))) + +(ert-deftest erc-lurker-maybe-trim () + (let (erc-lurker-trim-nicks + (erc-lurker-ignore-chars "_`")) + + (should (string= "nick`" (erc-lurker-maybe-trim "nick`"))) + + (setq erc-lurker-trim-nicks t) + (should (string= "nick" (erc-lurker-maybe-trim "nick`"))) + (should (string= "ni`_ck" (erc-lurker-maybe-trim "ni`_ck__``"))) + + (setq erc-lurker-ignore-chars "_-`") ; set of chars, not character alts + (should (string= "nick" (erc-lurker-maybe-trim "nick-_`"))))) + (ert-deftest erc-ring-previous-command-base-case () (ert-info ("Create ring when nonexistent and do nothing") (let (erc-input-ring @@ -61,13 +141,16 @@ (with-current-buffer (get-buffer-create "*#fake*") (erc-mode) (insert "\n\n") - (setq erc-input-marker (make-marker) ; these are all local - erc-insert-marker (make-marker) - erc-send-completed-hook nil) + (should-not (local-variable-if-set-p 'erc-send-completed-hook)) + (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals) + (setq erc-input-marker (make-marker) + erc-insert-marker (make-marker)) (set-marker erc-insert-marker (point-max)) (erc-display-prompt) (should (= (point) erc-input-marker)) - (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring nil t) + ;; Just in case erc-ring-mode is already on + (setq-local erc-pre-send-functions nil) + (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring) ;; (cl-letf (((symbol-function 'erc-process-input-line) (lambda (&rest _) @@ -109,3 +192,111 @@ (should (looking-at "abc"))))) (when noninteractive (kill-buffer "*#fake*"))) + +(ert-deftest erc-log-irc-protocol () + (should-not erc-debug-irc-protocol) + (with-temp-buffer + (setq erc-server-process (start-process "fake" (current-buffer) "true") + erc-server-current-nick "tester" + erc-session-server "myproxy.localhost" + erc-session-port 6667) + (let ((inhibit-message noninteractive)) + (erc-toggle-debug-irc-protocol) + (erc-log-irc-protocol "PASS changeme\r\n" 'outgoing) + (setq erc-server-announced-name "irc.gnu.org") + (erc-log-irc-protocol ":irc.gnu.org 001 tester :Welcome") + (erc-log-irc-protocol ":irc.gnu.org 002 tester :Your host is irc.gnu.org") + (setq erc-network 'FooNet) + (erc-log-irc-protocol ":irc.gnu.org 422 tester :MOTD missing") + (setq erc-network 'BarNet) + (erc-log-irc-protocol ":irc.gnu.org 221 tester +i") + (set-process-query-on-exit-flag erc-server-process nil))) + (with-current-buffer "*erc-protocol*" + (goto-char (point-min)) + (search-forward "Version") + (search-forward "\r\n\r\n") + (search-forward "myproxy.localhost:6667 >> PASS" (line-end-position)) + (forward-line) + (search-forward "irc.gnu.org << :irc.gnu.org 001" (line-end-position)) + (forward-line) + (search-forward "irc.gnu.org << :irc.gnu.org 002" (line-end-position)) + (forward-line) + (search-forward "FooNet << :irc.gnu.org 422" (line-end-position)) + (forward-line) + (search-forward "BarNet << :irc.gnu.org 221" (line-end-position))) + (when noninteractive + (kill-buffer "*erc-protocol*") + (should-not erc-debug-irc-protocol))) + + +;; The point of this test is to ensure output is handled identically +;; regardless of whether a command handler is summoned. + +(ert-deftest erc-process-input-line () + (let (erc-server-last-sent-time + erc-server-flood-queue + (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) + (erc-default-recipients '("#chan")) + calls) + (with-temp-buffer + (cl-letf (((symbol-function 'erc-cmd-MSG) + (lambda (line) + (push line calls) + (funcall orig-erc-cmd-MSG line))) + ((symbol-function 'erc-server-buffer) + (lambda () (current-buffer))) + ((symbol-function 'erc-server-process-alive) + (lambda () t)) + ((symbol-function 'erc-server-send-queue) + #'ignore)) + + (ert-info ("Dispatch to user command handler") + + (ert-info ("Baseline") + (erc-process-input-line "/msg #chan hi\n") + (should (equal (pop calls) " #chan hi")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Quote preserves line intact") + (erc-process-input-line "/QUOTE FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Unknown command respected") + (erc-process-input-line "/FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "/msg #chan hi you\n") + (should (equal (pop calls) " #chan hi you")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line honored") + (erc-process-input-line "/msg #chan\n") + (should (equal (pop calls) " #chan")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8))))) + + (ert-info ("Implicit cmd via `erc-send-input-line-function'") + + (ert-info ("Baseline") + (erc-process-input-line "hi") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "hi you") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line transmitted without injected-space kludge") + (erc-process-input-line "") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8)))) + + (should-not calls)))))) + +;;; erc-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 0ce93bd45c6..b2687a96ab3 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -119,3 +119,5 @@ '(bold erc-current-nick-face) str1) (should (erc-faces-in str0)) (should (erc-faces-in str1)) )) + +;;; erc-track-tests.el ends here diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index 31967a61c3c..5bc5690675d 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -20,19 +20,18 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-hist) (ert-deftest eshell-write-readonly-history () "Test that having read-only strings in history is okay." - (let ((histfile (make-temp-file "eshell-history")) - (eshell-history-ring (make-ring 2))) - (ring-insert eshell-history-ring - (propertize "echo foo" 'read-only t)) - (ring-insert eshell-history-ring - (propertize "echo bar" 'read-only t)) - (unwind-protect - (eshell-write-history histfile) - (delete-file histfile)))) + (ert-with-temp-file histfile + (let ((eshell-history-ring (make-ring 2))) + (ring-insert eshell-history-ring + (propertize "echo foo" 'read-only t)) + (ring-insert eshell-history-ring + (propertize "echo bar" 'read-only t)) + (eshell-write-history histfile)))) (provide 'em-hist-test) diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index 5d1742b76fd..3ea11ab2de1 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -25,30 +25,30 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-ls) (require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - (orig eshell-ls-use-in-dired) - buf) - (unwind-protect - (progn - (customize-set-value 'eshell-ls-use-in-dired t) - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (customize-set-variable 'eshell-ls-use-in-dired orig) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + (orig eshell-ls-use-in-dired) + buf) + (unwind-protect + (progn + (customize-set-value 'eshell-ls-use-in-dired t) + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (customize-set-variable 'eshell-ls-use-in-dired orig) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest em-ls-test-bug27817 () "Test for https://debbugs.gnu.org/27817 ." diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 4f0cc9b6785..0974784ef4c 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -26,23 +26,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'esh-mode) (require 'eshell) (defmacro with-temp-eshell (&rest body) "Evaluate BODY in a temporary Eshell buffer." - `(let* ((eshell-directory-name (make-temp-file "eshell" t)) - ;; We want no history file, so prevent Eshell from falling - ;; back on $HISTFILE. - (process-environment (cons "HISTFILE" process-environment)) - (eshell-history-file-name nil) - (eshell-buffer (eshell t))) - (unwind-protect - (with-current-buffer eshell-buffer - ,@body) - (let (kill-buffer-query-functions) - (kill-buffer eshell-buffer) - (delete-directory eshell-directory-name t))))) + `(ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer)))))) (defun eshell-insert-command (text &optional func) "Insert a command at the end of the buffer." @@ -65,11 +65,9 @@ (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." - (let ((eshell-directory-name (make-temp-file "eshell" t)) - (eshell-history-file-name nil)) - (unwind-protect - (eshell-command-result command) - (delete-directory eshell-directory-name t)))) + (ert-with-temp-directory eshell-directory-name + (let ((eshell-history-file-name nil)) + (eshell-command-result command)))) ;;; Tests: @@ -262,4 +260,4 @@ chars" (provide 'eshell-tests) -;;; tests/eshell-tests.el ends here +;;; eshell-tests.el ends here diff --git a/test/lisp/faces-resources/faces-test-dark-theme.el b/test/lisp/faces-resources/faces-test-dark-theme.el index f3ef6b67fa7..7e8871ec10a 100644 --- a/test/lisp/faces-resources/faces-test-dark-theme.el +++ b/test/lisp/faces-resources/faces-test-dark-theme.el @@ -22,7 +22,7 @@ ;;; Code: (deftheme faces-test-dark - "") + "Dark test theme.") (custom-theme-set-faces 'faces-test-dark diff --git a/test/lisp/faces-resources/faces-test-light-theme.el b/test/lisp/faces-resources/faces-test-light-theme.el index 390b8461644..70a75017614 100644 --- a/test/lisp/faces-resources/faces-test-light-theme.el +++ b/test/lisp/faces-resources/faces-test-light-theme.el @@ -22,7 +22,7 @@ ;;; Code: (deftheme faces-test-light - "") + "Light test theme.") (custom-theme-set-faces 'faces-test-light diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index c0db9c9de17..fe5f3ec95f8 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -25,7 +25,7 @@ (require 'ert) (require 'ert-x) -(defgroup faces--test nil "" +(defgroup faces--test nil "Group to test faces." :group 'faces--test) (defface faces--test1 diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 3ceb392d7fb..84b9cea6c12 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -25,30 +25,29 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'ffap) (ert-deftest ffap-tests-25243 () "Test for https://debbugs.gnu.org/25243 ." - (let ((file (make-temp-file "test-Bug#25243"))) - (unwind-protect - (with-temp-file file - (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el + (ert-with-temp-file file + :suffix "-bug25243" + (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el index 3d7cebadcf..ad4b70d737 100644 --- b/lisp/ffap.el +++ a/lisp/ffap.el @@ -203,6 +203,9 @@ ffap-foo-at-bar-prefix ")) - (transient-mark-mode 1) - (when (natnump ffap-max-region-length) - (insert - (concat - str - (make-string ffap-max-region-length #xa) - (format "%s ENDS HERE" file))) - (call-interactively 'mark-whole-buffer) - (should (equal "" (ffap-string-at-point))) - (should (equal '(1 1) ffap-string-at-point-region))))) - (and (file-exists-p file) (delete-file file))))) + (transient-mark-mode 1) + (when (natnump ffap-max-region-length) + (insert + (concat + str + (make-string ffap-max-region-length #xa) + (format "%s ENDS HERE" file))) + (call-interactively 'mark-whole-buffer) + (should (equal "" (ffap-string-at-point))) + (should (equal '(1 1) ffap-string-at-point-region)))))) (ert-deftest ffap-gopher-at-point () (with-temp-buffer @@ -123,6 +122,25 @@ left alone when opening a URL in an external browser." (save-excursion (insert "type=")) (ffap-guess-file-name-at-point)))) +(ert-deftest ffap-ido-mode () + (require 'ido) + (with-temp-buffer + (let ((ido-mode t) + (read-file-name-function read-file-name-function) + (read-buffer-function read-buffer-function)) + ;; Says ert-deftest: + ;; Macros in BODY are expanded when the test is defined, not when it + ;; is run. If a macro (possibly with side effects) is to be tested, + ;; it has to be wrapped in `(eval (quote ...))'. + (eval (quote (ido-everywhere))) + (let ((read-file-name-function (lambda (&rest args) + (expand-file-name + (nth 4 args) + (nth 1 args))))) + (save-excursion (insert "ffap-tests.el")) + (let (kill-buffer-query-functions) + (kill-buffer (call-interactively #'find-file-at-point))))))) + (provide 'ffap-tests) ;;; ffap-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 6125069c6b3..0fe72f278dc 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -162,9 +162,7 @@ Return nil when any other file notification watch is still active." (defun file-notify--test-cleanup () "Cleanup after a test." - (file-notify-rm-watch file-notify--test-desc) - (file-notify-rm-watch file-notify--test-desc1) - (file-notify-rm-watch file-notify--test-desc2) + (file-notify-rm-all-watches) (ignore-errors (delete-file (file-newest-backup file-notify--test-tmpfile))) @@ -421,7 +419,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; This test is inspired by Bug#26126 and Bug#26127. (ert-deftest file-notify-test02-rm-watch () - "Check `file-notify-rm-watch'." + "Check `file-notify-rm-watch' and `file-notify-rm-all-watches'." (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -517,6 +515,31 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (file-notify--test-cleanup-p)))) ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check `file-notify-rm-all-watches'. + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile1 '(change) #'ignore))) + (file-notify-rm-all-watches) + (delete-file file-notify--test-tmpfile) + (delete-file file-notify--test-tmpfile1) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test02-rm-watch @@ -743,7 +766,7 @@ delivered." ;; the directory. Except for ;; GFam{File,Directory}Monitor, GPollFileMonitor and ;; kqueue. And GFam{File,Directory}Monitor and - ;; GPollFileMonitordo not raise a `changed' event. + ;; GPollFileMonitor do not raise a `changed' event. ((memq (file-notify--test-monitor) '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created deleted stopped)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index a5c82360177..1e20317739a 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -154,12 +154,14 @@ form.") (ert-deftest files-tests-permanent-local-variables () (let ((enable-local-variables nil)) (with-temp-buffer + (setq lexical-binding nil) (insert ";;; test-test.el --- tests -*- lexical-binding: t; -*-\n\n") (hack-local-variables) (should (eq lexical-binding t)))) (let ((enable-local-variables nil) (permanently-enabled-local-variables nil)) (with-temp-buffer + (setq lexical-binding nil) (insert ";;; test-test.el --- tests -*- lexical-binding: t; -*-\n\n") (hack-local-variables) (should (eq lexical-binding nil))))) @@ -174,15 +176,14 @@ form.") ;; If called interactively, environment variable ;; $EMACS_TEST_DIRECTORY does not exist. (skip-unless (file-exists-p files-test-bug-18141-file)) - (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) - (unwind-protect - (progn - (copy-file files-test-bug-18141-file tempfile t) - (with-current-buffer (find-file-noselect tempfile) - (set-buffer-modified-p t) - (save-buffer) - (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + :prefix "emacs-test-files-bug-18141" + :suffix ".gz" + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix))))) (ert-deftest files-tests-make-temp-file-empty-prefix () "Test make-temp-file with an empty prefix." @@ -206,24 +207,24 @@ form.") "Test for https://debbugs.gnu.org/21454 ." (let ((input-result (if (memq system-type '(windows-nt ms-dos)) - '(("x:/foo/bar//baz/;y:/bar/foo/baz//" nil - ("x:/foo/bar/baz/" "y:/bar/foo/baz/")) + '(("/foo/bar//baz/;/bar/foo/baz//" nil + ("/foo/bar//baz/" "/bar/foo/baz//")) ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo" nil ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x://foo/bar/;y:/bar/qux/;z:/qux/foo/" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x://foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo/" nil ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo/" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo/bar" "$FOO/baz/;z:/qux/foo/" ("x:/foo/bar/baz/" "z:/qux/foo/")) - ("x://foo/bar/" "$FOO/baz/;z:/qux/foo/" - ("x:/foo/bar/baz/" "z:/qux/foo/"))) + ("//foo/bar/" "$FOO/baz/;/qux/foo/" + ("/foo/bar//baz/" "/qux/foo/"))) '(("/foo/bar//baz/:/bar/foo/baz//" nil - ("/foo/bar/baz/" "/bar/foo/baz/")) + ("/foo/bar//baz/" "/bar/foo/baz//")) ("/foo/bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) ("//foo/bar/:/bar/qux/:/qux/foo/" nil @@ -231,11 +232,11 @@ form.") ("/foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) ("/foo//bar/:/bar/qux/:/qux/foo/" nil - ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) ("/foo//bar/:/bar/qux/:/qux/foo" nil - ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) ("/foo/bar" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")) - ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/"))))) + ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar//baz/" "/qux/foo/"))))) (foo-env (getenv "FOO")) (bar-env (getenv "BAR"))) (unwind-protect @@ -281,22 +282,20 @@ If we are in a directory named `~', the default value should not be $HOME." (cl-letf (((symbol-function 'completing-read) (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (or def init)))) + (ert-with-temp-directory dir + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir)))))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. @@ -316,7 +315,9 @@ be $HOME." (ert-deftest files-tests-file-name-non-special--subprocess () "Check that Bug#25949 and Bug#48177 are fixed." - (skip-unless (and (executable-find "true") (file-exists-p null-device))) + (skip-unless (and (executable-find "true") (file-exists-p null-device) + ;; These systems cannot set date of the null device. + (not (memq system-type '(windows-nt ms-dos))))) (let ((default-directory (file-name-quote temporary-file-directory)) (true (file-name-quote (executable-find "true"))) (null (file-name-quote null-device))) @@ -337,14 +338,6 @@ be $HOME." (progn ,@body) (advice-remove #',symbol ,function))))) -(defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1) (debug (symbolp body))) - (cl-check-type name symbol) - `(let ((,name (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,name)))) - (ert-deftest files-tests-file-name-non-special--buffers () "Check that Bug#25951 is fixed. We call `verify-visited-file-modtime' on a buffer visiting a file @@ -353,7 +346,7 @@ the buffer current and a nil argument, second passing the buffer object explicitly. In both cases no error should be raised and the `file-name-non-special' handler for quoted file names should be invoked with the right arguments." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) @@ -608,7 +601,7 @@ unquoted file names." (ert-deftest files-tests-file-name-non-special-dired-compress-handler () ;; `dired-compress-file' can get confused by filenames with ":" in ;; them, which causes this to fail on `windows-nt' systems. - (when (string-match-p ":" (expand-file-name temporary-file-directory)) + (when (string-search ":" (expand-file-name temporary-file-directory)) (ert-skip "FIXME: `dired-compress-file' unreliable when filenames contain `:'.")) (files-tests--with-temp-non-special (tmpfile nospecial) (let ((compressed (dired-compress-file nospecial))) @@ -951,40 +944,51 @@ unquoted file names." (ert-deftest files-test-auto-save-name-default () (with-temp-buffer - (let ((auto-save-file-name-transforms nil)) + (let ((auto-save-file-name-transforms nil) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) (setq buffer-file-name "/tmp/foo.txt") - (should (equal (make-auto-save-file-name) "/tmp/#foo.txt#"))))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/tmp/#foo.txt#"))))) (ert-deftest files-test-auto-save-name-transform () (with-temp-buffer (setq buffer-file-name "/tmp/foo.txt") (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" nil)))) - (should (equal (make-auto-save-file-name) "/var/tmp/#foo.txt#"))))) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" nil))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/var/tmp/#foo.txt#"))))) (ert-deftest files-test-auto-save-name-unique () (with-temp-buffer (setq buffer-file-name "/tmp/foo.txt") (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t)))) - (should (equal (make-auto-save-file-name) "/var/tmp/#!tmp!foo.txt#"))) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/var/tmp/#!tmp!foo.txt#"))) (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1)))) - (should (equal (make-auto-save-file-name) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) "/var/tmp/#b57c5a04f429a83305859d3350ecdab8315a9037#"))))) (ert-deftest files-test-lock-name-default () - (let ((lock-file-name-transforms nil)) - (should (equal (make-lock-file-name "/tmp/foo.txt") "/tmp/.#foo.txt")))) + (let ((lock-file-name-transforms nil) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) + "/tmp/.#foo.txt")))) (ert-deftest files-test-lock-name-unique () (let ((lock-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t)))) - (should (equal (make-lock-file-name "/tmp/foo.txt") + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) "/var/tmp/.#!tmp!foo.txt"))) (let ((lock-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1)))) - (should (equal (make-lock-file-name "/tmp/foo.txt") + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) "/var/tmp/.#b57c5a04f429a83305859d3350ecdab8315a9037")))) (ert-deftest files-tests-file-name-non-special-make-directory () @@ -1224,26 +1228,26 @@ works as expected if the default directory is quoted." (insert-directory-wildcard-in-dir-p (car path-res))))))) (ert-deftest files-tests-make-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (file (concat dirname "file")) - (subdir1 (concat dirname "subdir1")) - (subdir2 (concat dirname "subdir2")) - (a/b (concat dirname "a/b"))) - (write-region "" nil file) - (should-error (make-directory "/")) - (should-not (make-directory "/" t)) - (should-error (make-directory dir)) - (should-not (make-directory dir t)) - (should-error (make-directory dirname)) - (should-not (make-directory dirname t)) - (should-error (make-directory file)) - (should-error (make-directory file t)) - (should-not (make-directory subdir1)) - (should-not (make-directory subdir2 t)) - (should-error (make-directory a/b)) - (should-not (make-directory a/b t)) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (file (concat dirname "file")) + (subdir1 (concat dirname "subdir1")) + (subdir2 (concat dirname "subdir2")) + (a/b (concat dirname "a/b"))) + (write-region "" nil file) + (should-error (make-directory "/")) + (should-not (make-directory "/" t)) + (should-error (make-directory dir)) + (should-not (make-directory dir t)) + (should-error (make-directory dirname)) + (should-not (make-directory dirname t)) + (should-error (make-directory file)) + (should-error (make-directory file t)) + (should-not (make-directory subdir1)) + (should-not (make-directory subdir2 t)) + (should-error (make-directory a/b)) + (should-not (make-directory a/b t)) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-modes-symbolic-to-number () (let ((alist (list (cons "a=rwx" #o777) @@ -1303,7 +1307,7 @@ name (Bug#28412)." (set-buffer-modified-p t) (should-error (save-buffer) :type 'error)) ;; Then a buffer visiting a file: should save normally. - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-current-buffer (find-file-noselect temp-file-name) (setq write-contents-functions nil) (insert "p") @@ -1311,21 +1315,54 @@ name (Bug#28412)." (should (eq (buffer-size) 1)))))) (ert-deftest files-tests-copy-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (source (concat dirname "source")) - (dest (concat dirname "dest/new/directory/")) - (file (concat (file-name-as-directory source) "file")) - (source2 (concat dirname "source2")) - (dest2 (concat dirname "dest/new2"))) - (make-directory source) - (write-region "" nil file) - (copy-directory source dest t t t) - (should (file-exists-p (concat dest "file"))) - (make-directory (concat (file-name-as-directory source2) "a") t) - (copy-directory source2 dest2) - (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (source (concat dirname "source")) + (dest (concat dirname "dest/new/directory/")) + (file (concat (file-name-as-directory source) "file")) + (source2 (concat dirname "source2")) + (dest2 (concat dirname "dest/new2"))) + (make-directory source) + (write-region "" nil file) + (copy-directory source dest t t t) + (should (file-exists-p (concat dest "file"))) + (make-directory (concat (file-name-as-directory source2) "a") t) + (copy-directory source2 dest2) + (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) + (delete-directory dir 'recursive)))) + +(ert-deftest files-tests-abbreviate-file-name-homedir () + ;; Check homedir abbreviation. + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + (should (equal "~/foo/bar" + (abbreviate-file-name (concat homedir "foo/bar"))))) + ;; Check that homedir abbreviation doesn't occur when homedir is just /. + (let* ((homedir "/") + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + (should (equal "/foo/bar" + (abbreviate-file-name (concat homedir "foo/bar")))))) + +(ert-deftest files-tests-abbreviate-file-name-directory-abbrev-alist () + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist '(("\\`/nowhere/special" . "/nw/sp")))) + (should (equal "/nw/sp/here" + (abbreviate-file-name "/nowhere/special/here")))) + ;; Check homedir and `directory-abbrev-alist' abbreviation. + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil) + (directory-abbrev-alist + `((,(concat "\\`" (regexp-quote homedir) "nowhere/special") + . ,(concat homedir "nw/sp"))))) + (should (equal "~/nw/sp/here" + (abbreviate-file-name + (concat homedir "nowhere/special/here")))))) (ert-deftest files-tests-abbreviated-home-dir () "Test that changing HOME does not confuse `abbreviate-file-name'. @@ -1344,43 +1381,40 @@ See <https://debbugs.gnu.org/19657#20>." (ert-deftest files-tests-executable-find () "Test that `executable-find' works also with a relative or remote PATH. See <https://debbugs.gnu.org/35241>." - (let ((tmpfile (make-temp-file "files-test" nil (car exec-suffixes)))) - (unwind-protect - (progn - (set-file-modes tmpfile #o777) - (let ((exec-path `(,temporary-file-directory))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; An empty element of `exec-path' means `default-directory'. - (let ((default-directory temporary-file-directory) - (exec-path nil)) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; The remote file name shall be quoted, and handled like a - ;; non-existing directory. - (let ((default-directory "/ssh::") - (exec-path (append exec-path `("." ,temporary-file-directory)))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile)))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix (car exec-suffixes) + (set-file-modes tmpfile #o755) + (let ((exec-path `(,temporary-file-directory))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; An empty element of `exec-path' means `default-directory'. + (let ((default-directory temporary-file-directory) + (exec-path nil)) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; The remote file name shall be quoted, and handled like a + ;; non-existing directory. + (let ((default-directory "/ssh::") + (exec-path (append exec-path `("." ,temporary-file-directory)))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))))) (ert-deftest files-tests-dont-rewrite-precious-files () "Test that `file-precious-flag' forces files to be saved by renaming only, rather than modified in-place." - (let* ((temp-file-name (make-temp-file "files-tests")) - (advice (lambda (_start _end filename &rest _r) - (should-not (string= filename temp-file-name))))) - (unwind-protect - (with-current-buffer (find-file-noselect temp-file-name) - (advice-add #'write-region :before advice) - (setq-local file-precious-flag t) - (insert "foobar") - (should (null (save-buffer)))) - (ignore-errors (advice-remove #'write-region advice)) - (ignore-errors (delete-file temp-file-name))))) + (ert-with-temp-file temp-file-name + (let* ((advice (lambda (_start _end filename &rest _r) + (should-not (string= filename temp-file-name))))) + (unwind-protect + (with-current-buffer (find-file-noselect temp-file-name) + (advice-add #'write-region :before advice) + (setq-local file-precious-flag t) + (insert "foobar") + (should (null (save-buffer)))) + (ignore-errors (advice-remove #'write-region advice)))))) (ert-deftest files-test-file-size-human-readable () (should (equal (file-size-human-readable 13) "13")) @@ -1446,9 +1480,11 @@ See <https://debbugs.gnu.org/36401>." (ert-deftest files-colon-path () (if (memq system-type '(windows-nt ms-dos)) (should (equal (parse-colon-path "x:/foo//bar/baz") - '("x:/foo/bar/baz/"))) + '("x:/foo//bar/baz/"))) (should (equal (parse-colon-path "/foo//bar/baz") - '("/foo/bar/baz/"))))) + '("/foo//bar/baz/")))) + (should (equal (parse-colon-path (concat "." path-separator "/tmp")) + '("./" "/tmp/")))) (ert-deftest files-test-magic-mode-alist-doctype () "Test that DOCTYPE and variants put files in mhtml-mode." @@ -1492,7 +1528,7 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer () "Test that revert-buffer is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) (write-file temp-file-name) @@ -1505,7 +1541,7 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer-with-fine-grain () "Test that revert-buffer-with-fine-grain is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) (write-file temp-file-name) @@ -1534,6 +1570,14 @@ The door of all subtleties! (should-error (file-name-with-extension "Jack" ".")) (should-error (file-name-with-extension "/is/a/directory/" "css"))) +(ert-deftest files-tests-file-name-base () + (should (equal (file-name-base "") "")) + (should (equal (file-name-base "/foo/") "")) + (should (equal (file-name-base "/foo") "foo")) + (should (equal (file-name-base "/foo/bar") "bar")) + (should (equal (file-name-base "foo") "foo")) + (should (equal (file-name-base "foo/bar") "bar"))) + (ert-deftest files-test-dir-locals-auto-mode-alist () "Test an `auto-mode-alist' entry in `.dir-locals.el'" (find-file (ert-resource-file "whatever.quux")) @@ -1545,5 +1589,223 @@ The door of all subtleties! (find-file (ert-resource-file "auto-test.zot3")) (should (eq major-mode 'fundamental-mode))) +(defun files-tests--save-some-buffers (pred def-pred-bind exp-1 exp-2) + "Helper function to test `save-some-buffers'. + +This function creates two file-visiting buffers, BUF-1, BUF-2 in +different directories at the same level, i.e., none of them is a +subdir of the other; then it modifies both buffers; finally, it +calls `save-some-buffers' from BUF-1 with first arg t, second +arg PRED and `save-some-buffers-default-predicate' let-bound to +DEF-PRED-BIND. + +EXP-1 and EXP-2 are the expected values of calling `buffer-modified-p' +on BUF-1 and BUF-2 after the `save-some-buffers' call. + +The test is repeated with `save-some-buffers-default-predicate' +let-bound to PRED and passing nil as second arg of +`save-some-buffers'." + (ert-with-temp-directory dir + (let* ((file-1 (expand-file-name "subdir-1/file.foo" dir)) + (file-2 (expand-file-name "subdir-2/file.bar" dir)) + (inhibit-message t) + buf-1 buf-2) + (unwind-protect + (progn + (make-empty-file file-1 'parens) + (make-empty-file file-2 'parens) + (setq buf-1 (find-file file-1) + buf-2 (find-file file-2)) + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (insert "foobar\n"))) + ;; Run the test. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate def-pred-bind)) + (save-some-buffers t pred)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2)))) + ;; Set both buffers as modified to run another test. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (set-buffer-modified-p t))) + ;; The result of this test must be identical as the previous one. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) + (save-some-buffers t nil)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2))))) + ;; Clean up. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))))))) + +(ert-deftest files-tests-save-some-buffers () + "Test `save-some-buffers'. +Test the 3 cases for the second argument PRED, i.e., nil, t, or +predicate. +The value of `save-some-buffers-default-predicate' is ignored unless +PRED is nil." + (let* ((foo-file-p (lambda () (string-suffix-p ".foo" buffer-file-name))) + (bar-file-p (lambda () (string-suffix-p ".bar" buffer-file-name))) + (args-results `((nil nil nil nil) + (nil ,foo-file-p nil t) + (nil ,bar-file-p t nil) + (,foo-file-p nil nil t) + (,bar-file-p nil t nil) + + (buffer-modified-p nil nil nil) + (t nil nil nil) + (t ,foo-file-p nil nil) + + (,foo-file-p save-some-buffers-root nil t) + (nil save-some-buffers-root nil t) + (,bar-file-p save-some-buffers-root t nil) + (t save-some-buffers-root nil nil)))) + (pcase-dolist (`(,pred ,def-pred-bind ,exp-1 ,exp-2) args-results) + (files-tests--save-some-buffers pred def-pred-bind exp-1 exp-2)))) + +(defmacro files-tests--with-buffer-offer-save (buffers-offer fn-test fn-binders args-results) + "Helper macro to test `save-some-buffers' and `save-buffers-kill-emacs'. + +This macro creates several non-file-visiting buffers in different +directories at the same level, i.e., none of them is a subdir of the +other. Then it modifies the buffers and sets their `buffer-offer-save' +as specified by BUFFERS-OFFER, a list of elements (BUFFER OFFER-SAVE). +Finally, it calls FN-TEST from the first buffer. + +FN-TEST is the function to test: either `save-some-buffers' or +`save-buffers-kill-emacs'. This function is called with +`save-some-buffers-default-predicate' let-bound to a value +specified inside ARGS-RESULTS. + +FN-BINDERS is a list of elements (FUNCTION . BINDING), where FUNCTION +is a function symbol that this macro temporary binds to BINDING during +the FN-TEST call. + +ARGS-RESULTS is a list of elements (FN-ARGS CALLERS-DIR EXPECTED), where +FN-ARGS are the arguments for FN-TEST; +CALLERS-DIR specifies the value to let-bind +\`save-some-buffers-default-predicate'; + EXPECTED is the expected result of the test." + (declare (debug (form symbol form form))) + (let ((dir (gensym "dir")) + (buffers (gensym "buffers"))) + `(let* ((,dir (make-temp-file "testdir" 'dir)) + (inhibit-message t) + (use-dialog-box nil) + ,buffers) + (pcase-dolist (`(,bufsym ,offer-save) ,buffers-offer) + (let* ((buf (generate-new-buffer (symbol-name bufsym))) + (subdir (expand-file-name + (format "subdir-%s" (buffer-name buf)) + ,dir))) + (make-directory subdir 'parens) + (push buf ,buffers) + (with-current-buffer buf + (cd subdir) + (setq buffer-offer-save offer-save) + (insert "foobar\n")))) + (setq ,buffers (nreverse ,buffers)) + (let ((nb-saved-buffers 0)) + (unwind-protect + (pcase-dolist (`(,fn-test-args ,callers-dir ,expected) + ,args-results) + (setq nb-saved-buffers 0) + (with-current-buffer (car ,buffers) + (cl-letf + (,@(mapcar (lambda (pair) `((symbol-function ,(car pair)) ,(cdr pair))) + fn-binders) + (save-some-buffers-default-predicate callers-dir)) + (apply #',fn-test fn-test-args) + (should (equal nb-saved-buffers expected))))) + ;; Clean up. + (dolist (buf ,buffers) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))) + (delete-directory ,dir 'recursive)))))) + +(defmacro files-tests-with-all-permutations (permutation list &rest body) + "Execute BODY forms for all permutations of LIST. +Execute the forms with the symbol PERMUTATION bound to the current +permutation." + (declare (indent 2) (debug (symbol form body))) + (let ((vec (gensym "vec"))) + `(let ((,vec (vconcat ,list))) + (cl-labels ((swap (,vec i j) + (let ((tmp (aref ,vec j))) + (aset ,vec j (aref ,vec i)) + (aset ,vec i tmp))) + (permute (,vec l r) + (if (= l r) + (let ((,permutation (append ,vec nil))) + ,@body) + (cl-loop for idx from l below (1+ r) do + (swap ,vec idx l) + (permute ,vec (1+ l) r) + (swap ,vec idx l))))) + (permute ,vec 0 (1- (length ,vec))))))) + +(ert-deftest files-tests-buffer-offer-save () + "Test `save-some-buffers' for non-file-visiting buffers. +Check the behavior of `save-some-buffers' for non-file-visiting +buffers under several values of `buffer-offer-save'. +The value of `save-some-buffers-default-predicate' is ignored unless +PRED is nil." + (let* ((buffers-offer-init '((buf-1 t) (buf-2 always) (buf-3 nil))) + (nb-might-save + (length + (cl-remove-if (lambda (l) (null (cadr l))) buffers-offer-init))) + (nb-always-save + (length + (cl-remove-if-not (lambda (l) (eq 'always (cadr l))) buffers-offer-init)))) + (files-tests-with-all-permutations + buffers-offer + buffers-offer-init + (dolist (pred `(nil t save-some-buffers-root)) + (dolist (callers-dir `(nil save-some-buffers-root)) + (let* ((head-offer (cadar buffers-offer)) + (res (cond ((null pred) + (if (null callers-dir) nb-always-save (or (and head-offer 1) 0))) + (t + ;; Save any buffer with `buffer-offer-save' non-nil. + (if (eq pred t) nb-might-save + ;; Restrict to caller's dir. + (or (and head-offer 1) 0))))) + (args-res `(((nil ,pred) ,callers-dir ,res)))) + (files-tests--with-buffer-offer-save + buffers-offer + save-some-buffers + ;; Increase counter and answer 'n' when prompted to save a buffer. + (('read-event . (lambda (&rest _) (cl-incf nb-saved-buffers) ?n))) + args-res))))))) + +(ert-deftest files-tests-save-buffers-kill-emacs--asks-to-save-buffers () + "Test that `save-buffers-kill-emacs' asks to save buffers as expected. +Prompt users for any modified buffer with `buffer-offer-save' non-nil." + (let* ((buffers-offer-init '((buf-1 t) (buf-2 always) (buf-3 nil))) + (nb-might-save + (length + (cl-remove-if (lambda (l) (null (cadr l))) buffers-offer-init)))) + (files-tests-with-all-permutations + buffers-offer + buffers-offer-init + (files-tests--with-buffer-offer-save + buffers-offer + save-buffers-kill-emacs + ;; Increase counter and answer 'n' when prompted to save a buffer. + (('read-event . (lambda (&rest _) (cl-incf nb-saved-buffers) ?n)) + ('kill-emacs . #'ignore)) ; Do not kill Emacs. + `((nil nil ,nb-might-save) + ;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored. + (nil save-some-buffers-root ,nb-might-save)))))) + +(defun test-file-name-split () + (should (equal (file-name-split "foo/bar") '("foo" "bar"))) + (should (equal (file-name-split "/foo/bar") '("" "foo" "bar"))) + (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))) + (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) + (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) + (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el new file mode 100644 index 00000000000..ee1e01be4b2 --- /dev/null +++ b/test/lisp/gnus/gnus-group-tests.el @@ -0,0 +1,52 @@ +;;; gnus-group-tests.el --- Tests for gnus-group.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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 'gnus-group) +(require 'ert) + +(ert-deftest gnus-short-group-name () + (map-apply + (lambda (input expected) + (should (string-equal (gnus-short-group-name input) expected))) + '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03") + ("nndiary+diary:birthdays" . "diary:birthdays") + ("nnimap+email@example.com:test" . "email@example:test") + ("nnimap+email@example.com:234" . "email@example:234") + + ;; This is a very aggressive shortening of the left hand side. + ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234") + ("nntp+some.where.edu:soc.motss" . "some:s.motss") + ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general") + ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps") + + ;; nnimap groups. + ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas") + ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas" + . "email@banana:I/Bananas") + + ;; The "n" from "nnspool" is perhaps not optimal. + ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture")))) + +;;; gnus-group-tests.el ends here diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el index 90c3a34a5c0..1206a976f6e 100644 --- a/test/lisp/gnus/gnus-icalendar-tests.el +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -216,7 +216,7 @@ RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE DTSTAMP:20200915T120627Z ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com -ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE +ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com CREATED:20200325T095723Z DESCRIPTION:Coffee talk diff --git a/test/lisp/gnus/gnus-search-tests.el b/test/lisp/gnus/gnus-search-tests.el index 6148da65621..9f012d4e888 100644 --- a/test/lisp/gnus/gnus-search-tests.el +++ b/test/lisp/gnus/gnus-search-tests.el @@ -97,4 +97,4 @@ "more bits")))) (provide 'gnus-search-tests) -;;; search-tests.el ends here +;;; gnus-search-tests.el ends here diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el index f8d30f6373e..60a9cde0e7f 100644 --- a/test/lisp/gnus/gnus-util-tests.el +++ b/test/lisp/gnus/gnus-util-tests.el @@ -132,4 +132,4 @@ (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) -;;; gnustest-gnus-util.el ends here +;;; gnus-util-tests.el ends here diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el index b4f2b7f675d..0f42f62f386 100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@ -185,4 +185,4 @@ Hello. (provide 'message-mode-tests) -;;; message-mode-tests.el ends here +;;; message-tests.el ends here diff --git a/test/lisp/gnus/nnrss-tests.el b/test/lisp/gnus/nnrss-tests.el index 9821ec76fb4..92b7dacf180 100644 --- a/test/lisp/gnus/nnrss-tests.el +++ b/test/lisp/gnus/nnrss-tests.el @@ -26,4 +26,20 @@ (should (equal (nnrss-normalize-date "2004-09-17T05:09:49.001+00:00") "Fri, 17 Sep 2004 05:09:49 +0000"))) +(defconst test-nnrss-xml + '((rss + ((version . "2.0") + (xmlns:dc . "http://purl.org/dc/elements/1.1/")) + (channel + ((xmlns:content . "http://purl.org/rss/1.0/modules/content/")))))) + +(ert-deftest test-nnrss-namespace-top () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/dc/elements/1.1/") + "dc:"))) +(ert-deftest test-nnrss-namespace-inner () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/rss/1.0/modules/content/") + "content:"))) + ;;; nnrss-tests.el ends here diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 513a0c2daea..24a42290a3f 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -148,7 +148,7 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-describe-keymap/value () (describe-keymap minibuffer-local-must-match-map) (with-current-buffer "*Help*" - (should (looking-at "^key")))) + (should (looking-at "\nKey")))) (ert-deftest help-fns-test-describe-keymap/not-keymap () (should-error (describe-keymap nil)) @@ -158,7 +158,7 @@ Return first line of the output of (describe-function-1 FUNC)." (let ((foobar minibuffer-local-must-match-map)) (describe-keymap foobar) (with-current-buffer "*Help*" - (should (looking-at "^key"))))) + (should (looking-at "\nKey"))))) (ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 871417da3d2..a331ec440a8 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -65,7 +65,7 @@ result)))) (test-re (lambda (orig regexp) - (should (string-match (concat "^" regexp "$") + (should (string-match (concat "\\`" regexp "\\'") (substitute-command-keys orig)))))) ,@body)) @@ -90,18 +90,16 @@ (ert-deftest help-tests-substitute-command-keys/keymaps () (with-substitute-command-keys-test - (test "\\{minibuffer-local-must-match-map}" - "\ -key binding ---- ------- - + (test-re "\\{minibuffer-local-must-match-map}" + " +Key Binding +-+ C-g abort-minibuffers TAB minibuffer-complete C-j minibuffer-complete-and-exit RET minibuffer-complete-and-exit -ESC Prefix Command SPC minibuffer-complete-word -? minibuffer-completion-help +\\? minibuffer-completion-help C-<tab> file-cache-minibuffer-complete <XF86Back> previous-history-element <XF86Forward> next-history-element @@ -110,11 +108,8 @@ C-<tab> file-cache-minibuffer-complete <prior> switch-to-completions <up> previous-line-or-history-element -M-g Prefix Command M-v switch-to-completions -M-g ESC Prefix Command - M-< minibuffer-beginning-of-buffer M-n next-history-element M-p previous-history-element @@ -122,7 +117,6 @@ M-r previous-matching-history-element M-s next-matching-history-element M-g M-c switch-to-completions - "))) (ert-deftest help-tests-substitute-command-keys/keymap-change () @@ -249,11 +243,10 @@ M-g M-c switch-to-completions (with-substitute-command-keys-test (with-temp-buffer (help-tests-major-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -261,7 +254,6 @@ a .. c foo-other-range C-e foo-something x foo-original <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/shadow () @@ -269,11 +261,10 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (help-tests-minor-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -283,7 +274,6 @@ C-e foo-something x foo-original (this binding is currently shadowed) <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/command-remap () @@ -292,15 +282,11 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (define-key help-tests-major-mode-map [remap foo] 'bar) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - -<remap> Prefix Command - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ <remap> <foo> bar - "))))) (ert-deftest help-tests-describe-map-tree/no-menu-t () @@ -312,12 +298,11 @@ key binding :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/no-menu-nil () (with-temp-buffer @@ -328,15 +313,13 @@ C-a foo :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -<menu-bar> Prefix Command -<menu-bar> <foo> foo - -"))))) +<menu-bar> <foo> foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-t () (with-temp-buffer @@ -345,14 +328,13 @@ C-a foo (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil t) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo (this binding is currently shadowed) -C-b bar - -"))))) +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-nil () (with-temp-buffer @@ -361,12 +343,11 @@ C-b bar (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-b bar - -"))))) + (should (string-match " +Key Binding +-+ +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-t () (with-temp-buffer @@ -374,12 +355,11 @@ C-b bar (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map t nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-nil () (with-temp-buffer @@ -387,13 +367,12 @@ C-a foo (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -C-b undefined - -"))))) +C-b undefined\n" + (buffer-string)))))) (defvar help-tests--was-in-buffer nil) diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index 199512fe7de..200caa7e1ad 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -31,7 +31,8 @@ (with-temp-buffer (insert "a A b B\n") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (dotimes (_ 2) (let ((face (hi-lock-read-face-name))) @@ -43,7 +44,8 @@ (with-temp-buffer (insert "foo bar") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (hi-lock-set-pattern "9999" (hi-lock-read-face-name)) ; No match (hi-lock-set-pattern "foo" (hi-lock-read-face-name))) @@ -89,7 +91,8 @@ (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) (should (= (length (overlays-in (point-min) (point-max))) 1)) (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (call-interactively 'unhighlight-regexp)) (should (= (length (overlays-in (point-min) (point-max))) 0)) @@ -142,7 +145,8 @@ (font-lock-ensure) (should (memq 'hi-yellow (get-text-property 1 'face))) (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults))) (font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) @@ -155,7 +159,8 @@ (insert "aAbB\n") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (highlight-regexp "a") diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el index 879131cae32..15798319a13 100644 --- a/test/lisp/htmlfontify-tests.el +++ b/test/lisp/htmlfontify-tests.el @@ -43,4 +43,4 @@ available (Bug#25468)." 0))) (provide 'htmlfontify-tests) -;; htmlfontify-tests.el ends here +;;; htmlfontify-tests.el ends here diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index a51079180a5..9b0327b0ef0 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -826,4 +826,4 @@ (should (equal (ibuffer-unary-operand '(not . a)) 'a))) (provide 'ibuffer-tests) -;; ibuffer-tests.el ends here +;;; ibuffer-tests.el ends here diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image-dired-tests.el new file mode 100644 index 00000000000..3f0304ee405 --- /dev/null +++ b/test/lisp/image-dired-tests.el @@ -0,0 +1,37 @@ +;;; image-dired-tests.el --- Tests for image-dired.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'image-dired) + +(defun image-dired-test-image-file (name) + (expand-file-name + name (expand-file-name "data/image" + (or (getenv "EMACS_TEST_DIRECTORY") + "../")))) + +(ert-deftest image-dired-tests-get-exif-file-name () + (skip-unless (image-type-available-p 'jpeg)) + (let ((img (image-dired-test-image-file "black.jpg"))) + (should (equal (image-dired-get-exif-file-name img) + "2019_09_21_16_22_13_black.jpg")))) + +;;; image-dired-tests.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index aa8600609c4..79b0014f60a 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -28,6 +28,27 @@ (expand-file-name "images" data-directory) "Directory containing Emacs images.") +(defconst image-tests--files + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(expand-file-name "splash.pbm" + image-tests--emacs-images-directory)) + (png . ,(expand-file-name "splash.png" + image-tests--emacs-images-directory)) + (svg . ,(expand-file-name "splash.svg" + image-tests--emacs-images-directory)) + (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 . ,(expand-file-name "gnus/gnus.xbm" + image-tests--emacs-images-directory)) + (xpm . ,(expand-file-name "splash.xpm" + image-tests--emacs-images-directory)))) + (ert-deftest image--set-property () "Test `image--set-property' behavior." (let ((image (list 'image))) @@ -49,12 +70,14 @@ (should (equal image '(image))))) (ert-deftest image-find-image () - (find-image '((:type xpm :file "undo.xpm"))) - (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))) + (should (listp (find-image '((:type xpm :file "undo.xpm"))))) + (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))) + (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) (ert-deftest image-type-from-file-name () (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png))) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. @@ -62,12 +85,37 @@ (bound-and-true-p image-load-path))) (should (eq (image-type "foo.jpg") 'jpeg))) -(ert-deftest image-type-from-file-header-test () +(defun image-tests--type-from-file-header (type) "Test image-type-from-file-header." - (should (eq (if (image-type-available-p 'svg) 'svg) - (image-type-from-file-header - (expand-file-name "splash.svg" - image-tests--emacs-images-directory))))) + (should (eq (if (image-type-available-p type) type) + (image-type-from-file-header (cdr (assq type image-tests--files)))))) + +(ert-deftest image-type-from-file-header-test/gif () + (image-tests--type-from-file-header 'gif)) + +(ert-deftest image-type-from-file-header-test/jpeg () + (image-tests--type-from-file-header 'jpeg)) + +(ert-deftest image-type-from-file-header-test/pbm () + (image-tests--type-from-file-header 'pbm)) + +(ert-deftest image-type-from-file-header-test/png () + (image-tests--type-from-file-header 'png)) + +(ert-deftest image-type-from-file-header-test/svg () + (image-tests--type-from-file-header 'svg)) + +(ert-deftest image-type-from-file-header-test/tiff () + (image-tests--type-from-file-header 'tiff)) + +(ert-deftest image-type-from-file-header-test/webp () + (image-tests--type-from-file-header 'webp)) + +(ert-deftest image-type-from-file-header-test/xbm () + (image-tests--type-from-file-header 'xbm)) + +(ert-deftest image-type-from-file-header-test/xpm () + (image-tests--type-from-file-header 'xpm)) (ert-deftest image-rotate () "Test `image-rotate'." diff --git a/test/lisp/image/exif-tests.el b/test/lisp/image/exif-tests.el index ddbee75467e..2357113f630 100644 --- a/test/lisp/image/exif-tests.el +++ b/test/lisp/image/exif-tests.el @@ -28,24 +28,19 @@ (or (getenv "EMACS_TEST_DIRECTORY") "../../")))) -(defun exif-elem (exif elem) - (plist-get (seq-find (lambda (e) - (eq elem (plist-get e :tag-name))) - exif) - :value)) - (ert-deftest test-exif-parse () (let ((exif (exif-parse-file (test-image-file "black.jpg")))) - (should (equal (exif-elem exif 'make) "Panasonic")) - (should (equal (exif-elem exif 'orientation) 1)) - (should (equal (exif-elem exif 'x-resolution) '(180 . 1))))) + (should (equal (exif-field 'make exif) "Panasonic")) + (should (equal (exif-field 'orientation exif) 1)) + (should (equal (exif-field 'x-resolution exif) '(180 . 1))) + (should (equal (exif-field 'date-time exif) "2019:09:21 16:22:13")))) (ert-deftest test-exif-parse-short () (let ((exif (exif-parse-file (test-image-file "black-short.jpg")))) - (should (equal (exif-elem exif 'make) "thr")) - (should (equal (exif-elem exif 'model) "four")) - (should (equal (exif-elem exif 'software) "em")) - (should (equal (exif-elem exif 'artist) "z")))) + (should (equal (exif-field 'make exif) "thr")) + (should (equal (exif-field 'model exif) "four")) + (should (equal (exif-field 'software exif) "em")) + (should (equal (exif-field 'artist exif) "z")))) (ert-deftest test-exit-direct-ascii-value () (should (equal (exif--direct-ascii-value 28005 2 t) (string ?e ?m 0))) diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index ecba86146f1..9379a53fe1d 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'info-xref) (defun info-xref-test-internal (body result) @@ -96,15 +97,17 @@ text. (ert-deftest info-xref-test-makeinfo () "Test that info-xref can parse basic makeinfo output." (skip-unless (executable-find "makeinfo")) - (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) - (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) - (errflag t)) - (unwind-protect - (progn - ;; tempfile contains xrefs to various things, including tempfile2. - (info-xref-test-write-file - tempfile - (concat "\ + (ert-with-temp-file tempfile + :suffix ".texi" + (ert-with-temp-file tempfile2 + :suffix ".texi" + (let ((errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ @xref{nodename,,,missing,Missing Manual}. @xref{nodename,crossref,title,missing,Missing Manual}. @@ -114,35 +117,36 @@ text. @xref{Chapter One,Something}. " - (format "@xref{Chapter One,,,%s,Present Manual}.\n" - (file-name-sans-extension (file-name-nondirectory - tempfile2))))) - ;; Something for tempfile to xref to. - (info-xref-test-write-file tempfile2 "") - (require 'info) - (save-window-excursion - (let ((Info-directory-list - (list - (or (file-name-directory tempfile) "."))) - Info-additional-directory-list) - (info-xref-check (format "%s.info" (file-name-sans-extension - tempfile)))) - (should (equal (list info-xref-bad info-xref-good - info-xref-unavail) - '(0 1 2))) - (setq errflag nil) - ;; If there was an error, we can leave this around. - (kill-buffer info-xref-output-buffer))) - ;; Useful diagnostic in case of problems. - (if errflag - (with-temp-buffer - (call-process "makeinfo" nil t nil "--version") - (message "%s" (buffer-string)))) - (mapc 'delete-file (list tempfile tempfile2 - (format "%s.info" (file-name-sans-extension - tempfile)) - (format "%s.info" (file-name-sans-extension - tempfile2))))))) + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile2))))))))) (ert-deftest info-xref-test-emacs-manuals () "Test that all internal links in the Emacs manuals work." @@ -161,4 +165,4 @@ text. (line-end-position))))))) -;;; info-xref.el ends here +;;; info-xref-tests.el ends here diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index 0f765e4ff88..f3da2d88732 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -246,3 +246,5 @@ At EOF: (registers [17 0 0 0 0 0 0 0])) (ccl-execute compiled registers) (should (equal registers [2 16 0 0 0 0 0 1]))))) + +;;; ccl-tests.el ends here diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 7727c118b2c..8ca1ade771d 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -23,7 +23,7 @@ ;;; Code: -(require 'ert-x) ;For `ert-run-keys'. +(require 'ert-x) ;For `ert-simulate-keys'. (ert-deftest find-auto-coding--bug27391 () "Check that Bug#27391 is fixed." diff --git a/test/lisp/international/mule-util-resources/utf-8.txt b/test/lisp/international/mule-util-resources/utf-8.txt new file mode 100644 index 00000000000..385bbb4ba80 --- /dev/null +++ b/test/lisp/international/mule-util-resources/utf-8.txt @@ -0,0 +1,2 @@ +Thís is a test line 1. +Line 2. diff --git a/test/lisp/international/mule-util-tests.el b/test/lisp/international/mule-util-tests.el index 6518be66dbe..0fcff9d02dd 100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'mule-util) (defconst mule-util-test-truncate-data @@ -82,4 +83,43 @@ (dotimes (i (length mule-util-test-truncate-data)) (mule-util-test-truncate-create i)) +(ert-deftest filepos/bufferpos-tests-utf-8 () + (let ((coding-system-for-read 'utf-8-unix)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (should (eq buffer-file-coding-system 'utf-8-unix)) + ;; First line is "Thís is a test line 1.". + ;; Bytes start counting at 0; chars at 1. + (should (= (filepos-to-bufferpos 1 'exact) 2)) + (should (= (bufferpos-to-filepos 2 'exact) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'exact) 4)) + (should (= (bufferpos-to-filepos 4 'exact) 4))))) + +(ert-deftest filepos/bufferpos-tests-binary () + (let ((coding-system-for-read 'binary)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (should (eq buffer-file-coding-system 'no-conversion)) + ;; First line is "Thís is a test line 1.". + ;; Bytes start counting at 0; chars at 1. + (should (= (filepos-to-bufferpos 1 'exact) 2)) + (should (= (bufferpos-to-filepos 2 'exact) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'exact) 5)) + (should (= (bufferpos-to-filepos 5 'exact) 4))))) + +(ert-deftest filepos/bufferpos-tests-undecided () + (let ((coding-system-for-read 'binary)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (setq buffer-file-coding-system 'undecided) + (should-error (filepos-to-bufferpos 1 'exact)) + (should-error (bufferpos-to-filepos 2 'exact)) + (should (= (filepos-to-bufferpos 1 'approximate) 2)) + (should (= (bufferpos-to-filepos 2 'approximate) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'approximate) 5)) + (should (= (bufferpos-to-filepos 5 'approximate) 4))))) + ;;; mule-util-tests.el ends here diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index 51f4ed3a80e..eb577b97dc4 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -123,9 +123,9 @@ The following invariants must be true for all conformant implementations..." (defsubst ucs-normalize-tests--rule2-holds-p (X) "Check 2nd conformance rule. -For every code point X assigned in this version of Unicode that is not specifically -listed in Part 1, the following invariants must be true for all conformant -implementations: +For every code point X assigned in this version of Unicode that +is not specifically listed in Part 1, the following invariants +must be true for all conformant implementations: X == toNFC(X) == toNFD(X) == toNFKC(X) == toNFKD(X)" (and (ucs-normalize-tests--normalization-chareq-p NFC X X) @@ -181,27 +181,34 @@ implementations: (should-not (ucs-normalize-tests--rule1-failing-for-partX 0))) (defconst ucs-normalize-tests--failing-lines-part1 - (list 2152 2418 15133 15134 15135 15136 15137 15138 - 15139 15140 15141 15142 16152 16153 16154 16155 - 16156 16157 16158 16159 16160 16161 16162 16163 - 16164 16165 16166 16167 16168 16169 16170 16171 - 16172 16173 16174 16175 16176 16177 16178 16179 - 16180 16181 16182 16183 16184 16185 16186 16187 - 16188 16189 16190 16191 16192 16193 16194 16195 - 16196 16197 16198 16199 16200 16201 16202 16203 - 16204 16205 16206 16207 16208 16209 16210 16211 - 16212 16213 16214 16215 16216 16217 16218 16219 - 16220 16221 16222 16223 16224 16225 16226 16227 - 16228 16229 16230 16231 16232 16233 16234 16235 - 16236 16237 16238 16239 16240 16241 16242 16243 - 16244 16245 16246 16247 16248 16249 16250 16251 - 16252 16253 16254 16255 16256 16257 16258 16259 - 16260 16261 16262 16263 16264 16265 16266 16267 - 16268 16269 16270 16271 16272 16273 16274 16275 - 16276 16277 16278 16279 16280 16281 16282 16283 - 16284 16285 16286 16287 16288 16289 16290 16291 - 16292 16429 16430 16431 16432 16433 16434 16435 - 16436 16437 16438)) + (list 2412 2413 2414 15133 15134 15135 15136 15137 + 15138 15139 15140 15141 15142 15143 15144 15145 + 15146 15147 15148 15149 15150 15151 15152 15153 + 15154 15155 15156 15157 15158 15159 15160 15161 + 15162 15163 15164 15165 15166 15167 15168 15169 + 15170 15171 15172 15173 15174 15175 15176 15177 + 15178 15179 15180 15181 15182 15183 15184 15185 + 15186 15187 15188 15192 15193 15194 15195 15196 + 15197 15198 15199 15200 15201 16211 16212 16213 + 16214 16215 16216 16217 16218 16219 16220 16221 + 16222 16223 16224 16225 16226 16227 16228 16229 + 16230 16231 16232 16233 16234 16235 16236 16237 + 16238 16239 16240 16241 16242 16243 16244 16245 + 16246 16247 16248 16249 16250 16251 16252 16253 + 16254 16255 16256 16257 16258 16259 16260 16261 + 16262 16263 16264 16265 16266 16267 16268 16269 + 16270 16271 16272 16273 16274 16275 16276 16277 + 16278 16279 16280 16281 16282 16283 16284 16285 + 16286 16287 16288 16289 16290 16291 16292 16293 + 16294 16295 16296 16297 16298 16299 16300 16301 + 16302 16303 16304 16305 16306 16307 16308 16309 + 16310 16311 16312 16313 16314 16315 16316 16317 + 16318 16319 16320 16321 16322 16323 16324 16325 + 16326 16327 16328 16329 16330 16331 16332 16333 + 16334 16335 16336 16337 16338 16339 16340 16341 + 16342 16343 16344 16345 16346 16347 16348 16349 + 16350 16351 16488 16489 16490 16491 16492 16493 + 16494 16495 16496 16497)) ;; Keep a record of failures, for consulting afterwards (the ert ;; backtrace only shows a truncated version of these lists). @@ -233,6 +240,7 @@ implementations: (ert-deftest ucs-normalize-part1 () :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 1800s ;; This takes a long time, so make sure we're compiled. (dolist (fun '(ucs-normalize-tests--part1-rule2 ucs-normalize-tests--rule1-failing-for-partX @@ -259,28 +267,76 @@ implementations: ucs-normalize-tests--failing-lines-part1))) (defconst ucs-normalize-tests--failing-lines-part2 - (list 17634 17635 17646 17647 17652 17653 17656 17657 - 17660 17661 17672 17673 17750 17751 17832 17834 - 17836 17837 17862 17863 17868 17869 18222 18270 - 18271 18368 18370 18400 18401 18402 18404 18406 - 18408 18410 18412 18413 18414 18416 18417 18418 - 18420 18421 18422 18423 18424 18426 18427 18428 - 18429 18430 18432 18434 18436 18438 18440 18442 - 18444 18446 18448 18450 18452 18454 18456 18458 - 18459 18460 18462 18464 18465 18466 18468 18469 - 18470 18472 18474 18475 18476 18478 18480 18481 - 18482 18484 18486 18487 18488 18490 18492 18494 - 18496 18498 18499 18500 18502 18504 18506 18508 - 18510 18512 18514 18516 18518 18520 18522 18524 - 18526 18528 18530 18531 18532 18533 18534 18602 - 18604 18606 18608 18610 18612 18614 18616 18618 - 18620 18622 18624 18626 18628 18630 18632 18634 - 18636 18638 18640 18642 18644 18646 18648 18650 - 18652 18654 18656 18658 18660 18662 18664 18666 - 18668 18670 18672 18674 18676 18678 18680 18682 - 18684 18686 18688 18690 18692 18694 18696 18698 - 18700 18702 18704 18706 18708 18710 18712 18714 - 18716 18718 18720 18722 18724 18726 18727)) + (list 17087 17088 17089 17090 17091 17092 17093 17094 + 17098 17099 17100 17101 17102 17103 17104 17105 + 17106 17107 17108 17113 17114 17115 17116 17117 + 17118 17119 17120 17125 17126 17127 17128 17129 + 17130 17131 17132 17133 17134 17135 17136 17137 + 17138 17139 17140 17141 17142 17143 17144 17145 + 17146 17157 17158 17159 17160 17161 17162 17163 + 17164 17185 17186 17187 17188 17189 17190 17197 + 17198 17199 17200 17207 17208 17209 17210 17211 + 17212 17213 17214 17219 17220 17221 17222 17275 + 17276 17285 17286 17295 17296 17309 17310 17311 + 17312 17313 17314 17315 17316 17317 17318 17319 + 17320 17325 17326 17373 17374 17419 17420 17421 + 17422 17433 17434 17439 17440 17465 17466 17473 + 17474 17479 17480 17485 17486 17491 17492 17497 + 17498 17499 17500 17501 17502 17505 17506 17507 + 17508 17511 17512 17519 17520 17523 17524 17527 + 17528 17531 17532 17551 17552 17555 17556 17599 + 17600 17601 17602 17603 17604 17605 17607 17608 + 17609 17610 17611 17612 17613 17615 17617 17619 + 17621 17623 17625 17627 17629 17631 17632 17633 + 17634 17635 17636 17637 17638 17639 17640 17669 + 17670 17675 17676 17681 17682 17689 17690 17691 + 17692 17693 17694 17707 17708 17713 17714 17715 + 17716 17727 17728 17733 17734 17739 17740 17745 + 17746 17749 17750 17753 17754 17759 17760 17767 + 17768 17807 17808 17809 17810 17811 17812 17813 + 17814 17816 17843 17844 17845 17846 17851 17852 + 17861 17875 17876 17879 17880 17899 17900 17911 + 17912 17913 17914 17915 17916 17917 17918 17919 + 17920 17921 17922 17927 17928 17929 17930 17931 + 17932 17933 17935 17937 17938 17939 17940 17941 + 17943 17945 17947 17949 17951 17952 17953 17955 + 17957 17959 17961 17962 17967 17968 17987 17988 + 17993 17994 18003 18004 18005 18006 18007 18008 + 18009 18010 18011 18012 18017 18018 18019 18020 + 18021 18022 18023 18024 18041 18042 18053 18054 + 18069 18070 18079 18080 18163 18164 18165 18166 + 18171 18172 18175 18176 18211 18212 18219 18220 + 18221 18222 18223 18224 18225 18226 18301 18302 + 18389 18390 18391 18392 18393 18394 18397 18398 + 18407 18408 18439 18440 18441 18442 18443 18444 + 18445 18446 18447 18448 18449 18450 18451 18452 + 18457 18458 18459 18460 18471 18472 18479 18480 + 18485 18486 18499 18500 18501 18502 18509 18510 + 18513 18514 18515 18516 18517 18518 18519 18520 + 18521 18523 18524 18525 18527 18528 18531 18537 + 18538 18539 18541 18543 18545 18547 18549 18550 + 18551 18553 18554 18555 18557 18558 18559 18560 + 18561 18563 18564 18565 18566 18567 18569 18571 + 18573 18575 18577 18579 18581 18583 18585 18587 + 18589 18591 18593 18595 18596 18597 18599 18601 + 18602 18603 18605 18606 18607 18609 18611 18612 + 18613 18615 18617 18618 18619 18621 18623 18624 + 18625 18627 18629 18631 18633 18635 18636 18637 + 18639 18641 18643 18645 18647 18649 18651 18653 + 18655 18657 18659 18661 18663 18665 18667 18668 + 18669 18670 18671 18674 18676 18686 18688 18690 + 18692 18694 18695 18696 18697 18698 18699 18700 + 18701 18702 18703 18704 18705 18706 18707 18708 + 18709 18710 18721 18722 18723 18724 18739 18741 + 18743 18745 18747 18749 18751 18753 18755 18757 + 18759 18761 18763 18765 18767 18769 18771 18773 + 18775 18777 18779 18781 18783 18785 18787 18789 + 18791 18793 18795 18797 18799 18801 18803 18805 + 18807 18809 18811 18813 18815 18817 18819 18821 + 18823 18825 18827 18829 18831 18833 18835 18837 + 18839 18840 18841 18842 18843 18844 18845 18846 + 18847 18848 18849 18850 18851 18852 18853 18855 + 18857 18859 18861 18863 18865 18866)) (ert-deftest ucs-normalize-part2 () :tags '(:expensive-test) diff --git a/test/lisp/jit-lock-tests.el b/test/lisp/jit-lock-tests.el index 121966b2b77..a54aad8165c 100644 --- a/test/lisp/jit-lock-tests.el +++ b/test/lisp/jit-lock-tests.el @@ -58,3 +58,5 @@ (with-silent-modifications (put-text-property (point-min) (point-max) 'fontified t)) (jit-lock-fontify-now (point-min) (point-max)))) + +;;; jit-lock-tests.el ends here diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index 8736f7fd2dc..ecd3d5fc22b 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -834,7 +834,7 @@ and `read-event' and `read-key-sequence' set up to return items from EVENTS and SEQUENCES respectively. SEQUENCES may be nil, but EVENTS should not be. EVENTS should be a list of symbols bound in `kmacro-step-edit-map' or `query-replace' map, and this function -will do the keymap lookup for you. SEQUENCES should contain +will do the keymap lookup for you. SEQUENCES should contain return values for `read-key-sequence'. Before running the macro, the current buffer will be erased. diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index e386398eea2..e3a75bed41d 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ls-lisp) (require 'dired) @@ -59,22 +60,22 @@ (ert-deftest ls-lisp-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - ls-lisp-use-insert-directory-program buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + :suffix "bug27631" + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + ls-lisp-use-insert-directory-program buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest ls-lisp-test-bug27693 () "Test for https://debbugs.gnu.org/27693 ." diff --git a/test/lisp/mail/mail-parse-tests.el b/test/lisp/mail/mail-parse-tests.el new file mode 100644 index 00000000000..70de92df45a --- /dev/null +++ b/test/lisp/mail/mail-parse-tests.el @@ -0,0 +1,54 @@ +;;; mail-parse-tests.el --- tests for mail-parse.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 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 'mail-parse) +(require 'subr-x) + +(ert-deftest test-mail-header-parse-address-lax () + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen <larsi@gnus.org>") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen larsi@gnus.org>") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen larsi@gnus.org") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "larsi@gnus.org (Lars Ingebrigtsen)") + '("larsi@gnus.org " . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax "larsi@gnus.org") + '("larsi@gnus.org"))) + (should (equal (mail-header-parse-address-lax "foo") + nil))) + +(ert-deftest test-mail-header-parse-addresses-lax () + (should (equal (mail-header-parse-addresses-lax + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("rsw@gnu.org" . "Bob Weiner") + ("matsl@gnu.org" . "Mats Lidell"))))) + +(provide 'mail-parse-tests) + +;;; mail-parse-tests.el ends here diff --git a/test/lisp/mail/rfc6068-tests.el b/test/lisp/mail/rfc6068-tests.el new file mode 100644 index 00000000000..caf8230cb1e --- /dev/null +++ b/test/lisp/mail/rfc6068-tests.el @@ -0,0 +1,52 @@ +;;; rfc6068-tests.el --- Tests for rfc6068.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2021 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 'rfc6068) + +(ert-deftest rfc6068-unhexify-string () + (should (equal (rfc6068-unhexify-string "hello%20there") "hello there")) + (should (equal (rfc6068-unhexify-string "caf%C3%A9") "café"))) + +(ert-deftest rfc6068-parse-mailto-url () + (should + (equal + (rfc6068-parse-mailto-url "mailto:foo@example.org?subject=Foo&bar=baz") + '(("To" . "foo@example.org") ("Subject" . "Foo") ("Bar" . "baz")))) + (should + (equal + (rfc6068-parse-mailto-url "mailto:foo@bar.com?to=bar@example.org") + '(("To" . "foo@bar.com, bar@example.org")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz") + '(("To" . "foo@bar.com") ("Subject" . "bar baz")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz&to=other@bar.com") + '(("Subject" . "bar baz") ("To" . "foo@bar.com, other@bar.com")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:user@example.org?subject=caf%C3%A9&body=caf%C3%A9") + '(("To" . "user@example.org") ("Subject" . "café") ("Body" . "café"))))) + +(provide 'rfc6068-tests) + +;;; rfc6068-tests.el ends here diff --git a/test/lisp/mail/rmail-tests.el b/test/lisp/mail/rmail-tests.el index f533401496b..826a90455fb 100644 --- a/test/lisp/mail/rmail-tests.el +++ b/test/lisp/mail/rmail-tests.el @@ -32,4 +32,4 @@ 'rmail-edit-current-message)))) (provide 'rmail-tests) -;; rmail-tests.el ends here +;;; rmail-tests.el ends here diff --git a/test/lisp/mail/rmailmm-tests.el b/test/lisp/mail/rmailmm-tests.el index a022008b534..d7b3775d6d0 100644 --- a/test/lisp/mail/rmailmm-tests.el +++ b/test/lisp/mail/rmailmm-tests.el @@ -114,4 +114,4 @@ This is the epilogue. It is also to be ignored.")) (provide 'rmailmm-tests) -;; rmailmm-tests.el ends here +;;; rmailmm-tests.el ends here diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el index 6ff767562e3..1899ff50f69 100644 --- a/test/lisp/mail/uudecode-tests.el +++ b/test/lisp/mail/uudecode-tests.el @@ -35,11 +35,11 @@ (defvar uudecode-tests-encoded-str (uudecode-tests-read-file (ert-resource-file "uuencoded.txt")) - "Uuencoded data for bookmark-tests.el + "Uuencoded data for bookmark-tests.el. Same as `uudecode-tests-decoded-str' but uuencoded.") (defvar uudecode-tests-decoded-str (uudecode-tests-read-file (ert-resource-file "uudecoded.txt")) - "Plain text data for bookmark-tests.el + "Plain text data for bookmark-tests.el. Same as `uudecode-tests-encoded-str' but plain text.") (ert-deftest uudecode-tests-decode-region-internal () @@ -50,14 +50,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-internal (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-internal (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str))))) (ert-deftest uudecode-tests-decode-region-external () ;; Write to buffer @@ -68,14 +65,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-external (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-external (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str)))))) (provide 'uudecode-tests) ;;; uudecode-tests.el ends here diff --git a/test/lisp/mh-e/mh-limit-tests.el b/test/lisp/mh-e/mh-limit-tests.el new file mode 100644 index 00000000000..982573d9b49 --- /dev/null +++ b/test/lisp/mh-e/mh-limit-tests.el @@ -0,0 +1,35 @@ +;;; mh-limit-tests.el --- tests for mh-limit.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'mh-limit) + +(ert-deftest mh-pick-args-list () + "Test `mh-pick-args-list'." + (should (equal '() (mh-pick-args-list ""))) + (should (equal '("-subject" "a") (mh-pick-args-list "-subject a"))) + (should (equal '("-subject" "a") (mh-pick-args-list " -subject a "))) + (should (equal '("-subject" "a" "-from" "b") + (mh-pick-args-list "-subject a -from b"))) + (should (equal '("-subject" "a b" "-from" "c d") + (mh-pick-args-list "-subject a b -from c d")))) + +;;; mh-limit-tests.el ends here diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el new file mode 100644 index 00000000000..ed979232a41 --- /dev/null +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -0,0 +1,479 @@ +;;; mh-utils-tests.el --- tests for mh-utils.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This test suite runs tests that use and depend on MH programs +;; installed on the system. + +;; When running such tests, MH-E can use a particular MH variant +;; installed on the system, or it can use the mocks provided here. +;; (Setup is done by the `with-mh-test-env' macro.) + +;; By setting environment variable TEST_MH_PATH, you can select which of +;; the installed MH variants to use, or ignore them all and use mocks. +;; See also the script test-all-mh-variants.sh in this directory. + +;; 1. To run these tests against the default MH variant installed on +;; this system: +;; cd ../.. && make lisp/mh-e/mh-utils-tests + +;; 2. To run these tests against an MH variant installed in a +;; specific directory, set TEST_MH_PATH, as in this example: +;; cd ../.. && make lisp/mh-e/mh-utils-tests TEST_MH_PATH=/usr/local/nmh/bin + +;; 3. To search for and run these tests against all MH variants +;; installed on this system: +;; ./test-all-mh-variants.sh + +;; Setting the environment variable TEST_MH_DEBUG or the Lisp variable +;; mh-test-utils-debug-mocks logs access to the file system during the test. + +;;; Code: + +(require 'ert) +(eval-when-compile (require 'cl-lib)) +(require 'mh-utils) + +(ert-deftest mh-quote-pick-expr () + "Test `mh-quote-pick-expr'." + (should (equal nil (mh-quote-pick-expr nil))) + (should (equal '() (mh-quote-pick-expr '()))) + (should (equal '("foo") (mh-quote-pick-expr '("foo")))) + (should (equal '("^\\[foo]?\\*+\\.\\$") + (mh-quote-pick-expr '("^[foo]?*+.$")))) + (should (equal '("^\\[foo]?\\*+\\.\\$" "bar" "baz\\$") + (mh-quote-pick-expr '("^[foo]?*+.$" "bar" "baz$"))))) + +(ert-deftest mh-normalize-folder-name () + "Test `mh-normalize-folder-name'." + (should (equal nil (mh-normalize-folder-name nil))) + (should (equal "+" (mh-normalize-folder-name ""))) + (should (equal "" (mh-normalize-folder-name "" t))) + (should (equal nil (mh-normalize-folder-name "" nil nil t))) + (should (equal nil (mh-normalize-folder-name "+" nil nil t))) + (should (equal nil (mh-normalize-folder-name "+" t t t))) + (should (equal "+inbox" (mh-normalize-folder-name "inbox"))) + (should (equal "+inbox" (mh-normalize-folder-name "+inbox"))) + (should (equal "+inbox" (mh-normalize-folder-name "+inbox/"))) + (should (equal "+inbox/" (mh-normalize-folder-name "+inbox/" t t t))) + (should (equal "+inbox/" (mh-normalize-folder-name "+inbox/" nil t))) + (should (equal "+news" (mh-normalize-folder-name "+inbox////../news"))) + (should (equal "+news" (mh-normalize-folder-name "+inbox////../news/"))) + (should (equal "+news/" + (mh-normalize-folder-name "+inbox////../news/" nil t))) + (should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news")))) + + +;; Folder names that are used by the following tests. +(defvar mh-test-rel-folder "rela-folder") +(defvar mh-test-abs-folder "/abso-folder") +(defvar mh-test-no-such-folder "/testdir/none" "A folder that does not exist.") + +(defvar mh-test-utils-variants nil + "The value of `mh-variants' used for these tests. +This variable allows setting `mh-variants' to a limited set for targeted +testing. Its value can be different from the normal value when +environment variable TEST_MH_PATH is set. By remembering the value, we +can log the choice only once, which makes the batch log easier to read.") + +(defvar mh-test-variant-logged-already nil + "Whether `with-mh-test-env' has written the MH variant to the log.") + +(defvar mh-test-utils-debug-mocks (> (length (getenv "TEST_MH_DEBUG")) 0) + "Whether to log detailed behavior of mock functions.") + +(defvar mh-test-call-process-real (symbol-function 'call-process)) +(defvar mh-test-file-directory-p-real (symbol-function 'file-directory-p)) + +;;; The macro with-mh-test-env wraps tests that touch the file system +;;; and/or run programs. + +(defmacro with-mh-test-env (&rest body) + "Evaluate BODY with a test mail environment. +Functions that touch the file system or run MH programs are either +mocked out or pointed at a test tree. Uses `mh-test-utils-setup' to +select which." + (declare (indent 0) (debug t)) + `(cl-letf ((temp-home-dir nil) + ;; make local bindings for things we will modify for test env + (mh-user-path) + (mh-test-abs-folder) + ((symbol-function 'call-process)) + ((symbol-function 'file-directory-p)) + ;; the test always gets its own sub-folders cache + (mh-sub-folders-cache (make-hash-table :test #'equal)) + ;; Allow envvar TEST_MH_PATH to control mh-variants. + (mh-variants mh-test-utils-variants) + ;; remember the original value + (original-mh-test-variant-logged mh-test-variant-logged-already) + (original-mh-path mh-path) + (original-mh-sys-path mh-sys-path) + (original-exec-path exec-path) + (original-mh-variant-in-use mh-variant-in-use) + (original-mh-progs mh-progs) + (original-mh-lib mh-lib) + (original-mh-lib-progs mh-lib-progs) + (original-mh-envvar (getenv "MH"))) + (unwind-protect + (progn + (setq temp-home-dir (mh-test-utils-setup)) + ,@body) + (unless noninteractive + ;; If interactive, forget that we logged the variant and + ;; restore any changes TEST_MH_PATH made. + (setq mh-test-variant-logged-already original-mh-test-variant-logged + mh-path original-mh-path + mh-sys-path original-mh-sys-path + exec-path original-exec-path + mh-variant-in-use original-mh-variant-in-use + mh-progs original-mh-progs + mh-lib original-mh-lib + mh-lib-progs original-mh-lib-progs)) + (if temp-home-dir (delete-directory temp-home-dir t)) + (setenv "MH" original-mh-envvar)))) + +(defun mh-test-utils-setup () + "Set dynamically bound variables needed by mock and/or variants. +Call `mh-variant-set' to look through the directories named by +envionment variable `TEST_MH_PATH' (default: `mh-path' and `mh-sys-path') +to find the MH variant to use, if any. +Return the name of the root of the created directory tree, if any." + (when (getenv "TEST_MH_PATH") + ;; force mh-variants to use only TEST_MH_PATH + (setq mh-path (split-string (getenv "TEST_MH_PATH") path-separator t) + mh-sys-path nil + exec-path '("/bin" "/usr/bin"))) + (unless mh-test-variant-logged-already + (mh-variant-set mh-variant) + (setq mh-test-utils-variants mh-variants) + (setq mh-test-variant-logged-already t)) + (when (native-comp-available-p) + ;; As `call-process'' and `file-directory-p' will be redefined, the + ;; native compiler will invoke `call-process' to compile the + ;; respective trampolines. To avoid interference with the + ;; `call-process' mocking, we build these ahead of time. + (mapc #'comp-subr-trampoline-install '(call-process file-directory-p))) + (if mh-variant-in-use + (mh-test-utils-setup-with-variant) + (mh-test-utils-setup-with-mocks))) + +(defun mh-test-utils-setup-with-mocks () + "Set dynamically bound variables so that MH programs are mocked out. +The tests use this method if no configured MH variant is found." + (setq mh-user-path "/testdir/Mail/") + (mh-populate-sub-folders-cache "+") + (mh-populate-sub-folders-cache "+rela-folder") + (mh-populate-sub-folders-cache "+rela-folder/bar") + (mh-populate-sub-folders-cache "+rela-folder/foo") + (mh-populate-sub-folders-cache "+rela-folder/food") + (fset 'call-process #'mh-test-utils-mock-call-process) + (fset 'file-directory-p #'mh-test-utils-mock-file-directory-p) + ;; no temp directory created + nil) + +(defun mh-test-utils-mock-call-process (program + &optional _infile _destination _display + &rest args) + "A mocked version of `call-process' that calls no processes." + (let ((argument-responses + ;; assoc list of program arguments and lines to output. + '((("folder" "-fast") . ("rela-folder")) + (("folders" "-noheader" "-norecurse" "-nototal") . + ("rela-folder has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+rela-folder") . + ("rela-folder+ has no messages." + "rela-folder/bar has no messages." + "rela-folder/foo has no messages." + "rela-folder/food has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+rela-folder/foo") . + ("rela-folder/foo+ has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+") . + ("+ has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+/abso-folder") . + ("/abso-folder+ has no messages." + "/abso-folder/bar has no messages." + "/abso-folder/foo has no messages." + "/abso-folder/food has no messages.")) + )) + (arglist (cons (file-name-base program) args))) + (let ((response-list-cons (assoc arglist argument-responses))) + (cond (response-list-cons + (let ((response-list (cdr response-list-cons))) + (when mh-test-utils-debug-mocks + (message "call-process mock arglist %s" arglist) + (message " -> response %S" response-list)) + (while response-list + (insert (car response-list) "\n") + (setq response-list (cdr response-list)))) + 0) + (t + (message "call-process mock unexpected arglist %s" arglist) + 1))))) + +(defun mh-test-utils-mock-file-directory-p (filename) + "A mocked version of `file-directory-p' that does not access the file system." + (let ((directories '("" "/" "/tmp" "/abso-folder" "/abso-folder/foo" + "/testdir/Mail" "/testdir/Mail/rela-folder" + "/testdir/Mail/rela-folder/foo" + "rela-folder" "rela-folder/foo")) + (non-directories '("/abso-folder/fo" "rela-folder/fo" + "/testdir/Mail/rela-folder/fo" + "/testdir/Mail/nosuchfolder" + "/nosuchfolder" "nosuchfolder"))) + (cond ((member (directory-file-name filename) directories) + (when mh-test-utils-debug-mocks + (message "file-directory-p mock: %S -> t" filename)) + t) + ((member (directory-file-name filename) non-directories) + (when mh-test-utils-debug-mocks + (message "file-directory-p mock: %S -> nil" filename)) + nil) + (t + (message "file-directory-p mock unexpected filename: %S" filename) + nil)))) + +(defun mh-test-utils-setup-with-variant () + "Create a temporary directory structure for actual MH programs to read. +Return the name of the root of the created directory tree. +Set dynamically bound variables so that MH programs may log. +The tests use this method if a configured MH variant is found." + (let* ((temp-home-dir + (make-temp-file "emacs-mh-e-unit-test-" t)) + (profile (expand-file-name + ".mh_profile" temp-home-dir)) + (mail-dir (expand-file-name "Mail" temp-home-dir)) + (rela-folder (expand-file-name + "rela-folder" mail-dir)) + (abso-folder (expand-file-name + "abso-folder" temp-home-dir))) + (with-temp-file profile + (insert "Path: " mail-dir "\n" "Welcome: disable\n")) + (setenv "MH" profile) + (make-directory (expand-file-name "bar" rela-folder) t) + (make-directory (expand-file-name "foo" rela-folder) t) + (make-directory (expand-file-name "food" rela-folder) t) + (setq mh-user-path (file-name-as-directory mail-dir)) + (make-directory (expand-file-name "bar" abso-folder) t) + (make-directory (expand-file-name "foo" abso-folder) t) + (make-directory (expand-file-name "food" abso-folder) t) + (setq mh-test-abs-folder abso-folder) + (fset 'call-process #'mh-test-utils-log-call-process) + (fset 'file-directory-p #'mh-test-utils-log-file-directory-p) + temp-home-dir)) + +(defun mh-test-utils-log-call-process (program + &optional infile destination display + &rest args) + "A wrapper around `call-process' that can log the program args and output. +Both args and output are written with `message' if `mh-test-utils-debug-mocks' +is non-nil." + (let (process-output) + (when mh-test-utils-debug-mocks + (message "call-process arglist %s" (cons program args))) + (with-temp-buffer + (apply mh-test-call-process-real program infile destination display args) + (setq process-output (buffer-string))) + (when mh-test-utils-debug-mocks + (message " -> response:\n%s" process-output)) + (insert process-output))) + +(defun mh-test-utils-log-file-directory-p (filename) + "A wrapper around `file-directory-p' that can log calls. +Both FILENAME and the return value are written with `message' +if `mh-test-utils-debug-mocks' is non-nil." + (let ((result (funcall mh-test-file-directory-p-real filename))) + (when mh-test-utils-debug-mocks + (message "file-directory-p: %S -> %s" filename result)) + result)) + + +(ert-deftest mh-sub-folders-actual () + "Test `mh-sub-folders-actual'." + ;; Note that mh-sub-folders-actual expects the folder to have + ;; already been normalized with + ;; (mh-normalize-folder-name folder nil nil t) + (with-mh-test-env + (should (equal + mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil))))) + ;; Empty string and "+" not tested since mh-normalize-folder-name + ;; would change them to nil. + (should (equal "foo" + (car (assoc "foo" (mh-sub-folders-actual + (format "+%s" mh-test-rel-folder)))))) + ;; Folder with trailing slash not tested since + ;; mh-normalize-folder-name would strip it. + (should (equal + nil + (mh-sub-folders-actual (format "+%s/foo" mh-test-rel-folder)))) + + (should (equal + (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders-actual (format "+%s" mh-test-abs-folder)))) + + ;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a + ;; nonexistent folder. + ;; (should (equal nil + ;; (mh-sub-folders-actual "+nosuchfolder"))) + ;; (should (equal nil + ;; (mh-sub-folders-actual "+/nosuchfolder"))) + )) + +(ert-deftest mh-sub-folders () + "Test `mh-sub-folders'." + (with-mh-test-env + (should (equal mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders nil))))) + (should (equal mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders ""))))) + (should (equal nil + (car (assoc mh-test-no-such-folder (mh-sub-folders + "+"))))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s" mh-test-rel-folder)))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s/" mh-test-rel-folder)))) + (should (equal nil + (mh-sub-folders (format "+%s/foo/" mh-test-rel-folder)))) + (should (equal nil + (mh-sub-folders (format "+%s/foo" mh-test-rel-folder)))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s" mh-test-abs-folder)))) + + ;; FIXME: mh-sub-folders doesn't (yet) expect to be given a + ;; nonexistent folder. + ;; (should (equal nil + ;; (mh-sub-folders "+nosuchfolder"))) + ;; (should (equal nil + ;; (mh-sub-folders "+/nosuchfolder"))) + )) + + +(defmacro mh-test-folder-completion-1 (name + nil-expected t-expected lambda-expected) + "Helper for testing `mh-folder-completion-function'. +Ask for completion on NAME three times, with three different +values for the FLAG argument of `mh-folder-completion-function'. +NIL-EXPECTED is the expected value with FLAG nil. +T-EXPECTED is the expected value with FLAG t. +LAMBDA-EXPECTED is the expected value with FLAG lambda." + (declare (debug t)) + `(with-mh-test-env + (mh-test-folder-completion-2 ,nil-expected ;case "a" + (mh-folder-completion-function ,name nil nil)) + (mh-test-folder-completion-2 ,t-expected ;case "b" + (mh-folder-completion-function ,name nil t)) + (mh-test-folder-completion-2 ,lambda-expected ;case "c" + (mh-folder-completion-function ,name nil + 'lambda)))) + +(defmacro mh-test-folder-completion-2 (expected actual) + "Inner helper for testing `mh-folder-completion-function'. +ACTUAL should evaluate to either EXPECTED or to a list containing EXPECTED. +ACTUAL may be evaluated twice, but this gives a clearer error on failure, +and the `should' macro requires idempotent evaluation anyway." + (declare (debug t)) + `(if (and (not (consp ,expected)) (consp ,actual)) + (should (member ,expected ,actual)) + (should (equal ,expected ,actual)))) + + +(ert-deftest mh-folder-completion-function-02-empty () + "Test `mh-folder-completion-function' with empty name." + (mh-test-folder-completion-1 "" "+" (format "%s/" mh-test-rel-folder) nil)) + +(ert-deftest mh-folder-completion-function-03-plus () + "Test `mh-folder-completion-function' with `+'." + (mh-test-folder-completion-1 "+" "+" (format "%s/" mh-test-rel-folder) nil)) + +(ert-deftest mh-folder-completion-function-04-rel-folder () + "Test `mh-folder-completion-function' with `+rela-folder'." + (mh-test-folder-completion-1 (format "+%s" mh-test-rel-folder) + (format "+%s/" mh-test-rel-folder) + (list (format "%s/" mh-test-rel-folder)) + t)) + +(ert-deftest mh-folder-completion-function-05-rel-folder-slash () + "Test `mh-folder-completion-function' with `+rela-folder/'." + (mh-test-folder-completion-1 (format "+%s/" mh-test-rel-folder) + (format "+%s/" mh-test-rel-folder) + (list "bar" "foo" "food") + t)) + +(ert-deftest mh-folder-completion-function-06-rel-folder-slash-foo () + "Test `mh-folder-completion-function' with `+rela-folder/foo'." + (mh-test-folder-completion-1 (format "+%s/foo" mh-test-rel-folder) + (format "+%s/foo" mh-test-rel-folder) + (list "foo" "food") + t) + (with-mh-test-env + (should (equal nil + (mh-folder-completion-function + (format "+%s/fo" mh-test-rel-folder) nil 'lambda))))) + +(ert-deftest mh-folder-completion-function-07-rel-folder-slash-foo-slash () + "Test `mh-folder-completion-function' with `+rela-folder/foo/'." + (mh-test-folder-completion-1 (format "+%s/foo/" mh-test-rel-folder) + nil + nil + t)) + +(ert-deftest mh-folder-completion-function-08-plus-slash () + "Test `mh-folder-completion-function' with `+/'." + :expected-result :failed ;to be fixed in a patch by mkupfer + (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil) + ;; case "bb" + (with-mh-test-env + (should (equal nil + (member (format "+%s/" mh-test-rel-folder) + (mh-folder-completion-function "+/" nil t)))))) + +(ert-deftest mh-folder-completion-function-09-plus-slash-tmp () + "Test `mh-folder-completion-function' with `+/tmp'." + :expected-result :failed ;to be fixed in a patch by mkupfer + (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t)) + +(ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () + "Test `mh-folder-completion-function' with `+/abso-folder'." + (mh-test-folder-completion-1 (format "+%s/" mh-test-abs-folder) + (format "+%s/" mh-test-abs-folder) + (list "bar" "foo" "food") + t)) + +(ert-deftest mh-folder-completion-function-11-plus-slash-abs-folder-slash-foo () + "Test `mh-folder-completion-function' with `+/abso-folder/foo'." + (mh-test-folder-completion-1 (format "+%s/foo" mh-test-abs-folder) + (format "+%s/foo" mh-test-abs-folder) + (list "foo" "food") + t) + (with-mh-test-env + (should (equal nil + (mh-folder-completion-function + (format "+%s/fo" mh-test-abs-folder) nil 'lambda))))) + +(ert-deftest mh-folder-completion-function-12-plus-nosuchfolder () + "Test `mh-folder-completion-function' with `+nosuchfolder'." + (mh-test-folder-completion-1 "+nosuchfolder" nil nil nil)) + +(ert-deftest mh-folder-completion-function-13-plus-slash-nosuchfolder () + "Test `mh-folder-completion-function' with `+/nosuchfolder'." + (mh-test-folder-completion-1 "+/nosuchfolder" nil nil nil)) + +;;; mh-utils-tests.el ends here diff --git a/test/lisp/mh-e/mh-xface-tests.el b/test/lisp/mh-e/mh-xface-tests.el new file mode 100644 index 00000000000..43355810abe --- /dev/null +++ b/test/lisp/mh-e/mh-xface-tests.el @@ -0,0 +1,50 @@ +;;; mh-xface-tests.el --- tests for mh-xface.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'mh-xface) + +(ert-deftest mh-x-image-url-sane-p () + "Test that `mh-x-image-url-sane-p' accepts a URL exactly if it is sane." + (should (equal (mh-x-image-url-sane-p (concat "http://" + (make-string 101 ?a))) + nil)) ;too long + (should (equal (mh-x-image-url-sane-p "http") nil)) ;too short + (should (equal (mh-x-image-url-sane-p "http:") t)) + (should (equal (mh-x-image-url-sane-p "https") nil)) ;too short + (should (equal (mh-x-image-url-sane-p "https:") t)) + (should (equal (mh-x-image-url-sane-p "https://www.example.com/me.png") t)) + (should (equal (mh-x-image-url-sane-p "abcde:") nil))) + +(ert-deftest mh-x-image-url-cache-canonicalize () + "Test `mh-x-image-url-cache-canonicalize'." + (should (equal (format "%s/%s" mh-x-image-cache-directory "%21foo%21bar.png") + (mh-x-image-url-cache-canonicalize "/foo/bar"))) + (should (equal (format "%s/%s" mh-x-image-cache-directory + "http%3A%21%21domain.com%21foo%21bar.png") + (mh-x-image-url-cache-canonicalize + "http://domain.com/foo/bar"))) + ;; All Windows invalid characters. + (should (equal (format "%s/%s" mh-x-image-cache-directory + "%21%3C%3E%3A%2A%3F%22%5C%7C%21bar.png") + (mh-x-image-url-cache-canonicalize "/<>:*?\"\\|/bar")))) + +;;; mh-xface-tests.el ends here diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh new file mode 100755 index 00000000000..e917d8155bc --- /dev/null +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -0,0 +1,104 @@ +#! /bin/bash +# Run the mh-utils-tests against all MH variants found on this system. + +# Copyright (C) 2021 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: + +# By default runs all tests; test names or Emacs-style regexps may be +# given on the command line to run just those tests. +# +# Option -d turns on Emacs variable mh-test-utils-debug-mocks, which +# causes the tests to output all interactions with the file system. + +# If you want to run the tests for only one MH variant, you don't need +# to use this script, because "make" can do it. See the commentary at +# the top of ./mh-utils-tests.el for the recipe. + +debug= +if [[ "$1" = -* ]]; then + if [[ "$1" != -d ]]; then + echo "Usage: $(basename "$0") [-d] [test ...]" >&2 + exit 2 + fi + debug=t + shift +fi + +shopt -s extglob +ert_test_list=() +for tst; do + # Guess the type the test spec + case $tst in + *[\[\].*+\\]*) # Regexp: put in string quotes + ert_test_list+=("\"$tst\"") + ;; + *) # Lisp expression, keyword, or symbol: use as is + ert_test_list+=("$tst") + ;; + esac +done +if [[ ${#ert_test_list[@]} -eq 0 ]]; then + # t means true for all tests, runs everything + ert_test_list=(t) +fi + +# This script is 3 directories down in the Emacs source tree. +cd "$(dirname "$0")" +cd ../../.. +emacs=(src/emacs --batch -Q) + +# MH-E has a good list of directories where an MH variant might be installed, +# so we look in each of those. +read -r -a mh_sys_path \ + < <("${emacs[@]}" -l mh-e --eval "(princ mh-sys-path)" | sed 's/[()]//g') + +have_done_mocked_variant=false +declare -i tests_total=0 tests_passed=0 + +for path in "${mh_sys_path[@]}"; do + if [[ ! -x "$path/mhparam" ]]; then + if [[ "$have_done_mocked_variant" = false ]]; then + have_done_mocked_variant=true + else + continue + fi + fi + echo "Testing with PATH $path" + ((++tests_total)) + # The LD_LIBRARY_PATH setting is needed + # to run locally installed Mailutils. + TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ + LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ + "${emacs[@]}" -l ert \ + --eval "(setq load-prefer-newer t)" \ + --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ + --eval "(ert-run-tests-batch-and-exit '(or ${ert_test_list[*]}))" \ + && ((++tests_passed)) +done + +if (( tests_total == 0 )); then + echo "NO tests run" + exit 1 +elif (( tests_total == tests_passed )); then + echo "All tested variants pass: $tests_passed/$tests_total" +else + echo "Tested variants passing: $tests_passed/$tests_total," \ + "FAILING: $((tests_total - tests_passed))/$tests_total" + exit 1 +fi diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el index 898bef8513b..68c7c349013 100644 --- a/test/lisp/net/browse-url-tests.el +++ b/test/lisp/net/browse-url-tests.el @@ -28,6 +28,7 @@ (require 'browse-url) (require 'ert) +(require 'ert-x) (ert-deftest browse-url-tests-browser-kind () (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") @@ -68,11 +69,11 @@ (ert-deftest browse-url-tests-encode-url () (should (equal (browse-url-encode-url "") "")) - (should (equal (browse-url-encode-url "a b c") "a b c")) + (should (equal (browse-url-encode-url "a b c") "a%20b%20c")) (should (equal (browse-url-encode-url "\"a\" \"b\"") - "\"a%22\"b\"")) - (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) - (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) + "%22a%22%20%22b%22")) + (should (equal (browse-url-encode-url "(a) (b)") "%28a%29%20%28b%29")) + (should (equal (browse-url-encode-url "a$ b$") "a%24%20b%24"))) (ert-deftest browse-url-tests-url-at-point () (with-temp-buffer @@ -87,11 +88,10 @@ "ftp://foo/"))) (ert-deftest browse-url-tests-delete-temp-file () - (let ((browse-url-temp-file-name - (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file browse-url-temp-file-name (browse-url-delete-temp-file) (should-not (file-exists-p browse-url-temp-file-name))) - (let ((file (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file file (browse-url-delete-temp-file file) (should-not (file-exists-p file)))) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 53c786ada48..cfc380d3029 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -630,16 +630,19 @@ This includes initialization and closing the bus." :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar")) `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) - ;; Three arguments, D-Bus error activated by `dbus-error' signal. + ;; Three arguments, D-Bus error activated by `dbus-error' + ;; signal. On CentOS, it is not guaranteed which format the + ;; error message arises. (Bug#51369) (should - (equal + (member (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar" "baz")) - `(dbus-error - ,dbus-error-failed - "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))) + `((dbus-error "D-Bus signal" "foo" "bar" "baz") + (dbus-error + ,dbus-error-failed + "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\"")))) ;; Unregister method. (should (dbus-unregister-object registered)) diff --git a/test/lisp/net/netrc-resources/netrc-folding b/test/lisp/net/netrc-resources/netrc-folding new file mode 100644 index 00000000000..85e5e324cdf --- /dev/null +++ b/test/lisp/net/netrc-resources/netrc-folding @@ -0,0 +1,6 @@ +# Foo +machine XM login XL password XP + +machine YM + login YL + password YP diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index 1328b191494..f75328a59f7 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,6 +48,13 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) +(ert-deftest test-netrc-credentials () + (let ((netrc-file (ert-resource-file "netrc-folding"))) + (should + (equal (netrc-parse netrc-file) + '((("machine" . "XM") ("login" . "XL") ("password" . "XP")) + (("machine" . "YM")) (("login" . "YL")) (("password" . "YP"))))))) + (provide 'netrc-tests) ;;; netrc-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 1a4cc744f0c..8f5bddb71fa 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -128,7 +128,7 @@ (when prev (setq string (concat prev string)) (process-put proc 'previous-string nil))) - (if (and (not (string-match "\n" string)) + (if (and (not (string-search "\n" string)) (> (length string) 0)) (process-put proc 'previous-string string)) (let ((command (split-string string))) @@ -611,7 +611,7 @@ (skip-unless (gnutls-available-p)) (let ((server (make-tls-server 44667)) (times 0) - nowait + (nowait nil) ; Workaround Bug#47080 proc status) (unwind-protect (progn diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index ed532af657a..bfb83f25184 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -67,4 +67,4 @@ (require 'shr) -;;; shr-stream-tests.el ends here +;;; shr-tests.el ends here diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el index 71bdd74890a..7fb885235c0 100644 --- a/test/lisp/net/socks-tests.el +++ b/test/lisp/net/socks-tests.el @@ -95,7 +95,7 @@ ;; From fedora.org: 2605:bc80:3010:600:dead:beef:cafe:fed9 ;; 5004 ~~> Version Status (OK) NOOP Addr-Type (4 -> IPv6) (socks-filter proc "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60") - (ert-info ("State still waiting and response emtpy") + (ert-info ("State still waiting and response empty") (should (eq (process-get proc 'socks-state) socks-state-waiting)) (should-not (process-get proc 'socks-response))) (ert-info ("Scratch field holds partial payload of pending msg") @@ -128,7 +128,7 @@ (defvar socks-tests-canned-server-patterns nil "Alist containing request/response cons pairs to be tried in order. -Vectors must match verbatim. Strings are considered regex patterns.") +Vectors must match verbatim. Strings are considered regex patterns.") (defun socks-tests-canned-server-create () "Create and return a fake SOCKS server." @@ -203,7 +203,7 @@ Vectors must match verbatim. Strings are considered regex patterns.") (should (equal host "example.com")) (list 93 184 216 34))) ((symbol-function 'user-full-name) - (lambda () "foo"))) + (lambda (&optional _) "foo"))) (socks-tests-perform-hello-world-http-request))))) ;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index aac1b13bd0e..98012f4e909 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -923,9 +923,10 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "(progn \ (message \"tramp-archive loaded: %%s\" \ (featurep 'tramp-archive)) \ - (file-attributes %S \"/\") \ + (let ((inhibit-message t)) \ + (file-attributes %S \"/\")) \ (message \"tramp-archive loaded: %%s\" \ - (featurep 'tramp-archive)))")) + (featurep 'tramp-archive))))")) (dolist (default-directory `(,temporary-file-directory ;; Starting Emacs in a directory which has diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 052c03029fd..3d6ce963eef 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -52,6 +52,7 @@ (require 'vc-git) (require 'vc-hg) +(declare-function tramp-check-remote-uname "tramp-sh") (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-chmod-h "tramp-sh") (declare-function tramp-get-remote-gid "tramp-sh") @@ -61,6 +62,7 @@ (declare-function tramp-list-tramp-buffers "tramp-cmds") (declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") +(declare-function dired-compress "dired-aux") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) (defvar lock-file-name-transforms) @@ -68,6 +70,7 @@ (defvar tramp-connection-properties) (defvar tramp-copy-size-limit) (defvar tramp-display-escape-sequence-regexp) +(defvar tramp-fuse-unmount-on-cleanup) (defvar tramp-inline-compress-start-size) (defvar tramp-persistency-file-name) (defvar tramp-remote-path) @@ -177,6 +180,19 @@ The temporary file is not created." (make-temp-name "tramp-test") (if local temporary-file-directory tramp-test-temporary-file-directory)))) +;; Method "smb" supports `make-symbolic-link' only if the remote host +;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el +;; and tramp-sshfs.el do not support symbolic links at all. +(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) + "Run BODY, ignoring \"make-symbolic-link not supported\" file error." + (declare (indent defun) (debug (body))) + `(condition-case err + (progn ,@body) + (file-error + (unless (string-equal (error-message-string err) + "make-symbolic-link not supported") + (signal (car err) (cdr err)))))) + ;; Don't print messages in nested `tramp--test-instrument-test-case' calls. (defvar tramp--test-instrument-test-case-p nil "Whether `tramp--test-instrument-test-case' run. @@ -2070,7 +2086,7 @@ Also see `ignore'." "/method:host:/:/path//foo")) ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 25, occasionally. No idea what's up. + ;; Emacs 25, occasionally. No idea what's up. (when (tramp--test-emacs26-p) (should (string-equal @@ -2759,21 +2775,31 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) - (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) + (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) + (unusual-file-mode-1 #o740) + (unusual-file-mode-2 #o710)) (unwind-protect (progn - (make-directory tmp-name1) + (with-file-modes unusual-file-mode-1 + (make-directory tmp-name1)) (should-error (make-directory tmp-name1) :type 'file-already-exists) (should (file-directory-p tmp-name1)) (should (file-accessible-directory-p tmp-name1)) + (when (tramp--test-supports-set-file-modes-p) + (should (equal (format "%#o" unusual-file-mode-1) + (format "%#o" (file-modes tmp-name1))))) (should-error (make-directory tmp-name2) :type 'file-error) - (make-directory tmp-name2 'parents) + (with-file-modes unusual-file-mode-2 + (make-directory tmp-name2 'parents)) (should (file-directory-p tmp-name2)) (should (file-accessible-directory-p tmp-name2)) + (when (tramp--test-supports-set-file-modes-p) + (should (equal (format "%#o" unusual-file-mode-2) + (format "%#o" (file-modes tmp-name2))))) ;; If PARENTS is non-nil, `make-directory' shall not ;; signal an error when DIR exists already. (make-directory tmp-name2 'parents)) @@ -2866,7 +2892,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (file-name-nondirectory tmp-name1) tmp-name2)) (tmp-name4 (expand-file-name "foo" tmp-name1)) (tmp-name5 (expand-file-name "foo" tmp-name2)) - (tmp-name6 (expand-file-name "foo" tmp-name3))) + (tmp-name6 (expand-file-name "foo" tmp-name3)) + (tmp-name7 (tramp--test-make-temp-name nil quoted))) ;; Copy complete directory. (unwind-protect @@ -2922,7 +2949,48 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive) - (delete-directory tmp-name2 'recursive)))))) + (delete-directory tmp-name2 'recursive))) + + ;; Copy symlink to directory. Implemented since Emacs 28.1. + (when (boundp 'copy-directory-create-symlink) + (dolist (copy-directory-create-symlink '(nil t)) + (unwind-protect + (tramp--test-ignore-make-symbolic-link-error + ;; Copy to file name. + (make-directory tmp-name1) + (write-region "foo" nil tmp-name4) + (make-symbolic-link tmp-name1 tmp-name7) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (should (file-symlink-p tmp-name7)) + (copy-directory tmp-name7 tmp-name2) + (if copy-directory-create-symlink + (should + (string-equal + (file-symlink-p tmp-name2) (file-symlink-p tmp-name7))) + (should (file-directory-p tmp-name2))) + ;; Copy to directory name. + (delete-directory tmp-name2 'recursive) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-directory tmp-name7 (file-name-as-directory tmp-name2)) + (if copy-directory-create-symlink + (should + (string-equal + (file-symlink-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2)) + (file-symlink-p tmp-name7))) + (should + (file-directory-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2))))) + + ;; Cleanup. + (ignore-errors + (delete-directory tmp-name1 'recursive) + (delete-directory tmp-name2 'recursive) + (delete-directory tmp-name7 'recursive)))))))) (ert-deftest tramp-test16-directory-files () "Check `directory-files'." @@ -3092,7 +3160,20 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (regexp-opt (directory-files tmp-name1)) (length (directory-files tmp-name1))))))) - ;; Check error case. + ;; Check error cases. + (when (and (tramp--test-supports-set-file-modes-p) + ;; With "sshfs", directories with zero file + ;; modes are still "accessible". + (not (tramp--test-sshfs-p)) + ;; A directory is always accessible for user "root". + (not (zerop (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1))))) + (set-file-modes tmp-name1 0) + (with-temp-buffer + (should-error + (insert-directory tmp-name1 nil) + :type 'file-error)) + (set-file-modes tmp-name1 #o777)) (delete-directory tmp-name1 'recursive) (with-temp-buffer (should-error @@ -3266,19 +3347,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ignore-errors (kill-buffer buffer)) (ignore-errors (delete-directory tmp-name1 'recursive)))))) -;; Method "smb" supports `make-symbolic-link' only if the remote host -;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el -;; and tramp-sshfs.el do not support symbolic links at all. -(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) - "Run BODY, ignoring \"make-symbolic-link not supported\" file error." - (declare (indent defun) (debug (body))) - `(condition-case err - (progn ,@body) - (file-error - (unless (string-equal (error-message-string err) - "make-symbolic-link not supported") - (signal (car err) (cdr err)))))) - (ert-deftest tramp-test18-file-attributes () "Check `file-attributes'. This tests also `access-file', `file-readable-p', @@ -3318,9 +3386,21 @@ This tests also `access-file', `file-readable-p', (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) + (when (tramp--test-supports-set-file-modes-p) + (write-region "foo" nil tmp-name1) + ;; A file is always accessible for user "root". + (when (not (zerop (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)))) + (set-file-modes tmp-name1 0) + (should-error + (access-file tmp-name1 "error") + :type 'file-error) + (set-file-modes tmp-name1 #o777)) + (delete-file tmp-name1)) (should-error (access-file tmp-name1 "error") :type tramp-file-missing) + ;; `file-ownership-preserved-p' should return t for ;; non-existing files. (when test-file-ownership-preserved-p @@ -3548,13 +3628,7 @@ They might differ only in time attributes or directory size." "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) - (skip-unless - (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) - ;; Not all tramp-gvfs.el methods support changing the file mode. - (and - (tramp--test-gvfs-p) - (string-match-p - "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) + (skip-unless (tramp--test-supports-set-file-modes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) @@ -3890,7 +3964,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) (if (tramp--test-smb-p) - ;; The symlink command of `smbclient' detects the + ;; The symlink command of "smbclient" detects the ;; cycle already. (should-error (make-symbolic-link tmp-name1 tmp-name2) @@ -4001,6 +4075,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test24-file-acl () "Check that `file-acl' and `set-file-acl' work proper." (skip-unless (tramp--test-enabled)) + ;; The following test checks also whether `set-file-modes' will work. (skip-unless (file-acl tramp-test-temporary-file-directory)) (skip-unless (not (tramp--test-crypt-p))) @@ -4239,12 +4314,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; for completion. We must refill the cache. (tramp-set-connection-property tramp-test-vec "property" nil) - (let ;; This is needed for the `simplified' syntax. - ((method-marker - (if (zerop (length tramp-method-regexp)) - "" tramp-default-method-marker)) - ;; This is needed for the `separate' syntax. - (prefix-format (substring tramp-prefix-format 1)) + (let ;; This is needed for the `separate' syntax. + ((prefix-format (substring tramp-prefix-format 1)) ;; This is needed for the IPv6 host name syntax. (ipv6-prefix (and (string-match-p tramp-ipv6-regexp host) @@ -4260,22 +4331,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (concat prefix-format method tramp-postfix-method-format) (file-name-all-completions (concat prefix-format (substring method 0 1)) "/")))) - ;; Complete host name for default method. With gvfs - ;; based methods, host name will be determined as - ;; host.local, so we omit the test. - (let ((tramp-default-method (or method tramp-default-method))) - (unless (or (zerop (length host)) - (tramp--test-gvfs-p tramp-default-method)) - (should - (member - (concat - prefix-format method-marker tramp-postfix-method-format - ipv6-prefix host ipv6-postfix tramp-postfix-host-format) - (file-name-all-completions - (concat - prefix-format method-marker tramp-postfix-method-format - ipv6-prefix (substring host 0 1)) - "/"))))) ;; Complete host name. (unless (or (zerop (length method)) (zerop (length tramp-method-regexp)) @@ -4388,8 +4443,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `process-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4431,7 +4485,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) (should (zerop (process-file "ls" nil t nil fnnd))) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4439,10 +4493,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (format "%s\n" fnnd) (buffer-string))) (should-not (get-buffer-window (current-buffer) t)) - ;; Second run. The output must be appended. + ;; Second run. The output must be appended. (goto-char (point-max)) (should (zerop (process-file "ls" nil t t fnnd))) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4455,7 +4509,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) -;; Must be a command, because used as `sigusr' handler. +;; Must be a command, because used as `sigusr1' handler. (defun tramp--test-timeout-handler (&rest _ignore) "Timeout handler, reporting a failed test." (interactive) @@ -4469,8 +4523,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `start-file-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) @@ -4535,16 +4588,75 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))) + ;; "telnet" and "sshfs" do not cooperate with disabled filter. + (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test3" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (set-process-filter proc t) + (process-send-string proc "foo\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) + ;; No output due to process filter. + (should (= (point-min) (point-max)))) + + ;; Cleanup. + (ignore-errors (delete-process proc)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + (not (tramp-direct-async-process-p)) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (process-connection-type '(nil pipe t pty)) + (unwind-protect + (with-temp-buffer + (setq proc + (start-file-process + (format "test4-%s" process-connection-type) + (current-buffer) "hexdump" "-v" "-e" "/1 \"%02X\n\"")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (and (memq process-connection-type '(nil pipe)) + (not (tramp--test-macos-p))) + ;; On macOS, there is always newline conversion. + ;; "telnet" converts \r to <CR><NUL> if `crlf' + ;; flag is FALSE. See telnet(1) man page. + "66\n6F\n6F\n0D\\(\n00\\)?\n0A\n" + "66\n6F\n6F\n0A\\(\n00\\)?\n0A\n") + (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + ;; PTY. (unwind-protect (with-temp-buffer ;; It works only for tramp-sh.el, and not direct async processes. (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error - (start-file-process "test4" (current-buffer) nil) + (start-file-process "test5" (current-buffer) nil) :type 'wrong-type-argument) - (setq proc (start-file-process "test4" (current-buffer) nil)) + (setq proc (start-file-process "test5" (current-buffer) nil)) (should (processp proc)) (should (equal (process-status proc) 'run)) ;; On MS Windows, `process-tty-name' returns nil. @@ -4559,8 +4671,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Define ert test `TEST-direct-async' for direct async processes. If UNSTABLE is non-nil, the test is tagged as `:unstable'." (declare (indent 1)) - ;; `make-process' supports file name handlers since Emacs 27. - (when (let ((file-name-handler-alist '(("" . #'tramp--test-always)))) + ;; `make-process' supports file name handlers since Emacs 27. We + ;; cannot use `tramp--test-always' during compilation of the macro. + (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t))))) (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring @@ -4589,8 +4702,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." "Check `make-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) @@ -4668,6 +4780,30 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) + ;; "telnet" and "sshfs" do not cooperate with disabled filter. + (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test3" :buffer (current-buffer) :command '("cat") + :filter t + :file-handler t))) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) + ;; No output due to process filter. + (should (= (point-min) (point-max)))) + + ;; Cleanup. + (ignore-errors (delete-process proc)))) + ;; Process sentinel. (unwind-protect (with-temp-buffer @@ -4693,8 +4829,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; Process with stderr buffer. - (unless (tramp-direct-async-process-p) + ;; Process with stderr buffer. "telnet" does not cooperate with + ;; three processes. + (unless (or (tramp--test-telnet-p) (tramp-direct-async-process-p)) (let ((stderr (generate-new-buffer "*stderr*"))) (unwind-protect (with-temp-buffer @@ -4749,7 +4886,57 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmp-name))))))) + (ignore-errors (delete-file tmp-name)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + (not (tramp-direct-async-process-p)) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (connection-type '(nil pipe t pty)) + ;; `process-connection-type' is taken when + ;; `:connection-type' is nil. + (dolist (process-connection-type + (unless connection-type '(nil pipe t pty))) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name + (format "test7-%s-%s" + connection-type process-connection-type) + :buffer (current-buffer) + :connection-type connection-type + :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + :file-handler t))) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (and (memq (or connection-type process-connection-type) + '(nil pipe)) + (not (tramp--test-macos-p))) + ;; On macOS, there is always newline conversion. + ;; "telnet" converts \r to <CR><NUL> if `crlf' + ;; flag is FALSE. See telnet(1) man page. + "66\n6F\n6F\n0D\\(\n00\\)?\n0A\n" + "66\n6F\n6F\n0A\\(\n00\\)?\n0A\n") + (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))))))) (tramp--test--deftest-direct-async-process tramp-test30-make-process "Check direct async `make-process'.") @@ -4818,11 +5005,11 @@ INPUT, if non-nil, is a string sent to the process." "Check `shell-command'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4846,7 +5033,7 @@ INPUT, if non-nil, is a string sent to the process." this-shell-command (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4920,8 +5107,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless nil) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. (skip-unless (tramp--test-emacs27-p)) @@ -5242,11 +5428,11 @@ Use direct async.") "Check that connection-local `explicit-shell-file-name' is set." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -5301,8 +5487,8 @@ Use direct async.") (ert-deftest tramp-test35-exec-path () "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) + (skip-unless (tramp--test-supports-set-file-modes-p)) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -5323,6 +5509,7 @@ Use direct async.") ;; found. (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) (should (file-executable-p tmp-name)) (should @@ -5391,9 +5578,9 @@ Use direct async.") ;; Ignore trailing newline. (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) ;; The shell doesn't handle such long strings. - (unless (<= (length path) - (tramp-get-connection-property - tramp-test-vec "pipe-buf" 4096)) + (when (<= (length path) + (tramp-get-connection-property + tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. (should (string-equal @@ -5767,10 +5954,7 @@ Use direct async.") tramp-allow-unsafe-temporary-files (inhibit-message t) ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. - (tramp-cleanup-connection-hook - (append - (and (tramp--test-fuse-p) '(tramp-fuse-unmount)) - tramp-cleanup-connection-hook)) + (tramp-fuse-unmount-on-cleanup t) auto-save-default noninteractive) @@ -5950,7 +6134,7 @@ This requires restrictions of file name syntax." 'tramp-ftp-file-name-handler)) (defun tramp--test-crypt-p () - "Check, whether the remote directory is crypted" + "Check, whether the remote directory is crypted." (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) (defun tramp--test-docker-p () @@ -5987,8 +6171,7 @@ If optional METHOD is given, it is checked first." Several special characters do not work properly there." ;; We must refill the cache. `file-truename' does it. (file-truename tramp-test-temporary-file-directory) - (string-match-p - "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) + (tramp-check-remote-uname tramp-test-vec "^HP-UX")) (defun tramp--test-ksh-p () "Check, whether the remote shell is ksh. @@ -5999,12 +6182,22 @@ a $'' syntax." (string-match-p "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) +(defun tramp--test-macos-p () + "Check, whether the remote host runs macOS." + ;; We must refill the cache. `file-truename' does it. + (file-truename tramp-test-temporary-file-directory) + (tramp-check-remote-uname tramp-test-vec "Darwin")) + (defun tramp--test-mock-p () "Check, whether the mock method is used. This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-out-of-band-p () + "Check, whether an out-of-band method is used." + (tramp-method-out-of-band-p tramp-test-vec 1)) + (defun tramp--test-rclone-p () "Check, whether the remote host is offered by rclone. This requires restrictions of file name syntax." @@ -6047,6 +6240,12 @@ This requires restrictions of file name syntax." "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) +(defun tramp--test-telnet-p () + "Check, whether the telnet method is used. +This does not support special file names." + (string-equal + "telnet" (file-remote-p tramp-test-temporary-file-directory 'method))) + (defun tramp--test-windows-nt-p () "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) @@ -6054,13 +6253,13 @@ This requires restrictions of file name syntax." (defun tramp--test-windows-nt-and-out-of-band-p () "Check, whether the locale host runs MS Windows and an out-of-band method. This does not support utf8 based file transfer." - (and (eq system-type 'windows-nt) - (tramp-method-out-of-band-p tramp-test-vec 1))) + (and (tramp--test-windows-nt-p) + (tramp--test-out-of-band-p))) (defun tramp--test-windows-nt-or-smb-p () "Check, whether the locale or remote host runs MS Windows. This requires restrictions of file name syntax." - (or (eq system-type 'windows-nt) + (or (tramp--test-windows-nt-p) (tramp--test-smb-p))) (defun tramp--test-smb-p () @@ -6068,6 +6267,22 @@ This requires restrictions of file name syntax." This requires restrictions of file name syntax." (tramp-smb-file-name-p tramp-test-temporary-file-directory)) +(defun tramp--test-supports-processes-p () + "Return whether the method under test supports external processes." + (and (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p)) + (not (tramp--test-crypt-p)))) + +(defun tramp--test-supports-set-file-modes-p () + "Return whether the method under test supports setting file modes." + ;; "smb" does not unless the SMB server supports "posix" extensions. + ;; "adb" does not unless the Android device is rooted. + (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) + ;; Not all tramp-gvfs.el methods support changing the file mode. + (and + (tramp--test-gvfs-p) + (string-match-p + "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) + (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. @@ -6161,9 +6376,9 @@ This requires restrictions of file name syntax." (kill-buffer buffer) ;; `substitute-in-file-name' could return different - ;; values. For `adb', there could be strange file + ;; values. For "adb", there could be strange file ;; permissions preventing overwriting a file. We don't - ;; care in this testcase. + ;; care in this test case. (dolist (elt files) (let ((file1 (substitute-in-file-name (expand-file-name elt tmp-name1))) @@ -6320,6 +6535,7 @@ This requires restrictions of file name syntax." ;; These tests are inspired by Bug#17238. (ert-deftest tramp-test41-special-characters () "Check special characters in file names." + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) @@ -6328,8 +6544,9 @@ This requires restrictions of file name syntax." (ert-deftest tramp-test41-special-characters-with-stat () "Check special characters in file names. -Use the `stat' command." +Use the \"stat\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 287s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6346,8 +6563,9 @@ Use the `stat' command." (ert-deftest tramp-test41-special-characters-with-perl () "Check special characters in file names. -Use the `perl' command." +Use the \"perl\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 266s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6367,8 +6585,9 @@ Use the `perl' command." (ert-deftest tramp-test41-special-characters-with-ls () "Check special characters in file names. -Use the `ls' command." +Use the \"ls\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 287s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6434,6 +6653,7 @@ Use the `ls' command." (ert-deftest tramp-test42-utf8 () "Check UTF8 encoding in file names and file contents." + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 620s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) @@ -6447,13 +6667,14 @@ Use the `ls' command." (ert-deftest tramp-test42-utf8-with-stat () "Check UTF8 encoding in file names and file contents. -Use the `stat' command." +Use the \"stat\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 595s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6469,13 +6690,14 @@ Use the `stat' command." (ert-deftest tramp-test42-utf8-with-perl () "Check UTF8 encoding in file names and file contents. -Use the `perl' command." +Use the \"perl\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 620s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6494,13 +6716,14 @@ Use the `perl' command." (ert-deftest tramp-test42-utf8-with-ls () "Check UTF8 encoding in file names and file contents. -Use the `ls' command." +Use the \"ls\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 690s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) @@ -6580,12 +6803,14 @@ process sentinels. They shall not disturb each other." :tags (if (getenv "EMACS_EMBA_CI") '(:expensive-test :unstable) '(:expensive-test)) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) (skip-unless (not (tramp--test-docker-p))) + (skip-unless (not (tramp--test-telnet-p))) + (skip-unless (not (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-windows-nt-p))) (with-timeout @@ -6623,11 +6848,6 @@ process sentinels. They shall not disturb each other." (cond ((getenv "EMACS_HYDRA_CI") 10) (t 1))) - ;; We must distinguish due to performance reasons. - (timer-operation - (cond - ((tramp--test-mock-p) #'vc-registered) - (t #'file-attributes))) ;; This is when all timers start. We check inside the ;; timer function, that we don't exceed timeout. (timer-start (current-time)) @@ -6655,6 +6875,8 @@ process sentinels. They shall not disturb each other." (default-directory tmp-name) (file (buffer-name + ;; Use `seq-random-elt' once <26.1 support + ;; is dropped. (nth (random (length buffers)) buffers))) ;; A remote operation in a timer could ;; confuse Tramp heavily. So we ignore this @@ -6663,7 +6885,7 @@ process sentinels. They shall not disturb each other." (cons 'remote-file-error debug-ignored-errors))) (tramp--test-message "Start timer %s %s" file (current-time-string)) - (funcall timer-operation file) + (vc-registered file) (tramp--test-message "Stop timer %s %s" file (current-time-string)) ;; Adjust timer if it takes too much time. @@ -6720,6 +6942,7 @@ process sentinels. They shall not disturb each other." ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers + ;; Use `seq-random-elt' once <26.1 support is dropped. (let* ((buf (nth (random (length buffers)) buffers)) (proc (get-buffer-process buf)) (file (process-get proc 'foo)) @@ -6776,8 +6999,40 @@ process sentinels. They shall not disturb each other." ;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) +(ert-deftest tramp-test45-dired-compress-file () + "Check that Tramp (un)compresses normal files." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (write-region "foo" nil tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-file tmp-name))) + +(ert-deftest tramp-test45-dired-compress-dir () + "Check that Tramp (un)compresses directories." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (make-directory tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".tar.gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-directory tmp-name))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test45-auto-load () +(ert-deftest tramp-test46-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -6802,7 +7057,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-delay-load () +(ert-deftest tramp-test46-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6835,7 +7090,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test45-recursive-load () +(ert-deftest tramp-test46-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -6859,7 +7114,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test45-remote-load-path () +(ert-deftest tramp-test46-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6888,7 +7143,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-unload () +(ert-deftest tramp-test47-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -6967,8 +7222,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. -;; * Fix `tramp-test06-directory-file-name' for `ftp'. -;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and +;; * Fix `tramp-test06-directory-file-name' for "ftp". +;; * Implement `tramp-test31-interrupt-process' for "adb", "sshfs" and ;; for direct async processes. ;; * Check, why direct async processes do not work for ;; `tramp-test44-asynchronous-requests'. diff --git a/test/lisp/newcomment-tests.el b/test/lisp/newcomment-tests.el new file mode 100644 index 00000000000..65690e593db --- /dev/null +++ b/test/lisp/newcomment-tests.el @@ -0,0 +1,39 @@ +;;; newcomment-tests.el --- Tests for newcomment.el -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest test-uncomment-space-comment-continue () + (let ((comment-style 'multi-line) + (comment-continue " ") + (text " a\n b")) + (should + (equal text + (with-temp-buffer + (c-mode) + (insert text) + (comment-region (point-min) (point-max)) + (uncomment-region (point-min) (point-max)) + (buffer-string)))))) + +;;; newcomment-tests.el ends here diff --git a/test/lisp/mail/rfc2368-tests.el b/test/lisp/obsolete/rfc2368-tests.el index f997ea3ecb4..f997ea3ecb4 100644 --- a/test/lisp/mail/rfc2368-tests.el +++ b/test/lisp/obsolete/rfc2368-tests.el diff --git a/test/lisp/org/org-tests.el b/test/lisp/org/org-tests.el index c1985a46a40..e53b0384081 100644 --- a/test/lisp/org/org-tests.el +++ b/test/lisp/org/org-tests.el @@ -29,3 +29,5 @@ Ref <https://debbugs.gnu.org/30310>." (should (require 'org-version nil t)) (should (equal (version-to-list (org-release)) (cdr (assq 'org package--builtin-versions))))) + +;;; org-tests.el ends here diff --git a/test/lisp/paren-tests.el b/test/lisp/paren-tests.el index c4bec5d86de..11249ee9bc1 100644 --- a/test/lisp/paren-tests.el +++ b/test/lisp/paren-tests.el @@ -117,5 +117,36 @@ (- (point-max) 1) (point-max) nil))))) +(ert-deftest paren-tests-open-paren-line () + (cl-flet ((open-paren-line () + (let* ((data (show-paren--default)) + (here-beg (nth 0 data)) + (there-beg (nth 2 data))) + (blink-paren-open-paren-line-string + (min here-beg there-beg))))) + ;; Lisp-like + (with-temp-buffer + (insert "(defun foo () + (dummy))") + (goto-char (point-max)) + (should (string= "(defun foo ()" (open-paren-line)))) + + ;; C-like + (with-temp-buffer + (insert "int foo() { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo() {" (open-paren-line)))) + + ;; C-like with hanging { + (with-temp-buffer + (insert "int foo() + { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo()...{" (open-paren-line)))))) + (provide 'paren-tests) ;;; paren-tests.el ends here diff --git a/test/lisp/play/cookie1-tests.el b/test/lisp/play/cookie1-tests.el index 75dea4e5ef0..2dd73d18028 100644 --- a/test/lisp/play/cookie1-tests.el +++ b/test/lisp/play/cookie1-tests.el @@ -37,4 +37,4 @@ (should (= (length (cookie-apropos "false" fortune-file)) 1)))) (provide 'fortune-tests) -;;; fortune-tests.el ends here +;;; cookie1-tests.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el new file mode 100644 index 00000000000..7a3ab5fbda0 --- /dev/null +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -0,0 +1,128 @@ +;;; bug-reference-tests.el --- Tests for bug-reference.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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 'bug-reference) +(require 'ert) + +(defun test--get-github-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "github.com" 'github "https")) + url) + (match-string 1 url))) + +(defun test--get-gitlab-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitlab.com" 'gitlab "https")) + url) + (match-string 1 url))) + +(defun test--get-gitea-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitea.com" 'gitea "https")) + url) + (match-string 1 url))) + +(ert-deftest test-github-entry () + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitlab-entry () + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitea-entry () + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit/") + "magit/magit"))) + +;;; bug-reference-tests.el ends here diff --git a/test/lisp/progmodes/cperl-mode-resources/grammar.pl b/test/lisp/progmodes/cperl-mode-resources/grammar.pl index c05fd7efc2a..96a86993082 100644 --- a/test/lisp/progmodes/cperl-mode-resources/grammar.pl +++ b/test/lisp/progmodes/cperl-mode-resources/grammar.pl @@ -1,6 +1,7 @@ use 5.024; use strict; use warnings; +use utf8; sub outside { say "Line @{[__LINE__]}: package '@{[__PACKAGE__]}'"; @@ -155,4 +156,17 @@ package :: { Shoved::elsewhere(); +# Finally, try unicode identifiers. +package Erdős::Number; + +sub erdős_number { + my $name = shift; + if ($name eq "Erdős Pál") { + return 0; + } + else { + die "No access to the database. Sorry."; + } +} + 1; diff --git a/test/lisp/progmodes/cperl-mode-resources/here-docs.pl b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl index 8af4625fff3..bb3d4871a91 100644 --- a/test/lisp/progmodes/cperl-mode-resources/here-docs.pl +++ b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl @@ -17,7 +17,7 @@ For each of the HERE documents, the following checks will done: =item * -All occurrences of the string "look-here" are fontified correcty. +All occurrences of the string "look-here" are fontified correctly. Note that we deliberately test the face, not the syntax property: Users won't care for the syntax property, but they see the face. Different implementations with different syntax properties have been diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index 4d2bac6ee47..29b9e3f6fb9 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -154,16 +154,122 @@ point in the distant past, and is still broken in perl-mode. " (should (equal (get-text-property (match-beginning 0) 'face) 'font-lock-keyword-face)))) +(ert-deftest cperl-test-fontify-special-variables () + "Test fontification of variables like $^T or ${^ENCODING}. +These can occur as \"local\" aliases." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (insert "local ($^I, ${^UNICODE});\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "$") + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (search-forward "$") + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-identify-heredoc () + "Test whether a construct containing \"<<\" followed by a + bareword is properly identified for a here-document if + appropriate." + (let ((here-docs + '("$text .= <<DELIM;" ; mutator concatenating a here-doc + "func($arg) . <<DELIM;" ; concatenating a return value + "func 1, <<DELIM;" ; a function taking two arguments + )) + ;; There forms are currently mishandled in `perl-mode' :-( + (here-docs-cperl + '("print {a} <<DELIM;" ; printing to a file handle + "system $prog <<DELIM;" ; lie about the program's name + )) + (_undecidable + '("foo <<bar") ; could be either "foo() <<bar" + ; or "foo(<<bar)" + )) + (dolist (code (append here-docs (if (eq cperl-test-mode #'cperl-mode) + here-docs-cperl))) + (with-temp-buffer + (insert code "\n\nDELIM\n") + (funcall cperl-test-mode) + (goto-char (point-min)) + (forward-line 1) + ;; We should now be within a here-doc. + (let ((ppss (syntax-ppss))) + (should (and (nth 8 ppss) (nth 4 ppss)))) + )))) + +(ert-deftest cperl-test-identify-no-heredoc () + "Test whether a construct containing \"<<\" which is not a + here-document is properly rejected." + (let ( + (not-here-docs + '("while (<<>>) {" ; double angle bracket operator + "expr <<func();" ; left shift by a return value + "$var <<func;" ; left shift by a return value + "($var+1) <<func;" ; same for an expression + "$hash{key} <<func;" ; same for a hash element + "or $var <<func;" ; same for an expression + "sorted $by <<func" ; _not_ a call to sort + )) + (_undecidable + '("foo <<bar" ; could be either "foo() <<bar" + ; or "foo(<<bar)" + "$foo = <<;") ; empty delim forbidden since 5.28 + )) + (dolist (code not-here-docs) + (with-temp-buffer + (insert code "\n\n") + (funcall cperl-test-mode) + (goto-char (point-min)) + (forward-line 1) + ;; Point is not within a here-doc (nor string nor comment). + (let ((ppss (syntax-ppss))) + (should-not (nth 8 ppss))) + )))) + +(ert-deftest cperl-test-here-doc-missing-end () + "Verify that a missing here-document terminator gives a message. +This message prints the terminator which wasn't found and is only +issued by CPerl mode." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "my $foo = <<HERE\n") + (insert "some text here\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (cperl-find-pods-heres) + (should (string-match "End of here-document [‘'`]HERE[’']" + collected-messages)))) + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "my $foo = <<HERE . <<'THERE'\n") + (insert "some text here\n") + (insert "HERE\n") + (insert "more text here\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (cperl-find-pods-heres) + (should (string-match "End of here-document [‘'`]THERE[’']" + collected-messages))))) + (defvar perl-continued-statement-offset) (defvar perl-indent-level) +(defconst cperl--tests-heredoc-face + (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc + 'font-lock-string-face)) +(defconst cperl--tests-heredoc-delim-face + (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc + 'font-lock-constant-face)) + (ert-deftest cperl-test-heredocs () "Test that HERE-docs are fontified with the appropriate face." (require 'perl-mode) (let ((file (ert-resource-file "here-docs.pl")) (cperl-continued-statement-offset perl-continued-statement-offset) - (target-font (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc - 'font-lock-string-face)) (case-fold-search nil)) (with-temp-buffer (insert-file-contents file) @@ -176,7 +282,7 @@ point in the distant past, and is still broken in perl-mode. " (while (search-forward "look-here" nil t) (should (equal (get-text-property (match-beginning 0) 'face) - target-font)) + cperl--tests-heredoc-face)) (beginning-of-line) (should (null (looking-at "[ \t]"))) (forward-line 1))) @@ -205,27 +311,30 @@ the whole string." (and (string-match regexp string) (string= (match-string 0 string) string)))))) -(ert-deftest cperl-test-ws-regexp () +(ert-deftest cperl-test-ws-rx () "Tests capture of very simple regular expressions (yawn)." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '(" " "\t" "\n")) (invalid '("a" " " ""))) - (cperl-test--validate-regexp cperl--ws-regexp + (cperl-test--validate-regexp (rx (eval cperl--ws-rx)) valid invalid))) -(ert-deftest cperl-test-ws-or-comment-regexp () +(ert-deftest cperl-test-ws+-rx () "Tests sequences of whitespace and comment lines." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid `(" " "\t#\n" "\n# \n" ,(concat "# comment\n" "# comment\n" "\n" "#comment\n"))) (invalid '("=head1 NAME\n" ))) - (cperl-test--validate-regexp cperl--ws-or-comment-regexp + (cperl-test--validate-regexp (rx (eval cperl--ws+-rx)) valid invalid))) (ert-deftest cperl-test-version-regexp () "Tests the regexp for recommended syntax of versions in Perl." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '("1" "1.1" "1.1_1" "5.032001" "v120.100.103")) @@ -241,6 +350,7 @@ the whole string." (ert-deftest cperl-test-package-regexp () "Tests the regular expression of Perl package names with versions. Also includes valid cases with whitespace in strange places." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '("package Foo" "package Foo::Bar" @@ -253,9 +363,287 @@ Also includes valid cases with whitespace in strange places." "packageFoo" ; not a package declaration "package Foo1.1" ; invalid package name "class O3D::Sphere"))) ; class not yet supported - (cperl-test--validate-regexp cperl--package-regexp + (cperl-test--validate-regexp (rx (eval cperl--package-rx)) valid invalid))) +(ert-deftest cperl-test-identifier-rx () + "Test valid and invalid identifiers (no sigils)." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("foo" "FOO" "f_oo" "a123" + "manĝis")) ; Unicode is allowed! + (invalid + '("$foo" ; no sigils allowed (yet) + "Foo::bar" ; no package qualifiers allowed + "lots_of_€"))) ; € is not alphabetic + (cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx)) + valid invalid))) + +;;; Test unicode identifier in various places + +(defun cperl--test-unicode-setup (code string) + "Insert CODE, prepare it for tests, and find STRING. +Invoke the appropriate major mode, ensure fontification, and set +point after the first occurrence of STRING (no regexp!)." + (insert code) + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (search-forward string)) + +(ert-deftest cperl-test-unicode-labels () + "Verify that non-ASCII labels are processed correctly." + (with-temp-buffer + (cperl--test-unicode-setup "LABEł: for ($manĝi) { say; }" "LAB") + (should (equal (get-text-property (point) 'face) + 'font-lock-constant-face)))) + +(ert-deftest cperl-test-unicode-sub () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "use strict;\n" ; distinguish bob from b-o-f + "sub ℏ {\n" + " 6.62607015e-34\n" + "};") + "sub ") ; point is before "ℏ" + + ;; Testing fontification + ;; FIXME 2021-09-10: This tests succeeds because cperl-mode + ;; accepts almost anything as a sub name for fontification. For + ;; example, it fontifies "sub @ {...;}" which is a syntax error in + ;; Perl. I let this pass for the moment. + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + + ;; Testing `beginning-of-defun'. Not available in perl-mode, + ;; where it jumps to the beginning of the buffer. + (when (eq cperl-test-mode #'cperl-mode) + (goto-char (point-min)) + (search-forward "-34") + (beginning-of-defun) + (should (looking-at "sub"))))) + +(ert-deftest cperl-test-unicode-varname () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "use strict;\n" + "my $π = 3.1415926535897932384626433832795028841971;\n" + "\n" + "my $manĝi = $π;\n" + "__END__\n") + "my $") ; perl-mode doesn't fontify the sigil, so include it here + + ;; Testing fontification + ;; FIXME 2021-09-10: This test succeeds in cperl-mode because the + ;; π character is "not ASCII alphabetic", so it treats $π as a + ;; punctuation variable. The following two `should' forms with a + ;; longer variable name were added for stronger verification. + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + ;; Test both ends of a longer variable name + (search-forward "my $") ; again skip the sigil + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (search-forward "manĝi") + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-varname-list () + "Verify that all elements of a variable list are fontified." + + (let ((hash-face (if (eq cperl-test-mode #'perl-mode) + 'perl-non-scalar-variable + 'cperl-hash-face)) + (array-face (if (eq cperl-test-mode #'perl-mode) + 'perl-non-scalar-variable + 'cperl-array-face))) + (with-temp-buffer + (cperl--test-unicode-setup + "my (%äsh,@ärräy,$scâlâr);" "%") + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "@") + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "scâlâr") + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face))) + + ;; Now with package-qualified variables + (with-temp-buffer + (cperl--test-unicode-setup + "local (%Søme::äsh,@Søme::ärräy,$Søme::scâlâr);" "%") + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "Søme::") ; test basic identifier + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "@") ; test package name + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "Søme::") ; test basic identifier + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "Søme") ; test package name + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face)) + (search-forward "scâlâr") ; test basic identifier + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face))))) + +(ert-deftest cperl-test-unicode-arrays () + "Test fontification of array access." + ;; Perl mode just looks at the sigil, for element access + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; simple array element + (with-temp-buffer + (cperl--test-unicode-setup + "$ärräy[1] = 7;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array slice + (with-temp-buffer + (cperl--test-unicode-setup + "@ärräy[(1..3)] = (4..6);" "@") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array max index + (with-temp-buffer + (cperl--test-unicode-setup + "$#ärräy = 1;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array dereference + (with-temp-buffer + (cperl--test-unicode-setup + "@$ärräy = (1,2,3)" "@") + (should (equal (get-text-property (1- (point)) 'face) + 'cperl-array-face)) + (should (equal (get-text-property (1+ (point)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-hashes () + "Test fontification of hash access." + ;; Perl mode just looks at the sigil, for element access + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; simple hash element + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh{'a'} = 7;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash array slice + (with-temp-buffer + (cperl--test-unicode-setup + "@häsh{(1..3)} = (4..6);" "@") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash subset + (with-temp-buffer + (cperl--test-unicode-setup + "my %hash = %häsh{'a',2,3};" "= %") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash dereference + (with-temp-buffer + (cperl--test-unicode-setup + "%$äsh = (key => 'value');" "%") + (should (equal (get-text-property (1- (point)) 'face) + 'cperl-hash-face)) + (should (equal (get-text-property (1+ (point)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-hashref () + "Verify that a hashref access disambiguates {s}. +CPerl mode takes the token \"s\" as a substitution unless +detected otherwise. Not for perl-mode: it doesn't stringify +bareword hash keys and doesn't recognize a substitution +\"s}foo}bar}\"" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (cperl--test-unicode-setup "$häshref->{s} # }}" "{") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)) + (should (equal (get-text-property (1+ (point)) 'face) + nil)))) + +(ert-deftest cperl-test-unicode-proto () + ;; perl-mode doesn't fontify prototypes at all + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (cperl--test-unicode-setup + (concat "sub prötötyped ($) {\n" + " ...;" + "}\n") + "prötötyped (") + + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)))) + +(ert-deftest cperl-test-unicode-fhs () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "while (<BAREWÖRD>) {\n" + " ...;)\n" + "}\n") + "while (<") ; point is before the first char of the handle + ;; Testing fontification + ;; FIXME 2021-09-10: perl-mode.el and cperl-mode.el handle these + ;; completely differently. perl-mode interprets barewords as + ;; constants, cperl-mode does not fontify them. Both treat + ;; non-barewords as globs, which are not fontified by perl-mode, + ;; but fontified as strings in cperl-mode. We keep (and test) + ;; that behavior "as is" because both bareword filehandles and + ;; <glob> syntax are no longer recommended. + (let ((bareword-face + (if (equal cperl-test-mode 'perl-mode) 'font-lock-constant-face + nil))) + (should (equal (get-text-property (point) 'face) + bareword-face))))) + +(ert-deftest cperl-test-unicode-hashkeys () + "Test stringification of bareword hash keys. Not in perl-mode. +perl-mode generally does not stringify bareword hash keys." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; Plain hash key + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh { kéy }" "{ ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face))) + ;; Nested hash key + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh { kéy } { kèy }" "} { ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face))) + ;; Key => value + (with-temp-buffer + (cperl--test-unicode-setup + "( kéy => 'value'," "( ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)))) + +(ert-deftest cperl-test-word-at-point () + "Test whether the function captures non-ASCII words." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((words '("rôle" "café" "ångström" + "Data::Dump::dump" + "_underscore"))) + (dolist (word words) + (with-temp-buffer + (insert " + ") ; this will be the suffix + (beginning-of-line) + (insert ")") ; A non-word char + (insert word) + (should (string= word (cperl-word-at-point-hard))))))) + ;;; Function test: Building an index for imenu (ert-deftest cperl-test-imenu-index () @@ -279,7 +667,8 @@ created by CPerl mode, so skip it for Perl mode." "Versioned::Package::outer" "lexical" "Versioned::Block::signatured" - "Package::in_package_again"))) + "Package::in_package_again" + "Erdős::Number::erdős_number"))) (dolist (sub expected) (should (assoc-string sub index))))))) @@ -339,6 +728,72 @@ under timeout control." (should (string-match "poop ('foo', \n 'bar')" (buffer-string)))))) +(ert-deftest cperl-test-bug-14343 () + "Verify that inserting text into a HERE-doc string with Elisp +does not break fontification." + (with-temp-buffer + (insert "my $string = <<HERE;\n" + "One line of text.\n" + "Last line of this string.\n" + "HERE\n") + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (search-forward "One line") + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (beginning-of-line) + (insert "Another line if text.\n") + (font-lock-ensure) + (forward-line -1) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face))) + ;; insert into an empty here-document + (with-temp-buffer + (insert "print <<HERE;\n" + "HERE\n") + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (forward-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert a newline into the empty here-document + (goto-char (point-min)) + (forward-line) + (insert "\n") + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert text at the beginning of the here-doc + (goto-char (point-min)) + (forward-line) + (insert "text") + (font-lock-ensure) + (search-backward "text") + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert a new line immediately before the delimiter + ;; (That's where the point is anyway) + (insert "A new line\n") + (font-lock-ensure) + ;; The delimiter is still the delimiter + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + (forward-line -1) + ;; The new line has been "added" to the here-document + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)))) + (ert-deftest cperl-test-bug-16368 () "Verify that `cperl-forward-group-in-re' doesn't hide errors." (skip-unless (eq cperl-test-mode #'cperl-mode)) diff --git a/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts new file mode 100644 index 00000000000..2c0d51edae8 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts @@ -0,0 +1,88 @@ +Code: + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))) + +Name: defun + +=-= +(defun foo () +"doc" +(+ 1 2)) +=-= +(defun foo () + "doc" + (+ 1 2)) +=-=-= + +Name: function call + +=-= +(foo zot +bar +(zot bar)) +=-= +(foo zot + bar + (zot bar)) +=-=-= + +Name: lisp data + +=-= +( foo zot +bar +(zot bar)) +=-= +( foo zot + bar + (zot bar)) +=-=-= + +Name: defun-space + +=-= +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) +=-=-= + +Name: defvar-keymap + +=-= +(defvar-keymap eww-link-keymap + :copy shr-map + :foo bar + "\r" #'eww-follow-link) +=-=-= + +Name: def-indent1 + +=-= +(defzot-does-not-exist 1 + 2 3) +=-=-= + +Name: def-indent2 + +=-= +(define-keymap 1 + 2 3) +=-=-= + +Name: elisp-indents1 + +=-= +(defvar foo + () + "bar") +=-=-= + +Name: elisp-indents2 + +=-= +(defvar foo () + "bar") +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/flet.erts b/test/lisp/progmodes/elisp-mode-resources/flet.erts new file mode 100644 index 00000000000..da3dcb6ec3e --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/flet.erts @@ -0,0 +1,353 @@ +Name: flet1 + +=-= +(cl-flet () + (a (dangerous-position + b))) +=-=-= + +Name: flet2 + +=-= +(cl-flet wrong-syntax-but-should-not-obstruct-indentation + (a (dangerous-position + b))) +=-=-= + +Name: flet3 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c))) +=-=-= + +Name: flet4 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet5 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet6 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (irregular-local-def (form returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet7 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet8 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +;; (setf _) not yet supported but looks like it will be +Name: flet9 + +=-= +(cl-flet (((setf a) (new value) + stuff) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet10 + +=-= +(cl-flet ( (a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet11 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet12 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet13 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet14 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation)) +=-=-= + +Name: flet15 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet16 + +=-= +(cl-flet ((f (x) + (g x))) + (pcase e + ((dangerous-expression) + (form)))) +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-1 +Code: (lambda () (emacs-lisp-mode) (setq indent-tabs-mode nil) (newline nil t)) +Point-Char: | + +=-= +(let ((x (and y| +=-= +(let ((x (and y + | +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-2 + +=-= +(let ((x| +=-= +(let ((x + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-1 +Point-Char: | + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-2 +Point-Char: | + +=-= +(cl-flet((f(x)| +=-= +(cl-flet((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-3 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-5 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-1 + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-2 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-3 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-5 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-6 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el new file mode 100644 index 00000000000..9b41fb5426c --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el @@ -0,0 +1,40 @@ +;;; simple-shorthand-test.el --- -*- lexical-binding: t; -*- + +(defun f-test () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (with-temp-buffer + (insert "(foo-bar)") + (goto-char (point-min)) + (read (current-buffer))))) + +(defun f-test2 () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (read-from-string "(foo-bar)"))) + + +(defun f-test3 () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (intern "foo-bar"))) + +(defvar f-test-complete-me 42) + +(elisp--foo-test3) + +(defun #_f-test4--- () 84) + +(defmacro f-define-test-5 ()) + +;; should be font locked with both shorthand +;; highlighting _and_ macro highlighting. +(f-define-test-5) + +(when nil + (f-test3) + (f-test2) + (f-test) + (#_f-test4---)) + + +;; Local Variables: +;; read-symbol-shorthands: (("f-" . "elisp--foo-")) +;; End: diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index f47d54e59c0..7f1cd6795ef 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -23,8 +23,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'xref) (eval-when-compile (require 'cl-lib)) +(require 'ert-x) ;;; Completion @@ -300,12 +302,9 @@ ;; tmp may be on a different filesystem to the tests, but, ehh. (defvar xref--case-insensitive - (let ((dir (make-temp-file "xref-test" t))) - (unwind-protect - (progn - (with-temp-file (expand-file-name "hElLo" dir) "hello") - (file-exists-p (expand-file-name "HELLO" dir))) - (delete-directory dir t))) + (ert-with-temp-directory dir + (with-temp-file (expand-file-name "hElLo" dir) "hello") + (file-exists-p (expand-file-name "HELLO" dir))) "Non-nil if file system seems to be case-insensitive.") (defun xref-elisp-test-run (xrefs expected-xrefs) @@ -315,27 +314,27 @@ (expected (pop expected-xrefs)) (expected-xref (or (when (consp expected) (car expected)) expected)) (expected-source (when (consp expected) (cdr expected))) - (xref-file (xref-elisp-location-file (oref xref location))) + (xref-file (xref-elisp-location-file (xref-item-location xref))) (expected-file (xref-elisp-location-file - (oref expected-xref location)))) + (xref-item-location expected-xref)))) ;; Make sure file names compare as strings. (when (file-name-absolute-p xref-file) - (setf (xref-elisp-location-file (oref xref location)) - (file-truename (xref-elisp-location-file (oref xref location))))) + (setf (xref-elisp-location-file (xref-item-location xref)) + (file-truename (xref-elisp-location-file (xref-item-location xref))))) (when (file-name-absolute-p expected-file) - (setf (xref-elisp-location-file (oref expected-xref location)) + (setf (xref-elisp-location-file (xref-item-location expected-xref)) (file-truename (xref-elisp-location-file - (oref expected-xref location))))) + (xref-item-location expected-xref))))) ;; Downcase the filenames for case-insensitive file systems. (when xref--case-insensitive - (setf (xref-elisp-location-file (oref xref location)) - (downcase (xref-elisp-location-file (oref xref location)))) + (setf (xref-elisp-location-file (xref-item-location xref)) + (downcase (xref-elisp-location-file (xref-item-location xref)))) - (setf (xref-elisp-location-file (oref expected-xref location)) + (setf (xref-elisp-location-file (xref-item-location expected-xref)) (downcase (xref-elisp-location-file - (oref expected-xref location))))) + (xref-item-location expected-xref))))) (should (equal xref expected-xref)) @@ -416,8 +415,6 @@ to (xref-elisp-test-descr-to-target xref)." ;; FIXME: defconst -;; FIXME: eieio defclass - ;; Possible ways of defining the default method implementation for a ;; generic function. We declare these here, so we know we cover all ;; cases, and we don't rely on other code not changing. @@ -429,7 +426,7 @@ to (xref-elisp-test-descr-to-target xref)." slot-1) (cl-defgeneric xref-elisp-generic-no-methods (arg1 arg2) - "doc string generic no-methods" + "Doc string generic no-methods." ;; No default implementation, no methods, but fboundp is true for ;; this symbol; it calls cl-no-applicable-method ) @@ -440,44 +437,44 @@ to (xref-elisp-test-descr-to-target xref)." ;; ‘this’. It passes in interactive tests, so I haven't been able to ;; track down the problem. (cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) - "doc string generic no-default xref-elisp-root-type" + "Doc string generic no-default xref-elisp-root-type." "non-default for no-default") ;; defgeneric after defmethod in file to ensure the fallback search ;; method of just looking for the function name will fail. (cl-defgeneric xref-elisp-generic-no-default (arg1 arg2) - "doc string generic no-default generic" + "Doc string generic no-default generic." ;; No default implementation; this function calls the cl-generic ;; dispatching code. ) (cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) - "doc string generic co-located-default" + "Doc string generic co-located-default." "co-located default") (cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) - "doc string generic co-located-default xref-elisp-root-type" + "Doc string generic co-located-default xref-elisp-root-type." "non-default for co-located-default") (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) - "doc string generic separate-default" + "Doc string generic separate-default." ;; default implementation provided separately ) (cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) - "doc string generic separate-default default" + "Doc string generic separate-default default." "separate default") (cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) - "doc string generic separate-default xref-elisp-root-type" + "Doc string generic separate-default xref-elisp-root-type." "non-default for separate-default") (cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) - "doc string generic implicit-generic default" + "Doc string generic implicit-generic default." "default for implicit generic") (cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) - "doc string generic implicit-generic xref-elisp-root-type" + "Doc string generic implicit-generic xref-elisp-root-type." "non-default for implicit generic") @@ -604,6 +601,12 @@ to (xref-elisp-test-descr-to-target xref)." 'xref-location-marker nil '(xref-etags-location)) 'cl-defmethod (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-etags-apropos-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-etags-apropos-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) )) (xref-elisp-deftest find-defs-defgeneric-eval @@ -617,35 +620,35 @@ to (xref-elisp-test-descr-to-target xref)." (declare-function xref-elisp-overloadable-no-default-default "elisp-mode-tests") (define-overloadable-function xref-elisp-overloadable-no-methods () - "doc string overloadable no-methods") + "Doc string overloadable no-methods.") (define-overloadable-function xref-elisp-overloadable-no-default () - "doc string overloadable no-default") + "Doc string overloadable no-default.") (define-mode-local-override xref-elisp-overloadable-no-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable no-default c-mode." + "Doc string overloadable no-default c-mode." "result overloadable no-default c-mode.") (define-overloadable-function xref-elisp-overloadable-co-located-default () - "doc string overloadable co-located-default" + "Doc string overloadable co-located-default." "result overloadable co-located-default.") (define-mode-local-override xref-elisp-overloadable-co-located-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable co-located-default c-mode." + "Doc string overloadable co-located-default c-mode." "result overloadable co-located-default c-mode.") (define-overloadable-function xref-elisp-overloadable-separate-default () - "doc string overloadable separate-default.") + "Doc string overloadable separate-default.") (defun xref-elisp-overloadable-separate-default-default () - "doc string overloadable separate-default default" + "Doc string overloadable separate-default default." "result overloadable separate-default.") (define-mode-local-override xref-elisp-overloadable-separate-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable separate-default c-mode." + "Doc string overloadable separate-default c-mode." "result overloadable separate-default c-mode.") (xref-elisp-deftest find-defs-define-overload-no-methods @@ -746,15 +749,11 @@ to (xref-elisp-test-descr-to-target xref)." ;; Source for both variable and defun is "(define-minor-mode ;; compilation-minor-mode". There is no way to tell that directly from ;; the symbol, but we can use (memq sym minor-mode-list) to detect -;; that the symbol is a minor mode. See `elisp--xref-find-definitions' -;; for more comments. -;; -;; IMPROVEME: return defvar instead of defun if source near starting -;; point indicates the user is searching for a variable, not a -;; function. +;; that the symbol is a minor mode. In non-filtering mode we only +;; return the function. (require 'compile) ;; not loaded by default at test time (xref-elisp-deftest find-defs-defun-defvar-el - (elisp--xref-find-definitions 'compilation-minor-mode) + (xref-backend-definitions 'elisp "compilation-minor-mode") (list (cons (xref-make "(defun compilation-minor-mode)" @@ -764,12 +763,27 @@ to (xref-elisp-test-descr-to-target xref)." "(define-minor-mode compilation-minor-mode") )) +;; Returning only defvar because source near point indicates the user +;; is searching for a variable, not a function. +(xref-elisp-deftest find-defs-minor-defvar-c + (with-temp-buffer + (emacs-lisp-mode) + (insert "(foo overwrite-mode") + (xref-backend-definitions 'elisp + (xref-backend-identifier-at-point 'elisp))) + (list + (cons + (xref-make "(defvar overwrite-mode)" + (xref-make-elisp-location 'overwrite-mode 'defvar "src/buffer.c")) + "DEFVAR_PER_BUFFER (\"overwrite-mode\"") + )) + (xref-elisp-deftest find-defs-defvar-el - (elisp--xref-find-definitions 'xref--marker-ring) + (elisp--xref-find-definitions 'xref--history) (list - (xref-make "(defvar xref--marker-ring)" + (xref-make "(defvar xref--history)" (xref-make-elisp-location - 'xref--marker-ring 'defvar + 'xref--history 'defvar (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) )) @@ -825,18 +839,6 @@ to (xref-elisp-test-descr-to-target xref)." (insert "?\\N{HEAVY CHECK MARK}") (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) -(ert-deftest elisp-indent-basic () - (with-temp-buffer - (emacs-lisp-mode) - (let ((orig "(defun x () - (print (quote ( thingy great - stuff))) - (print (quote (thingy great - stuff))))")) - (insert orig) - (indent-region (point-min) (point-max)) - (should (equal (buffer-string) orig))))) - (defun test--font (form search) (with-temp-buffer (emacs-lisp-mode) @@ -893,5 +895,218 @@ to (xref-elisp-test-descr-to-target xref)." "(\\(when\\)") nil))) +(defmacro elisp-mode-test--with-buffer (text-with-pos &rest body) + "Eval BODY with buffer and variables from TEXT-WITH-POS. +All occurrences of {NAME} are removed from TEXT-WITH-POS and +the remaining text put in a buffer in `elisp-mode'. +Each NAME is then bound to its position in the text during the +evaluation of BODY." + (declare (indent 1)) + (let* ((annot-text (eval text-with-pos t)) + (pieces nil) + (positions nil) + (tlen (length annot-text)) + (ofs 0) + (text-ofs 0)) + (while + (and (< ofs tlen) + (let ((m (string-match (rx "{" (group (+ (not "}"))) "}") + annot-text ofs))) + (and m + (let ((var (intern (match-string 1 annot-text)))) + (push (substring annot-text ofs m) pieces) + (setq text-ofs (+ text-ofs (- m ofs))) + (push (list var (1+ text-ofs)) positions) + (setq ofs (match-end 0)) + t))))) + (push (substring annot-text ofs tlen) pieces) + (let ((text (apply #'concat (nreverse pieces))) + (bindings (nreverse positions))) + `(with-temp-buffer + (ert-info (,text :prefix "text: ") + (emacs-lisp-mode) + (insert ,text) + (let ,bindings . ,body)))))) + +(ert-deftest elisp-mode-with-buffer () + ;; Sanity test of macro, also demonstrating how it works. + (elisp-mode-test--with-buffer + "{a}123{b}45{c}6" + (should (equal a 1)) + (should (equal b 4)) + (should (equal c 6)) + (should (equal (buffer-string) "123456")))) + +(ert-deftest elisp-mode-infer-namespace () + (elisp-mode-test--with-buffer + (concat " ({p1}alphaX {p2}beta {p3}gamma '{p4}delta\n" + " #'{p5}epsilon `{p6}zeta `(,{p7}eta ,@{p8}theta))\n") + (should (equal (elisp--xref-infer-namespace p1) 'function)) + (should (equal (elisp--xref-infer-namespace p2) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p3) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p4) 'any)) + (should (equal (elisp--xref-infer-namespace p5) 'function)) + (should (equal (elisp--xref-infer-namespace p6) 'any)) + (should (equal (elisp--xref-infer-namespace p7) 'variable)) + (should (equal (elisp--xref-infer-namespace p8) 'variable))) + + (elisp-mode-test--with-buffer + (concat "(let ({p1}alpha {p2}beta ({p3}gamma {p4}delta))\n" + " ({p5}epsilon {p6}zeta)\n" + " {p7}eta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'function)) + (should (equal (elisp--xref-infer-namespace p6) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p7) 'variable))) + + (elisp-mode-test--with-buffer + (concat "(let (({p1}alpha {p2}beta)\n" + " ({p3}gamma ({p4}delta {p5}epsilon)))\n" + " ({p6}zeta))\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'function)) + (should (equal (elisp--xref-infer-namespace p5) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p6) 'function))) + + (elisp-mode-test--with-buffer + (concat "(defun {p1}alpha () {p2}beta)\n" + "(defface {p3}gamma ...)\n" + "(defvar {p4}delta {p5}epsilon)\n" + "(function {p6}zeta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'function)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'face)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'variable)) + (should (equal (elisp--xref-infer-namespace p6) 'function))) + + (elisp-mode-test--with-buffer + (concat "(require '{p1}alpha)\n" + "(fboundp '{p2}beta)\n" + "(boundp '{p3}gamma)\n" + "(facep '{p4}delta)\n" + "(define-key map [f1] '{p5}epsilon)\n") + (should (equal (elisp--xref-infer-namespace p1) 'feature)) + (should (equal (elisp--xref-infer-namespace p2) 'function)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'face)) + (should (equal (elisp--xref-infer-namespace p5) 'function))) + + (elisp-mode-test--with-buffer + (concat "(list {p1}alpha {p2}beta)\n" + "(progn {p3}gamma {p4}delta)\n" + "(lambda ({p5}epsilon {p6}zeta) {p7}eta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'variable)) + (should (equal (elisp--xref-infer-namespace p6) 'variable)) + (should (equal (elisp--xref-infer-namespace p7) 'variable))) + + (elisp-mode-test--with-buffer + (concat "'({p1}alpha {p2}beta\n" + " ({p3}gamma ({p4}delta)))\n") + (should (equal (elisp--xref-infer-namespace p1) 'any)) + (should (equal (elisp--xref-infer-namespace p2) 'any)) + (should (equal (elisp--xref-infer-namespace p3) 'any)) + (should (equal (elisp--xref-infer-namespace p4) 'any)))) + + +(ert-deftest elisp-shorthand-read-buffer () + (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (shorthand-sname (format "s-%s" gsym)) + (expected (intern (format "shorthand-longhand-%s" gsym)))) + (cl-assert (not (intern-soft shorthand-sname))) + (should (equal (let ((read-symbol-shorthands + '(("s-" . "shorthand-longhand-")))) + (with-temp-buffer + (insert shorthand-sname) + (goto-char (point-min)) + (read (current-buffer)))) + expected)) + (should (not (intern-soft shorthand-sname))))) + +(ert-deftest elisp-shorthand-read-from-string () + (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (shorthand-sname (format "s-%s" gsym)) + (expected (intern (format "shorthand-longhand-%s" gsym)))) + (cl-assert (not (intern-soft shorthand-sname))) + (should (equal (let ((read-symbol-shorthands + '(("s-" . "shorthand-longhand-")))) + (car (read-from-string shorthand-sname))) + expected)) + (should (not (intern-soft shorthand-sname))))) + +(ert-deftest elisp-shorthand-load-a-file () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (mapatoms (lambda (s) + (when (string-match "^elisp--foo-" (symbol-name s)) + (unintern s obarray)))) + (load test-file) + (should (intern-soft "elisp--foo-test")) + (should-not (intern-soft "f-test")))) + +(ert-deftest elisp-shorthand-byte-compile-a-file () + + (let ((test-file (ert-resource-file "simple-shorthand-test.el")) + (byte-compiled (ert-resource-file "simple-shorthand-test.elc"))) + (mapatoms (lambda (s) + (when (string-match "^elisp--foo-" (symbol-name s)) + (unintern s obarray)))) + (byte-compile-file test-file) + (should-not (intern-soft "f-test")) + (should (intern-soft "elisp--foo-test")) + (should-not (fboundp (intern-soft "elisp--foo-test"))) + (load byte-compiled) + (should (intern-soft "elisp--foo-test")) + (should-not (intern-soft "f-test")))) + +(ert-deftest elisp-shorthand-completion-at-point () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (load test-file) + (with-current-buffer (find-file-noselect test-file) + (revert-buffer t t) + (goto-char (point-min)) + (insert "f-test-compl") + (completion-at-point) + (goto-char (point-min)) + (should (search-forward "f-test-complete-me" (line-end-position) t)) + (goto-char (point-min)) + (should (string= (symbol-name (read (current-buffer))) + "elisp--foo-test-complete-me")) + (revert-buffer t t)))) + +(ert-deftest elisp-shorthand-escape () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (load test-file) + (should (intern-soft "f-test4---")) + (should-not (intern-soft "elisp--foo-test4---")) + (should (= 84 (funcall (intern-soft "f-test4---")))) + (should (unintern "f-test4---")))) + +(ert-deftest elisp-dont-shadow-punctuation-only-symbols () + (let* ((shorthanded-form '(/= 42 (-foo 42))) + (expected-longhand-form '(/= 42 (fooey-foo 42))) + (observed (let ((read-symbol-shorthands + '(("-" . "fooey-")))) + (car (read-from-string + (with-temp-buffer + (print shorthanded-form (current-buffer)) + (buffer-string))))))) + (should (equal observed expected-longhand-form)))) + +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "elisp-indents.erts")) + (ert-test-erts-file (ert-resource-file "flet.erts") + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index 35a2592e76f..32b73f101e1 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'etags) (eval-when-compile (require 'cl-lib)) @@ -95,19 +96,19 @@ (ert-deftest etags-buffer-local-tags-table-list () "Test that a buffer-local value of `tags-table-list' is used." - (let ((file (make-temp-file "etag-test-tmpfile"))) - (unwind-protect - (progn - (set-buffer (find-file-noselect file)) - (fundamental-mode) - (setq-local tags-table-list - (list (expand-file-name "manual/etags/ETAGS.good_3" - etags-tests--test-dir))) - (cl-letf ((tag-tables tags-table-list) - (tags-file-name nil) - ((symbol-function 'read-file-name) - (lambda (&rest _) - (error "We should not prompt the user")))) - (should (visit-tags-table-buffer)) - (should (equal tags-file-name (car tag-tables))))) - (delete-file file)))) + (ert-with-temp-file file + :suffix "etag-test-tmpfile" + (set-buffer (find-file-noselect file)) + (fundamental-mode) + (setq-local tags-table-list + (list (expand-file-name "manual/etags/ETAGS.good_3" + etags-tests--test-dir))) + (cl-letf ((tag-tables tags-table-list) + (tags-file-name nil) + ((symbol-function 'read-file-name) + (lambda (&rest _) + (error "We should not prompt the user")))) + (should (visit-tags-table-buffer)) + (should (equal tags-file-name (car tag-tables)))))) + +;;; etags-tests.el ends here diff --git a/test/lisp/progmodes/flymake-resources/another-problematic-file.c b/test/lisp/progmodes/flymake-resources/another-problematic-file.c new file mode 100644 index 00000000000..03eacdd8011 --- /dev/null +++ b/test/lisp/progmodes/flymake-resources/another-problematic-file.c @@ -0,0 +1,5 @@ +#include "some-problems.h" + +int frob(char* freb) { + return 42; +} diff --git a/test/lisp/progmodes/flymake-resources/some-problems.h b/test/lisp/progmodes/flymake-resources/some-problems.h index 165d8dd525e..86ea2de3b0d 100644 --- a/test/lisp/progmodes/flymake-resources/some-problems.h +++ b/test/lisp/progmodes/flymake-resources/some-problems.h @@ -2,4 +2,6 @@ strange; +int frob(char); + sint main(); diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index bda1b663c22..4840018236a 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'flymake) (eval-when-compile (require 'subr-x)) ; string-trim @@ -60,7 +61,7 @@ (cl-defun flymake-tests--call-with-fixture (fn file &key (severity-predicate nil sev-pred-supplied-p)) - "Call FN after flymake setup in FILE, using `flymake-proc`. + "Call FN after flymake setup in FILE, using `flymake-proc'. SEVERITY-PREDICATE is used to setup `flymake-proc-diagnostic-type-pred'" (let* ((file (expand-file-name file flymake-tests-data-directory)) @@ -109,7 +110,7 @@ SEVERITY-PREDICATE is used to setup (face-at-point))))) (ert-deftest perl-backend () - "Test the perl backend" + "Test the perl backend." (skip-unless (executable-find "perl")) (flymake-tests--with-flymake ("test.pl") (flymake-goto-next-error) @@ -120,25 +121,24 @@ SEVERITY-PREDICATE is used to setup (defvar ruby-mode-hook) (ert-deftest ruby-backend () - "Test the ruby backend" + "Test the ruby backend." (skip-unless (executable-find "ruby")) ;; Some versions of ruby fail if HOME doesn't exist (bug#29187). - (let* ((tempdir (make-temp-file "flymake-tests-ruby" t)) - (process-environment (cons (format "HOME=%s" tempdir) - process-environment)) - ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 - ;; for this particular yuckiness - (abbreviated-home-dir nil)) - (unwind-protect - (let ((ruby-mode-hook - (lambda () - (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) - (flymake-tests--with-flymake ("test.rb") - (flymake-goto-next-error) - (should (eq 'flymake-warning (face-at-point))) - (flymake-goto-next-error) - (should (eq 'flymake-error (face-at-point))))) - (delete-directory tempdir t)))) + (ert-with-temp-directory tempdir + :suffix "flymake-tests-ruby" + (let* ((process-environment (cons (format "HOME=%s" tempdir) + process-environment)) + ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 + ;; for this particular yuckiness + (abbreviated-home-dir nil) + (ruby-mode-hook + (lambda () + (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) + (flymake-tests--with-flymake ("test.rb") + (flymake-goto-next-error) + (should (eq 'flymake-warning (face-at-point))) + (flymake-goto-next-error) + (should (eq 'flymake-error (face-at-point))))))) (ert-deftest different-diagnostic-types () "Test GCC warning via function predicate." @@ -193,7 +193,7 @@ SEVERITY-PREDICATE is used to setup (defun flymake-tests--diagnose-words (report-fn type words) - "Helper. Call REPORT-FN with diagnostics for WORDS in buffer." + "Helper. Call REPORT-FN with diagnostics for WORDS in buffer." (funcall report-fn (cl-loop for word in words @@ -234,7 +234,7 @@ SEVERITY-PREDICATE is used to setup (lambda (_report-fn) ;; HACK: Shoosh log during tests (setq-local warning-minimum-log-level :emergency) - (error "crashed")))) + (error "Crashed")))) (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore manha aliqua. Ut enim ad minim veniam, quis nostrud @@ -291,7 +291,7 @@ SEVERITY-PREDICATE is used to setup (should-error (flymake-goto-next-error nil nil t)))))) (ert-deftest recurrent-backend () - "Test a backend that calls REPORT-FN multiple times" + "Test a backend that calls REPORT-FN multiple times." (with-temp-buffer (let (tick) (cl-letf @@ -374,4 +374,4 @@ SEVERITY-PREDICATE is used to setup (provide 'flymake-tests) -;;; flymake.el ends here +;;; flymake-tests.el ends here diff --git a/test/lisp/progmodes/gdb-mi-tests.el b/test/lisp/progmodes/gdb-mi-tests.el index ab482214afb..d66df961b63 100644 --- a/test/lisp/progmodes/gdb-mi-tests.el +++ b/test/lisp/progmodes/gdb-mi-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'gdb-mi) @@ -44,3 +46,5 @@ ) (provide 'gdb-mi-tests) + +;;; gdb-mi-tests.el ends here diff --git a/test/lisp/progmodes/opascal-tests.el b/test/lisp/progmodes/opascal-tests.el index 682f2c6cb6b..ea91479362d 100644 --- a/test/lisp/progmodes/opascal-tests.el +++ b/test/lisp/progmodes/opascal-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'opascal) diff --git a/test/lisp/progmodes/pascal-tests.el b/test/lisp/progmodes/pascal-tests.el index e9c705806b3..f5202143e20 100644 --- a/test/lisp/progmodes/pascal-tests.el +++ b/test/lisp/progmodes/pascal-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'pascal) @@ -61,3 +63,5 @@ (should (equal (point) 15)))) (provide 'pascal-tests) + +;;; pascal-tests.el ends here diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el index f63f8ad7253..3f4af5e1f61 100644 --- a/test/lisp/progmodes/perl-mode-tests.el +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -21,6 +21,13 @@ (require 'perl-mode) +(ert-deftest perl-test-lock () + (with-temp-buffer + (perl-mode) + (insert "$package = foo;") + (font-lock-ensure (point-min) (point-max)) + (should (equal (get-text-property 4 'face) 'font-lock-variable-name-face)))) + ;;;; Re-use cperl-mode tests (defvar cperl-test-mode) diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 68460a9fa5b..a469414a743 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -29,29 +29,17 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'grep) (require 'xref) -(defmacro project-tests--with-temporary-directory (var &rest body) - "Create a new temporary directory. -Bind VAR to the name of the directory, and evaluate BODY. Delete -the directory after BODY exits." - (declare (debug (symbolp body)) (indent 1)) - (cl-check-type var symbol) - (let ((directory (make-symbol "directory"))) - `(let ((,directory (make-temp-file "project-tests-" :directory))) - (unwind-protect - (let ((,var ,directory)) - ,@body) - (delete-directory ,directory :recursive))))) - (ert-deftest project/quoted-directory () "Check that `project-files' and `project-find-regexp' deal with quoted directory names (Bug#47799)." (skip-unless (executable-find find-program)) (skip-unless (executable-find "xargs")) (skip-unless (executable-find "grep")) - (project-tests--with-temporary-directory directory + (ert-with-temp-directory directory (let ((default-directory directory) (project-current-inhibit-prompt t) (project-find-functions nil) @@ -95,7 +83,7 @@ quoted directory names (Bug#47799)." returned by `project-ignores' if the root directory is a directory name (Bug#48471)." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (make-empty-file (expand-file-name "ignored-file" dir)) (let* ((project (make-project-tests--trivial @@ -107,4 +95,19 @@ directory name (Bug#48471)." collect (file-relative-name file dir)))) (should (equal relative-files '("some-file")))))) +(ert-deftest project-ignores-bug-50240 () + "Check that `project-files' does not ignore all files. +When `project-ignores' includes a name matching project dir." + (skip-unless (executable-find find-program)) + (ert-with-temp-directory dir + (make-empty-file (expand-file-name "some-file" dir)) + (let* ((project (make-project-tests--trivial + :root (file-name-as-directory dir) + :ignores (list (file-name-nondirectory + (directory-file-name dir))))) + (files (project-files project))) + (should (equal files + (list + (expand-file-name "some-file" dir))))))) + ;;; project-tests.el ends here diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 1af579bb7a4..15bda5c197a 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'python) ;; Dependencies for testing: @@ -48,17 +49,17 @@ BODY is code to be executed within the temp buffer. Point is always located at the beginning of buffer." (declare (indent 1) (debug t)) ;; temp-file never actually used for anything? - `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) - (buffer (find-file-noselect temp-file)) - (python-indent-guess-indent-offset nil)) - (unwind-protect - (with-current-buffer buffer - (python-mode) - (insert ,contents) - (goto-char (point-min)) - ,@body) - (and buffer (kill-buffer buffer)) - (delete-file temp-file)))) + `(ert-with-temp-file temp-file + :suffix "-python.py" + (let ((buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)))))) (defun python-tests-look-at (string &optional num restore-point) "Move point at beginning of STRING in the current buffer. @@ -193,7 +194,6 @@ aliqua." (ert-deftest python-syntax-after-python-backspace () ;; `python-indent-dedent-line-backspace' garbles syntax - :expected-result :failed (python-tests-with-temp-buffer "\"\"\"" (goto-char (point-max)) @@ -5283,7 +5283,7 @@ urlpatterns = patterns('', (should (= (current-indentation) 23)))) (or eim (electric-indent-mode -1))))) -(ert-deftest python-triple-quote-pairing () +(ert-deftest python-triple-double-quote-pairing () (let ((epm electric-pair-mode)) (unwind-protect (progn @@ -5310,6 +5310,33 @@ urlpatterns = patterns('', "\"\n\"\"\"\n")))) (or epm (electric-pair-mode -1))))) +(ert-deftest python-triple-single-quote-pairing () + (let ((epm electric-pair-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + "''\n" + (or epm (electric-pair-mode 1)) + (goto-char (1- (point-max))) + (python-tests-self-insert ?') + (should (string= (buffer-string) + "''''''\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\n" + (python-tests-self-insert (list ?' ?' ?')) + (should (string= (buffer-string) + "''''''\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "'\n''\n" + (goto-char (1- (point-max))) + (python-tests-self-insert ?') + (should (= (point) (1- (point-max)))) + (should (string= (buffer-string) + "'\n'''\n")))) + (or epm (electric-pair-mode -1))))) + ;;; Hideshow support diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index e2ea0d91370..2168b38484e 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -357,7 +357,7 @@ VALUES-PLIST is a list with alternating index and value elements." (let ((ruby-align-chained-calls t)) (ruby-should-indent-buffer "one.two.three - | .four + | .four | |my_array.select { |str| str.size > 5 } | .map { |str| str.downcase }" @@ -875,6 +875,28 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby-mode-set-encoding) (should (string= "# coding: iso-8859-15\nⓇ" (buffer-string)))))) +(ert-deftest ruby-imenu-with-private-modifier () + (ruby-with-temp-buffer + (ruby-test-string + "class Blub + | def hi + | 'Hi!' + | end + | + | def bye + | 'Bye!' + | end + | + | private def hiding + | 'You can't see me' + | end + |end") + (should (equal (mapcar #'car (ruby-imenu-create-index)) + '("Blub" + "Blub#hi" + "Blub#bye" + "Blub#hiding"))))) + (ert-deftest ruby--indent/converted-from-manual-test () :tags '(:expensive-test) ;; Converted from manual test. @@ -886,6 +908,33 @@ VALUES-PLIST is a list with alternating index and value elements." (should (equal (buffer-string) orig)))) (kill-buffer buf)))) +(ert-deftest ruby--test-chained-indentation () + (with-temp-buffer + (ruby-mode) + (setq-local ruby-align-chained-calls t) + (insert "some_variable.where +.not(x: nil) +.where(y: 2) +") + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "some_variable.where + .not(x: nil) + .where(y: 2) +"))) + + (with-temp-buffer + (ruby-mode) + (setq-local ruby-align-chained-calls t) + (insert "some_variable.where.not(x: nil) +.where(y: 2) +") + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "some_variable.where.not(x: nil) + .where(y: 2) +")))) + (provide 'ruby-mode-tests) ;;; ruby-mode-tests.el ends here diff --git a/test/lisp/progmodes/sh-script-tests.el b/test/lisp/progmodes/sh-script-tests.el new file mode 100644 index 00000000000..c21010c8b43 --- /dev/null +++ b/test/lisp/progmodes/sh-script-tests.el @@ -0,0 +1,51 @@ +;;; sh-script-tests.el --- Tests for sh-script.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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 'sh-script) +(require 'ert) + +(ert-deftest test-sh-script-indentation () + (with-temp-buffer + (insert "relative-path/to/configure --prefix=$prefix\\ + --with-x") + (shell-script-mode) + (goto-char (point-min)) + (forward-line 1) + (indent-for-tab-command) + (should (equal + (buffer-substring-no-properties (point-min) (point-max)) + "relative-path/to/configure --prefix=$prefix\\ + --with-x")))) + +(ert-deftest test-basic-sh-indentation () + (with-temp-buffer + (insert "myecho () {\necho foo\n}\n") + (shell-script-mode) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "myecho () { + echo foo +} +")))) + +;;; sh-script-tests.el ends here diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 21dd0649529..1bbe3a95e90 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -28,6 +28,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'sql) (ert-deftest sql-tests-postgres-list-databases () @@ -50,7 +51,7 @@ (lambda (_command) t)) ((symbol-function 'process-lines) (lambda (_program &rest _args) - (error "some error")))) + (error "Some error")))) (should-not (sql-postgres-list-databases)))) ;;; Check Connection Password Handling/Wallet @@ -63,52 +64,49 @@ Identify tests by ID. Set :sql-login dialect attribute to LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED string of values passed to the comint function for validation." (declare (indent 2)) - `(cl-letf - ((sql-test-login-params ' ,login-params) - ((symbol-function 'sql-comint-test) - (lambda (product options &optional buf-name) - (with-current-buffer (get-buffer-create buf-name) - (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) - ((symbol-function 'sql-run-test) - (lambda (&optional buffer) - (interactive "P") - (sql-product-interactive 'sqltest buffer))) - (sql-user nil) - (sql-server nil) - (sql-database nil) - (sql-product-alist - '((ansi) - (sqltest - :name "SqlTest" - :sqli-login sql-test-login-params - :sqli-comint-func sql-comint-test))) - (sql-connection-alist - '((,(format "test-%s" id) - ,@connection))) - (sql-password-wallet - (list - (make-temp-file - "sql-test-netrc" nil nil - (mapconcat #'identity - '("machine aMachine user aUserName password \"netrc-A aPassword\"" - "machine aServer user aUserName password \"netrc-B aPassword\"" - "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" - "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" - "machine aDatabase user aUserName password \"netrc-E aPassword\"" - "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" - "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" - ) "\n"))))) - - (let* ((connection ,(format "test-%s" id)) - (buffername (format "*SQL: ERT TEST <%s>*" connection))) - (when (get-buffer buffername) - (kill-buffer buffername)) - (sql-connect connection buffername) - (should (get-buffer buffername)) - (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) - (when (get-buffer buffername) - (kill-buffer buffername)) - (delete-file (car sql-password-wallet))))) + `(ert-with-temp-file tempfile + :suffix "sql-test-netrc" + :text (concat + "machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + "\n") + (cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet (list tempfile))) + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)))))) (ert-deftest sql-test-connect () "Test of basic `sql-connect'." @@ -416,6 +414,16 @@ The ACTION will be tested after set-up of PRODUCT." (kill-buffer "*SQL: exist*"))) +(ert-deftest sql-tests-comint-automatic-password () + (let ((sql-password nil)) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "")) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password "Password: ")))) + ;; Also, we shouldn't care what the password is - we rely on comint for that. + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password ""))))) (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/progmodes/xref-tests.el b/test/lisp/progmodes/xref-tests.el index d29452243b2..b1de1a4df5a 100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@ -52,6 +52,14 @@ (should (string-match-p "file1\\.txt\\'" (xref-location-group (nth 0 locs)))) (should (string-match-p "file2\\.txt\\'" (xref-location-group (nth 1 locs)))))) +(ert-deftest xref-matches-in-directory-filters-with-ignores () + (let ((locs (xref-matches-in-directory "bar" "*" xref-tests--data-dir + '("./file1.*")))) + (should (= 1 (length locs))) + (should (string-match-p "file2\\.txt\\'" (xref-location-group + (xref-item-location + (nth 0 locs))))))) + (ert-deftest xref-matches-in-directory-finds-two-matches-on-the-same-line () (let ((locs (xref-tests--locations-in-data-dir "foo"))) (should (= 2 (length locs))) @@ -120,8 +128,12 @@ (let ((xref-file-name-display 'abs)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + nil)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list (concat xref-tests--data-dir "file1.txt") (concat xref-tests--data-dir "file2.txt")))))) @@ -129,8 +141,12 @@ (ert-deftest xref--xref-file-name-display-is-nondirectory () (let ((xref-file-name-display 'nondirectory)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + nil)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list "file1.txt" "file2.txt"))))) @@ -138,13 +154,15 @@ (ert-deftest xref--xref-file-name-display-is-relative-to-project-root () (let* ((data-parent-dir (file-name-directory (directory-file-name xref-tests--data-dir))) - (project-find-functions - (lambda (_) (cons 'transient data-parent-dir))) (xref-file-name-display 'project-relative)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + data-parent-dir)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list "xref-resources/file1.txt" "xref-resources/file2.txt"))))) diff --git a/test/lisp/ps-print-tests.el b/test/lisp/ps-print-tests.el index b25e88622d8..d468911dd3d 100644 --- a/test/lisp/ps-print-tests.el +++ b/test/lisp/ps-print-tests.el @@ -34,3 +34,5 @@ (autoloadp (symbol-function 'ps-mule-initialize)))) + +;;; ps-print-tests.el ends here diff --git a/test/lisp/repeat-tests.el b/test/lisp/repeat-tests.el new file mode 100644 index 00000000000..a1f9bbb1739 --- /dev/null +++ b/test/lisp/repeat-tests.el @@ -0,0 +1,111 @@ +;;; repeat-tests.el --- Tests for repeat.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Juri Linkov <juri@linkov.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'repeat) + +(defvar repeat-tests-calls nil) + +(defun repeat-tests-call-a (&optional arg) + (interactive "p") + (push `(,arg a) repeat-tests-calls)) + +(defun repeat-tests-call-b (&optional arg) + (interactive "p") + (push `(,arg b) repeat-tests-calls)) + +(defvar repeat-tests-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-x w a") 'repeat-tests-call-a) + map) + "Keymap for keys that initiate repeating sequences.") + +(defvar repeat-tests-repeat-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'repeat-tests-call-a) + (define-key map "b" 'repeat-tests-call-b) + map) + "Keymap for repeating sequences.") +(put 'repeat-tests-call-a 'repeat-map 'repeat-tests-repeat-map) +(put 'repeat-tests-call-b 'repeat-map 'repeat-tests-repeat-map) + +(defmacro with-repeat-mode (&rest body) + "Create environment for testing `repeat-mode'." + `(unwind-protect + (progn + (repeat-mode +1) + (with-temp-buffer + (save-window-excursion + ;; `execute-kbd-macro' applied to window only + (set-window-buffer nil (current-buffer)) + (use-local-map repeat-tests-map) + ,@body))) + (repeat-mode -1))) + +(defun repeat-tests--check (keys calls inserted) + (setq repeat-tests-calls nil) + (delete-region (point-min) (point-max)) + (execute-kbd-macro (kbd keys)) + (should (equal (nreverse repeat-tests-calls) calls)) + ;; Check for self-inserting keys + (should (equal (buffer-string) inserted))) + +(ert-deftest repeat-tests-exit-key () + (with-repeat-mode + (let ((repeat-echo-function 'ignore)) + (let ((repeat-exit-key nil)) + (repeat-tests--check + "C-x w a b a b RET c" + '((1 a) (1 b) (1 a) (1 b)) "\nc")) + (let ((repeat-exit-key [return])) + (repeat-tests--check + "C-x w a b a b <return> c" + '((1 a) (1 b) (1 a) (1 b)) "c"))))) + +(ert-deftest repeat-tests-keep-prefix () + (with-repeat-mode + (let ((repeat-echo-function 'ignore)) + (repeat-tests--check + "C-x w a b a b c" + '((1 a) (1 b) (1 a) (1 b)) "c") + (let ((repeat-keep-prefix nil)) + (repeat-tests--check + "C-2 C-x w a b a b c" + '((2 a) (1 b) (1 a) (1 b)) "c") + (repeat-tests--check + "C-2 C-x w a C-3 c" + '((2 a)) "ccc")) + ;; TODO: fix and uncomment + ;; (let ((repeat-keep-prefix t)) + ;; (repeat-tests--check + ;; "C-2 C-x w a b a b c" + ;; '((2 a) (2 b) (2 a) (2 b)) "c") + ;; (repeat-tests--check + ;; "C-2 C-x w a C-1 C-2 b a C-3 C-4 b c" + ;; '((2 a) (12 b) (12 a) (34 b)) "c")) + ))) + +;; TODO: :tags '(:expensive-test) for repeat-exit-timeout + +(provide 'repeat-tests) +;;; repeat-tests.el ends here diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el index 17199ed443a..190ffb78288 100644 --- a/test/lisp/saveplace-tests.el +++ b/test/lisp/saveplace-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'ert-x) (require 'saveplace) @@ -39,49 +41,42 @@ (ert-deftest saveplace-test-save-place-to-alist/file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile (file-truename tmpfile)) - (save-place-alist nil) - (save-place-loaded t) - (loc tmpfile) - (pos 4)) - (unwind-protect - (save-window-excursion - (find-file loc) - (insert "abc") ; must insert something - (save-place-to-alist) - (should (equal save-place-alist (list (cons tmpfile pos))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + (let* ((tmpfile (file-truename tmpfile)) + (save-place-alist nil) + (save-place-loaded t) + (loc tmpfile) + (pos 4)) + (save-window-excursion + (find-file loc) + (insert "abc") ; must insert something + (save-place-to-alist) + (should (equal save-place-alist (list (cons tmpfile pos)))))))) (ert-deftest saveplace-test-forget-unreadable-files () (save-place-mode) - (let* ((save-place-loaded t) - (tmpfile (make-temp-file "emacs-test-saveplace-")) - (alist-orig (list (cons "/this/file/does/not/exist" 10) - (cons tmpfile 1917))) - (save-place-alist alist-orig)) - (unwind-protect - (progn - (save-place-forget-unreadable-files) - (should (equal save-place-alist (cdr alist-orig)))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix "-saveplace" + (let* ((save-place-loaded t) + (alist-orig (list (cons "/this/file/does/not/exist" 10) + (cons tmpfile 1917))) + (save-place-alist alist-orig)) + (save-place-forget-unreadable-files) + (should (equal save-place-alist (cdr alist-orig)))))) (ert-deftest saveplace-test-place-alist-to-file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile2 (make-temp-file "emacs-test-saveplace-")) - (save-place-file tmpfile) - (save-place-alist (list (cons tmpfile2 99)))) - (unwind-protect - (progn (save-place-alist-to-file) - (setq save-place-alist nil) - (save-window-excursion - (find-file save-place-file) - (unwind-protect - (should (string-match tmpfile2 (buffer-string))) - (kill-buffer)))) - (delete-file tmpfile) - (delete-file tmpfile2)))) + (ert-with-temp-file tmpfile + (ert-with-temp-file tmpfile2 + (let* ((save-place-file tmpfile) + (save-place-alist (list (cons tmpfile2 99)))) + (save-place-alist-to-file) + (setq save-place-alist nil) + (save-window-excursion + (find-file save-place-file) + (unwind-protect + (should (string-match tmpfile2 (buffer-string))) + (kill-buffer))))))) (ert-deftest saveplace-test-load-alist-from-file () (save-place-mode) diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index 04f255dcd4c..9a7fb502d7c 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -175,3 +175,5 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to (provide 'ses-tests) + +;;; ses-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index c571dc3e14b..1ab539f3e42 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -664,7 +664,29 @@ guaranteed by the originator of a cluster definition." (should (member (format "/%s:%s" cluster2 (file-local-name file2)) (car shadow-literal-groups))) ;; Bug#49596. - (should (member (concat primary file1) (car shadow-literal-groups)))) + (should (member (concat primary file1) (car shadow-literal-groups))) + + ;; Error handling. + (setq shadow-literal-groups nil) + ;; There's no `buffer-file-name'. + (with-temp-buffer + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups) + ;; Define an empty literal group. + (setq mocked-input `(,(kbd "RET"))) + (with-temp-buffer + (set-visited-file-name file1) + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups) + ;; Use a non-existing site name. + (setq mocked-input `("foo" ,(kbd "RET"))) + (with-temp-buffer + (set-visited-file-name file1) + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups)) ;; Cleanup. (shadow--tests-cleanup)))) diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el index 223a18590b1..342b421911f 100644 --- a/test/lisp/shell-tests.el +++ b/test/lisp/shell-tests.el @@ -1,4 +1,4 @@ -;;; shell-tests.el -*- lexical-binding:t -*- +;;; shell-tests.el --- Tests for shell.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 4b153d117f0..742da0bde59 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -959,6 +959,17 @@ See Bug#21722." (with-shell-command-dont-erase-buffer str output-buffer-is-current (should (= (point) (alist-get shell-command-dont-erase-buffer expected-point))))))) +(ert-deftest test-undo-region () + (with-temp-buffer + (insert "This is a test\n") + (goto-char (point-min)) + (setq buffer-undo-list nil) + (downcase-word 1) + (should (= (length (delq nil (undo-make-selective-list 1 9))) 2)) + (should (= (length (delq nil (undo-make-selective-list 4 9))) 1)) + ;; FIXME this is the off-by-one error case. + ;;(should (= (length (delq nil (undo-make-selective-list 5 9))) 0)) + (should (= (length (delq nil (undo-make-selective-list 6 9))) 0)))) (provide 'simple-test) -;;; simple-test.el ends here +;;; simple-tests.el ends here diff --git a/test/lisp/so-long-tests/so-long-tests-helpers.el b/test/lisp/so-long-tests/so-long-tests-helpers.el index ab4d9c6c137..f542806ac16 100644 --- a/test/lisp/so-long-tests/so-long-tests-helpers.el +++ b/test/lisp/so-long-tests/so-long-tests-helpers.el @@ -43,7 +43,8 @@ (cl-case action ('so-long-mode (should (eq major-mode 'so-long-mode)) - (so-long-tests-assert-overrides)) + (so-long-tests-assert-overrides) + (so-long-tests-assert-preserved)) ('so-long-minor-mode (should (eq so-long-minor-mode t)) (so-long-tests-assert-overrides)) @@ -62,7 +63,8 @@ (cl-case action ('so-long-mode (should-not (eq major-mode 'so-long-mode)) - (so-long-tests-assert-overrides-reverted)) + (so-long-tests-assert-overrides-reverted) + (so-long-tests-assert-preserved)) ('so-long-minor-mode (should-not (eq so-long-minor-mode t)) (so-long-tests-assert-overrides-reverted)) @@ -90,11 +92,22 @@ (when (boundp (car ovar)) (should (equal (symbol-value (car ovar)) (cdr ovar)))))) +(defun so-long-tests-assert-preserved () + "Assert that preserved modes and variables have their expected values." + (dolist (var so-long-mode-preserved-variables) + (when (boundp var) + (should (equal (symbol-value var) + (alist-get var so-long-tests-memory))))) + (dolist (mode so-long-mode-preserved-minor-modes) + (when (boundp mode) + (should (equal (symbol-value mode) + (alist-get mode so-long-tests-memory)))))) + (defun so-long-tests-remember () "Remember the original states of modes and variables. -Call this after setting up a buffer in the normal (not so-long) -state for its major mode, so that after triggering a so-long +Call this after setting up a buffer in the normal (not `so-long') +state for its major mode, so that after triggering a `so-long' action we can call `so-long-revert' and compare the reverted state against this remembered state." (setq so-long-tests-memory nil) @@ -107,7 +120,22 @@ state against this remembered state." (dolist (mode so-long-minor-modes) (when (boundp mode) (push (cons mode (symbol-value mode)) + so-long-tests-memory))) + (dolist (var so-long-mode-preserved-variables) + (when (boundp var) + (push (cons var (symbol-value var)) + so-long-tests-memory))) + (dolist (mode so-long-mode-preserved-minor-modes) + (when (boundp mode) + (push (cons mode (symbol-value mode)) so-long-tests-memory)))) +(defun so-long-tests-predicates () + "Return the list of testable predicate functions." + (if (fboundp 'buffer-line-statistics) + '(so-long-statistics-excessive-p + so-long-detected-long-line-p) + '(so-long-detected-long-line-p))) + (provide 'so-long-tests-helpers) ;;; so-long-tests-helpers.el ends here diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index a6d8721ffc8..7eee345aadd 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -57,101 +57,131 @@ (declare-function so-long-tests-assert-active "so-long-tests-helpers") (declare-function so-long-tests-assert-reverted "so-long-tests-helpers") (declare-function so-long-tests-assert-and-revert "so-long-tests-helpers") +(declare-function so-long-tests-predicates "so-long-tests-helpers") -;; Enable the automated behavior for all tests. +;; Enable the automated behaviour for all tests. (global-so-long-mode 1) (ert-deftest so-long-tests-threshold-under () "Under line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1- so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1- so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-threshold-at () "At line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1- so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1- so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-threshold-over () "Over line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (normal-mode) - (so-long-tests-remember) - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (so-long-tests-assert-and-revert 'so-long-mode))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + (so-long-tests-remember) + (insert (make-string (1+ so-long-threshold) ?x)) + (normal-mode) + (so-long-tests-assert-and-revert 'so-long-mode)))) (ert-deftest so-long-tests-skip-comments () "Skip leading shebang, whitespace, and comments." - ;; Long comment, no newline. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with newline. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with short text following. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (insert (make-string so-long-threshold ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with long text following. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'so-long-mode)))) + ;; Only for `so-long-detected-long-line-p' -- comments are not + ;; treated differently when using `so-long-statistics-excessive-p'. + (dolist (so-long-predicate (so-long-tests-predicates)) + ;; Long comment, no newline. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with newline. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with short text following. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (insert (make-string so-long-threshold ?x)) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with long text following. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (insert (make-string (1+ so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'so-long-mode))))) (ert-deftest so-long-tests-max-lines () "Give up after `so-long-max-lines'." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - ;; Insert exactly `so-long-max-lines' non-comment lines, followed - ;; by a long line. - (dotimes (_ so-long-max-lines) - (insert "x\n")) - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)) - ;; If `so-long-max-lines' is nil, don't give up the search. - (let ((so-long-max-lines nil)) - (normal-mode) - (should (eq major-mode 'so-long-mode))) - ;; If `so-long-skip-leading-comments' is nil, all lines are - ;; counted, and so the shebang line counts, which makes the - ;; long line one line further away. - (let ((so-long-skip-leading-comments nil) - (so-long-max-lines (1+ so-long-max-lines))) + ;; Only for `so-long-detected-long-line-p' -- the whole buffer is + ;; 'seen' when using `so-long-statistics-excessive-p'. + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + ;; Insert exactly `so-long-max-lines' non-comment lines, followed + ;; by a long line. + (dotimes (_ so-long-max-lines) + (insert "x\n")) + (insert (make-string (1+ so-long-threshold) ?x)) (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)) - (let ((so-long-max-lines (1+ so-long-max-lines))) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode)))) + ;; If `so-long-max-lines' is nil, don't give up the search. + (let ((so-long-max-lines nil)) (normal-mode) - (should (eq major-mode 'so-long-mode)))))) + (should (eq major-mode 'so-long-mode))) + ;; If `so-long-skip-leading-comments' is nil, all lines are + ;; counted, and so the shebang line counts, which makes the + ;; long line one line further away. + (let ((so-long-skip-leading-comments nil) + (so-long-max-lines (1+ so-long-max-lines))) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode)))) + (let ((so-long-max-lines (1+ so-long-max-lines))) + (normal-mode) + (should (eq major-mode 'so-long-mode))))))) (ert-deftest so-long-tests-invisible-buffer-function () "Call `so-long-invisible-buffer-function' in invisible buffers." @@ -180,7 +210,7 @@ ;; From Emacs 27 the `display-buffer' call is insufficient. ;; The various 'window change functions' are now invoked by the ;; redisplay, and redisplay does nothing at all in batch mode, - ;; so we cannot test under this revised behavior. Refer to: + ;; so we cannot test under this revised behaviour. Refer to: ;; https://lists.gnu.org/r/emacs-devel/2019-10/msg00971.html ;; For interactive (non-batch) test runs, calling `redisplay' ;; does do the trick; so do that first. @@ -195,9 +225,11 @@ ;; Emacs adds the framework necessary to make `redisplay' work ;; in batch mode. (unless (eq so-long--active t) - (run-window-configuration-change-hook)))) + (with-suppressed-warnings + ((obsolete run-window-configuration-change-hook)) + (run-window-configuration-change-hook))))) (so-long-tests-assert-and-revert 'so-long-mode)) - ;; `so-long-invisible-buffer-function' is `nil'. + ;; `so-long-invisible-buffer-function' is nil. (with-temp-buffer (insert "#!emacs\n") (normal-mode) @@ -230,7 +262,9 @@ (redisplay) (when noninteractive (unless (eq so-long--active t) - (run-window-configuration-change-hook)))) + (with-suppressed-warnings + ((obsolete run-window-configuration-change-hook)) + (run-window-configuration-change-hook))))) (should (eq major-mode 'emacs-lisp-mode)))) (ert-deftest so-long-tests-actions () @@ -323,20 +357,76 @@ (normal-mode) (should (eq major-mode 'so-long-mode))))) +(ert-deftest so-long-tests-preserved-variables-and-modes () + "Preserved variables and minor modes when using `so-long-mode'." + ;; Test the user options `so-long-mode-preserved-variables' and + ;; `so-long-mode-preserved-minor-modes'. The minor mode `view-mode' + ;; is 'preserved' by default (using both options). + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + ;; We enable `view-mode' before triggering `so-long'. + (insert (make-string (1+ so-long-threshold) ?x)) + (view-mode 1) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + (so-long-tests-remember) + (let ((so-long-action 'so-long-mode) + (menu (so-long-menu))) + (so-long) + (so-long-tests-assert-active 'so-long-mode) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + ;; Revert. + (funcall (lookup-key menu [so-long-revert])) + (so-long-tests-assert-reverted 'so-long-mode) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + ;; Disable `view-mode'. Note that without the preserved + ;; variables, the conflict between how `view-mode' and `so-long' + ;; each deal with the buffer's original `buffer-read-only' value + ;; would lead to a situation whereby the buffer would still be + ;; read-only after `view-mode' had been disabled. + (view-mode 0) + (should (eq view-mode nil)) + (should (eq buffer-read-only nil)))) + ;; Without `view-mode'. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + (insert (make-string (1+ so-long-threshold) ?x)) + (should (eq view-mode nil)) + (so-long-tests-remember) + (let ((so-long-action 'so-long-mode) + (menu (so-long-menu))) + (so-long) + (so-long-tests-assert-active 'so-long-mode) + (should (eq view-mode nil)) + ;; Revert. + (funcall (lookup-key menu [so-long-revert])) + (so-long-tests-assert-reverted 'so-long-mode) + (should (eq view-mode nil))))) + (ert-deftest so-long-tests-predicate () "Custom predicate function." ;; Test the `so-long-predicate' user option. + ;; Always true. Trigger when we normally wouldn't. (with-temp-buffer (display-buffer (current-buffer)) (insert "#!emacs\n") - ;; Always false. - (let ((so-long-predicate #'ignore)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Always true. (let ((so-long-predicate (lambda () t))) (normal-mode) - (should (eq major-mode 'so-long-mode))))) + (should (eq major-mode 'so-long-mode)))) + ;; Always false. Don't trigger when we normally would. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?x)) + (let ((so-long-predicate #'ignore)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-file-local-action () "File-local action." @@ -405,7 +495,10 @@ (insert ,local-vars) (normal-mode) ;; Remember the `emacs-lisp-mode' state. The other cases - ;; will validate the 'reverted' state against this. + ;; will validate the 'reverted' state against this. (Note + ;; that we haven't displayed the buffer, and therefore only + ;; `so-long-invisible-buffer-function' has acted, so we are + ;; still remembering the 'before' state.) (so-long-tests-remember) (should (eq major-mode 'emacs-lisp-mode))) ;; Downgrade the action from major mode to minor mode. diff --git a/test/lisp/so-long-tests/spelling-tests.el b/test/lisp/so-long-tests/spelling-tests.el index 0be8555bdd2..b598366ba7a 100644 --- a/test/lisp/so-long-tests/spelling-tests.el +++ b/test/lisp/so-long-tests/spelling-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ispell) (require 'cl-lib) @@ -50,20 +51,19 @@ ;; The Emacs test Makefile's use of HOME=/nonexistent triggers an error ;; when starting the inferior ispell process, so we set HOME to a valid ;; (but empty) temporary directory for this test. - (let* ((tmpdir (make-temp-file "so-long." :dir ".ispell")) - (process-environment (cons (format "HOME=%s" tmpdir) - process-environment)) - (find-spelling-mistake - (unwind-protect - (cl-letf (((symbol-function 'ispell-command-loop) - (lambda (_miss _guess word _start _end) - (message "Unrecognized word: %s." word) - (throw 'mistake t)))) - (catch 'mistake - (find-library "so-long") - (ispell-buffer) - nil)) - (delete-directory tmpdir)))) - (should (not find-spelling-mistake))))) + (ert-with-temp-file tmpdir + :suffix "so-long.ispell" + (let* ((process-environment (cons (format "HOME=%s" tmpdir) + process-environment)) + (find-spelling-mistake + (cl-letf (((symbol-function 'ispell-command-loop) + (lambda (_miss _guess word _start _end) + (message "Unrecognised word: %s." word) + (throw 'mistake t)))) + (catch 'mistake + (find-library "so-long") + (ispell-buffer) + nil)))) + (should (not find-spelling-mistake)))))) ;;; spelling-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index b57982a7055..238c9be1ab0 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -62,19 +62,259 @@ (0 font-lock-keyword-face)))))))) +;;;; List functions. + +(ert-deftest subr-test-caaar () + (should (null (caaar '()))) + (should (null (caaar '(() (2))))) + (should (null (caaar '((() (2)) (a b))))) + (should-error (caaar '(1 2)) :type 'wrong-type-argument) + (should-error (caaar '((1 2))) :type 'wrong-type-argument) + (should (= 1 (caaar '(((1 2) (3 4)))))) + (should (null (caaar '((() (3 4))))))) + +(ert-deftest subr-test-caadr () + (should (null (caadr '()))) + (should (null (caadr '(1)))) + (should-error (caadr '(1 2)) :type 'wrong-type-argument) + (should (= 2 (caadr '(1 (2 3))))) + (should (equal '((2) (3)) (caadr '((1) (((2) (3))) (4)))))) + + ;;;; Keymap support. (ert-deftest subr-test-kbd () + (should (equal (kbd "") "")) (should (equal (kbd "f") "f")) + (should (equal (kbd "X") "X")) + (should (equal (kbd "foobar") "foobar")) ; 6 characters + (should (equal (kbd "return") "return")) ; 6 characters + + (should (equal (kbd "<F2>") [F2])) + (should (equal (kbd "<f1> <f2> TAB") [f1 f2 ?\t])) + (should (equal (kbd "<f1> RET") [f1 ?\r])) + (should (equal (kbd "<f1> SPC") [f1 ? ])) (should (equal (kbd "<f1>") [f1])) - (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "<f1>") [f1])) + (should (equal (kbd "[f1]") "[f1]")) + (should (equal (kbd "<return>") [return])) + (should (equal (kbd "< right >") "<right>")) ; 7 characters + + ;; Modifiers: + (should (equal (kbd "C-x") "\C-x")) (should (equal (kbd "C-x a") "\C-xa")) - ;; Check that kbd handles both new and old style key descriptions - ;; (bug#45536). + (should (equal (kbd "C-;") [?\C-\;])) + (should (equal (kbd "C-a") "\C-a")) + (should (equal (kbd "C-c SPC") "\C-c ")) + (should (equal (kbd "C-c TAB") "\C-c\t")) + (should (equal (kbd "C-c c") "\C-cc")) + (should (equal (kbd "C-x 4 C-f") "\C-x4\C-f")) + (should (equal (kbd "C-x C-f") "\C-x\C-f")) + (should (equal (kbd "C-M-<down>") [C-M-down])) + (should (equal (kbd "<C-M-down>") [C-M-down])) + (should (equal (kbd "C-RET") [?\C-\C-m])) + (should (equal (kbd "C-SPC") [?\C- ])) + (should (equal (kbd "C-TAB") [?\C-\t])) + (should (equal (kbd "C-<down>") [C-down])) + (should (equal (kbd "C-c C-c C-c") "\C-c\C-c\C-c")) + + (should (equal (kbd "M-a") [?\M-a])) + (should (equal (kbd "M-<DEL>") [?\M-\d])) + (should (equal (kbd "M-C-a") [?\M-\C-a])) + (should (equal (kbd "M-ESC") [?\M-\e])) + (should (equal (kbd "M-RET") [?\M-\r])) + (should (equal (kbd "M-SPC") [?\M- ])) + (should (equal (kbd "M-TAB") [?\M-\t])) + (should (equal (kbd "M-x a") [?\M-x ?a])) + (should (equal (kbd "M-<up>") [M-up])) + (should (equal (kbd "M-c M-c M-c") [?\M-c ?\M-c ?\M-c])) + + (should (equal (kbd "s-SPC") [?\s- ])) + (should (equal (kbd "s-a") [?\s-a])) + (should (equal (kbd "s-x a") [?\s-x ?a])) + (should (equal (kbd "s-c s-c s-c") [?\s-c ?\s-c ?\s-c])) + + (should (equal (kbd "S-H-a") [?\S-\H-a])) + (should (equal (kbd "S-a") [?\S-a])) + (should (equal (kbd "S-x a") [?\S-x ?a])) + (should (equal (kbd "S-c S-c S-c") [?\S-c ?\S-c ?\S-c])) + + (should (equal (kbd "H-<RET>") [?\H-\r])) + (should (equal (kbd "H-DEL") [?\H-\d])) + (should (equal (kbd "H-a") [?\H-a])) + (should (equal (kbd "H-x a") [?\H-x ?a])) + (should (equal (kbd "H-c H-c H-c") [?\H-c ?\H-c ?\H-c])) + + (should (equal (kbd "A-H-a") [?\A-\H-a])) + (should (equal (kbd "A-SPC") [?\A- ])) + (should (equal (kbd "A-TAB") [?\A-\t])) + (should (equal (kbd "A-a") [?\A-a])) + (should (equal (kbd "A-c A-c A-c") [?\A-c ?\A-c ?\A-c])) + + (should (equal (kbd "C-M-a") [?\C-\M-a])) + (should (equal (kbd "C-M-<up>") [C-M-up])) + + ;; Special characters. + (should (equal (kbd "DEL") "\d")) + (should (equal (kbd "ESC C-a") "\e\C-a")) + (should (equal (kbd "ESC") "\e")) + (should (equal (kbd "LFD") "\n")) + (should (equal (kbd "NUL") "\0")) + (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "SPC") "\s")) + (should (equal (kbd "TAB") "\t")) + (should (equal (kbd "\^i") "")) + (should (equal (kbd "^M") "\^M")) + + ;; With numbers. + (should (equal (kbd "\177") "\^?")) + (should (equal (kbd "\000") "\0")) + (should (equal (kbd "\\177") "\^?")) + (should (equal (kbd "\\000") "\0")) + (should (equal (kbd "C-x \\150") "\C-xh")) + + ;; Multibyte + (should (equal (kbd "ñ") [?ñ])) + (should (equal (kbd "ü") [?ü])) + (should (equal (kbd "ö") [?ö])) + (should (equal (kbd "ğ") [?ğ])) + (should (equal (kbd "ա") [?ա])) + (should (equal (kbd "üüöö") [?ü ?ü ?ö ?ö])) + (should (equal (kbd "C-ü") [?\C-ü])) + (should (equal (kbd "M-ü") [?\M-ü])) + (should (equal (kbd "H-ü") [?\H-ü])) + + ;; Handle both new and old style key descriptions (bug#45536). (should (equal (kbd "s-<return>") [s-return])) (should (equal (kbd "<s-return>") [s-return])) (should (equal (kbd "C-M-<return>") [C-M-return])) - (should (equal (kbd "<C-M-return>") [C-M-return]))) + (should (equal (kbd "<C-M-return>") [C-M-return])) + + ;; Error. + (should-error (kbd "C-xx")) + (should-error (kbd "M-xx")) + (should-error (kbd "M-x<TAB>")) + + ;; These should be equivalent: + (should (equal (kbd "\C-xf") (kbd "C-x f")))) + +(ert-deftest subr-test-kbd-valid-p () + (should (not (kbd-valid-p ""))) + (should (kbd-valid-p "f")) + (should (kbd-valid-p "X")) + (should (not (kbd-valid-p " X"))) + (should (kbd-valid-p "X f")) + (should (not (kbd-valid-p "a b"))) + (should (not (kbd-valid-p "foobar"))) + (should (not (kbd-valid-p "return"))) + + (should (kbd-valid-p "<F2>")) + (should (kbd-valid-p "<f1> <f2> TAB")) + (should (kbd-valid-p "<f1> RET")) + (should (kbd-valid-p "<f1> SPC")) + (should (kbd-valid-p "<f1>")) + (should (not (kbd-valid-p "[f1]"))) + (should (kbd-valid-p "<return>")) + (should (not (kbd-valid-p "< right >"))) + + ;; Modifiers: + (should (kbd-valid-p "C-x")) + (should (kbd-valid-p "C-x a")) + (should (kbd-valid-p "C-;")) + (should (kbd-valid-p "C-a")) + (should (kbd-valid-p "C-c SPC")) + (should (kbd-valid-p "C-c TAB")) + (should (kbd-valid-p "C-c c")) + (should (kbd-valid-p "C-x 4 C-f")) + (should (kbd-valid-p "C-x C-f")) + (should (kbd-valid-p "C-M-<down>")) + (should (not (kbd-valid-p "<C-M-down>"))) + (should (kbd-valid-p "C-RET")) + (should (kbd-valid-p "C-SPC")) + (should (kbd-valid-p "C-TAB")) + (should (kbd-valid-p "C-<down>")) + (should (kbd-valid-p "C-c C-c C-c")) + + (should (kbd-valid-p "M-a")) + (should (kbd-valid-p "M-<DEL>")) + (should (not (kbd-valid-p "M-C-a"))) + (should (kbd-valid-p "C-M-a")) + (should (kbd-valid-p "M-ESC")) + (should (kbd-valid-p "M-RET")) + (should (kbd-valid-p "M-SPC")) + (should (kbd-valid-p "M-TAB")) + (should (kbd-valid-p "M-x a")) + (should (kbd-valid-p "M-<up>")) + (should (kbd-valid-p "M-c M-c M-c")) + + (should (kbd-valid-p "s-SPC")) + (should (kbd-valid-p "s-a")) + (should (kbd-valid-p "s-x a")) + (should (kbd-valid-p "s-c s-c s-c")) + + (should (not (kbd-valid-p "S-H-a"))) + (should (kbd-valid-p "S-a")) + (should (kbd-valid-p "S-x a")) + (should (kbd-valid-p "S-c S-c S-c")) + + (should (kbd-valid-p "H-<RET>")) + (should (kbd-valid-p "H-DEL")) + (should (kbd-valid-p "H-a")) + (should (kbd-valid-p "H-x a")) + (should (kbd-valid-p "H-c H-c H-c")) + + (should (kbd-valid-p "A-H-a")) + (should (kbd-valid-p "A-SPC")) + (should (kbd-valid-p "A-TAB")) + (should (kbd-valid-p "A-a")) + (should (kbd-valid-p "A-c A-c A-c")) + + (should (kbd-valid-p "C-M-a")) + (should (kbd-valid-p "C-M-<up>")) + + ;; Special characters. + (should (kbd-valid-p "DEL")) + (should (kbd-valid-p "ESC C-a")) + (should (kbd-valid-p "ESC")) + (should (kbd-valid-p "LFD")) + (should (kbd-valid-p "NUL")) + (should (kbd-valid-p "RET")) + (should (kbd-valid-p "SPC")) + (should (kbd-valid-p "TAB")) + (should (not (kbd-valid-p "\^i"))) + (should (not (kbd-valid-p "^M"))) + + ;; With numbers. + (should (not (kbd-valid-p "\177"))) + (should (not (kbd-valid-p "\000"))) + (should (not (kbd-valid-p "\\177"))) + (should (not (kbd-valid-p "\\000"))) + (should (not (kbd-valid-p "C-x \\150"))) + + ;; Multibyte + (should (kbd-valid-p "ñ")) + (should (kbd-valid-p "ü")) + (should (kbd-valid-p "ö")) + (should (kbd-valid-p "ğ")) + (should (kbd-valid-p "ա")) + (should (not (kbd-valid-p "üüöö"))) + (should (kbd-valid-p "C-ü")) + (should (kbd-valid-p "M-ü")) + (should (kbd-valid-p "H-ü")) + + ;; Handle both new and old style key descriptions (bug#45536). + (should (kbd-valid-p "s-<return>")) + (should (not (kbd-valid-p "<s-return>"))) + (should (kbd-valid-p "C-M-<return>")) + (should (not (kbd-valid-p "<C-M-return>"))) + + (should (kbd-valid-p "<mouse-1>")) + (should (kbd-valid-p "<Scroll_Lock>")) + + (should (not (kbd-valid-p "c-x"))) + (should (not (kbd-valid-p "C-xx"))) + (should (not (kbd-valid-p "M-xx"))) + (should (not (kbd-valid-p "M-x<TAB>")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) @@ -473,11 +713,11 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should (equal subr-tests--hook '(f5 f2 f1 f4 f3))) (add-hook 'subr-tests--hook 'f6) (should (equal subr-tests--hook '(f5 f6 f2 f1 f4 f3))) - ;; Make sure `t' is equivalent to 90. + ;; Make sure t is equivalent to 90. (add-hook 'subr-tests--hook 'f7 90) (add-hook 'subr-tests--hook 'f8 t) (should (equal subr-tests--hook '(f5 f6 f2 f1 f4 f3 f7 f8))) - ;; Make sure `nil' is equivalent to 0. + ;; Make sure nil is equivalent to 0. (add-hook 'subr-tests--hook 'f9 0) (add-hook 'subr-tests--hook 'f10) (should (equal subr-tests--hook '(f5 f10 f9 f6 f2 f1 f4 f3 f7 f8))) @@ -694,5 +934,76 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-not (buffer-local-boundp 'test-not-boundp buf)) (should (buffer-local-boundp 'test-global-boundp buf)))) +(ert-deftest test-replace-string-in-region () + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-string-in-region "foo" "new" (point-min) (point-max)) + 2)) + (should (equal (buffer-string) "new bar zot newbar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-string-in-region "foo" "new" (point-min) 14) + 1)) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should-error (replace-string-in-region "foo" "new" (point-min) 30))) + + (with-temp-buffer + (insert "Foo bar zot foobar") + (should (= (replace-string-in-region "Foo" "new" (point-min)) + 1)) + (should (equal (buffer-string) "new bar zot foobar")))) + +(ert-deftest test-replace-regexp-in-region () + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-regexp-in-region "fo+" "new" (point-min) (point-max)) + 2)) + (should (equal (buffer-string) "new bar zot newbar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-regexp-in-region "fo+" "new" (point-min) 14) + 1)) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should-error (replace-regexp-in-region "fo+" "new" (point-min) 30))) + + (with-temp-buffer + (insert "Foo bar zot foobar") + (should (= (replace-regexp-in-region "Fo+" "new" (point-min)) + 1)) + (should (equal (buffer-string) "new bar zot foobar")))) + +(ert-deftest test-with-existing-directory () + (let ((dir (make-temp-name "/tmp/not-exist-"))) + (let ((default-directory dir)) + (should-not (file-exists-p default-directory))) + (with-existing-directory + (should-not (equal dir default-directory)) + (should (file-exists-p default-directory))))) + +(ert-deftest subr-test-internal--format-docstring-line () + (should + (string= (let ((fill-column 70)) + (internal--format-docstring-line + "In addition to any hooks its parent mode might have run, this \ +mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the final \ +or penultimate step during initialization.")) + "In addition to any hooks its parent mode might have run, this mode +runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the +final or penultimate step during initialization.")) + (should-error (internal--format-docstring-line "foo\nbar"))) + +(ert-deftest test-ensure-list () + (should (equal (ensure-list nil) nil)) + (should (equal (ensure-list :foo) '(:foo))) + (should (equal (ensure-list '(1 2 3)) '(1 2 3)))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 48a127157dd..6964d423185 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -47,4 +47,4 @@ (provide 'tar-mode-tests) -;; tar-mode-tests.el ends here +;;; tar-mode-tests.el ends here diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index 503cb5d7aab..73d39cf3b66 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -28,6 +28,65 @@ (defvar term-height) ; Number of lines in window. (defvar term-width) ; Number of columns in window. +(defvar yellow-fg-props + `( :foreground ,(face-foreground 'term-color-yellow nil 'default) + :background "unspecified-bg" :inverse-video nil)) +(defvar yellow-bg-props + `( :foreground "unspecified-fg" + :background ,(face-background 'term-color-yellow nil 'default) + :inverse-video nil)) +(defvar bright-yellow-fg-props + `( :foreground ,(face-foreground 'term-color-bright-yellow nil 'default) + :background "unspecified-bg" :inverse-video nil)) +(defvar bright-yellow-bg-props + `( :foreground "unspecified-fg" + :background ,(face-background 'term-color-bright-yellow nil 'default) + :inverse-video nil)) +(defvar custom-color-fg-props + `( :foreground "#87FFFF" + :background "unspecified-bg" :inverse-video nil)) + +(defvar ansi-test-strings + `(("\e[33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,yellow-fg-props))) + ("\e[43mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,yellow-bg-props))) + ("\e[93mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-fg-props))) + ("\e[103mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-bg-props))) + ("\e[1;33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[33;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[1m\e[33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[33m\e[1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;3;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;123;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))) + ("\e[38;2;135;255;255;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))))) + (defun term-test-screen-from-input (width height input &optional return-var) (with-temp-buffer (term-mode) @@ -48,7 +107,7 @@ (mapc (lambda (input) (term-emulate-terminal proc input)) input) (term-emulate-terminal proc input)) (if return-var (buffer-local-value return-var (current-buffer)) - (buffer-substring-no-properties (point-min) (point-max)))))) + (buffer-substring (point-min) (point-max)))))) (ert-deftest term-simple-lines () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) @@ -56,7 +115,7 @@ first line\r next line\r\n")) (should (equal (term-test-screen-from-input 40 12 str) - (replace-regexp-in-string "\r" "" str))))) + (string-replace "\r" "" str))))) (ert-deftest term-carriage-return () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) @@ -77,6 +136,24 @@ first line\r_next line\r\n")) (term-test-screen-from-input 40 12 (let ((str (make-string 30 ?a))) (list str str)))))) +(ert-deftest term-colors () + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (pcase-dolist (`(,str ,expected) ansi-test-strings) + (let ((result (term-test-screen-from-input 40 12 str))) + (should (equal result expected)) + (should (equal (text-properties-at 0 result) + (text-properties-at 0 expected)))))) + +(ert-deftest term-colors-bold-is-bright () + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (let ((ansi-color-bold-is-bright t)) + (pcase-dolist (`(,str ,expected ,bright-expected) ansi-test-strings) + (let ((expected (or bright-expected expected)) + (result (term-test-screen-from-input 40 12 str))) + (should (equal result expected)) + (should (equal (text-properties-at 0 result) + (text-properties-at 0 expected))))))) + (ert-deftest term-cursor-movement () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) ;; Absolute positioning. diff --git a/test/lisp/term/tty-colors-tests.el b/test/lisp/term/tty-colors-tests.el index ba29a9c376e..d0e739b5ec9 100644 --- a/test/lisp/term/tty-colors-tests.el +++ b/test/lisp/term/tty-colors-tests.el @@ -35,4 +35,4 @@ (provide 'term-tests) -;;; term-tests.el ends here +;;; tty-colors-tests.el ends here diff --git a/test/lisp/textmodes/dns-mode-tests.el b/test/lisp/textmodes/dns-mode-tests.el index 8bc48732c62..1be5291509f 100644 --- a/test/lisp/textmodes/dns-mode-tests.el +++ b/test/lisp/textmodes/dns-mode-tests.el @@ -77,3 +77,5 @@ (insert " ") (dns-mode-ipv6-to-nibbles nil) (should (equal (buffer-string) "8.b.d.0.1.0.0.2.ip6.arpa. "))))) + +;;; dns-mode-tests.el ends here diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el index a4c7f447b59..2a1195b87ea 100644 --- a/test/lisp/textmodes/fill-tests.el +++ b/test/lisp/textmodes/fill-tests.el @@ -54,7 +54,7 @@ (beg (line-beginning-position)) (end (line-end-position)) (fill-prefix (make-string (- pos beg) ?\s)) - ;; `fill-column' is too small to accomodate the current line + ;; `fill-column' is too small to accommodate the current line (fill-column (- end beg 10))) (fill-region-as-paragraph beg end nil nil pos)) (should (equal (buffer-string) string))))) @@ -69,13 +69,35 @@ (beg (line-beginning-position)) (end (line-end-position)) (fill-prefix (make-string (- pos beg) ?\s)) - ;; `fill-column' is too small to accomodate the current line + ;; `fill-column' is too small to accommodate the current line (fill-column (- end beg 10))) (fill-region-as-paragraph beg end nil nil pos)) (should (equal (buffer-string) "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n"))))) +(ert-deftest test-fill-end-period () + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.") + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius. ")) + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.Foo") + (forward-char -3) + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do +eius. Foo"))) + (provide 'fill-tests) ;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index b824e05f6d5..cc5b23e1c9c 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) ;;; reftex (require 'reftex) @@ -33,32 +34,31 @@ (ert-deftest reftex-locate-bibliography-files () "Test `reftex-locate-bibliography-files'." - (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) - (files '("ref1.bib" "ref2.bib")) - (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) - ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) - ("\\begin{document}\n\\bibliographystyle{plain}\n + (ert-with-temp-directory temp-dir + (let ((files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n \\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) - (reftex-bibliography-commands - ;; Default value: See reftex-vars.el `reftex-bibliography-commands' - '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" - "addbibresource"))) - (with-temp-buffer - (insert "test\n") + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) (mapc - (lambda (file) - (write-region (point-min) (point-max) (expand-file-name file - temp-dir))) - files)) - (mapc - (lambda (data) - (with-temp-buffer - (insert (car data)) - (let ((res (mapcar #'file-name-nondirectory - (reftex-locate-bibliography-files temp-dir)))) - (should (equal res (cdr data)))))) - test) - (delete-directory temp-dir 'recursive))) + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test)))) (ert-deftest reftex-what-environment-test () "Test `reftex-what-environment'." @@ -102,12 +102,12 @@ ;; reason. (An alternative solution would be to use file-equal-p, ;; but I'm too lazy to do that, as one of the tests compares a ;; list.) - (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) - (tex-file (expand-file-name "test.tex" temp-dir)) - (bib-file (expand-file-name "ref.bib" temp-dir))) - (with-temp-buffer - (insert -"\\begin{document} + (ert-with-temp-directory temp-dir + (let* ((tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert + "\\begin{document} \\section{test}\\label{sec:test} \\subsection{subtest} @@ -118,27 +118,26 @@ \\bibliographystyle{plain} \\bibliography{ref} \\end{document}") - (write-region (point-min) (point-max) tex-file)) - (with-temp-buffer - (insert "test\n") - (write-region (point-min) (point-max) bib-file)) - (reftex-ensure-compiled-variables) - (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) - (should (equal (car parsed) `(eof ,tex-file))) - (pop parsed) - (while parsed - (let ((entry (pop parsed))) - (cond - ((eq (car entry) 'bib) - (should (string= (cadr entry) bib-file))) - ((eq (car entry) 'toc)) ;; ... - ((string= (car entry) "eq:foo")) - ((string= (car entry) "sec:test")) - ((eq (car entry) 'bof) - (should (string= (cadr entry) tex-file)) - (should (null parsed))) - (t (should-not t))))) - (delete-directory temp-dir 'recursive)))) + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))))))) ;;; reftex-cite (require 'reftex-cite) diff --git a/test/lisp/textmodes/texinfo-resources/fill.erts b/test/lisp/textmodes/texinfo-resources/fill.erts new file mode 100644 index 00000000000..95f3b09eba8 --- /dev/null +++ b/test/lisp/textmodes/texinfo-resources/fill.erts @@ -0,0 +1,70 @@ +Code: + (lambda () + (texinfo-mode) + (fill-paragraph)) + +Name: fill1 +Point-Char: | + +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +=-=-= + +Name: fill2 +Point-Char: | + +=-= +@cindex relative| remapping, faces +@cindex base remapping, faces + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + + +Name: fill3 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces| + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + +Name: fill4 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to @code{face-remapping-alist}. +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to +@code{face-remapping-alist}. +=-=-= + +Name: fill5 +Point-Char: | + +=-= +@defun face-remap-add-relative face &rest specs +|This function adds the face spec in @var{specs} as relative +remappings for face @var{face} in the current buffer. The remaining +arguments, @var{specs}, should form either a list of face names, or a +property list of attribute/value pairs. +=-= +@defun face-remap-add-relative face &rest specs +This function adds the face spec in @var{specs} as relative remappings +for face @var{face} in the current buffer. The remaining arguments, +@var{specs}, should form either a list of face names, or a property +list of attribute/value pairs. +=-=-= + +Name: fill6 + +=-= +@subsection This is a very very very very very very very very very very long subsection name +=-=-= diff --git a/test/lisp/textmodes/texinfo-tests.el b/test/lisp/textmodes/texinfo-tests.el new file mode 100644 index 00000000000..fa0c4de005e --- /dev/null +++ b/test/lisp/textmodes/texinfo-tests.el @@ -0,0 +1,33 @@ +;;; texinfo-tests.el --- Tests for texinfo.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 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 'texinfo) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-filling () + (ert-test-erts-file (ert-resource-file "fill.erts"))) + +;;; texinfo-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index fba6f21d5dc..2a32dc57b1c 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -70,7 +70,7 @@ ;; UUID, only hex is allowed ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789") ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)) - "List of thing-at-point tests. + "List of `thing-at-point' tests. Each list element should have the form (STRING POS THING RESULT) @@ -223,4 +223,12 @@ position to retrieve THING.") (should (equal (test--number "0xf00" 2) 3840)) (should (equal (test--number "0xf00" 3) 3840))) -;;; thingatpt.el ends here +(ert-deftest test-fields () + (with-temp-buffer + (insert (propertize "foo" 'field 1) "bar" (propertize "zot" 'field 2)) + (goto-char 1) + (should (eq (symbol-at-point) 'foo)) + (goto-char 5) + (should (eq (symbol-at-point) 'bar)))) + +;;; thingatpt-tests.el ends here diff --git a/test/lisp/thumbs-tests.el b/test/lisp/thumbs-tests.el index ee096138453..a9b41d7c00f 100644 --- a/test/lisp/thumbs-tests.el +++ b/test/lisp/thumbs-tests.el @@ -20,15 +20,13 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'thumbs) (ert-deftest thumbs-tests-thumbsdir/create-if-missing () - (let ((thumbs-thumbsdir (make-temp-file "thumbs-test" t))) - (unwind-protect - (progn - (delete-directory thumbs-thumbsdir) - (should (file-directory-p (thumbs-thumbsdir)))) - (delete-directory thumbs-thumbsdir)))) + (ert-with-temp-directory thumbs-thumbsdir + (delete-directory thumbs-thumbsdir) + (should (file-directory-p (thumbs-thumbsdir))))) (provide 'thumbs-tests) ;;; thumbs-tests.el ends here diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 0d64320496d..cb446eb486e 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -26,7 +26,7 @@ (defmacro with-time-stamp-test-env (&rest body) "Evaluate BODY with some standard time-stamp test variables bound." - (declare (indent defun)) + (declare (indent 0) (debug t)) `(let ((user-login-name "test-logname") (user-full-name "100%d Tester") ;verify "%" passed unchanged (buffer-file-name "/emacs/test/time-stamped-file") @@ -46,7 +46,7 @@ (defmacro with-time-stamp-test-time (reference-time &rest body) "Force any contained time-stamp call to use time REFERENCE-TIME." - (declare (indent defun)) + (declare (indent 1) (debug t)) `(cl-letf* ((orig-time-stamp-string-fn (symbol-function 'time-stamp-string)) ((symbol-function 'time-stamp-string) @@ -56,13 +56,14 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." - (declare (indent defun)) + (declare (indent 1) (debug t)) `(cl-letf (((symbol-function 'system-name) (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) "Similar to `should' but verifies that a format warning is generated." + (declare (debug t)) `(let ((warning-count 0)) (cl-letf (((symbol-function 'time-stamp-conv-warn) (lambda (_old _new) @@ -86,7 +87,7 @@ (should (equal (time-stamp-string "%H %Z" ref-time1) "15 GMT"))))) (iter-defun time-stamp-test-pattern-sequential () - "Iterate through each possibility for a part of time-stamp-pattern." + "Iterate through each possibility for a part of `time-stamp-pattern'." (let ((pattern-value-parts '(("4/" "10/" "-4/" "0/" "") ;0: line limit ("stamp<" "") ;1: start @@ -115,7 +116,7 @@ (extract-part 5)))))))))) (iter-defun time-stamp-test-pattern-multiply () - "Iterate through every combination of parts of time-stamp-pattern." + "Iterate through every combination of parts of `time-stamp-pattern'." (let ((line-limit-values '("" "4/")) (start-values '("" "stamp<")) (format-values '("%%" "%m")) @@ -141,9 +142,9 @@ ts-format _format-lines _end-lines) ;; Verify that time-stamp parsed time-stamp-pattern and ;; called us with the correct pieces. - (let ((limit-number (string-to-number line-limit1))) - (if (equal line-limit1 "") - (setq limit-number time-stamp-line-limit)) + (let ((limit-number (if (equal line-limit1 "") + time-stamp-line-limit + (string-to-number line-limit1)))) (goto-char (point-min)) (if (> limit-number 0) (should (= search-limit (line-beginning-position @@ -703,9 +704,10 @@ ;;;; Setup for tests of time offset formatting with %z (defun formatz (format zone) - "Uses time FORMAT string to format the offset of ZONE, returning the result. -FORMAT is \"%z\" or a variation. -ZONE is as the ZONE argument of the `format-time-string' function." + "Uses FORMAT to format the offset of ZONE, returning the result. +FORMAT must be time format \"%z\" or some variation thereof. +ZONE is as the ZONE argument of the `format-time-string' function. +This function is called by 99% of the `time-stamp' \"%z\" unit tests." (with-time-stamp-test-env (let ((time-stamp-time-zone zone)) ;; Call your favorite time formatter here. @@ -717,9 +719,9 @@ ZONE is as the ZONE argument of the `format-time-string' function." (defun format-time-offset (format offset-secs) "Uses FORMAT to format the time zone represented by OFFSET-SECS. -FORMAT must be \"%z\", possibly with a flag and padding. +FORMAT must be time format \"%z\" or some variation thereof. This function is a wrapper around `time-stamp-formatz-from-parsed-options' -and is used for testing." +and is called by some low-level `time-stamp' \"%z\" unit tests." ;; This wrapper adds a simple regexp-based parser that handles only ;; %z and variants. In normal use, time-stamp-formatz-from-parsed-options ;; is called from a parser that handles all time string formats. @@ -761,6 +763,7 @@ and is used for testing." "Formats ZONE and compares it to EXPECT. Uses the free variables `form-string' and `pattern-mod'. The functions in `pattern-mod' are composed left to right." + (declare (debug t)) `(let ((result ,expect)) (dolist (fn pattern-mod) (setq result (funcall fn result))) @@ -849,7 +852,7 @@ The functions in `pattern-mod' are composed left to right." (defun formatz-mod-del-colons (string) "Returns STRING with any colons removed." - (replace-regexp-in-string ":" "" string)) + (string-replace ":" "" string)) (defun formatz-mod-add-00 (string) "Returns STRING with \"00\" appended." @@ -871,7 +874,7 @@ The functions in `pattern-mod' are composed left to right." (defmacro formatz-generate-tests (form-strings hour-mod mins-mod secs-mod big-mod secbig-mod) - "Defines ert-deftest tests for time formats FORM-STRINGS. + "Defines tests for time formats FORM-STRINGS. FORM-STRINGS is a list of formats, each \"%z\" or some variation thereof. Each of the remaining arguments is an unquoted list of the form @@ -895,10 +898,11 @@ BIG-MOD is the result for offset +100 hours and modifiers for the other expected results for hours greater than 99 with a whole number of minutes. SECBIG-MOD is the result for offset +100 hours 30 seconds and modifiers for the other expected results for hours greater than 99 with non-zero seconds." - (declare (indent 1)) + (declare (indent 1) (debug (&rest sexp))) ;; Generate a form to create a list of tests to define. When this ;; macro is called, the form is evaluated, thus defining the tests. - (let ((ert-test-list '(list))) + ;; We will modify this list, so start with a list consed at runtime. + (let ((ert-test-list (list 'list))) (dolist (form-string form-strings ert-test-list) (nconc ert-test-list diff --git a/test/lisp/time-tests.el b/test/lisp/time-tests.el index 88b7638d91d..89e6985b842 100644 --- a/test/lisp/time-tests.el +++ b/test/lisp/time-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'ert-x) (require 'time) diff --git a/test/lisp/timezone-tests.el b/test/lisp/timezone-tests.el index 9f6961409e6..9bbe36cfe8a 100644 --- a/test/lisp/timezone-tests.el +++ b/test/lisp/timezone-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'timezone) diff --git a/test/lisp/url/url-auth-tests.el b/test/lisp/url/url-auth-tests.el index ff30f100250..05ccfc0d12a 100644 --- a/test/lisp/url/url-auth-tests.el +++ b/test/lisp/url/url-auth-tests.el @@ -154,7 +154,7 @@ Essential is how realms and paths are matched." auth) (dolist (row (list - ;; If :expected-user is `nil' it indicates + ;; If :expected-user is nil it indicates ;; authentication information shouldn't be found. ;; non-existent server diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-tests.el index 7e5a60363da..71e054b1287 100644 --- a/test/lisp/url/url-handlers-test.el +++ b/test/lisp/url/url-handlers-tests.el @@ -1,4 +1,4 @@ -;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- +;;; url-handlers-tests.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- ;; Copyright (C) 2018-2021 Free Software Foundation, Inc. @@ -73,5 +73,4 @@ (should (equal (file-name-directory "https://foo.org/") "https://foo.org/")))) -(provide 'url-handlers-test) -;;; url-handlers-test.el ends here +;;; url-handlers-tests.el ends here diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el index 2418af40aca..a7f81eba8f5 100644 --- a/test/lisp/url/url-parse-tests.el +++ b/test/lisp/url/url-parse-tests.el @@ -23,7 +23,7 @@ ;;; Commentary: ;; Test cases covering generic URI syntax as described in RFC3986, -;; section 3. Syntax Components and 4. Usage. See also appendix +;; section 3. Syntax Components and 4. Usage. See also appendix ;; A. Collected ABNF for URI, as the example given here are all ;; productions of this grammar. diff --git a/test/lisp/vc/add-log-tests.el b/test/lisp/vc/add-log-tests.el index dc2b9961c6c..70e49fe57fe 100644 --- a/test/lisp/vc/add-log-tests.el +++ b/test/lisp/vc/add-log-tests.el @@ -29,8 +29,8 @@ content marker expected-defun) "Generate an ert test for mode-own `add-log-current-defun-function'. Run `add-log-current-defun' at the point where MARKER specifies -in a buffer which content is CONTENT under major mode MODE. Then -it compares the result with EXPECTED-DEFUN." +in a buffer which content is CONTENT under major mode MODE. +Then it compares the result with EXPECTED-DEFUN." (let ((xname (intern (concat "add-log-current-defun-test-" (symbol-name name) )))) diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 5bc4ad6dace..909d5620de6 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -173,35 +173,33 @@ wristwatches wrongheadedly wrongheadedness youthfulness -") - (temp-dir (make-temp-file "diff-mode-test" 'dir))) - - (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) - (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) - (unwind-protect - (progn - (with-current-buffer buf (insert fil_before) (save-buffer)) - (with-current-buffer buf2 (insert fil2_before) (save-buffer)) - - (with-temp-buffer - (cd temp-dir) - (insert patch) - (goto-char (point-min)) - (diff-apply-hunk) - (diff-apply-hunk) - (diff-apply-hunk)) - - (should (equal (with-current-buffer buf (buffer-string)) - fil_after)) - (should (equal (with-current-buffer buf2 (buffer-string)) - fil2_after))) - - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf) - (with-current-buffer buf2 (set-buffer-modified-p nil)) - (kill-buffer buf2) - (delete-directory temp-dir 'recursive)))))) +")) + (ert-with-temp-directory temp-dir + (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) + (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) + (unwind-protect + (progn + (with-current-buffer buf (insert fil_before) (save-buffer)) + (with-current-buffer buf2 (insert fil2_before) (save-buffer)) + + (with-temp-buffer + (cd temp-dir) + (insert patch) + (goto-char (point-min)) + (diff-apply-hunk) + (diff-apply-hunk) + (diff-apply-hunk)) + + (should (equal (with-current-buffer buf (buffer-string)) + fil_after)) + (should (equal (with-current-buffer buf2 (buffer-string)) + fil2_after))) + + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf) + (with-current-buffer buf2 (set-buffer-modified-p nil)) + (kill-buffer buf2))))))) (ert-deftest diff-mode-test-hunk-text-no-newline () "Check output of `diff-hunk-text' with no newline at end of file." @@ -468,4 +466,17 @@ baz")))) (114 131 (diff-mode syntax face font-lock-string-face)) (134 140 (diff-mode syntax face font-lock-keyword-face)))))))) +(ert-deftest test-hunk-file-names () + (with-temp-buffer + (insert "diff -c /tmp/ange-ftp13518wvE.el /tmp/ange-ftp1351895K.el\n") + (goto-char (point-min)) + (should (equal (diff-hunk-file-names) + '("/tmp/ange-ftp1351895K.el" "/tmp/ange-ftp13518wvE.el")))) + (with-temp-buffer + (insert "diff -c -L /ftp:slbhao:/home/albinus/src/tramp/lisp/tramp.el -L /ftp:slbhao:/home/albinus/src/emacs/lisp/net/tramp.el /tmp/ange-ftp13518wvE.el /tmp/ange-ftp1351895K.el\n") + (goto-char (point-min)) + (should (equal (diff-hunk-file-names) + '("/tmp/ange-ftp1351895K.el" "/tmp/ange-ftp13518wvE.el"))))) + (provide 'diff-mode-tests) +;;; diff-mode-tests.el ends here diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index a464db2349d..0f09616a816 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ediff-ptch) (ert-deftest ediff-ptch-test-bug25010 () @@ -45,34 +46,33 @@ index 6a07f80..6e8e947 100644 "Test for https://debbugs.gnu.org/26084 ." (skip-unless (executable-find "git")) (skip-unless (executable-find ediff-patch-program)) - (let* ((tmpdir (make-temp-file "ediff-ptch-test" t)) - (default-directory (file-name-as-directory tmpdir)) - (patch (make-temp-file "ediff-ptch-test")) - (qux (expand-file-name "qux.txt" tmpdir)) - (bar (expand-file-name "bar.txt" tmpdir)) - (git-program (executable-find "git"))) - ;; Create repository. - (with-temp-buffer - (insert "qux here\n") - (write-region nil nil qux nil 'silent) - (erase-buffer) - (insert "bar here\n") - (write-region nil nil bar nil 'silent)) - (call-process git-program nil nil nil "init") - (call-process git-program nil nil nil "add" ".") - (call-process git-program nil nil nil "commit" "-m" "Test repository.") - ;; Update repo., save the diff and reset to initial state. - (with-temp-buffer - (insert "foo here\n") - (write-region nil nil qux nil 'silent) - (write-region nil nil bar nil 'silent)) - (call-process git-program nil `(:file ,patch) nil "diff") - (call-process git-program nil nil nil "reset" "--hard" "HEAD") - ;; Visit the diff file i.e., patch; extract from it the parts - ;; affecting just each of the files: store in patch-bar the part - ;; affecting 'bar', and in patch-qux the part affecting 'qux'. - (find-file patch) - (unwind-protect + (ert-with-temp-directory tmpdir + (ert-with-temp-file patch + (let* ((default-directory (file-name-as-directory tmpdir)) + (qux (expand-file-name "qux.txt" tmpdir)) + (bar (expand-file-name "bar.txt" tmpdir)) + (git-program (executable-find "git"))) + ;; Create repository. + (with-temp-buffer + (insert "qux here\n") + (write-region nil nil qux nil 'silent) + (erase-buffer) + (insert "bar here\n") + (write-region nil nil bar nil 'silent)) + (call-process git-program nil nil nil "init") + (call-process git-program nil nil nil "add" ".") + (call-process git-program nil nil nil "commit" "-m" "Test repository.") + ;; Update repo., save the diff and reset to initial state. + (with-temp-buffer + (insert "foo here\n") + (write-region nil nil qux nil 'silent) + (write-region nil nil bar nil 'silent)) + (call-process git-program nil `(:file ,patch) nil "diff") + (call-process git-program nil nil nil "reset" "--hard" "HEAD") + ;; Visit the diff file i.e., patch; extract from it the parts + ;; affecting just each of the files: store in patch-bar the part + ;; affecting 'bar', and in patch-qux the part affecting 'qux'. + (find-file patch) (let* ((info (progn (ediff-map-patch-buffer (current-buffer)) ediff-patch-map)) (patch-bar @@ -116,9 +116,7 @@ index 6a07f80..6e8e947 100644 (buffer-string)) (with-temp-buffer (insert-file-contents backup) - (buffer-string))))))) - (delete-directory tmpdir 'recursive) - (delete-file patch))))) + (buffer-string)))))))))))) (provide 'ediff-ptch-tests) diff --git a/test/lisp/vc/smerge-mode-tests.el b/test/lisp/vc/smerge-mode-tests.el index 2c8f48618e5..d7827c7a8cb 100644 --- a/test/lisp/vc/smerge-mode-tests.el +++ b/test/lisp/vc/smerge-mode-tests.el @@ -34,3 +34,5 @@ (should (equal (buffer-substring (point-min) (point-max)) "")))) (provide 'smerge-mode-tests) + +;;; smerge-mode-tests.el ends here diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index b02dce8f707..afced819fbc 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc-bzr) (require 'vc-dir) @@ -51,106 +52,97 @@ ;; temporary directory. ;; TODO does this means tests should be setting XDG_ variables (not ;; just HOME) to temporary values too? - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (ignored-dir (progn - (make-directory bzrdir) - (expand-file-name "ignored-dir" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (make-directory ignored-dir) - (with-temp-buffer - (insert (file-name-nondirectory ignored-dir)) - (write-region nil nil (expand-file-name ".bzrignore" bzrdir) - nil 'silent)) - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (with-temp-buffer - (insert "unregistered file") - (write-region nil nil (expand-file-name "testfile2" ignored-dir) - nil 'silent)) - (vc-dir ignored-dir) - (while (vc-dir-busy) - (sit-for 0.1)) - ;; FIXME better to explicitly test for error from process sentinel. - (with-current-buffer "*vc-dir*" - (goto-char (point-min)) - (should (search-forward "unregistered" nil t)))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (ignored-dir (progn + (make-directory bzrdir) + (expand-file-name "ignored-dir" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (make-directory ignored-dir) + (with-temp-buffer + (insert (file-name-nondirectory ignored-dir)) + (write-region nil nil (expand-file-name ".bzrignore" bzrdir) + nil 'silent)) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (with-temp-buffer + (insert "unregistered file") + (write-region nil nil (expand-file-name "testfile2" ignored-dir) + nil 'silent)) + (vc-dir ignored-dir) + (while (vc-dir-busy) + (sit-for 0.1)) + ;; FIXME better to explicitly test for error from process sentinel. + (with-current-buffer "*vc-dir*" + (goto-char (point-min)) + (should (search-forward "unregistered" nil t)))))) ;; Not specific to bzr. (ert-deftest vc-bzr-test-bug9781 () "Test for https://debbugs.gnu.org/9781 ." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (subdir (progn - (make-directory bzrdir) - (expand-file-name "subdir" bzrdir))) - (file (expand-file-name "file" bzrdir)) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (make-directory subdir) - (with-temp-buffer - (insert "text") - (write-region nil nil file nil 'silent) - (write-region nil nil (expand-file-name "subfile" subdir) - nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (call-process vc-bzr-program nil nil nil "remove" subdir) - (with-temp-buffer - (insert "different text") - (write-region nil nil file nil 'silent)) - (vc-dir bzrdir) - (while (vc-dir-busy) - (sit-for 0.1)) - (vc-dir-mark-all-files t) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) - (vc-next-action nil)) - (should (get-buffer "*vc-log*"))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (subdir (progn + (make-directory bzrdir) + (expand-file-name "subdir" bzrdir))) + (file (expand-file-name "file" bzrdir)) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (make-directory subdir) + (with-temp-buffer + (insert "text") + (write-region nil nil file nil 'silent) + (write-region nil nil (expand-file-name "subfile" subdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (call-process vc-bzr-program nil nil nil "remove" subdir) + (with-temp-buffer + (insert "different text") + (write-region nil nil file nil 'silent)) + (vc-dir bzrdir) + (while (vc-dir-busy) + (sit-for 0.1)) + (vc-dir-mark-all-files t) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) + (vc-next-action nil)) + (should (get-buffer "*vc-log*"))))) ;; https://lists.gnu.org/r/help-gnu-emacs/2012-04/msg00145.html (ert-deftest vc-bzr-test-faulty-bzr-autoloads () "Test we can generate autoloads in a bzr directory when bzr is faulty." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (file (progn - (make-directory bzrdir) - (expand-file-name "foo.el" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (call-process vc-bzr-program nil nil nil "init") - (with-temp-buffer - (insert ";;;###autoload + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (file (progn + (make-directory bzrdir) + (expand-file-name "foo.el" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (call-process vc-bzr-program nil nil nil "init") + (with-temp-buffer + (insert ";;;###autoload \(defun foo () \"foo\" (interactive) (message \"foo!\"))") - (write-region nil nil file nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - ;; Deleting dirstate ensures both that vc-bzr's status heuristic - ;; fails, so it has to call the external bzr status, and - ;; causes bzr status to fail. This simulates a broken bzr - ;; installation. - (delete-file ".bzr/checkout/dirstate") - (should (progn (make-directory-autoloads - default-directory - (expand-file-name "loaddefs.el" bzrdir)) - t))) - (delete-directory homedir t)))) + (write-region nil nil file nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + ;; Deleting dirstate ensures both that vc-bzr's status heuristic + ;; fails, so it has to call the external bzr status, and + ;; causes bzr status to fail. This simulates a broken bzr + ;; installation. + (delete-file ".bzr/checkout/dirstate") + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) + t))))) -;;; vc-bzr.el ends here +;;; vc-bzr-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 5430535c5ed..578d7ebb418 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -52,7 +52,7 @@ ;; - responsible-p (file) ;; - receive-file (file rev) ;; - unregister (file) DONE -;; * checkin (files comment) +;; * checkin (files comment) DONE ;; * find-revision (file rev buffer) ;; * checkout (file &optional rev) ;; * revert (file &optional contents-done) @@ -75,7 +75,7 @@ ;; - show-log-entry (revision) ;; - comment-history (file) ;; - update-changelog (files) -;; * diff (files &optional async rev1 rev2 buffer) +;; * diff (files &optional async rev1 rev2 buffer) DONE ;; - revision-completion-table (files) ;; - annotate-command (file buf &optional rev) ;; - annotate-time () @@ -100,7 +100,7 @@ ;; - log-edit-mode () ;; - check-headers () ;; - delete-file (file) -;; - rename-file (old new) +;; - rename-file (old new) DONE ;; - find-file-hook () ;; - extra-menu () ;; - extra-dir-menu () @@ -109,7 +109,9 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc) +(require 'log-edit) (declare-function w32-application-type "w32proc.c") @@ -177,41 +179,38 @@ For backends which dont support it, it is emulated." (defun vc-test--create-repo (backend) "Create a test repository in `default-directory', a temporary directory." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--create-repo" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Check the revision granularity. - (should (memq (vc-test--revision-granularity-function backend) - '(file repository))) - - ;; Create empty repository. - (make-directory default-directory) - (should (file-directory-p default-directory)) - (vc-test--create-repo-function backend) - (should (eq (vc-responsible-backend default-directory) backend))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; FIXME: Why isn't there `vc-unregister'? (defun vc-test--unregister-function (backend file) @@ -234,318 +233,429 @@ Catch the `vc-not-supported' error." (defun vc-test--register (backend) "Register and unregister a file. This checks also `vc-backend' and `vc-responsible-backend'." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--register" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - ;; For file oriented backends CVS, RCS and SVN the backend is - ;; returned, and the directory is registered already. - (should (if (vc-backend default-directory) - (vc-registered default-directory) - (not (vc-registered default-directory)))) - (should (eq (vc-responsible-backend default-directory) backend)) - - (let ((tmp-name1 (expand-file-name "foo" default-directory)) - (tmp-name2 "bla")) - ;; Register files. Check for it. - (write-region "foo" nil tmp-name1 nil 'nomessage) - (should (file-exists-p tmp-name1)) - (should-not (vc-backend tmp-name1)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should-not (vc-registered tmp-name1)) - - (write-region "bla" nil tmp-name2 nil 'nomessage) - (should (file-exists-p tmp-name2)) - (should-not (vc-backend tmp-name2)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should-not (vc-registered tmp-name2)) - - (vc-register (list backend (list tmp-name1 tmp-name2))) - (should (file-exists-p tmp-name1)) - (should (eq (vc-backend tmp-name1) backend)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should (vc-registered tmp-name1)) - - (should (file-exists-p tmp-name2)) - (should (eq (vc-backend tmp-name2) backend)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should (vc-registered tmp-name2)) - - ;; `vc-backend' accepts also a list of files, - ;; `vc-responsible-backend' doesn't. - (should (vc-backend (list tmp-name1 tmp-name2))) - - ;; Unregister the files. - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name1) - 'vc-not-supported) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + ;; For file oriented backends CVS, RCS and SVN the backend is + ;; returned, and the directory is registered already. + (should (if (vc-backend default-directory) + (vc-registered default-directory) + (not (vc-registered default-directory)))) + (should (eq (vc-responsible-backend default-directory) backend)) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) (should-not (vc-backend tmp-name1)) - (should-not (vc-registered tmp-name1))) - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name2) - 'vc-not-supported) - (should-not (vc-backend tmp-name2)) - (should-not (vc-registered tmp-name2))) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should-not (vc-registered tmp-name1)) - ;; The files should still exist. - (should (file-exists-p tmp-name1)) - (should (file-exists-p tmp-name2)))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-backend tmp-name2)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should-not (vc-registered tmp-name2)) + + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (eq (vc-backend tmp-name1) backend)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should (vc-registered tmp-name1)) + + (should (file-exists-p tmp-name2)) + (should (eq (vc-backend tmp-name2) backend)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should (vc-registered tmp-name2)) + + ;; `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. + (should (vc-backend (list tmp-name1 tmp-name2))) + + ;; Unregister the files. + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name1) + 'vc-not-supported) + (should-not (vc-backend tmp-name1)) + (should-not (vc-registered tmp-name1))) + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name2) + 'vc-not-supported) + (should-not (vc-backend tmp-name2)) + (should-not (vc-registered tmp-name2))) + + ;; The files should still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--state (backend) "Check the different states of a file." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--state" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of a nonexistent file. - - (message "vc-state2 %s" (vc-state tmp-name)) - (should (null (vc-state tmp-name))) - - ;; Write a new file. Check state. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; nil: Mtn - ;; unregistered: Bzr CVS Git Hg SVN RCS - (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) '(nil unregistered))) - - ;; Register a file. Check state. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; FIXME: nil is definitely wrong. - ;; nil: SRC - ;; added: Bzr CVS Git Hg Mtn SVN - ;; up-to-date: RCS SCCS - (message "vc-state4 %s" (vc-state tmp-name)) - (should (memq (vc-state tmp-name) '(nil added up-to-date))) - - ;; Unregister the file. Check state. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-state5 unsupported") - ;; unregistered: Bzr Git RCS Hg - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) - '(nil unregistered)))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of a nonexistent file. + + (message "vc-state2 %s" (vc-state tmp-name)) + (should (null (vc-state tmp-name))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; unregistered: Bzr CVS Git Hg SVN RCS + (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) '(nil unregistered))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; FIXME: nil is definitely wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) + + ;; Unregister the file. Check state. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-state5 unsupported") + ;; unregistered: Bzr Git RCS Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) + '(nil unregistered)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--working-revision (backend) "Check the working revision of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--working-revision" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check working revision of - ;; repository, should be nil. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; FIXME: Is the value for SVN correct? - ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC - ;; "0": SVN - (message - "vc-working-revision1 %s" (vc-working-revision default-directory)) - (should (member (vc-working-revision default-directory) '(nil "0"))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check initial working revision, should be nil until - ;; it's registered. - - (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Write a new file. Check working revision. - (write-region "foo" nil tmp-name nil 'nomessage) - - (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Register a file. Check working revision. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; XXX: nil is fine, at least in Git's case, because - ;; `vc-register' only makes the file `added' in this case. - ;; nil: Git Mtn - ;; "0": Bzr CVS Hg SRC SVN - ;; "1.1": RCS SCCS - ;; "-1": Hg versions before 5 (probably) - (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) - (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) - - ;; TODO: Call `vc-checkin', and check the resulting - ;; working revision. None of the return values should be - ;; nil then. - - ;; Unregister the file. Check working revision. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-working-revision5 unsupported") - ;; nil: Bzr Git Hg RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; FIXME: Is the value for SVN correct? + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC + ;; "0": SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; XXX: nil is fine, at least in Git's case, because + ;; `vc-register' only makes the file `added' in this case. + ;; nil: Git Mtn + ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1": RCS SCCS + ;; "-1": Hg versions before 5 (probably) + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) + + ;; TODO: Call `vc-checkin', and check the resulting + ;; working revision. None of the return values should be + ;; nil then. + + ;; Unregister the file. Check working revision. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-working-revision5 unsupported") + ;; nil: Bzr Git Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--checkout-model (backend) "Check the checkout model of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--checkout-model" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; Surprisingly, none of the backends returns 'announce. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model1 %s" - (vc-checkout-model backend default-directory)) - (should (memq (vc-checkout-model backend default-directory) - '(announce implicit locking))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of a nonexistent file. - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; Surprisingly, none of the backends returns 'announce. + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) - ;; Write a new file. Check checkout model. - (write-region "foo" nil tmp-name nil 'nomessage) + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of a nonexistent file. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) - ;; Register a file. Check checkout model. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Unregister the file. Check checkout model. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-checkout-model5 unsupported") - ;; implicit: Bzr Git Hg - ;; locking: RCS - ;; unsupported: CVS Mtn SCCS SRC SVN + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking)))))) + '(announce implicit locking))) - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-checkout-model5 unsupported") + ;; implicit: Bzr Git Hg + ;; locking: RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--rename-file (backend) + "Check the rename-file action." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory)) + (new-name (expand-file-name "bar" default-directory))) + ;; Write a new file. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; Register it. Renaming can fail otherwise. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + (vc-rename-file tmp-name new-name) + + (should (not (file-exists-p tmp-name))) + (should (file-exists-p new-name)) + + (should (equal (vc-state new-name) + (if (memq backend '(RCS SCCS)) + 'up-to-date + 'added))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(declare-function log-edit-done "vc/log-edit") + +(defun vc-test--version-diff (backend) + "Check the diff version of a repository." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + ;; git tries various approaches to guess a user name and email, + ;; which can fail depending on how the system is configured. + ;; Eg if the user account has no GECOS, git commit can fail with + ;; status 128 "fatal: empty ident name". + (when (memq backend '(Bzr Git)) + (setq process-environment (cons "EMAIL=john@doe.ee" + process-environment))) + (if (eq backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let* ((tmp-name (expand-file-name "foo" default-directory)) + (files (list (file-name-nondirectory tmp-name)))) + ;; Write and register a new file. + (write-region "originaltext" nil tmp-name nil 'nomessage) + (vc-register (list backend files)) + + (let ((buff (find-file tmp-name))) + (with-current-buffer buff + (progn + ;; Optionally checkout file. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + + ;; Checkin file. + (vc-checkin files backend) + (insert "Testing vc-version-diff") + (log-edit-done)))) + + ;; Modify file content. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + (write-region "updatedtext" nil tmp-name nil 'nomessage) + + ;; Check version diff. + (vc-version-diff files nil nil) + (should (bufferp (get-buffer "*vc-diff*"))) + + (with-current-buffer "*vc-diff*" + (progn + (let ((rawtext (buffer-substring-no-properties (point-min) + (point-max)))) + (should (string-search "-originaltext" rawtext)) + (should (string-search "+updatedtext" rawtext))))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; Create the test cases. @@ -648,7 +758,35 @@ This checks also `vc-backend' and `vc-responsible-backend'." (ert-get-test ',(intern (format "vc-test-%s01-register" backend-string)))))) - (vc-test--checkout-model ',backend)))))) + (vc-test--checkout-model ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s05-rename-file" backend-string)) () + ,(format "Check `vc-rename-file' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + ;; CVS calls vc-delete-file, which insists on prompting + ;; "Really want to delete ...?" + (skip-unless (not (eq 'CVS ',backend))) + (vc-test--rename-file ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s06-version-diff" backend-string)) () + ,(format "Check `vc-version-diff' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--version-diff ',backend)) + )))) (provide 'vc-tests) ;;; vc-tests.el ends here diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index ba276e24d96..e768a165529 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (require 'wdired) @@ -28,104 +29,100 @@ (ert-deftest wdired-test-bug32173-01 () "Test using non-nil wdired-use-interactive-rename. Partially modifying a file name should succeed." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (replace-regexp-in-string "foo" replace test-file)) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. - :override - (lambda (_sym _prompt &rest _args) (setq dired-query t)) - '((name . "advice-dired-query"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (wdired-finish-edit) - (should (equal (dired-file-name-at-point) new-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file)) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. + :override + (lambda (_sym _prompt &rest _args) (setq dired-query t)) + '((name . "advice-dired-query"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (wdired-finish-edit) + (should (equal (dired-file-name-at-point) new-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-bug32173-02 () "Test using non-nil wdired-use-interactive-rename. Aborting an edit should leaving original file name unchanged." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - ;; Make dired-do-create-files-regexp a noop to mimic typing C-g - ;; at its prompt before wdired-finish-edit returns. - (advice-add 'dired-do-create-files-regexp - :override - (lambda (&rest _) (ignore)) - '((name . "advice-dired-do-create-files-regexp"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert "bar") - (wdired-finish-edit) - (should (equal (dired-get-filename) test-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + ;; Make dired-do-create-files-regexp a noop to mimic typing C-g + ;; at its prompt before wdired-finish-edit returns. + (advice-add 'dired-do-create-files-regexp + :override + (lambda (&rest _) (ignore)) + '((name . "advice-dired-do-create-files-regexp"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert "bar") + (wdired-finish-edit) + (should (equal (dired-get-filename) test-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-symlink-name () "Test the file name of a symbolic link. The Dired and WDired functions returning the name should include only the name before the link arrow." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (link-name "foo")) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (skip-unless - ;; This check is for wdired, not symbolic links, so skip - ;; it when make-symbolic-link fails for any reason (like - ;; insufficient privileges). - (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) - (revert-buffer) - (let* ((file-name (dired-get-filename)) - (dir-part (file-name-directory file-name)) - (lf-name (concat dir-part link-name))) - (should (equal file-name lf-name)) - (dired-toggle-read-only) - (should (equal (wdired-get-filename) lf-name)) - (dired-toggle-read-only))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((link-name "foo")) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (skip-unless + ;; This check is for wdired, not symbolic links, so skip + ;; it when make-symbolic-link fails for any reason (like + ;; insufficient privileges). + (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) + (revert-buffer) + (let* ((file-name (dired-get-filename)) + (dir-part (file-name-directory file-name)) + (lf-name (concat dir-part link-name))) + (should (equal file-name lf-name)) + (dired-toggle-read-only) + (should (equal (wdired-get-filename) lf-name)) + (dired-toggle-read-only))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-unfinished-edit-01 () "Test editing a file name without saving the change. Finding the new name should be possible while still in wdired-mode." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (replace-regexp-in-string "foo" replace test-file))) - (write-region "" nil test-file nil 'silent) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (should (equal (dired-get-filename) new-file))) - (when buf - (with-current-buffer buf - ;; Prevent kill-buffer-query-functions from chiming in. - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file))) + (write-region "" nil test-file nil 'silent) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (should (equal (dired-get-filename) new-file))) + (when buf + (with-current-buffer buf + ;; Prevent kill-buffer-query-functions from chiming in. + (set-buffer-modified-p nil) + (kill-buffer buf)))))))) (defvar server-socket-dir) (declare-function dired-smart-shell-command "dired-x" @@ -139,61 +136,59 @@ dired-move-to-end-of-filename handles indicator characters, it suffices to compare the return values of dired-get-filename and wdired-get-filename before and after editing." ;; FIXME: Add a test for a door (indicator ">") only under Solaris? - (let* ((test-dir (make-temp-file "test-dir-" t)) - (server-socket-dir test-dir) - (dired-listing-switches "-Fl") - (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) - (unwind-protect - (progn - (with-current-buffer buf - (dired-create-empty-file "foo") - (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) - (make-symbolic-link "foo" "bar") - (make-directory "foodir") - (require 'dired-x) - (dired-smart-shell-command "mkfifo foopipe") - (server-force-delete) - ;; FIXME? This seems a heavy-handed way of making a socket. - (server-start) ; Add a socket file. - (kill-buffer buf)) - (dired test-dir) - (dired-toggle-read-only) - (let (names) - ;; Test that the file names are the same in Dired and WDired. - (while (not (eobp)) - (should (equal (dired-get-filename 'no-dir t) - (wdired-get-filename t))) - (insert "w") - (push (wdired-get-filename t) names) - (dired-next-line 1)) - (wdired-finish-edit) - ;; Test that editing the file names ignores the indicator - ;; character. - (let (dir) - (while (and (dired-previous-line 1) - (setq dir (dired-get-filename 'no-dir t))) - (should (equal dir (pop names))))))) - (kill-buffer (get-buffer test-dir)) - (server-force-delete) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let* ((server-socket-dir test-dir) + (dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) + (buf (find-file-noselect test-dir))) + (unwind-protect + (progn + (with-current-buffer buf + (dired-create-empty-file "foo") + (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) + (make-symbolic-link "foo" "bar") + (make-directory "foodir") + (require 'dired-x) + (dired-smart-shell-command "mkfifo foopipe") + (server-force-delete) + ;; FIXME? This seems a heavy-handed way of making a socket. + (server-start) ; Add a socket file. + (kill-buffer buf)) + (dired test-dir) + (dired-toggle-read-only) + (let (names) + ;; Test that the file names are the same in Dired and WDired. + (while (not (eobp)) + (should (equal (dired-get-filename 'no-dir t) + (wdired-get-filename t))) + (insert "w") + (push (wdired-get-filename t) names) + (dired-next-line 1)) + (wdired-finish-edit) + ;; Test that editing the file names ignores the indicator + ;; character. + (let (dir) + (while (and (dired-previous-line 1) + (setq dir (dired-get-filename 'no-dir t))) + (should (equal dir (pop names))))))) + (kill-buffer (get-buffer test-dir)) + (server-force-delete))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." - (let* ((test-dir (make-temp-file "test-dir" 'dir)) - (fname "foo") - (full-fname (expand-file-name fname test-dir))) - (make-empty-file full-fname) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (dired-toggle-read-only) - (dolist (old '(t nil)) - (should (equal fname (wdired-get-filename 'nodir old))) - (should (equal full-fname (wdired-get-filename nil old)))) - (wdired-finish-edit)) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf))))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 9f54a4fd340..1001476a286 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -51,7 +51,7 @@ ;; We cannot call whitespace-mode because it will do nothing in batch ;; mode. So we call its innards instead. (defun whitespace-tests-whitespace-mode-on () - "Turn whitespace-mode on even in batch mode." + "Turn `whitespace-mode' on even in batch mode." (whitespace-turn-on) (whitespace-action-when-on) (setq whitespace-mode t)) diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index b00b58acfc5..7c64ef39f8d 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -78,7 +78,7 @@ ;; Bug#16344 "<!----><x>< /x>" "<a>< b/></a>") - "List of XML strings that should signal an error in the parser") + "List of XML strings that should signal an error in the parser.") (defvar xml-parse-tests--qnames '( ;; Test data for name expansion @@ -199,4 +199,4 @@ Parser is called with and without 'symbol-qnames argument.") ;; no-byte-compile: t ;; End: -;;; xml-parse-tests.el ends here. +;;; xml-tests.el ends here |