diff options
Diffstat (limited to 'test/lisp/files-tests.el')
| -rw-r--r-- | test/lisp/files-tests.el | 512 |
1 files changed, 297 insertions, 215 deletions
diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index be9339a8f5b..682b5cdb449 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -136,7 +136,7 @@ form.") ;; Prevent any dir-locals file interfering with the tests. (enable-dir-local-variables nil)) (hack-local-variables) - (eval (nth 2 test-settings))))) + (eval (nth 2 test-settings) t)))) (ert-deftest files-tests-local-variables () "Test the file-local variables implementation." @@ -176,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." @@ -222,22 +221,41 @@ form.") ("x:/foo//bar/" "y:/bar/qux/" "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/:/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/" 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" nil - ("/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/"))) + (if (eq system-type 'cygwin) + '(("/foo/bar//baz/:/bar/foo/baz//" nil + ("/foo/bar//baz/" "/bar/foo/baz//")) + ("/foo/bar/:/bar/qux/:/qux/foo" nil + ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("//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/" nil + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo" nil + ("/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//baz/:/bar/foo/baz//" nil + ("/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 + ("/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/" nil + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/:/bar/qux/:/qux/foo" nil + ("/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-env (getenv "FOO")) (bar-env (getenv "BAR"))) (unwind-protect @@ -264,7 +282,7 @@ form.") nil)) (kill-emacs-args nil) ((symbol-function #'kill-emacs) - (lambda (&optional arg) (push arg kill-emacs-args))) + (lambda (&rest args) (push args kill-emacs-args))) (process (make-process :name "sleep" @@ -275,7 +293,7 @@ form.") (save-buffers-kill-emacs) (kill-process process) (should-not yes-or-no-p-prompts) - (should (equal kill-emacs-args '(nil))))) + (should (equal kill-emacs-args '((nil nil)))))) (ert-deftest files-tests-read-file-in-~ () "Test file prompting in directory named `~'. @@ -283,22 +301,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. @@ -341,14 +357,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 @@ -357,7 +365,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 ()) @@ -404,6 +412,8 @@ After evaluating BODY, the temporary file or directory is deleted." (cl-check-type name symbol) (cl-check-type non-special-name symbol) `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (temporary-file-directory + (file-name-as-directory (make-temp-file "files-tests" t))) (,name (make-temp-file "files-tests" ,dir-flag)) (,non-special-name (file-name-quote ,name))) (unwind-protect @@ -413,7 +423,9 @@ After evaluating BODY, the temporary file or directory is deleted." (delete-file ,name))) (when (file-exists-p ,non-special-name) (if ,dir-flag (delete-directory ,non-special-name t) - (delete-file ,non-special-name)))))) + (delete-file ,non-special-name))) + (when (file-exists-p temporary-file-directory) + (delete-directory temporary-file-directory t))))) (defconst files-tests--special-file-name-extension ".special" "Trailing string for test file name handler.") @@ -455,14 +467,16 @@ unquoted file names." (cl-check-type name symbol) (cl-check-type non-special-name symbol) `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (temporary-file-directory + (file-name-as-directory (make-temp-file "files-tests" t))) (file-name-handler-alist `((,files-tests--special-file-name-regexp . files-tests--special-file-name-handler) . ,file-name-handler-alist)) - (,name (concat + (,name (concat (make-temp-file "files-tests" ,dir-flag) files-tests--special-file-name-extension)) - (,non-special-name (file-name-quote ,name))) + (,non-special-name (file-name-quote ,name))) (unwind-protect (progn ,@body) (when (file-exists-p ,name) @@ -470,12 +484,23 @@ unquoted file names." (delete-file ,name))) (when (file-exists-p ,non-special-name) (if ,dir-flag (delete-directory ,non-special-name t) - (delete-file ,non-special-name)))))) + (delete-file ,non-special-name))) + (when (file-exists-p temporary-file-directory) + (delete-directory temporary-file-directory t))))) (defun files-tests--new-name (name part) (let (file-name-handler-alist) (concat (file-name-sans-extension name) part (file-name-extension name t)))) +(ert-deftest files-tests-file-name-non-special-abbreviate-file-name () + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + ;; Check that abbreviation doesn't occur for quoted file names. + (should (equal (concat "/:" homedir "foo/bar") + (abbreviate-file-name (concat "/:" homedir "foo/bar")))))) + (ert-deftest files-tests-file-name-non-special-access-file () (files-tests--with-temp-non-special (tmpfile nospecial) ;; Both versions of the file name work. @@ -933,7 +958,7 @@ unquoted file names." (files-tests--with-temp-non-special (tmpfile nospecial) (should (load nospecial nil t))) (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) - (should (load nospecial nil t)))) + (should-error (load nospecial nil t)))) (ert-deftest files-tests-file-name-non-special-make-auto-save-file-name () (files-tests--with-temp-non-special (tmpfile nospecial) @@ -1239,26 +1264,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) @@ -1318,7 +1343,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") @@ -1326,21 +1351,21 @@ 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. @@ -1392,43 +1417,43 @@ 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-deftest files-tests-dont-rewrite-precious-files () + (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))))))) + +;; Note: we call this test "...-zzdont..." so that it runs near the +;; end, because otherwise the advice it adds to write-region doesn't +;; get removed(??) and breaks the revert-file tests on MS-Windows. +(ert-deftest files-tests-zzdont-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")) @@ -1462,7 +1487,7 @@ renaming only, rather than modified in-place." (should (equal (file-size-human-readable-iec 0) "0 B")) (should (equal (file-size-human-readable-iec 1) "1 B")) (should (equal (file-size-human-readable-iec 9621) "9.4 KiB")) - (should (equal (file-size-human-readable-iec 72528034765) "67.5 GiB"))) + (should (equal (file-size-human-readable-iec 72528034765) "68 GiB"))) (ert-deftest files-test-magic-mode-alist-re-baseline () "Test magic-mode-alist with RE, expected behavior for match." @@ -1498,7 +1523,11 @@ See <https://debbugs.gnu.org/36401>." (should (equal (parse-colon-path "/foo//bar/baz") '("/foo//bar/baz/")))) (should (equal (parse-colon-path (concat "." path-separator "/tmp")) - '("./" "/tmp/")))) + '("./" "/tmp/"))) + (should (equal (parse-colon-path (concat "/foo" path-separator "///bar")) + (if (memq system-type '(windows-nt cygwin ms-dos)) + '("/foo/" "//bar/") + '("/foo/" "/bar/"))))) (ert-deftest files-test-magic-mode-alist-doctype () "Test that DOCTYPE and variants put files in mhtml-mode." @@ -1542,7 +1571,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) @@ -1555,7 +1584,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) @@ -1584,6 +1613,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")) @@ -1611,40 +1648,39 @@ 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'." - (let* ((dir (make-temp-file "testdir" 'dir)) - (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))) - (delete-directory dir 'recursive)))) + (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'. @@ -1671,7 +1707,7 @@ PRED is 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) +(defun files-tests--with-buffer-offer-save (buffers-offer fn-test args-results) "Helper macro to test `save-some-buffers' and `save-buffers-kill-emacs'. This macro creates several non-file-visiting buffers in different @@ -1685,52 +1721,52 @@ FN-TEST is the function to test: either `save-some-buffers' or `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. +During the call to FN-TEST,`read-event' is overridden with a function that +just returns `n' and `kill-emacs' is overridden to do nothing. 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)))))) + (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 + (((symbol-function 'read-event) + ;; Increase counter and answer 'n' when prompted + ;; to save a buffer. + (lambda (&rest _) (cl-incf nb-saved-buffers) ?n)) + ;; Do not kill Emacs. + ((symbol-function 'kill-emacs) #'ignore) + (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. @@ -1782,9 +1818,7 @@ PRED is nil." (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))) + #'save-some-buffers args-res))))))) (ert-deftest files-tests-save-buffers-kill-emacs--asks-to-save-buffers () @@ -1799,14 +1833,62 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." 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. + #'save-buffers-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)))))) +(ert-deftest 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" "")))) + +(ert-deftest files-test-set-mode () + (find-file (ert-resource-file "file-mode")) + (should (eq major-mode 'text-mode)) + (emacs-lisp-mode) + ;; Check that the mode cookie doesn't override the explicit setting. + (should (eq major-mode 'emacs-lisp-mode))) + +(ert-deftest files-test-set-mode-multiple () + (find-file (ert-resource-file "file-mode-multiple")) + (should (eq major-mode 'outline-mode))) + +(ert-deftest files-test-set-mode-prop-line () + (find-file (ert-resource-file "file-mode-prop-line")) + (should (eq major-mode 'text-mode))) + +(ert-deftest files-load-elc-gz-file () + (skip-unless (executable-find "gzip")) + (ert-with-temp-directory dir + (let* ((pref (expand-file-name "compile-utf8" dir)) + (el (concat pref ".el"))) + (copy-file (ert-resource-file "compile-utf8.el") el) + (push dir load-path) + (should (load pref t)) + (should (fboundp 'foo)) + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot)) + + (byte-compile-file el) + (fmakunbound 'foo) + (should (load (concat pref ".elc") t)) + (should (fboundp 'foo)) + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot)) + + (dired-compress-file (concat pref ".elc")) + (fmakunbound 'foo) + (should (load (concat pref ".elc.gz") t)) + (should (fboundp 'foo)) + ;; This fails due to bug#12598. + (should (documentation 'foo)) + (should (documentation 'bar)) + (should (documentation 'zot))))) (provide 'files-tests) ;;; files-tests.el ends here |