diff options
Diffstat (limited to 'test')
116 files changed, 8754 insertions, 954 deletions
diff --git a/test/Makefile.in b/test/Makefile.in index 481c418787a..4eddb676d4f 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -105,16 +105,19 @@ endif # Whether to run tests from .el files in preference to .elc, we do # this by default since it gives nicer stacktraces. -TEST_LOAD_EL ?= yes +# If you just want a pass/fail, setting this to no is much faster. +export TEST_LOAD_EL ?= \ + $(if $(findstring $(MAKECMDGOALS), all check check-maybe),no,yes) + +# Additional settings for ert. +ert_opts = # Maximum length of lines in ert backtraces; nil for no limit. # (if empty, use the default ert-batch-backtrace-right-margin). TEST_BACKTRACE_LINE_LENGTH = -ifeq (${TEST_BACKTRACE_LINE_LENGTH},) -ert_opts = -else -ert_opts = --eval '(setq ert-batch-backtrace-right-margin ${TEST_BACKTRACE_LINE_LENGTH})' +ifneq (${TEST_BACKTRACE_LINE_LENGTH},) +ert_opts += --eval '(setq ert-batch-backtrace-right-margin ${TEST_BACKTRACE_LINE_LENGTH})' endif ifeq (@HAVE_MODULES@, yes) @@ -134,7 +137,7 @@ emacs = EMACSLOADPATH= LC_ALL=$(TEST_LOCALE) \ # exists, or writing to ~/.bzr.log when running bzr commands). TEST_HOME = /nonexistent -test_module_dir := $(srcdir)/data/emacs-module +test_module_dir := data/emacs-module .PHONY: all check @@ -163,6 +166,11 @@ endif ## Save logs, and show logs for failed tests. WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; } +ifdef EMACS_HYDRA_CI +## On Hydra, always show logs for certain problematic tests. +lisp/net/tramp-tests.log \ +: WRITE_LOG = 2>&1 | tee $@ +endif ifeq ($(TEST_LOAD_EL), yes) testloadfile = $*.el @@ -182,11 +190,26 @@ else maybe_exclude_module_tests := -name emacs-module-tests.el -prune -o endif +## Optional list of .el files to exclude from testing. +## Intended for use in automated testing where one or more files +## has some problem and needs to be excluded. +## To avoid writing full name, can use eg %foo-tests.el. +EXCLUDE_TESTS = + +## To speed up parallel builds, put these slow test files (which can +## take longer than all the rest combined) at the start of the list. +SLOW_TESTS = ${srcdir}/lisp/net/tramp-tests.el + ELFILES := $(sort $(shell find ${srcdir} -path "${srcdir}/manual" -prune -o \ -path "${srcdir}/data" -prune -o \ -name "*resources" -prune -o \ ${maybe_exclude_module_tests} \ -name "*.el" ! -name ".*" -print)) + +$(foreach slow,${SLOW_TESTS},$(eval ELFILES:= ${slow} $(filter-out ${slow},${ELFILES}))) + +$(foreach exclude,${EXCLUDE_TESTS},$(eval ELFILES:= $(filter-out ${exclude},${ELFILES}))) + ## .log files may be in a different directory for out of source builds LOGFILES := $(patsubst %.el,%.log, \ $(patsubst $(srcdir)/%,%,$(ELFILES))) @@ -239,6 +262,7 @@ MODULE_CFLAGS = -I../src $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \ test_module = $(test_module_dir)/mod-test${SO} src/emacs-module-tests.log: $(test_module) $(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h + $(AM_V_at)${MKDIR_P} $(dir $@) $(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ -o $@ $< endif @@ -283,14 +307,15 @@ ifeq ($(TEST_INTERACTIVE), yes) $(TEST_RUN_ERT) else -@${MAKE} -k ${LOGFILES} - @$(emacs) --batch -l ert -f ert-summarize-tests-batch-and-exit ${LOGFILES} + @$(emacs) --batch -l ert --eval \ + "(ert-summarize-tests-batch-and-exit ${SUMMARIZE_TESTS})" ${LOGFILES} endif .PHONY: mostlyclean clean bootstrap-clean distclean maintainer-clean mostlyclean: -@for f in ${LOGFILES}; do test ! -f $$f || mv $$f $$f~; done - rm -f *.tmp + rm -f ./*.tmp clean: find . '(' -name '*.log' -o -name '*.log~' ')' $(FIND_DELETE) @@ -304,3 +329,9 @@ distclean: clean rm -f Makefile maintainer-clean: distclean bootstrap-clean + +.PHONY: check-declare + +check-declare: + $(emacs) -l check-declare \ + --eval '(check-declare-directory "$(srcdir)")' diff --git a/test/README b/test/README index fa5611bdd53..2b705f313df 100644 --- a/test/README +++ b/test/README @@ -11,12 +11,23 @@ Emacs uses ERT, Emacs Lisp Regression Testing, for testing. See (info "(ert)") or https://www.gnu.org/software/emacs/manual/html_node/ert/ for more information on writing and running tests. +Tests could be tagged by the developer. In this test directory, the +following tags are recognized: + +* :expensive-test + The test needs a serious amount of time to run. It is not intended + to run on a regular basis by users. Instead, it runs on demand + only, or during regression tests. + +* :unstable + The test is under development. It shall run on demand only. + The Makefile in this directory supports the following targets: * make check - Run all tests as defined in the directory. Expensive tests are - suppressed. The result of the tests for <filename>.el is stored in - <filename>.log. + Run all tests as defined in the directory. Expensive and unstable + tests are suppressed. The result of the tests for <filename>.el is + stored in <filename>.log. * make check-maybe Like "make check", but run only the tests for files which have @@ -25,6 +36,9 @@ The Makefile in this directory supports the following targets: * make check-expensive Like "make check", but run also the tests marked as expensive. +* make check-all + Like "make check", but run all tests. + * make <filename> or make <filename>.log Run all tests declared in <filename>.el. This includes expensive tests. In the former case the output is shown on the terminal, in @@ -38,7 +52,7 @@ https://www.gnu.org/software/emacs/manual/html_node/ert/Test-Selectors.html You could use predefined selectors of the Makefile. "make <filename> SELECTOR='$(SELECTOR_DEFAULT)'" runs all tests for <filename>.el -except the tests tagged as expensive. +except the tests tagged as expensive or unstable. If your test file contains the tests "test-foo", "test2-foo" and "test-foo-remote", and you want to run only the former two tests, you @@ -48,11 +62,17 @@ protect against "make" variable expansion): make <filename> SELECTOR='"foo$$"' Note that although the test files are always compiled (unless they set -no-byte-compile), the source files will be run by default, to give -nicer backtraces. To run the compiled version of a test use +no-byte-compile), the source files will be run when expensive or +unstable tests are involved, to give nicer backtraces. To run the +compiled version of a test use make TEST_LOAD_EL=no ... +Some tests might take long time to run. In order to summarize the +<nn> tests with the longest duration, call + + make SUMMARIZE_TESTS=<nn> ... + The tests are run in batch mode by default; sometimes it's useful to get precisely the same environment but run in interactive mode for debugging. To do that, use diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index 30dc4fd9245..98242e85baf 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -317,11 +317,11 @@ provide (emacs_env *env, const char *feature) static void bind_function (emacs_env *env, const char *name, emacs_value Sfun) { - emacs_value Qfset = env->intern (env, "fset"); + emacs_value Qdefalias = env->intern (env, "defalias"); emacs_value Qsym = env->intern (env, name); emacs_value args[] = { Qsym, Sfun }; - env->funcall (env, Qfset, 2, args); + env->funcall (env, Qdefalias, 2, args); } /* Module init function. */ diff --git a/test/data/xdg/mimeapps.list b/test/data/xdg/mimeapps.list new file mode 100644 index 00000000000..27fbd94b16b --- /dev/null +++ b/test/data/xdg/mimeapps.list @@ -0,0 +1,9 @@ +[Default Applications] +x-test/foo=a.desktop + +[Added Associations] +x-test/foo=b.desktop +x-test/baz=a.desktop + +[Removed Associations] +x-test/foo=c.desktop;d.desktop diff --git a/test/data/xdg/mimeinfo.cache b/test/data/xdg/mimeinfo.cache new file mode 100644 index 00000000000..6e54f604fa0 --- /dev/null +++ b/test/data/xdg/mimeinfo.cache @@ -0,0 +1,4 @@ +[MIME Cache] +x-test/foo=c.desktop;d.desktop +x-test/bar=a.desktop;c.desktop +x-test/baz=b.desktop;d.desktop diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 800c9aac33c..3b8acf5519a 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -38,6 +38,12 @@ (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") ert-test-abbrevs) +(defun setup-test-abbrev-table-with-props () + (defvar ert-test-abbrevs nil) + (define-abbrev-table 'ert-test-abbrevs '(("fb" "fooBar" nil :case-fixed t))) + (abbrev-table-put ert-test-abbrevs :ert-test "ert-test-value") + ert-test-abbrevs) + (ert-deftest abbrev-table-p-test () (should-not (abbrev-table-p 42)) (should-not (abbrev-table-p "aoeu")) @@ -58,6 +64,14 @@ (should (= (length table) obarray-default-size)) (should (eq (abbrev-table-get table 'foo) 'bar)))) +(ert-deftest abbrev--table-symbols-test () + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (define-abbrev ert-test-abbrevs "sys" "system abbrev" nil :system t) + (should (equal (mapcar #'symbol-name (abbrev--table-symbols 'ert-test-abbrevs)) + '("a-e-t"))) + (should (equal (mapcar #'symbol-name (abbrev--table-symbols 'ert-test-abbrevs t)) + '("a-e-t" "sys"))))) + (ert-deftest abbrev-table-get-put-test () (let ((table (make-abbrev-table))) (should-not (abbrev-table-get table 'foo)) @@ -230,6 +244,17 @@ (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) (delete-file temp-test-file))) +(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))) + (ert-deftest abbrev-edit-save-to-file-test () "Test saving abbrev definitions in buffer to file" (defvar ert-save-test-table nil) diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 9cb92fe3842..d1e486ad6be 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -73,102 +73,113 @@ This function is intended to be set to `auth-source-debug`." (auth-source-pass--debug-log nil)) ,@body))) +(ert-deftest auth-source-pass-any-host () + (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user")) + ("bar")) + (should-not (auth-source-pass-search :host t)))) + +(ert-deftest auth-source-pass-undefined-host () + (auth-source-pass--with-store '(("foo" ("port" . "foo-port") ("host" . "foo-user")) + ("bar")) + (should-not (auth-source-pass-search :host nil)))) + + (ert-deftest auth-source-pass-find-match-matching-at-entry-name () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "foo" nil) + (should (equal (auth-source-pass--find-match "foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-part () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "https://foo" nil) + (should (equal (auth-source-pass--find-match "https://foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-ignoring-user () (auth-source-pass--with-store '(("foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-with-user () (auth-source-pass--with-store '(("SomeUser@foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full () (auth-source-pass--with-store '(("SomeUser@foo") ("foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-prefer-full-reversed () (auth-source-pass--with-store '(("foo") ("SomeUser@foo")) - (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil) + (should (equal (auth-source-pass--find-match "https://SomeUser@foo" nil nil) "SomeUser@foo")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain () (auth-source-pass--with-store '(("bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) "bar.com")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-user () (auth-source-pass--with-store '(("someone@bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" "someone") + (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil) "someone@bar.com")))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-with-bad-user () (auth-source-pass--with-store '(("someoneelse@bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" "someone") + (should (equal (auth-source-pass--find-match "foo.bar.com" "someone" nil) nil)))) (ert-deftest auth-source-pass-find-match-matching-at-entry-name-without-subdomain-prefer-full () (auth-source-pass--with-store '(("bar.com") ("foo.bar.com")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) "foo.bar.com")))) (ert-deftest auth-source-pass-dont-match-at-folder-name () (auth-source-pass--with-store '(("foo.bar.com/foo")) - (should (equal (auth-source-pass--find-match "foo.bar.com" nil) + (should (equal (auth-source-pass--find-match "foo.bar.com" nil nil) nil)))) +(ert-deftest auth-source-pass-find-match-matching-extracting-user-from-host () + (auth-source-pass--with-store '(("foo.com/bar")) + (should (equal (auth-source-pass--find-match "https://bar@foo.com" nil nil) + "foo.com/bar")))) + (ert-deftest auth-source-pass-search-with-user-first () (auth-source-pass--with-store '(("foo") ("user@foo")) - (should (equal (auth-source-pass--find-match "foo" "user") + (should (equal (auth-source-pass--find-match "foo" "user" nil) "user@foo")) (auth-source-pass--should-have-message-containing "Found 1 match"))) (ert-deftest auth-source-pass-give-priority-to-desired-user () (auth-source-pass--with-store '(("foo") ("subdir/foo" ("user" . "someone"))) - (should (equal (auth-source-pass--find-match "foo" "someone") + (should (equal (auth-source-pass--find-match "foo" "someone" nil) "subdir/foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "matching user field"))) (ert-deftest auth-source-pass-give-priority-to-desired-user-reversed () (auth-source-pass--with-store '(("foo" ("user" . "someone")) ("subdir/foo")) - (should (equal (auth-source-pass--find-match "foo" "someone") + (should (equal (auth-source-pass--find-match "foo" "someone" nil) "foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "matching user field"))) (ert-deftest auth-source-pass-return-first-when-several-matches () (auth-source-pass--with-store '(("foo") ("subdir/foo")) - (should (equal (auth-source-pass--find-match "foo" nil) + (should (equal (auth-source-pass--find-match "foo" nil nil) "foo")) (auth-source-pass--should-have-message-containing "Found 2 matches") (auth-source-pass--should-have-message-containing "the first one"))) (ert-deftest auth-source-pass-make-divansantana-happy () (auth-source-pass--with-store '(("host.com")) - (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za") + (should (equal (auth-source-pass--find-match "smtp.host.com" "myusername@host.co.za" nil) "host.com")))) -(ert-deftest auth-source-pass-hostname () - (should (equal (auth-source-pass--hostname "https://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname "http://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname "https://SomeUser@foo.bar") "foo.bar"))) - -(ert-deftest auth-source-pass-hostname-with-user () - (should (equal (auth-source-pass--hostname-with-user "https://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname-with-user "http://foo.bar") "foo.bar")) - (should (equal (auth-source-pass--hostname-with-user "https://SomeUser@foo.bar") "SomeUser@foo.bar"))) +(ert-deftest auth-source-pass-find-host-without-port () + (auth-source-pass--with-store '(("host.com")) + (should (equal (auth-source-pass--find-match "host.com:8888" "someuser" nil) + "host.com")))) (defmacro auth-source-pass--with-store-find-foo (store &rest body) "Use STORE while executing BODY. \"foo\" is the matched entry." @@ -197,14 +208,25 @@ This function is intended to be set to `auth-source-debug`." (should (equal (plist-get result :port) 512)) (should (equal (plist-get result :user) "anuser"))))) +(ert-deftest auth-source-pass-build-result-passes-full-host-to-find-match () + (let (passed-host) + (cl-letf (((symbol-function 'auth-source-pass--find-match) + (lambda (host _user _port) (setq passed-host host)))) + (auth-source-pass--build-result "https://user@host.com:123" nil nil) + (should (equal passed-host "https://user@host.com:123")) + (auth-source-pass--build-result "https://user@host.com" nil nil) + (should (equal passed-host "https://user@host.com")) + (auth-source-pass--build-result "user@host.com" nil nil) + (should (equal passed-host "user@host.com")) + (auth-source-pass--build-result "user@host.com:443" nil nil) + (should (equal passed-host "user@host.com:443"))))) + (ert-deftest auth-source-pass-only-return-entries-that-can-be-open () (cl-letf (((symbol-function 'auth-source-pass-entries) - (lambda () '("foo.site.com" "bar.site.com" - "mail/baz.site.com/scott"))) + (lambda () '("foo.site.com" "bar.site.com" "mail/baz.site.com/scott"))) ((symbol-function 'auth-source-pass--entry-valid-p) ;; only foo.site.com and "mail/baz.site.com/scott" are valid - (lambda (entry) (member entry '("foo.site.com" - "mail/baz.site.com/scott"))))) + (lambda (entry) (member entry '("foo.site.com" "mail/baz.site.com/scott"))))) (should (equal (auth-source-pass--find-all-by-entry-name "foo.site.com" "someuser") '("foo.site.com"))) (should (equal (auth-source-pass--find-all-by-entry-name "bar.site.com" "someuser") @@ -222,6 +244,13 @@ This function is intended to be set to `auth-source-debug`." (should (auth-source-pass--entry-valid-p "foo")) (should-not (auth-source-pass--entry-valid-p "bar")))) +(ert-deftest auth-source-pass-can-start-from-auth-source-search () + (auth-source-pass--with-store '(("gitlab.com" ("user" . "someone"))) + (auth-source-pass-enable) + (let ((result (car (auth-source-search :host "gitlab.com")))) + (should (equal (plist-get result :user) "someone")) + (should (equal (plist-get result :host) "gitlab.com"))))) + (provide 'auth-source-pass-tests) ;;; auth-source-pass-tests.el ends here diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 748e9eccd54..c8460c00353 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -29,9 +29,7 @@ (require 'ert) (require 'cl-lib) (require 'auth-source) - -(defvar secrets-enabled t - "Enable the secrets backend to test its features.") +(require 'secrets) (defun auth-source-ensure-ignored-backend (source) (auth-source-validate-backend source '((:source . "") @@ -308,6 +306,44 @@ (should (equal found-as-string (concat testname ": " needed))))) (delete-file netrc-file))) +(ert-deftest auth-source-test-secrets-create-secret () + (skip-unless secrets-enabled) + ;; The "session" collection is temporary for the lifetime of the + ;; 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 _initial _history default) 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))))) + (ert-deftest auth-source-delete () (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ machine a1 port a2 user a3 password a4 diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 831c6f7b375..6e8219d238d 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -159,14 +159,18 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test02-auto-revert-deleted-file () "Check autorevert for a deleted file." :tags '(:expensive-test) + ;; Repeated unpredictable failures, bug#32645. + ;; Unlikely to be hydra-specific? + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (let ((tmpfile (make-temp-file "auto-revert-test")) - buf) + buf desc) (unwind-protect (progn (write-region "any text" nil tmpfile nil 'no-message) (setq buf (find-file-noselect tmpfile)) (with-current-buffer buf + (should-not 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 @@ -174,12 +178,16 @@ This expects `auto-revert--messages' to be bound by (sleep-for 1) (auto-revert-mode 1) (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) ;; Remove file while reverting. We simulate this by ;; modifying `before-revert-hook'. (add-hook 'before-revert-hook - (lambda () (delete-file buffer-file-name)) + (lambda () + ;; Temporarily. + (message "%s deleted" buffer-file-name) + (delete-file buffer-file-name)) nil t) (ert-with-message-capture auto-revert--messages @@ -192,7 +200,7 @@ This expects `auto-revert--messages' to be bound by (should (string-match "any text" (buffer-string))) ;; With w32notify, the 'stopped' events are not sent. (or (eq file-notify--library 'w32notify) - (should-not auto-revert-use-notify)) + (should-not auto-revert-notify-watch-descriptor)) ;; Once the file has been recreated, the buffer shall be ;; reverted. @@ -203,6 +211,11 @@ This expects `auto-revert--messages' to be bound by (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 diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 4d34f896015..af617e677f1 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -57,17 +57,16 @@ (ert-deftest icalendar--create-uid () "Test for `icalendar--create-uid'." - (let* ((icalendar-uid-format "xxx-%t-%c-%h-%u-%s") + (let* ((icalendar-uid-format "xxx-%c-%h-%u-%s") (icalendar--uid-count 77) (entry-full "30.06.1964 07:01 blahblah") (hash (format "%d" (abs (sxhash entry-full)))) (contents "DTSTART:19640630T070100\nblahblah") (username (or user-login-name "UNKNOWN_USER"))) - (cl-letf (((symbol-function 'current-time) (lambda () '(1 2 3)))) - (should (= 77 icalendar--uid-count)) - (should (string= (concat "xxx-123-77-" hash "-" username "-19640630") - (icalendar--create-uid entry-full contents))) - (should (= 78 icalendar--uid-count))) + (should (= 77 icalendar--uid-count)) + (should (string= (concat "xxx-77-" hash "-" username "-19640630") + (icalendar--create-uid entry-full contents))) + (should (= 78 icalendar--uid-count)) (setq contents "blahblah") (setq icalendar-uid-format "yyy%syyy") (should (string= (concat "yyyDTSTARTyyy") diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el index 839265d7689..7435620b71f 100644 --- a/test/lisp/calendar/parse-time-tests.el +++ b/test/lisp/calendar/parse-time-tests.el @@ -28,35 +28,51 @@ (ert-deftest parse-time-tests () (should (equal (parse-time-string "Mon, 22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 nil 3600))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "22 Feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 nil nil 3600))) + '(42 35 19 22 2 2016 nil -1 3600))) (should (equal (parse-time-string "22 Feb 2016 +0100") - '(nil nil nil 22 2 2016 nil nil 3600))) + '(nil nil nil 22 2 2016 nil -1 3600))) (should (equal (parse-time-string "Mon, 22 Feb 16 19:35:42 +0100") - '(42 35 19 22 2 2016 1 nil 3600))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Mon, 22 February 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 nil 3600))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Mon, 22 feb 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 nil 3600))) + '(42 35 19 22 2 2016 1 -1 3600))) (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 +0100") - '(42 35 19 22 2 2016 1 nil 3600))) - (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PDT") - '(42 35 19 22 2 2016 1 t -25200))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-0200") - '(13818 33666))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-0230") - '(13818 35466))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-02:00") - '(13818 33666))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54-02") - '(13818 33666))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54+0230") - '(13818 17466))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54+02") - '(13818 19266))) - (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54Z") - '(13818 26466))) + '(42 35 19 22 2 2016 1 -1 3600))) + (should (equal (parse-time-string "Monday, 22 february 2016 19:35:42 PST") + '(42 35 19 22 2 2016 1 nil -28800))) + (should (equal (parse-time-string "Friday, 21 Sep 2018 13:47:58 PDT") + '(58 47 13 21 9 2018 5 t -25200))) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54-0200") t) + "1998-09-12 14:21:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54-0230") t) + "1998-09-12 14:51:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54-02:00") t) + "1998-09-12 14:21:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54-02") t) + "1998-09-12 14:21:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54+0230") t) + "1998-09-12 09:51:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54+02") t) + "1998-09-12 10:21:54")) + (should (equal (format-time-string + "%Y-%m-%d %H:%M:%S" + (parse-iso8601-time-string "1998-09-12T12:21:54Z") t) + "1998-09-12 12:21:54")) (should (equal (parse-iso8601-time-string "1998-09-12T12:21:54") (encode-time 54 21 12 12 9 1998)))) diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 606af30180b..7d4f7a77683 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'todo-mode) (defvar todo-test-data-dir @@ -561,11 +562,12 @@ source file is different." ;; Headers in the todo file are still hidden. (should (equal (overlay-get (todo-get-overlay 'header) 'display) ""))))) -(defun todo-test--insert-item (item &optional priority) +(defun todo-test--insert-item (item &optional priority + _arg diary-type date-type time where) "Insert string ITEM into current category with priority PRIORITY. -Use defaults for all other item insertion parameters. This -provides a noninteractive API for todo-insert-item for use in -automatic testing." +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)) ((symbol-function 'read-number) ; For todo-set-item-priority @@ -581,6 +583,271 @@ automatic testing." (todo-test--insert-item item 1) (should (equal (overlay-get (todo-get-overlay 'header) 'display) ""))))) +(defun todo-test--done-items-separator (&optional eol) + "Set up test of command interaction with done items separator. +With non-nil argument EOL, return the position at the end of the +separator, otherwise, return the position at the beginning." + (todo-test--show 1) + (goto-char (point-max)) + ;; See comment about recentering in todo-test-raise-lower-priority. + (set-window-buffer nil (current-buffer)) + (todo-toggle-view-done-items) + ;; FIXME: Point should now be on the first done item, and in batch + ;; testing it is, so we have to move back one line to the done items + ;; separator; but for some reason, in the graphical test + ;; environment, it stays on the last empty line of the todo items + ;; section, so there we have to advance one character to the done + ;; items separator. + (if (display-graphic-p) + (forward-char) + (forward-line -1)) + (if eol (forward-char))) + +(ert-deftest todo-test-done-items-separator01-bol () ; bug#32343 + "Test item copying and here insertion at BOL of separator. +Both should be user errors." + (with-todo-test + (todo-test--done-items-separator) + (let* ((copy-err "Item copying is not valid here") + (here-err "Item insertion is not valid here") + (insert-item-test (lambda (where) + (should-error (todo-insert-item--basic + nil nil nil nil where))))) + (should (string= copy-err (cadr (funcall insert-item-test 'copy)))) + (should (string= here-err (cadr (funcall insert-item-test 'here))))))) + +(ert-deftest todo-test-done-items-separator01-eol () ; bug#32343 + "Test item copying and here insertion at EOL of separator. +Both should be user errors." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let* ((copy-err "Item copying is not valid here") + (here-err "Item insertion is not valid here") + (insert-item-test (lambda (where) + (should-error (todo-insert-item--basic + nil nil nil nil where))))) + (should (string= copy-err (cadr (funcall insert-item-test 'copy)))) + (should (string= here-err (cadr (funcall insert-item-test 'here))))))) + +(ert-deftest todo-test-done-items-separator02-bol () ; bug#32343 + "Test item editing commands at BOL of done items separator. +They should all be noops." + (with-todo-test + (todo-test--done-items-separator) + (should-not (todo-item-done)) + (should-not (todo-raise-item-priority)) + (should-not (todo-lower-item-priority)) + (should-not (called-interactively-p #'todo-set-item-priority)) + (should-not (called-interactively-p #'todo-move-item)) + (should-not (called-interactively-p #'todo-delete-item)) + (should-not (called-interactively-p #'todo-edit-item)))) + +(ert-deftest todo-test-done-items-separator02-eol () ; bug#32343 + "Test item editing command at EOL of done items separator. +They should all be noops." + (with-todo-test + (todo-test--done-items-separator 'eol) + (should-not (todo-item-done)) + (should-not (todo-raise-item-priority)) + (should-not (todo-lower-item-priority)) + (should-not (called-interactively-p #'todo-set-item-priority)) + (should-not (called-interactively-p #'todo-move-item)) + (should-not (called-interactively-p #'todo-delete-item)) + (should-not (called-interactively-p #'todo-edit-item)))) + +(ert-deftest todo-test-done-items-separator03-bol () ; bug#32343 + "Test item marking at BOL of done items separator. +This should be a noop, adding no marks to the category." + (with-todo-test + (todo-test--done-items-separator) + (call-interactively #'todo-toggle-mark-item) + (should-not (assoc (todo-current-category) todo-categories-with-marks)))) + +(ert-deftest todo-test-done-items-separator03-eol () ; bug#32343 + "Test item marking at EOL of done items separator. +This should be a noop, adding no marks to the category." + (with-todo-test + (todo-test--done-items-separator 'eol) + (call-interactively #'todo-toggle-mark-item) + (should-not (assoc (todo-current-category) todo-categories-with-marks)))) + +(ert-deftest todo-test-done-items-separator04-bol () ; bug#32343 + "Test moving to previous item from BOL of done items separator. +This should move point to the last not done todo item." + (with-todo-test + (todo-test--done-items-separator) + (let ((last-item (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-previous-item) + (todo-item-string)))) + (should (string= last-item (save-excursion + (todo-previous-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator04-eol () ; bug#32343 + "Test moving to previous item from EOL of done items separator. +This should move point to the last not done todo item." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let ((last-item (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-previous-item) + (todo-item-string)))) + (should (string= last-item (save-excursion + (todo-previous-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator05-bol () ; bug#32343 + "Test moving to next item from BOL of done items separator. +This should move point to the first done todo item." + (with-todo-test + (todo-test--done-items-separator) + (let ((first-done (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-next-item) + (todo-item-string)))) + (should (string= first-done (save-excursion + (todo-next-item) + (todo-item-string))))))) + +(ert-deftest todo-test-done-items-separator05-eol () ; bug#32343 + "Test moving to next item from EOL of done items separator. +This should move point to the first done todo item." + (with-todo-test + (todo-test--done-items-separator 'eol) + (let ((first-done (save-excursion + ;; Move to empty line after last todo item. + (forward-line -1) + (todo-next-item) + (todo-item-string)))) + (should (string= first-done (save-excursion + (todo-next-item) + (todo-item-string))))))) + +;; Item highlighting uses hl-line-mode, which enables highlighting in +;; post-command-hook. For some reason, in the test environment, the +;; hook function is not automatically run, so after enabling item +;; highlighting, use ert-simulate-command around the next command, +;; which explicitly runs the hook function. +(ert-deftest todo-test-done-items-separator06-bol () ; bug#32343 + "Test enabling item highlighting at BOL of done items separator. +Subsequently moving to an item should show it highlighted." + (with-todo-test + (todo-test--done-items-separator) + (call-interactively #'todo-toggle-item-highlighting) + (ert-simulate-command '(todo-previous-item)) + (should (eq 'hl-line (get-char-property (point) 'face))))) + +(ert-deftest todo-test-done-items-separator06-eol () ; bug#32343 + "Test enabling item highlighting at EOL of done items separator. +Subsequently moving to an item should show it highlighted." + (with-todo-test + (todo-test--done-items-separator 'eol) + (todo-toggle-item-highlighting) + (forward-line -1) + (ert-simulate-command '(todo-previous-item)) + (should (eq 'hl-line (get-char-property (point) 'face))))) + +(ert-deftest todo-test-done-items-separator07 () ; bug#32343 + "Test item highlighting when crossing done items separator. +The highlighting should remain enabled." + (with-todo-test + (todo-test--done-items-separator) + (todo-previous-item) + (todo-toggle-item-highlighting) + (todo-next-item) ; Now on empty line above separator. + (forward-line) ; Now on separator. + (ert-simulate-command '(forward-line)) ; Now on first done item. + (should (eq 'hl-line (get-char-property (point) 'face))))) + +(ert-deftest todo-test-current-file-in-edit-mode () ; bug#32437 + "Test the value of todo-current-todo-file in todo-edit-mode." + (with-todo-test + (todo-test--show 1) + ;; The preceding calls todo-mode but does not run pre-command-hook + ;; in the test environment, thus failing to set + ;; todo-global-current-todo-file, which is needed for the test + ;; after todo-edit-item--text. So force the hook function to run. + (ert-simulate-command '(todo-mode)) + (let ((curfile todo-current-todo-file)) + (should (equal curfile todo-test-file-1)) + (todo-edit-item--text 'multiline) + (should (equal todo-current-todo-file curfile)) + (todo-edit-quit) + (todo-edit-file) + (should (equal todo-current-todo-file curfile)) + (todo-edit-quit)) + (todo-find-archive) + (let ((curfile todo-current-todo-file)) + (should (equal curfile todo-test-archive-1)) + (todo-edit-file) + (should (equal todo-current-todo-file curfile))))) + +(ert-deftest todo-test-edit-quit () ; bug#32437 + "Test result of exiting todo-edit-mode on a whole file. +Exiting should return to the same todo-mode or todo-archive-mode +buffer from which the editing command was invoked." + (with-todo-test + (todo-test--show 1) + (let ((buf (current-buffer))) + (todo-edit-file) + (todo-edit-quit) + (should (eq (current-buffer) buf)) + (should (eq major-mode 'todo-mode)) + (todo-find-archive) + (let ((buf (current-buffer))) + (todo-edit-file) + (todo-edit-quit) + (should (eq (current-buffer) buf)) + (should (eq major-mode 'todo-archive-mode)))))) + +(defun todo-test--add-file (file cat) + "Add file FILE with category CAT to todo-files and show it. +This provides a noninteractive API for todo-add-file for use in +automatic testing." + (let ((file0 (file-truename (concat todo-test-data-dir file ".todo"))) + todo-add-item-if-new-category) ; Don't need an item in cat. + (cl-letf (((symbol-function 'todo-read-file-name) + (lambda (_prompt) file0)) + ((symbol-function 'todo-read-category) + (lambda (_prompt &optional _match-type _file) (cons cat file0)))) + (call-interactively 'todo-add-file) ; Interactive to call todo-show. + (todo-add-category file0 cat)))) + +(defun todo-test--delete-file () + "Delete current todo file without prompting." + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) t))) + (todo-delete-file))) + +(ert-deftest todo-test-add-and-delete-file () ; bug#32627 + "Test adding a new todo file and then deleting it. +Calling todo-show should display the last current todo file, not +necessarily the new file. After deleting the new file, todo-show +should display the previously current (or default) todo file." + (with-todo-test + (todo-show) + (should (equal todo-current-todo-file todo-test-file-1)) + (let* ((file (concat todo-directory "todo-test-2.todo")) + (file-nb (file-name-base file)) + (cat "cat21")) + (todo-test--add-file file-nb cat) ; Add new file and show it. + (should (equal todo-current-todo-file file)) + (todo-quit) ; Quitting todo-mode displays previous buffer. + (should (equal todo-current-todo-file todo-test-file-1)) + (switch-to-buffer "*scratch*") + (todo-show) ; Show the last current todo-file (not the new one). + (should (equal todo-current-todo-file todo-test-file-1)) + (switch-to-buffer (get-file-buffer file)) ; Back to new file. + (should (equal todo-current-todo-file file)) + (todo-test--delete-file) + (todo-show) ; Back to old file. + (should (equal todo-current-todo-file todo-test-file-1)) + (delete-file (concat file "~"))))) + (provide 'todo-mode-tests) ;;; todo-mode-tests.el ends here diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index 51c64145f8b..8a647bd0765 100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@ -117,16 +117,14 @@ (char-fold-to-regexp string))) (with-temp-buffer (save-excursion (insert string)) - (let ((time (time-to-seconds (current-time)))) + (let ((time (time-to-seconds))) ;; Our initial implementation of case-folding in char-folding ;; created a lot of redundant paths in the regexp. Because of ;; that, if a really long string "almost" matches, the regexp ;; engine took a long time to realize that it doesn't match. (should-not (char-fold-search-forward (concat string "c") nil 'noerror)) ;; Ensure it took less than a second. - (should (< (- (time-to-seconds (current-time)) - time) - 1)))))) + (should (< (- (time-to-seconds) time) 1)))))) (provide 'char-fold-tests) ;;; char-fold-tests.el ends here diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 468feeaa1ac..49e59c526f4 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -36,9 +36,10 @@ "Enter same passphrase again: " ; ssh-keygen "Passphrase for key root@GNU.ORG: " ; plink "[sudo] password for user:" ; Ubuntu sudo + "[sudo] user 的密码：" ; localized "Password (again):" "Enter password:" - "Mot de Passe:" ; localized + "Mot de Passe :" ; localized (Bug#29729) "Passwort:") ; localized "List of strings that should match `comint-password-prompt-regexp'.") diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el new file mode 100644 index 00000000000..96887f8f5fe --- /dev/null +++ b/test/lisp/custom-tests.el @@ -0,0 +1,87 @@ +;;; custom-tests.el --- tests for custom.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest custom-theme--load-path () + "Test `custom-theme--load-path' behavior." + (let ((tmpdir (file-name-as-directory (make-temp-file "custom-tests-" t)))) + (unwind-protect + ;; Create all temporary files under the same deletable parent. + (let ((temporary-file-directory tmpdir)) + ;; Path is empty. + (let ((custom-theme-load-path ())) + (should (null (custom-theme--load-path)))) + + ;; Path comprises non-existent file. + (let* ((name (make-temp-name tmpdir)) + (custom-theme-load-path (list name))) + (should (not (file-exists-p name))) + (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)))) + + ;; 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))) + + ;; Expand `custom-theme-directory' path element. + (let ((custom-theme-load-path '(custom-theme-directory))) + (let ((custom-theme-directory (make-temp-name tmpdir))) + (should (not (file-exists-p custom-theme-directory))) + (should (null (custom-theme--load-path)))) + (let ((custom-theme-directory (make-temp-file "file"))) + (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))) + (should (file-directory-p custom-theme-directory)) + (should (equal (custom-theme--load-path) + (list custom-theme-directory))))) + + ;; Expand t path element. + (let ((custom-theme-load-path '(t))) + (let ((data-directory (make-temp-name tmpdir))) + (should (not (file-exists-p data-directory))) + (should (null (custom-theme--load-path)))) + (let ((data-directory tmpdir) + (themedir (expand-file-name "themes" tmpdir))) + (should (not (file-exists-p themedir))) + (should (null (custom-theme--load-path))) + (with-temp-file themedir) + (should (file-exists-p themedir)) + (should (not (file-directory-p themedir))) + (should (null (custom-theme--load-path))) + (delete-file themedir) + (make-directory themedir) + (should (file-directory-p themedir)) + (should (equal (custom-theme--load-path) (list themedir)))))) + (when (file-directory-p tmpdir) + (delete-directory tmpdir t))))) + +;;; custom-tests.el ends here diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 6c368359525..ccd3192792d 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -20,7 +20,7 @@ ;;; Code: (require 'ert) (require 'dired-aux) - +(eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." @@ -40,5 +40,80 @@ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) (delete-file foo)))) +;; Auxiliar macro for `dired-test-bug28834': it binds +;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. +;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to +;; to avoid the prompt. +(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-deftest dired-test-bug28834 () + "test for https://debbugs.gnu.org/28834 ." + (let (from to-cp to-mv) + ;; `dired-create-destination-dirs' set to 'always. + (with-dired-bug28834-test + 'always nil + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + ;; `dired-create-destination-dirs' set to nil. + (with-dired-bug28834-test + nil nil + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))) + ;; `dired-create-destination-dirs' set to 'ask. + (with-dired-bug28834-test + 'ask 'yes ; Answer `yes' + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + (with-dired-bug28834-test + 'ask 'no ; Answer `no' + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))))) + +(ert-deftest dired-test-bug30624 () + "test for https://debbugs.gnu.org/30624 ." + (cl-letf* ((target-dir (make-temp-file "target" 'dir)) + ((symbol-function 'dired-mark-read-file-name) + (lambda (&rest _) target-dir)) + (inhibit-message t)) + ;; Delete target-dir: `dired-do-create-files' must recreate it. + (delete-directory target-dir) + (let ((file1 (make-temp-file "bug30624_file1")) + (file2 (make-temp-file "bug30624_file2")) + (dired-create-destination-dirs 'always) + (buf (dired temporary-file-directory))) + (unwind-protect + (progn + (dired-revert) + (dired-mark-files-regexp "bug30624_file") + (should (dired-do-create-files 'copy 'dired-copy-file "Copy" nil))) + (delete-directory target-dir 'recursive) + (mapc #'delete-file `(,file1 ,file2)) + (kill-buffer buf))))) + + (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 12b6fffbd60..71ffcdd5458 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -210,12 +210,12 @@ (concat (file-name-as-directory test-dir) (file-name-as-directory "test-subdir")))) (push (dired-find-file) buffers) - (let ((pt2 (point))) ; 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)))) + ;; 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)))) @@ -224,7 +224,7 @@ "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) - test-subdir1 test-subdir2 allbufs) + allbufs) (unwind-protect (progn (with-current-buffer (find-file-noselect test-dir) @@ -294,9 +294,9 @@ (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." - (let* ((dir (expand-file-name "src" source-directory)) - (buf (dired (list dir "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c"))) - (orig dired-hide-details-mode)) + (dired (list (expand-file-name "src" source-directory) + "cygw32.c" "alloc.c" "w32xfns.c" "xdisp.c")) + (let ((orig dired-hide-details-mode)) (dired-goto-file (expand-file-name "cygw32.c")) (forward-line 0) (unwind-protect @@ -362,8 +362,7 @@ (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")) - (ignore-funcs (make-symbol "ignore-funcs"))) + (let ((dir (make-symbol "dir"))) `(let* ((,dir (make-temp-file "bug27940" t)) (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. (inhibit-message t) diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 55fefcebd79..467abd1f274 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -114,14 +114,30 @@ mode extra-desc)) () - ,(format "With |%s|, try input %c at point %d. \ -Should %s |%s| and point at %d" + ,(format "Electricity test in a `%s' buffer.\n +Start with point at %d in a %d-char-long buffer +like this one: + + |%s| (buffer start and end are denoted by `|') +%s +%s +Now press the key for: %c + +The buffer's contents should %s: + + |%s| + +, and point should be at %d." + mode + (1+ pos) + (length fixture) fixture + (if fixture-fn (format "\nNow call this:\n\n%s" + (pp-to-string fixture-fn)) "") + (if bindings (format "\nEnsure the following bindings:\n\n%s" + (pp-to-string bindings)) "") char - (1+ pos) - (if (string= fixture expected-string) - "stay" - "become") + (if (string= fixture expected-string) "stay" "become") (replace-regexp-in-string "\n" "\\\\n" expected-string) expected-point) (electric-pair-test-for ,fixture @@ -163,9 +179,9 @@ Should %s |%s| and point at %d" "" "-in-comments"))) (if test-in-strings - `(("\"" "\"" "-in-strings"))) + '(("\"" "\"" "-in-strings"))) (if test-in-code - `(("" "" "")))) + '(("" "" "")))) append (cl-loop for char across input @@ -375,6 +391,16 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-comments nil) + +;; A test failure introduced by some changes in CC mode. Hopefully CC +;; mode will sort this out eventually, using some new e-p-m machinery. +;; See +;; https://lists.gnu.org/archive/html/emacs-devel/2018-06/msg00535.html +(setf + (ert-test-expected-result-type + (ert-get-test 'electric-pair-whitespace-chomping-2-at-point-4-in-c++-mode-in-strings)) + :failed) + (define-electric-pair-test whitespace-chomping-dont-cross-comments " ( \n\t\t\n ) " "--)------" :expected-string " () \n\t\t\n ) " :expected-point 4 @@ -617,6 +643,12 @@ baz\"\"" :fixture-fn #'electric-quote-local-mode :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-disabled + "" "\"" :expected-string "\"" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-backtick "" "`" :expected-string "`" :expected-point 2 :modes '(text-mode) @@ -638,6 +670,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bob + "" "\"" :expected-string "“" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-bol-single "a\n" "--'" :expected-string "a\n‘" :expected-point 4 :modes '(text-mode) @@ -652,6 +691,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bol + "a\n" "--\"" :expected-string "a\n“" :expected-point 4 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-space-single " " "-'" :expected-string " ‘" :expected-point 3 :modes '(text-mode) @@ -666,6 +712,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-space + " " "-\"" :expected-string " “" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-letter-single "a" "-'" :expected-string "a’" :expected-point 3 :modes '(text-mode) @@ -680,6 +733,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-letter + "a" "-\"" :expected-string "a”" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-paren-single "(" "-'" :expected-string "(‘" :expected-point 3 :modes '(text-mode) @@ -694,6 +754,38 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-paren + "(" "-\"" :expected-string "(“" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-no-context-single + " " "-'" :expected-string " ’" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-open + "foo \\" "-----\"" :expected-string "foo \\“" + :expected-point 7 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-close + "foo \\“foo\\" "----------\"" :expected-string "foo \\“foo\\”" + :expected-point 12 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + ;; Simulate ‘markdown-mode’: it sets both ‘comment-start’ and ;; ‘comment-use-syntax’, but derives from ‘text-mode’. (define-electric-pair-test electric-quote-markdown-in-text diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..edd45c770c5 --- /dev/null +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -0,0 +1,436 @@ +;;; backtrace-tests.el --- Tests for backtraces -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell + +;; 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 'backtrace) +(require 'ert) +(require 'ert-x) +(require 'seq) + +;; Delay evaluation of the backtrace-creating functions until +;; load so that the backtraces are the same whether this file +;; is compiled or not. + +(eval-and-compile + (defconst backtrace-tests--uncompiled-functions + '(progn + (defun backtrace-tests--make-backtrace (arg) + (backtrace-tests--setup-buffer)) + + (defun backtrace-tests--setup-buffer () + "Set up the current buffer in backtrace mode." + (backtrace-mode) + (setq backtrace-frames (backtrace-get-frames)) + (let ((this-index)) + ;; Discard all past `backtrace-tests-make-backtrace'. + (dotimes (index (length backtrace-frames)) + (when (eq (backtrace-frame-fun (nth index backtrace-frames)) + 'backtrace-tests--make-backtrace) + (setq this-index index))) + (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) + (backtrace-print)))) + + (eval backtrace-tests--uncompiled-functions)) + +(defun backtrace-tests--backtrace-lines () + (if debugger-stack-frame-as-list + '(" (backtrace-get-frames)\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " (backtrace-tests--setup-buffer)\n" + " (backtrace-tests--make-backtrace %s)\n") + '(" backtrace-get-frames()\n" + " (setq backtrace-frames (backtrace-get-frames))\n" + " backtrace-tests--setup-buffer()\n" + " backtrace-tests--make-backtrace(%s)\n"))) + +(defconst backtrace-tests--line-count (length (backtrace-tests--backtrace-lines))) + +(defun backtrace-tests--backtrace-lines-with-locals () + (let ((lines (backtrace-tests--backtrace-lines)) + (locals '(" [no locals]\n" + " [no locals]\n" + " [no locals]\n" + " arg = %s\n"))) + (apply #'append (cl-mapcar #'list lines locals)))) + +(defun backtrace-tests--result (value) + (format (apply #'concat (backtrace-tests--backtrace-lines)) + (cl-prin1-to-string value))) + +(defun backtrace-tests--result-with-locals (value) + (let ((str (cl-prin1-to-string value))) + (format (apply #'concat (backtrace-tests--backtrace-lines-with-locals)) + str str))) + +;; TODO check that debugger-batch-max-lines still works + +(defconst backtrace-tests--header "Test header\n") +(defun backtrace-tests--insert-header () + (insert backtrace-tests--header)) + +;;; Tests + +(ert-deftest backtrace-tests--variables () + "Backtrace buffers can show and hide local variables." + (ert-with-test-buffer (:name "variables") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result 'value))) + (last-frame (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) 'value)) + (last-frame-with-locals + (format (apply #'concat (nthcdr (* 2 (1- backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals))) + 'value 'value))) + (backtrace-tests--make-backtrace 'value) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat results + (format (car (last (backtrace-tests--backtrace-lines-with-locals))) + 'value)))) + ;; Turn off locals for that frame. + (backtrace-toggle-locals) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Turn all locals on. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring (point) (point-max)) + last-frame-with-locals)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + (concat backtrace-tests--header + (backtrace-tests--result-with-locals 'value)))) + ;; Turn all locals off. + (backtrace-toggle-locals '(4)) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))) + last-frame)) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--backward-frame () + "`backtrace-backward-frame' moves backward to the start of a frame." + (ert-with-test-buffer (:name "backward") + (let ((results (concat backtrace-tests--header + (backtrace-tests--result nil)))) + (backtrace-tests--make-backtrace nil) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + + ;; Try to move backward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Try to move backward from start of first line. + (forward-line) + (let ((pos (point))) + (should-error (backtrace-backward-frame)) + (should (= pos (point)))) + + ;; Move backward from middle of line. + (let ((start (point))) + (forward-char (/ (length (nth 0 (backtrace-tests--backtrace-lines))) 2)) + (backtrace-backward-frame) + (should (= start (point)))) + + ;; Move backward from end of buffer. + (goto-char (point-max)) + (backtrace-backward-frame) + (let* ((last (format (car (last (backtrace-tests--backtrace-lines))) nil)) + (len (length last))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + last))) + + ;; Move backward from start of line. + (backtrace-backward-frame) + (let* ((line (car (last (backtrace-tests--backtrace-lines) 2))) + (len (length line))) + (should (string= (buffer-substring-no-properties (point) (+ (point) len)) + line)))))) + +(ert-deftest backtrace-tests--forward-frame () + "`backtrace-forward-frame' moves forward to the start of a frame." + (ert-with-test-buffer (:name "forward") + (let* ((arg '(1 2 3)) + (results (concat backtrace-tests--header + (backtrace-tests--result arg))) + (first-line (nth 0 (backtrace-tests--backtrace-lines)))) + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function #'backtrace-tests--insert-header) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Move forward from header. + (goto-char (+ (point-min) (/ (length backtrace-tests--header) 2))) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length first-line))) + first-line)) + + (let ((start (point)) + (offset (/ (length first-line) 2)) + (second-line (nth 1 (backtrace-tests--backtrace-lines)))) + ;; Move forward from start of first frame. + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line)) + ;; Move forward from middle of first frame. + (goto-char (+ start offset)) + (backtrace-forward-frame) + (should (string= (backtrace-tests--get-substring + (point) (+ (point) (length second-line))) + second-line))) + ;; Try to move forward from middle of last frame. + (goto-char (- (point-max) + (/ 2 (length (car (last (backtrace-tests--backtrace-lines))))))) + (should-error (backtrace-forward-frame)) + ;; Try to move forward from end of buffer. + (goto-char (point-max)) + (should-error (backtrace-forward-frame))))) + +(ert-deftest backtrace-tests--single-and-multi-line () + "Forms in backtrace frames can be on a single line or on multiple lines." + (ert-with-test-buffer (:name "single-multi-line") + (let* ((arg '(lambda (x) ; Quote this so it isn't made into a closure. + (let ((number (1+ x))) + (+ x number)))) + (header-string "Test header: ") + (header (format "%s%s\n" header-string arg)) + (insert-header-function (lambda () + (insert header-string) + (insert (backtrace-print-to-string arg)) + (insert "\n"))) + (results (concat header (backtrace-tests--result arg))) + (last-line (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg)) + (last-line-locals (format (nth (1- (* 2 backtrace-tests--line-count)) + (backtrace-tests--backtrace-lines-with-locals)) + arg))) + + (backtrace-tests--make-backtrace arg) + (setq backtrace-insert-header-function insert-header-function) + (backtrace-print) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results)) + ;; Check pp and collapse for the form in the header. + (goto-char (point-min)) + (backtrace-tests--verify-single-and-multi-line header) + ;; Check pp and collapse for the last frame. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-tests--verify-single-and-multi-line last-line) + ;; Check pp and collapse for local variables in the last line. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-toggle-locals) + (forward-line) + (backtrace-tests--verify-single-and-multi-line last-line-locals)))) + +(defun backtrace-tests--verify-single-and-multi-line (line) + "Verify that `backtrace-single-line' and `backtrace-multi-line' work at point. +Point should be at the beginning of a line, and LINE should be a +string containing the text of the line at point. Assume that the +line contains the strings \"lambda\" and \"number\"." + (let ((pos (point))) + (backtrace-multi-line) + ;; Verify point is still at the start of the line. + (should (= pos (point)))) + + ;; Verify the form now spans multiple lines. + (let ((pos (point))) + (search-forward "number") + (should-not (= pos (point-at-bol)))) + ;; Collapse the form. + (backtrace-single-line) + ;; Verify that the form is now back on one line, + ;; and that point is at the same place. + (should (string= (backtrace-tests--get-substring + (- (point) 6) (point)) "number")) + (should-not (= (point) (point-at-bol))) + (should (string= (backtrace-tests--get-substring + (point-at-bol) (1+ (point-at-eol))) + line))) + +(ert-deftest backtrace-tests--print-circle () + "Backtrace buffers can toggle `print-circle' syntax." + (ert-with-test-buffer (:name "print-circle") + (let* ((print-circle nil) + (arg (let ((val (make-list 5 'a))) (nconc val val) val)) + (results (backtrace-tests--make-regexp + (backtrace-tests--result arg))) + (results-circle (regexp-quote (let ((print-circle t)) + (backtrace-tests--result arg)))) + (last-frame (backtrace-tests--make-regexp + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))) + (last-frame-circle (regexp-quote + (let ((print-circle t)) + (format (nth (1- backtrace-tests--line-count) + (backtrace-tests--backtrace-lines)) + arg))))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Go to the last frame. + (goto-char (point-max)) + (forward-line -1) + ;; Turn on print-circle for that frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + ;; Turn off print-circle for the frame. + (backtrace-toggle-print-circle) + (should (string-match-p last-frame + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle on for the buffer. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame-circle + (backtrace-tests--get-substring (point) (point-max)))) + (should (string-match-p results-circle + (backtrace-tests--get-substring (point-min) (point-max)))) + ;; Turn print-circle off. + (backtrace-toggle-print-circle '(4)) + (should (string-match-p last-frame + (backtrace-tests--get-substring + (point) (+ (point) (length last-frame))))) + (should (string-match-p results + (backtrace-tests--get-substring (point-min) (point-max))))))) + +(defun backtrace-tests--make-regexp (str) + "Make regexp from STR for `backtrace-tests--print-circle'. +Used for results of printing circular objects without +`print-circle' on. Look for #n in string STR where n is any +digit and replace with #[0-9]." + (let ((regexp (regexp-quote str))) + (with-temp-buffer + (insert regexp) + (goto-char (point-min)) + (while (re-search-forward "#[0-9]" nil t) + (replace-match "#[0-9]"))) + (buffer-string))) + +(ert-deftest backtrace-tests--expand-ellipsis () + "Backtrace buffers ellipsify large forms as buttons which expand the ellipses." + ;; make a backtrace with an ellipsis + ;; expand the ellipsis + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (make-list 40 (make-string 10 ?a))) + (results (backtrace-tests--result arg))) + (backtrace-tests--make-backtrace arg) + (backtrace-print) + + ;; There should be an ellipsis. Find and expand it. + (goto-char (point-min)) + (search-forward "...") + (backward-char) + (push-button) + + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + +(ert-deftest backtrace-tests--expand-ellipses () + "Backtrace buffers ellipsify large forms and can expand the ellipses." + (ert-with-test-buffer (:name "variables") + (let* ((print-level nil) + (print-length nil) + (backtrace-line-length 300) + (arg (let ((outer (make-list 40 (make-string 10 ?a))) + (nested (make-list 40 (make-string 10 ?b)))) + (setf (nth 39 nested) (make-list 40 (make-string 10 ?c))) + (setf (nth 39 outer) nested) + outer)) + (results (backtrace-tests--result-with-locals arg))) + + ;; Make a backtrace with local variables visible. + (backtrace-tests--make-backtrace arg) + (backtrace-print) + (backtrace-toggle-locals '(4)) + + ;; There should be two ellipses. + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "...")) + + ;; Expanding the last frame without argument should expand both + ;; ellipses, but the expansions will contain one ellipsis each. + (let ((buffer-len (- (point-max) (point-min)))) + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses) + (should (> (- (point-max) (point-min)) buffer-len)) + (goto-char (point-min)) + (should (search-forward "...")) + (should (search-forward "...")) + (should-error (search-forward "..."))) + + ;; Expanding with argument should remove all ellipses. + (goto-char (point-max)) + (backtrace-backward-frame) + (backtrace-expand-ellipses '(4)) + (goto-char (point-min)) + + (should-error (search-forward "...")) + (should (string= (backtrace-tests--get-substring (point-min) (point-max)) + results))))) + + +(ert-deftest backtrace-tests--to-string () + "Backtraces can be produced as strings." + (let ((frames (ert-with-test-buffer (:name nil) + (backtrace-tests--make-backtrace "string") + backtrace-frames))) + (should (string= (backtrace-to-string frames) + (backtrace-tests--result "string"))))) + +(defun backtrace-tests--get-substring (beg end) + "Return the visible text between BEG and END. +Strip the string properties because it makes failed test results +easier to read." + (substring-no-properties (filter-buffer-substring beg end))) + +(provide 'backtrace-tests) + +;;; backtrace-tests.el ends here diff --git a/test/lisp/emacs-lisp/benchmark-tests.el b/test/lisp/emacs-lisp/benchmark-tests.el index a4be6d30748..a8c37bbe836 100644 --- a/test/lisp/emacs-lisp/benchmark-tests.el +++ b/test/lisp/emacs-lisp/benchmark-tests.el @@ -23,29 +23,37 @@ (require 'ert) (ert-deftest benchmark-tests () - (let (str t-long t-short) - (should (consp (benchmark-run nil (1+ 0)))) - (should (consp (benchmark-run 1 (1+ 0)))) + (let (str t-long t-short m) + (should (consp (benchmark-run nil (setq m (1+ 0))))) + (should (consp (benchmark-run 1 (setq m (1+ 0))))) (should (stringp (benchmark nil (1+ 0)))) (should (stringp (benchmark 1 (1+ 0)))) - (should (consp (benchmark-run-compiled nil (1+ 0)))) + (should (consp (benchmark-run-compiled (1+ 0)))) (should (consp (benchmark-run-compiled 1 (1+ 0)))) ;; First test is heavier, must need longer time. - (should (> (car (benchmark-run nil + (let ((count1 0) + (count2 0) + (repeat 2)) + (ignore (benchmark-run (setq count1 (1+ count1)))) + (ignore (benchmark-run repeat (setq count2 (1+ count2)))) + (should (> count2 count1))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run nil (1+ 0))))) - (should (> (car (benchmark-run-compiled nil + (car (benchmark-run (setq m (1+ 0)))))) + (should (> (car (benchmark-run-compiled (let ((n 100000)) (while (> n 1) (setq n (1- n)))))) - (car (benchmark-run-compiled nil (1+ 0))))) + (car (benchmark-run-compiled (1+ 0))))) (setq str (benchmark nil '(let ((n 100000)) (while (> n 1) (setq n (1- n)))))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-long (string-to-number (match-string 1 str))) (setq str (benchmark nil '(1+ 0))) (string-match "Elapsed time: \\([0-9.]+\\)" str) (setq t-short (string-to-number (match-string 1 str))) - (should (> t-long t-short)))) + (should (> t-long t-short)) + ;; Silence compiler. + m)) ;;; benchmark-tests.el ends here. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index bc28c5a6a00..f66a06bc1bc 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -27,6 +27,7 @@ (require 'ert) (require 'cl-lib) +(require 'bytecomp) ;;; Code: (defconst byte-opt-testsuite-arith-data @@ -38,8 +39,7 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (+ a -1 b)) (let ((a (+ 1 (expt 2 -64))) (b (expt 2 -65))) (- a 1 (- b))) - ;; This fails. Should it be a bug? - ;; (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) + (let ((a (expt 2 -1074)) (b 0.125)) (* a 8 b)) (let ((a 1.0)) (* a 0)) (let ((a 1.0)) (* a 2.0 0)) (let ((a 1.0)) (/ 0 a)) @@ -244,6 +244,9 @@ (let ((a 3) (b 2) (c 1.0)) (/ a b c 0)) (let ((a 3) (b 2) (c 1.0)) (/ a b c 1)) (let ((a 3) (b 2) (c 1.0)) (/ a b c -1)) + + (let ((a t)) (logand 0 a)) + ;; Test switch bytecode (let ((a 3)) (cond ((eq a 1) 'one) ((eq a 2) 'two) ((eq a 3) 'three) (t t))) (let ((a 'three)) (cond ((eq a 'one) 1) ((eq a 2) 'two) ((eq a 'three) 3) @@ -541,23 +544,17 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (write-region "(` (a b))" nil source) (bytecomp-tests--with-temp-file destination (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + (byte-compile-debug t) + (err (should-error (byte-compile-file source)))) + (should (equal (cdr err) '("Old-style backquotes detected!"))))))) (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) @@ -582,6 +579,38 @@ and will be removed soon. See (elisp)Backquote in the manual."))))))) (goto-char (point-min)) (should-not (search-forward "Warning" nil t)))) +(ert-deftest bytecomp-test-featurep-warnings () + (let ((byte-compile-log-buffer (generate-new-buffer " *Compile-Log*"))) + (unwind-protect + (progn + (with-temp-buffer + (insert "\ +\(defun foo () + (an-undefined-function)) + +\(defun foo1 () + (if (featurep 'xemacs) + (some-undefined-function-if))) + +\(defun foo2 () + (and (featurep 'xemacs) + (some-undefined-function-and))) + +\(defun foo3 () + (if (not (featurep 'emacs)) + (some-undefined-function-not))) + +\(defun foo4 () + (or (featurep 'emacs) + (some-undefined-function-or))) +") + (byte-compile-from-buffer (current-buffer))) + (with-current-buffer byte-compile-log-buffer + (should (search-forward "an-undefined-function" nil t)) + (should-not (search-forward "some-undefined-function" nil t)))) + (if (buffer-live-p byte-compile-log-buffer) + (kill-buffer byte-compile-log-buffer))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el new file mode 100644 index 00000000000..d14847ce45e --- /dev/null +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -0,0 +1,40 @@ +;;; cconv-tests.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018 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: + +(require 'ert) + +(ert-deftest cconv-convert-lambda-lifted () + "Bug#30872." + (should + (equal (funcall + (byte-compile + '#'(lambda (handle-fun arg) + (let* ((subfun + #'(lambda (params) + (ignore handle-fun) + (funcall #'(lambda () (setq params 42))) + params))) + (funcall subfun arg)))) + nil 99) + 42))) + +(provide 'cconv-tests) +;; cconv-tests.el ends here. diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index cc29ca91147..82c2c0d8e01 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -201,6 +201,10 @@ :b :a :a 42) '(42 :a)))) +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + (cl-defstruct (mystruct (:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) @@ -216,7 +220,7 @@ (should-error (cl-struct-slot-offset 'mystruct 'marypoppins)) (should (pcase (cl-struct-slot-info 'mystruct) (`((cl-tag-slot) (abc 5 :readonly t) - (def . ,(or `nil `(nil)))) + (def . ,(or 'nil '(nil)))) t))))) (ert-deftest cl-lib-struct-constructors () (should (string-match "\\`Constructor docstring." @@ -512,6 +516,17 @@ (ert-deftest cl-lib-symbol-macrolet-2 () (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325, bug#26073 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y)) + (apply (lambda (x) (+ x 1)) (list 8))))) + '(5 (6 5) (6 6) 9)))) + (defun cl-lib-tests--dummy-function () ;; Dummy function to see if the file is compiled. t) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 2c5925f15b4..989553bd7bd 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -497,4 +497,20 @@ collection clause." vconcat (vector (1+ x))) [2 3 4 5 6]))) +(ert-deftest cl-macs-loop-for-as-equals-and () + "Test for https://debbugs.gnu.org/29799 ." + (let ((arr (make-vector 3 0))) + (should (equal '((0 0) (1 1) (2 2)) + (cl-loop for k below 3 for x = k and z = (elt arr k) + collect (list k x)))))) + + +(ert-deftest cl-defstruct/builtin-type () + (should-error + (macroexpand '(cl-defstruct hash-table)) + :type 'wrong-type-argument) + (should-error + (macroexpand '(cl-defstruct (hash-table (:predicate hash-table-p)))) + :type 'wrong-type-argument)) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-preloaded-tests.el b/test/lisp/emacs-lisp/cl-preloaded-tests.el new file mode 100644 index 00000000000..9d5feee396a --- /dev/null +++ b/test/lisp/emacs-lisp/cl-preloaded-tests.el @@ -0,0 +1,33 @@ +;;; cl-preloaded-tests.el --- unit tests for cl-preloaded.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. +;; Author: Philipp Stephani <phst@google.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for lisp/emacs-lisp/cl-preloaded.el. + +;;; Code: + +(ert-deftest cl-struct-define/builtin-type () + (should-error + (cl-struct-define 'hash-table nil nil 'record nil nil + 'cl-preloaded-tests-tag 'cl-preloaded-tests nil) + :type 'wrong-type-argument)) + +;;; cl-preloaded-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el index 6ba2f2fcede..e163fb8a8dd 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -56,19 +56,30 @@ (let ((long-list (make-list 5 'a)) (long-vec (make-vector 5 'b)) (long-struct (cl-print-tests-con)) + (long-string (make-string 5 ?a)) (print-length 4)) (should (equal "(a a a a ...)" (cl-prin1-to-string long-list))) (should (equal "[b b b b ...]" (cl-prin1-to-string long-vec))) (should (equal "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" - (cl-prin1-to-string long-struct))))) + (cl-prin1-to-string long-struct))) + (should (equal "\"aaaa...\"" (cl-prin1-to-string long-string))))) (ert-deftest cl-print-tests-4 () "CL printing observes `print-level'." - (let ((deep-list '(a (b (c (d (e)))))) - (deep-struct (cl-print-tests-con)) - (print-level 4)) + (let* ((deep-list '(a (b (c (d (e)))))) + (buried-vector '(a (b (c (d [e]))))) + (deep-struct (cl-print-tests-con)) + (buried-struct `(a (b (c (d ,deep-struct))))) + (buried-string '(a (b (c (d #("hello" 0 5 (cl-print-test t))))))) + (buried-simple-string '(a (b (c (d "hello"))))) + (print-level 4)) (setf (cl-print-tests-struct-a deep-struct) deep-list) (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string deep-list))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-vector))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-struct))) + (should (equal "(a (b (c (d ...))))" (cl-prin1-to-string buried-string))) + (should (equal "(a (b (c (d \"hello\"))))" + (cl-prin1-to-string buried-simple-string))) (should (equal "#s(cl-print-tests-struct :a (a (b (c ...))) :b nil :c nil :d nil :e nil)" (cl-prin1-to-string deep-struct))))) @@ -82,6 +93,129 @@ (should (equal "((quote a) (function b) (\\` ((\\, c) (\\,@ d))))" (cl-prin1-to-string quoted-stuff)))))) +(ert-deftest cl-print-tests-strings () + "CL printing prints strings and propertized strings." + (let* ((str1 "abcdefghij") + (str2 #("abcdefghij" 3 6 (bold t) 7 9 (italic t))) + (str3 #("abcdefghij" 0 10 (test t))) + (obj '(a b)) + ;; Since the byte compiler reuses string literals, + ;; and the put-text-property call is destructive, use + ;; copy-sequence to make a new string. + (str4 (copy-sequence "abcdefghij"))) + (put-text-property 0 5 'test obj str4) + (put-text-property 7 10 'test obj str4) + + (should (equal "\"abcdefghij\"" (cl-prin1-to-string str1))) + (should (equal "#(\"abcdefghij\" 3 6 (bold t) 7 9 (italic t))" + (cl-prin1-to-string str2))) + (should (equal "#(\"abcdefghij\" 0 10 (test t))" + (cl-prin1-to-string str3))) + (let ((print-circle nil)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test (a b)) 7 10 (test (a b)))" + (cl-prin1-to-string str4)))) + (let ((print-circle t)) + (should + (equal + "#(\"abcdefghij\" 0 5 (test #1=(a b)) 7 10 (test #1#))" + (cl-prin1-to-string str4)))))) + +(ert-deftest cl-print-tests-ellipsis-cons () + "Ellipsis expansion works in conses." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5) "(0 1 2 3 ...)" "4 5") + (cl-print-tests-check-ellipsis-expansion + '(0 1 2 3 4 5 6 7 8 9) "(0 1 2 3 ...)" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + '(a (b (c (d (e))))) "(a (b (c ...)))" "(d (e))") + (cl-print-tests-check-ellipsis-expansion + (let ((x (make-list 6 'b))) + (setf (nthcdr 6 x) 'c) + x) + "(b b b b ...)" "b b . c"))) + +(ert-deftest cl-print-tests-ellipsis-vector () + "Ellipsis expansion works in vectors." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5] "[0 1 2 3 ...]" "4 5") + (cl-print-tests-check-ellipsis-expansion + [0 1 2 3 4 5 6 7 8 9] "[0 1 2 3 ...]" "4 5 6 7 ...") + (cl-print-tests-check-ellipsis-expansion + [a [b [c [d [e]]]]] "[a [b [c ...]]]" "[d [e]]"))) + +(ert-deftest cl-print-tests-ellipsis-string () + "Ellipsis expansion works in strings." + (let ((print-length 4) + (print-level 3)) + (cl-print-tests-check-ellipsis-expansion + "abcdefg" "\"abcd...\"" "efg") + (cl-print-tests-check-ellipsis-expansion + "abcdefghijk" "\"abcd...\"" "efgh...") + (cl-print-tests-check-ellipsis-expansion + '(1 (2 (3 #("abcde" 0 5 (test t))))) + "(1 (2 (3 ...)))" "#(\"abcd...\" 0 5 (test t))") + (cl-print-tests-check-ellipsis-expansion + #("abcd" 0 1 (bold t) 1 2 (invisible t) 3 4 (italic t)) + "#(\"abcd\" 0 1 (bold t) ...)" "1 2 (invisible t) ..."))) + +(ert-deftest cl-print-tests-ellipsis-struct () + "Ellipsis expansion works in structures." + (let ((print-length 4) + (print-level 3) + (struct (cl-print-tests-con))) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)" ":e nil") + (let ((print-length 2)) + (cl-print-tests-check-ellipsis-expansion + struct "#s(cl-print-tests-struct :a nil :b nil ...)" ":c nil :d nil ...")) + (cl-print-tests-check-ellipsis-expansion + `(a (b (c ,struct))) + "(a (b (c ...)))" + "#s(cl-print-tests-struct :a nil :b nil :c nil :d nil ...)"))) + +(ert-deftest cl-print-tests-ellipsis-circular () + "Ellipsis expansion works with circular objects." + (let ((wide-obj (list 0 1 2 3 4)) + (deep-obj `(0 (1 (2 (3 (4)))))) + (print-length 4) + (print-level 3)) + (setf (nth 4 wide-obj) wide-obj) + (setf (car (cadadr (cadadr deep-obj))) deep-obj) + (let ((print-circle nil)) + (cl-print-tests-check-ellipsis-expansion-rx + wide-obj (regexp-quote "(0 1 2 3 ...)") "\\`#[0-9]\\'") + (cl-print-tests-check-ellipsis-expansion-rx + deep-obj (regexp-quote "(0 (1 (2 ...)))") "\\`(3 (#[0-9]))\\'")) + (let ((print-circle t)) + (cl-print-tests-check-ellipsis-expansion + wide-obj "#1=(0 1 2 3 ...)" "#1#") + (cl-print-tests-check-ellipsis-expansion + deep-obj "#1=(0 (1 (2 ...)))" "(3 (#1#))")))) + +(defun cl-print-tests-check-ellipsis-expansion (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + value) + (should pos) + (setq value (get-text-property pos 'cl-print-ellipsis result)) + (should (equal expected result)) + (should (equal expanded (with-output-to-string (cl-print-expand-ellipsis + value nil)))))) + +(defun cl-print-tests-check-ellipsis-expansion-rx (obj expected expanded) + (let* ((result (cl-prin1-to-string obj)) + (pos (next-single-property-change 0 'cl-print-ellipsis result)) + (value (get-text-property pos 'cl-print-ellipsis result))) + (should (string-match expected result)) + (should (string-match expanded (with-output-to-string + (cl-print-expand-ellipsis value nil)))))) + (ert-deftest cl-print-circle () (let ((x '(#1=(a . #1#) #1#))) (let ((print-circle nil)) @@ -99,5 +233,41 @@ (let ((print-circle t)) (should (equal "(0 . #1=(0 . #1#))" (cl-prin1-to-string x)))))) +(ert-deftest cl-print-tests-print-to-string-with-limit () + (let* ((thing10 (make-list 10 'a)) + (thing100 (make-list 100 'a)) + (thing10x10 (make-list 10 thing10)) + (nested-thing (let ((val 'a)) + (dotimes (_i 20) + (setq val (list val))) + val)) + ;; Make a consistent environment for this test. + (print-circle nil) + (print-level nil) + (print-length nil)) + + ;; Print something that fits in the space given. + (should (string= (cl-prin1-to-string thing10) + (cl-print-to-string-with-limit #'cl-prin1 thing10 100))) + + ;; Print something which needs to be abbreviated and which can be. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 thing100 100)) + 100 + (length (cl-prin1-to-string thing100)))) + + ;; Print something resistant to easy abbreviation. + (should (string= (cl-prin1-to-string thing10x10) + (cl-print-to-string-with-limit #'cl-prin1 thing10x10 100))) + + ;; Print something which should be abbreviated even if the limit is large. + (should (< (length (cl-print-to-string-with-limit #'cl-prin1 nested-thing 1000)) + (length (cl-prin1-to-string nested-thing)))) + + ;; Print with no limits. + (dolist (thing (list thing10 thing100 thing10x10 nested-thing)) + (let ((rep (cl-prin1-to-string thing))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing 0))) + (should (string= rep (cl-print-to-string-with-limit #'cl-prin1 thing nil))))))) + ;;; cl-print-tests.el ends here. diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index e3bcb3d9410..013843826e0 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -41,7 +41,7 @@ (defun edebug-test-code-range (num) !start!(let ((index 0) (result nil)) - (while (< index num)!test! + (while !lt!(< index num)!test! (push index result)!loop! (cl-incf index))!end-loop! (nreverse result))) @@ -130,5 +130,12 @@ (let ((two 2) (three 3)) (cl-destructuring-bind (x . y) (cons two three) (+ x!x! y!y!)))) +(defun edebug-test-code-use-cl-macrolet (x) + (cl-macrolet ((wrap (func &rest args) + `(format "The result of applying %s to %s is %S" + ',func!func! ',args + ,(cons func args)))) + (wrap + 1 x))) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 7bfaf98e02e..4c517406cf8 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -432,9 +432,11 @@ test and possibly others should be updated." (verify-keybinding "P" 'edebug-view-outside) ;; same as v (verify-keybinding "W" 'edebug-toggle-save-windows) (verify-keybinding "?" 'edebug-help) - (verify-keybinding "d" 'edebug-backtrace) + (verify-keybinding "d" 'edebug-pop-to-backtrace) (verify-keybinding "-" 'negative-argument) - (verify-keybinding "=" 'edebug-temp-display-freq-count))) + (verify-keybinding "=" 'edebug-temp-display-freq-count) + (should (eq (lookup-key backtrace-mode-map "n") 'backtrace-forward-frame)) + (should (eq (lookup-key backtrace-mode-map "s") 'backtrace-goto-source)))) (ert-deftest edebug-tests-stop-point-at-start-of-first-instrumented-function () "Edebug stops at the beginning of an instrumented function." @@ -913,5 +915,28 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result 5))))) +(ert-deftest edebug-tests-cl-macrolet () + "Edebug can instrument `cl-macrolet' expressions. (Bug#29919)" + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-cl-macrolet" '(10) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "use-cl-macrolet" "func") + (edebug-tests-should-match-result-in-messages "+") + "g" + (should (equal edebug-tests-@-result "The result of applying + to (1 x) is 11"))))) + +(ert-deftest edebug-tests-backtrace-goto-source () + "Edebug can jump to instrumented source from its *Edebug-Backtrace* buffer." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "range" '(2) t) + (edebug-tests-run-kbd-macro + "@ SPC SPC" + (edebug-tests-should-be-at "range" "lt") + "dns" ; Pop to backtrace, next frame, goto source. + (edebug-tests-should-be-at "range" "start") + "g" + (should (equal edebug-tests-@-result '(0 1)))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index c9e67d31366..a7c63467bf9 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -326,7 +326,7 @@ ) (ert-deftest eieio-test-method-order-list-9 () - (should (eitest-Jd "test"))) + (should (eitest-Jd))) ;;; call-next-method with replacement arguments across a simple class hierarchy. ;; @@ -372,7 +372,7 @@ (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) - (CNM-M (CNM-2 "") '(INIT)) + (CNM-M (CNM-2) '(INIT)) (should (equal (eieio-test-arguments-for 'CNM-0) '(CNM-1-1 CNM-2 INIT))) (should (equal (eieio-test-arguments-for 'CNM-1-1) 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 dfaa031844f..2820d16254a 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -107,7 +107,7 @@ This is usually a symbol that starts with `:'." (ert-deftest eieio-test-persist-simple-1 () (let ((persist-simple-1 - (persist-simple "simple 1" :slot1 'goose :slot2 "testing" + (persist-simple :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps1.pt")))) (should persist-simple-1) @@ -141,7 +141,7 @@ Assume SLOTVALUE is a symbol of some sort." (ert-deftest eieio-test-persist-printer () (let ((persist-:printer-1 - (persist-:printer "persist" :slot1 'goose :slot2 "testing" + (persist-:printer :slot1 'goose :slot2 "testing" :file (concat default-directory "test-ps2.pt")))) (should persist-:printer-1) (persist-test-save-and-compare persist-:printer-1) @@ -178,8 +178,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot () (let ((persist-wos (persistent-with-objs-slot - "persist wos 1" - :pnp (persist-not-persistent "pnp 1" :slot1 3) + :pnp (persist-not-persistent :slot1 3) :file (concat default-directory "test-ps3.pt")))) (persist-test-save-and-compare persist-wos) @@ -205,8 +204,7 @@ persistent class.") (ert-deftest eieio-test-non-persistent-as-slot-child () (let ((persist-woss (persistent-with-objs-slot-subs - "persist woss 1" - :pnp (persist-not-persistent-subclass "pnps 1" :slot1 3) + :pnp (persist-not-persistent-subclass :slot1 3) :file (concat default-directory "test-ps4.pt")))) (persist-test-save-and-compare persist-woss) @@ -228,7 +226,7 @@ persistent class.") (ert-deftest eieio-test-multiple-class-slot () (let ((persist - (persistent-multiclass-slot "random string" + (persistent-multiclass-slot :slot1 (persistent-random-class) :slot2 (persist-not-persistent) :slot3 (persistent-random-class) @@ -249,10 +247,9 @@ persistent class.") (ert-deftest eieio-test-slot-with-list-of-objects () (let ((persist-wols (persistent-with-objs-list-slot - "persist wols 1" - :pnp (list (persist-not-persistent "pnp 1" :slot1 3) - (persist-not-persistent "pnp 2" :slot1 4) - (persist-not-persistent "pnp 3" :slot1 5)) + :pnp (list (persist-not-persistent :slot1 3) + (persist-not-persistent :slot1 4) + (persist-not-persistent :slot1 5)) :file (concat default-directory "test-ps5.pt")))) (persist-test-save-and-compare persist-wols) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 09ee123efaa..ea6df0f36fc 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -689,7 +689,7 @@ Do not override for `prot-2'." (defvar eitest-II2 nil) (defvar eitest-II3 nil) (ert-deftest eieio-test-29-instance-inheritor () - (setq eitest-II1 (II "II Test.")) + (setq eitest-II1 (II)) (oset eitest-II1 slot2 'cat) (setq eitest-II2 (clone eitest-II1 "eitest-II2 Test.")) (oset eitest-II2 slot1 'moose) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 7736360b6ac..36db1eeb425 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -188,7 +188,7 @@ failed or if there was a problem." (ert-deftest ert-test-should-with-macrolet () (let ((test (make-ert-test :body (lambda () - (cl-macrolet ((foo () `(progn t nil))) + (cl-macrolet ((foo () '(progn t nil))) (should (foo))))))) (let ((result (let ((ert-debug-on-error nil)) (ert-run-test test)))) @@ -376,7 +376,7 @@ This macro is used to test if macroexpansion in `should' works." (test (make-ert-test :body test-body)) (result (ert-run-test test))) (should (ert-test-failed-p result)) - (should (eq (nth 1 (car (ert-test-failed-backtrace result))) + (should (eq (backtrace-frame-fun (car (ert-test-failed-backtrace result))) 'signal)))) (ert-deftest ert-test-messages () @@ -490,54 +490,12 @@ This macro is used to test if macroexpansion in `should' works." :name nil :body nil :tags '(a b)))) - (should (equal (ert-select-tests `(tag a) (list test)) (list test))) - (should (equal (ert-select-tests `(tag b) (list test)) (list test))) - (should (equal (ert-select-tests `(tag c) (list test)) '())))) + (should (equal (ert-select-tests '(tag a) (list test)) (list test))) + (should (equal (ert-select-tests '(tag b) (list test)) (list test))) + (should (equal (ert-select-tests '(tag c) (list test)) '())))) ;;; Tests for utility functions. -(ert-deftest ert-test-proper-list-p () - (should (ert--proper-list-p '())) - (should (ert--proper-list-p '(1))) - (should (ert--proper-list-p '(1 2))) - (should (ert--proper-list-p '(1 2 3))) - (should (ert--proper-list-p '(1 2 3 4))) - (should (not (ert--proper-list-p 'a))) - (should (not (ert--proper-list-p '(1 . a)))) - (should (not (ert--proper-list-p '(1 2 . a)))) - (should (not (ert--proper-list-p '(1 2 3 . a)))) - (should (not (ert--proper-list-p '(1 2 3 4 . a)))) - (let ((a (list 1))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) a) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cdr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cddr a)) - (should (not (ert--proper-list-p a)))) - (let ((a (list 1 2 3 4))) - (setf (cdr (last a)) (cl-cdddr a)) - (should (not (ert--proper-list-p a))))) - (ert-deftest ert-test-parse-keys-and-body () (should (equal (ert--parse-keys-and-body '(foo)) '(nil (foo)))) (should (equal (ert--parse-keys-and-body '(:bar foo)) '((:bar foo) nil))) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..7d1a128694c --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -0,0 +1,76 @@ +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Dummy major-mode for testing `faceup', a regression test system for +;; font-lock keywords (syntax highlighting rules for Emacs). +;; +;; This mode use `syntax-propertize' to set the `syntax-table' +;; property on "<" and ">" in "<TEXT>" to make them act like +;; parentheses. +;; +;; This mode also sets the `help-echo' property on the text WARNING, +;; the effect is that Emacs displays a tooltip when you move your +;; mouse on to the text. + +;;; Code: + +(defvar faceup-test-mode-syntax-table + (make-syntax-table) + "Syntax table for `faceup-test-mode'.") + +(defvar faceup-test-font-lock-keywords + '(("\\_<WARNING\\_>" + (0 (progn + (add-text-properties (match-beginning 0) + (match-end 0) + '(help-echo "Baloon tip: Fly smoothly!")) + font-lock-warning-face)))) + "Highlight rules for `faceup-test-mode'.") + +(defun faceup-test-syntax-propertize (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\([^<>\n]*\\)\\(>\\)" + (1 "() ") + (3 ")( "))) + start end)) + +(defmacro faceup-test-define-prog-mode (mode name &rest args) + "Define a major mode for a programming language. +If `prog-mode' is defined, inherit from it." + (declare (indent defun)) + `(define-derived-mode + ,mode ,(and (fboundp 'prog-mode) 'prog-mode) + ,name ,@args)) + +(faceup-test-define-prog-mode faceup-test-mode "faceup-test" + "Dummy major mode for testing `faceup', a test system for font-lock." + (set (make-local-variable 'syntax-propertize-function) + #'faceup-test-syntax-propertize) + (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) + +(provide 'faceup-test-mode) + +;;; faceup-test-mode.el ends here 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 new file mode 100644 index 00000000000..0558bd12e5f --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -0,0 +1,32 @@ +;;; faceup-test-this-file-directory.el --- Support file for faceup tests + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Support file for `faceup-test-basics.el'. This file is used to test +;; `faceup-this-file-directory' in various contexts. + +;;; Code: + +(defvar faceup-test-this-file-directory (faceup-this-file-directory)) + +;;; faceup-test-this-file-directory.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt new file mode 100644 index 00000000000..d971f364c2d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +WARNING: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode "<" and ">" are parentheses, but only when on the same +line without any other "<" and ">" characters between them. +<OK> <NOT <OK> > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup new file mode 100644 index 00000000000..7d4938adf17 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same +line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them. +«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el new file mode 100644 index 00000000000..f910a1d732a --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,269 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Basic tests for the `faceup' package. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'faceup) + +(ert-deftest faceup-functions () + "Test primitive functions." + (should (equal (faceup-normalize-face-property '()) '())) + (should (equal (faceup-normalize-face-property 'a) '(a))) + (should (equal (faceup-normalize-face-property '(a)) '(a))) + (should (equal (faceup-normalize-face-property '(:x t)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t)) + '(a b (:x t)))) + + (should (equal (faceup-normalize-face-property '(:x t :y nil)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a b)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t :y nil)) + '(a (:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t :y nil)) + '(a b (:y nil) (:x t))))) + + +(ert-deftest faceup-markup-basics () + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test"))) + +(ert-deftest faceup-markup-escaping () + (should (equal (faceup-markup-string "«") "««")) + (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««")) + (should (equal (faceup-markup-string "»") "«»")) + (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))) + +(ert-deftest faceup-markup-plain () + ;; UU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face underline))) + "AB«U:CD»EF"))) + +(ert-deftest faceup-markup-plain-full-text () + ;; UUUUUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face underline))) + "«U:ABCDEF»"))) + +(ert-deftest faceup-markup-anonymous-face () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:underline t)))) + "AB«:(:underline t):CD»EF"))) + +(ert-deftest faceup-markup-anonymous-face-2keys () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:foo t :bar nil)))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Plist in list. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t :bar nil))))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Two plists. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t) (:bar nil))))) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + +(ert-deftest faceup-markup-anonymous-nested () + ;; AA + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face ((:foo t))) + 2 4 (face ((:bar t) (:foo t))) + 4 5 (face ((:foo t))))) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + +(ert-deftest faceup-markup-nested () + ;; UU + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face italic))) + "A«I:B«U:CD»E»F"))) + +(ert-deftest faceup-markup-overlapping () + ;; UUU + ;; III + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face underline))) + "A«I:B«U:CD»»«U:E»F")) + ;; III + ;; UUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (italic underline)) + 4 5 (face underline))) + "A«I:B»«U:«I:CD»E»F"))) + +(ert-deftest faceup-markup-multi-face () + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (underline italic)))) + "AB«I:«U:CD»»EF")) + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (italic underline)))) + "AB«U:«I:CD»»EF")) + ;; Equal ranges, full text. + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face (underline italic)))) + "«I:«U:ABCDEF»»")) + ;; Ditto, with stray markup characters. + (should (equal (faceup-markup-string + #("AB«CD»EF" 0 8 (face (underline italic)))) + "«I:«U:AB««CD«»EF»»"))) + +(ert-deftest faceup-markup-multi-property () + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (alpha (a l p h a)))) + "AB«(alpha):(a l p h a):CD»EF")) + + ;; Two properties, inner enclosed. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 8 '(alpha (a l p h a)) s) + (font-lock-append-text-property 4 6 'beta '(b e t a) s) + s)) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")) + + ;; Two properties, same end + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGH"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH")) + + ;; Two properties, overlap. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))) + + +(ert-deftest faceup-clean () + "Test the clean features of `faceup'." + (should (equal (faceup-clean-string "") "")) + (should (equal (faceup-clean-string "test") "test")) + (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF")) + (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF")) + (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF")) + (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF")) + ;; Escaped markup characters. + (should (equal (faceup-clean-string "««") "«")) + (should (equal (faceup-clean-string "«»") "»")) + (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(ert-deftest faceup-render () + "Test the render features of `faceup'." + (should (equal (faceup-render-string "") "")) + (should (equal (faceup-render-string "««") "«")) + (should (equal (faceup-render-string "«»") "»")) + (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(defvar faceup-test-resources-directory + (concat (file-name-directory + (substring (faceup-this-file-directory) 0 -1)) + "faceup-resources/") + "The `faceup-resources' directory.") + + +(defvar faceup-test-this-file-directory nil + "The result of `faceup-this-file-directory' in various contexts. + +This is set by the file test support file +`faceup-test-this-file-directory.el'.") + + +(ert-deftest faceup-directory () + "Test `faceup-this-file-directory'." + (let ((file (concat faceup-test-resources-directory + "faceup-test-this-file-directory.el")) + (load-file-name nil)) + ;; Test normal load. + (makunbound 'faceup-test-this-file-directory) + (load file nil :nomessage) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-buffer'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (eval-buffer)) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-defun'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + ;; Note: In batch mode, this prints the result of the + ;; evaluation. Unfortunately, this is hard to fix. + (eval-defun nil) + (forward-sexp)))) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)))) + +(provide 'faceup-test-basics) + +;;; faceup-test-basics.el ends here diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el new file mode 100644 index 00000000000..8df38bcc8a9 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -0,0 +1,63 @@ +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Self test of `faceup' with a major mode that sets both the +;; `syntax-table' and the `echo-help' property. +;; +;; This file can also be seen as a blueprint of test cases for real +;; major modes. + +;;; Code: + +(require 'faceup) + +;; Note: The byte compiler needs the value to load `faceup-test-mode', +;; hence the `eval-and-compile'. +(eval-and-compile + (defvar faceup-test-files-dir (faceup-this-file-directory) + "The directory of this file.")) + +(require 'faceup-test-mode + (concat faceup-test-files-dir + "../faceup-resources/" + "faceup-test-mode.el")) + +(defun faceup-test-files-check-one (file) + "Test that FILE is fontified as the .faceup file describes. + +FILE is interpreted as relative to this source directory." + (let ((faceup-properties '(face syntax-table help-echo))) + (faceup-test-font-lock-file 'faceup-test-mode + (concat + faceup-test-files-dir + "../faceup-resources/" + file)))) +(faceup-defexplainer faceup-test-files-check-one) + +(ert-deftest faceup-files () + (should (faceup-test-files-check-one "files/test1.txt"))) + +(provide 'faceup-test-files) + +;;; faceup-test-files.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 35382dd8d04..613de2fd577 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -292,3 +292,13 @@ identical output. (i 0) (j (setq i (1+ i)))) (iter-yield i)))))))) + +(ert-deftest iter-lambda-variable-shadowing () + "`iter-lambda' forms which have local variable shadowing (Bug#26073)." + (should (equal (iter-next + (funcall (iter-lambda () + (let ((it 1)) + (iter-yield (funcall + (lambda (it) (- it)) + (1+ it))))))) + -2))) diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index 55238ec034d..a54af8059b3 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -38,17 +38,19 @@ Evaluate BODY for each created map. \(fn (var map) body)" (declare (indent 1) (debug (symbolp body))) (let ((alist (make-symbol "alist")) + (plist (make-symbol "plist")) (vec (make-symbol "vec")) (ht (make-symbol "ht"))) `(let ((,alist (list (cons 0 3) (cons 1 4) (cons 2 5))) + (,plist (list 0 3 1 4 2 5)) (,vec (vector 3 4 5)) (,ht (make-hash-table))) (puthash 0 3 ,ht) (puthash 1 4 ,ht) (puthash 2 5 ,ht) - (dolist (,var (list ,alist ,vec ,ht)) + (dolist (,var (list ,alist ,plist ,vec ,ht)) ,@body)))) (ert-deftest test-map-elt () @@ -76,13 +78,26 @@ Evaluate BODY for each created map. 'b '2)))) -(ert-deftest test-map-put () +(ert-deftest test-map-put! () (with-maps-do map (setf (map-elt map 2) 'hello) (should (eq (map-elt map 2) 'hello))) (with-maps-do map (map-put map 2 'hello) (should (eq (map-elt map 2) 'hello))) + (with-maps-do map + (map-put! map 2 'hello) + (should (eq (map-elt map 2) 'hello)) + (if (not (or (hash-table-p map) + (and (listp map) (not (listp (car map)))))) ;plist! + (should-error (map-put! map 5 'value) + ;; For vectors, it could arguably signal + ;; map-not-inplace as well, but it currently doesn't. + :type (if (listp map) + 'map-not-inplace + 'error)) + (map-put! map 5 'value) + (should (eq (map-elt map 5) 'value)))) (let ((ht (make-hash-table))) (setf (map-elt ht 2) 'a) (should (eq (map-elt ht 2) @@ -92,7 +107,7 @@ Evaluate BODY for each created map. (should (eq (map-elt alist 2) 'a))) (let ((vec [3 4 5])) - (should-error (setf (map-elt vec 3) 6)))) + (should-error (setf (map-elt vec 3) 6)))) (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." @@ -105,9 +120,9 @@ Evaluate BODY for each created map. (let ((alist (list (cons "a" 1) (cons "b" 2))) ;; Make sure to use a non-eq "a", even when compiled. (noneq-key (string ?a))) - (map-put alist noneq-key 3 'equal) + (map-put alist noneq-key 3 #'equal) (should-not (cddr alist)) - (map-put alist noneq-key 9) + (map-put alist noneq-key 9 #'eql) (should (cddr alist)))) (ert-deftest test-map-put-return-value () diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 212e73f4726..8f021bf6fc9 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -112,7 +112,7 @@ upload-base) &rest body) "Set up temporary locations and variables for testing." - (declare (indent 1)) + (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)) @@ -158,6 +158,7 @@ (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." + (declare (debug body)) `(with-temp-buffer (help-mode) ;; Trick `help-buffer' into using the temp buffer. @@ -414,7 +415,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package '5x5) (goto-char (point-min)) - (should (search-forward "5x5 is a built-in package." nil t)) + (should (search-forward "5x5 is built-in." nil t)) ;; Don't assume the descriptions are in any particular order. (save-excursion (should (search-forward "Status: Built-in." nil t))) (save-excursion (should (search-forward "Summary: simple little puzzle game" nil t))) @@ -428,17 +429,30 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "simple-single is an installed package." nil t)) + (should (search-forward "Package simple-single is installed." nil t)) (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 (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) - ;; No description, though. Because at this point we don't know - ;; what archive the package originated from, and we don't have - ;; its readme file saved. + (save-excursion (should (search-forward "This package provides a minor mode to frobnicate" + nil t))) ))) +(ert-deftest package-test-describe-installed-multi-file-package () + "Test displaying of the readme for installed multi-file package." + + (with-package-test () + (package-initialize) + (package-refresh-contents) + (package-install 'multi-file) + (with-fake-help-buffer + (describe-package 'multi-file) + (goto-char (point-min)) + (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "This is a bare-bones readme file for the multi-file" + nil t))))) + (ert-deftest package-test-describe-non-installed-package () "Test displaying of the readme for non-installed package." @@ -467,15 +481,23 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (ignore-errors - (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (format "HOME=%s" homedir) - process-environment))) - (epg-check-configuration (epg-configuration)) - (epg-find-configuration 'OpenPGP)) - (delete-directory homedir t))))) + (skip-unless (let ((homedir (make-temp-file "package-test" t))) + (unwind-protect + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (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)))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (expand-file-name "package-resources/signed" package-test-file-dir))) @@ -484,14 +506,16 @@ Must called from within a `tar-mode' buffer." (package-import-keyring keyring) (package-refresh-contents) (let ((package-check-signature 'allow-unsigned)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature t)) - (should (package-install 'signed-good)) + (should (progn (package-install 'signed-good) 'noerror)) (should-error (package-install 'signed-bad))) + (package-delete (car (alist-get 'signed-good package-alist))) (let ((package-check-signature nil)) - (should (package-install 'signed-good)) - (should (package-install 'signed-bad))) + (should (progn (package-install 'signed-good) 'noerror)) + (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. (let ((buf (package-list-packages))) (package-menu-refresh) @@ -504,7 +528,7 @@ Must called from within a `tar-mode' buffer." (with-fake-help-buffer (describe-package 'signed-good) (goto-char (point-min)) - (should (re-search-forward "signed-good is an? \\(\\S-+\\) package." nil t)) + (should (re-search-forward "Package signed-good is \\(\\S-+\\)\\." nil t)) (should (string-equal (match-string-no-properties 1) "installed")) (should (re-search-forward "Status: Installed in ['`‘]signed-good-1.0/['’]." diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index bc451a6212f..1e9d37fbfa9 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -53,7 +53,7 @@ (should (pcase-tests-grep 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) (should (pcase-tests-grep - 'member (macroexpand-all '(pcase x ((or '"a" '2 '3) body))))) + 'member (macroexpand-all '(pcase x ((or "a" 2 3) body))))) (should-not (pcase-tests-grep 'memq (macroexpand-all '(pcase x ((or "a" 2 3) body))))) (let ((exp (macroexpand-all diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 0b6b57c6f8f..991c4e55119 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -162,6 +162,43 @@ (should (= (ring-size ring) 5)) (should (equal (ring-elements ring) '(3 2 1))))) +(ert-deftest ring-resize/grow () + (let ((ring (make-ring 3))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '(3 2 1))))) + +(ert-deftest ring-resize/grow-empty () + (let ((ring (make-ring 3))) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '())))) + +(ert-deftest ring-resize/grow-wrapped-ring () + (let ((ring (make-ring 3))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-insert ring 4) + (ring-insert ring 5) + (ring-resize ring 5) + (should (= (ring-size ring) 5)) + (should (equal (ring-elements ring) '(5 4 3))))) + +(ert-deftest ring-resize/shrink () + (let ((ring (make-ring 5))) + (ring-insert ring 1) + (ring-insert ring 2) + (ring-insert ring 3) + (ring-insert ring 4) + (ring-insert ring 5) + (ring-resize ring 3) + (should (= (ring-size ring) 3)) + (should (equal (ring-elements ring) '(5 4 3))))) + (ert-deftest ring-tests-insert () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 9f5a6a62c30..392a38ab95b 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -33,6 +33,28 @@ (number-sequence ?< ?\]) (number-sequence ?- ?:)))))) +(ert-deftest rx-char-any-range-nl () + "Test character alternatives with LF as a range endpoint." + (should (equal (rx (any "\n-\r")) + "[\n-\r]")) + (should (equal (rx (any "\a-\n")) + "[\a-\n]"))) + +(ert-deftest rx-char-any-raw-byte () + "Test raw bytes in character alternatives." + ;; Separate raw characters. + (should (equal (string-match-p (rx (any "\326A\333B")) + "X\326\333") + 1)) + ;; Range of raw characters, unibyte. + (should (equal (string-match-p (rx (any "\200-\377")) + "ÿA\310B") + 2)) + ;; Range of raw characters, multibyte. + (should (equal (string-match-p (rx (any "Å\211\326-\377\177")) + "XY\355\177\327") + 2))) + (ert-deftest rx-pcase () (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index deb2829db45..d8f00cfea4c 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -424,5 +424,17 @@ Evaluate BODY for each created sequence. (should (eq (seq-into vec 'vector) vec)) (should (eq (seq-into str 'string) str)))) +(ert-deftest test-seq-first () + (let ((lst '(1 2 3)) + (vec [1 2 3])) + (should (eq (seq-first lst) 1)) + (should (eq (seq-first vec) 1)))) + +(ert-deftest test-seq-rest () + (let ((lst '(1 2 3)) + (vec [1 2 3])) + (should (equal (seq-rest lst) '(2 3))) + (should (equal (seq-rest vec) [2 3])))) + (provide 'seq-tests) ;;; seq-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 519cb384920..d3cb2b140d9 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -148,34 +148,34 @@ "Test `if-let' with falsie bindings." (should (equal (if-let* ((a nil)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a nil) (b 2) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b nil) (c 3)) - (list a b c) + "yes" "no") "no")) (should (equal (if-let* ((a 1) (b 2) (c nil)) - (list a b c) + "yes" "no") "no")) (should (equal (let (z) (if-let* (z (a 1) (b 2) (c 3)) - (list a b c) + "yes" "no")) "no")) (should (equal (let (d) (if-let* ((a 1) (b 2) (c 3) d) - (list a b c) + "yes" "no")) "no"))) @@ -312,34 +312,28 @@ "Test `when-let' with falsie bindings." (should (equal (when-let* ((a nil)) - (list a b c) "no") nil)) (should (equal (when-let* ((a nil) (b 2) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b nil) (c 3)) - (list a b c) "no") nil)) (should (equal (when-let* ((a 1) (b 2) (c nil)) - (list a b c) "no") nil)) (should (equal (let (z) (when-let* (z (a 1) (b 2) (c 3)) - (list a b c) "no")) nil)) (should (equal (let (d) (when-let* ((a 1) (b 2) (c 3) d) - (list a b c) "no")) nil))) @@ -538,6 +532,53 @@ (format "abs sum is: %s")) "abs sum is: 15"))) + +;; Substring tests + +(ert-deftest subr-x-test-string-trim-left () + "Test `string-trim-left' behavior." + (should (equal (string-trim-left "") "")) + (should (equal (string-trim-left " \t\n\r") "")) + (should (equal (string-trim-left " \t\n\ra") "a")) + (should (equal (string-trim-left "a \t\n\r") "a \t\n\r")) + (should (equal (string-trim-left "" "") "")) + (should (equal (string-trim-left "a" "") "a")) + (should (equal (string-trim-left "aa" "a*") "")) + (should (equal (string-trim-left "ba" "a*") "ba")) + (should (equal (string-trim-left "aa" "a*?") "aa")) + (should (equal (string-trim-left "aa" "a+?") "a"))) + +(ert-deftest subr-x-test-string-trim-right () + "Test `string-trim-right' behavior." + (should (equal (string-trim-right "") "")) + (should (equal (string-trim-right " \t\n\r") "")) + (should (equal (string-trim-right " \t\n\ra") " \t\n\ra")) + (should (equal (string-trim-right "a \t\n\r") "a")) + (should (equal (string-trim-right "" "") "")) + (should (equal (string-trim-right "a" "") "a")) + (should (equal (string-trim-right "aa" "a*") "")) + (should (equal (string-trim-right "ab" "a*") "ab")) + (should (equal (string-trim-right "aa" "a*?") ""))) + +(ert-deftest subr-x-test-string-remove-prefix () + "Test `string-remove-prefix' behavior." + (should (equal (string-remove-prefix "" "") "")) + (should (equal (string-remove-prefix "" "a") "a")) + (should (equal (string-remove-prefix "a" "") "")) + (should (equal (string-remove-prefix "a" "b") "b")) + (should (equal (string-remove-prefix "a" "a") "")) + (should (equal (string-remove-prefix "a" "aa") "a")) + (should (equal (string-remove-prefix "a" "ab") "b"))) + +(ert-deftest subr-x-test-string-remove-suffix () + "Test `string-remove-suffix' behavior." + (should (equal (string-remove-suffix "" "") "")) + (should (equal (string-remove-suffix "" "a") "a")) + (should (equal (string-remove-suffix "a" "") "")) + (should (equal (string-remove-suffix "a" "b") "b")) + (should (equal (string-remove-suffix "a" "a") "")) + (should (equal (string-remove-suffix "a" "aa") "a")) + (should (equal (string-remove-suffix "a" "ba") "b"))) (provide 'subr-x-tests) ;;; subr-x-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 832775a730d..571e9ab3884 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -53,7 +53,6 @@ ;; ==== constants-bug-25316 ==== "Testcover doesn't splotch constants." -:expected-result :failed ;; ==== (defconst testcover-testcase-const "apples") (defun testcover-testcase-zero () 0) @@ -76,7 +75,6 @@ ;; ==== customize-defcustom-bug-25326 ==== "Testcover doesn't prevent testing of defcustom values." -:expected-result :failed ;; ==== (defgroup testcover-testcase nil "Test case for testcover" @@ -135,7 +133,6 @@ ;; ==== 1-value-symbol-bug-25316 ==== "Wrapping a form with 1value prevents splotching." -:expected-result :failed ;; ==== (defun testcover-testcase-always-zero (num) (- num%%% num%%%)%%%) @@ -229,8 +226,7 @@ (should-not (testcover-testcase-cc nil)) ;; ==== quotes-within-backquotes-bug-25316 ==== -"Forms to instrument are found within quotes within backquotes." -:expected-result :failed +"Forms to analyze are found within quotes within backquotes." ;; ==== (defun testcover-testcase-make-list () (list 'defun 'defvar)) @@ -296,7 +292,6 @@ ;; ==== backquote-1value-bug-24509 ==== "Commas within backquotes are recognized as non-1value." -:expected-result :failed ;; ==== (defmacro testcover-testcase-lambda (&rest body) `(lambda () ,@body)) @@ -320,7 +315,6 @@ ;; ==== pcase-bug-24688 ==== "Testcover copes with condition-case within backquoted list." -:expected-result :failed ;; ==== (defun testcover-testcase-pcase (form) (pcase form%%% @@ -335,7 +329,6 @@ ;; ==== defun-in-backquote-bug-11307-and-24743 ==== "Testcover handles defun forms within backquoted list." -:expected-result :failed ;; ==== (defmacro testcover-testcase-defun (name &rest body) (declare (debug (symbolp def-body))) @@ -348,7 +341,6 @@ ;; ==== closure-1value-bug ==== "Testcover does not mark closures as 1value." -:expected-result :failed ;; ==== ;; -*- lexical-binding:t -*- (setq testcover-testcase-foo nil) @@ -365,7 +357,6 @@ ;; ==== by-value-vs-by-reference-bug-25351 ==== "An object created by a 1value expression may be modified by other code." -:expected-result :failed ;; ==== (defun testcover-testcase-ab () (list 'a 'b)) @@ -386,7 +377,7 @@ (should-error (testcover-testcase-thing 3)) ;; ==== dotted-backquote ==== -"Testcover correctly instruments dotted backquoted lists." +"Testcover can analyze code inside dotted backquoted lists." ;; ==== (defun testcover-testcase-dotted-bq (flag extras) (let* ((bq @@ -396,9 +387,16 @@ (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e)))) (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e)))) +;; ==== quoted-backquote ==== +"Testcover correctly handles the quoted backquote symbol." +;; ==== +(defun testcover-testcase-special-symbols () + (list '\` '\, '\,@)) + +(should (equal '(\` \, \,@) (testcover-testcase-special-symbols))) + ;; ==== backquoted-vector-bug-25316 ==== -"Testcover reinstruments within backquoted vectors." -:expected-result :failed +"Testcover can analyze code within backquoted vectors." ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -413,9 +411,15 @@ (should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6))) (should (equal '([100]) (testcover-testcase-vec-arg 100))) +;; ==== dotted-list-in-vector-bug-30909 ==== +"Testcover can analyze dotted pairs within vectors." +;; ==== +(defun testcover-testcase-vectors-with-dotted-pairs () + (equal [(1 . "x")] [(1 2 . "y")])%%%) +(should-not (testcover-testcase-vectors-with-dotted-pairs)) + ;; ==== vector-in-macro-spec-bug-25316 ==== -"Testcover reinstruments within vectors." -:expected-result :failed +"Testcover can analyze code inside vectors." ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) @@ -435,7 +439,6 @@ ;; ==== mapcar-is-not-compose ==== "Mapcar with 1value arguments is not 1value." -:expected-result :failed ;; ==== (defvar testcover-testcase-num 0) (defun testcover-testcase-add-num (n) @@ -450,10 +453,10 @@ ;; ==== function-with-edebug-spec-bug-25316 ==== "Functions can have edebug specs too. -See c-make-font-lock-search-function for an example in the Emacs -sources. The other issue is that it's ok to use quote in an -edebug spec, so testcover needs to cope with that." -:expected-result :failed +See `c-make-font-lock-search-function' for an example in the +Emacs sources. `c-make-font-lock-search-function''s Edebug spec +also contains a quote. See comment in `testcover-analyze-coverage' +regarding the odd-looking coverage result for the quoted form." ;; ==== (defun testcover-testcase-make-function (forms) `(lambda (flag) (if flag 0 ,@forms%%%))%%%) @@ -462,7 +465,7 @@ edebug spec, so testcover needs to cope with that." (("quote" (&rest def-form)))) (defun testcover-testcase-thing () - (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%) + (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%) (defun testcover-testcase-use-thing () (funcall (testcover-testcase-thing)%%% nil)%%%) @@ -470,7 +473,7 @@ edebug spec, so testcover needs to cope with that." (should (equal (testcover-testcase-use-thing) 15)) ;; ==== backquoted-dotted-alist ==== -"Testcover can instrument a dotted alist constructed with backquote." +"Testcover can analyze a dotted alist constructed with backquote." ;; ==== (defun testcover-testcase-make-alist (expr entries) `((0 . ,expr%%%) . ,entries%%%)%%%) @@ -494,10 +497,18 @@ edebug spec, so testcover needs to cope with that." "Testcover captures and ignores circular list errors." ;; ==== (defun testcover-testcase-cyc1 (a) - (let ((ls (make-list 10 a%%%))) - (nconc ls ls) - ls)) + (let ((ls (make-list 10 a%%%)%%%)) + (nconc ls%%% ls%%%) + ls)) ; The lack of a mark here is due to an ignored circular list error. (testcover-testcase-cyc1 1) (testcover-testcase-cyc1 1) +(defun testcover-testcase-cyc2 (a b) + (let ((ls1 (make-list 10 a%%%)%%%) + (ls2 (make-list 10 b))) + (nconc ls2 ls2) + (nconc ls1%%% ls2) + ls1)) +(testcover-testcase-cyc2 1 2) +(testcover-testcase-cyc2 1 4) ;; testcases.el ends here. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 6f9ee694d3e..cbef493cc84 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -124,14 +124,12 @@ arguments for `testcover-start'." (save-current-buffer (set-buffer (find-file-noselect tempfile)) ;; Fail the test if the debugger tries to become active, - ;; which will happen if Testcover's reinstrumentation - ;; leaves an edebug-enter in the code. This will also - ;; prevent debugging these tests using Edebug. - (cl-letf (((symbol-function #'edebug-enter) + ;; 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 - (concat "Debugger invoked during test run " - "(possible edebug-enter not replaced)"))))) + (ert-fail "Debugger invoked during test run")))) (dolist (byte-compile '(t nil)) (testcover-tests-unmarkup-region (point-min) (point-max)) (unwind-protect diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el new file mode 100644 index 00000000000..5ea6b5372e1 --- /dev/null +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -0,0 +1,113 @@ +;;; text-property-search-tests.el --- Testing text-property-search + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Lars Ingebrigtsen <larsi@gnus.org> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'text-property-search) +(require 'cl-lib) + +(defun text-property-setup () + (insert "This is " + (propertize "bold1" 'face 'bold) + " and this is " + (propertize "italic1" 'face 'italic) + (propertize "bold2" 'face 'bold) + (propertize "italic2" 'face 'italic) + " at the end") + (goto-char (point-min))) + +(defmacro with-test (form result &optional point) + `(with-temp-buffer + (text-property-setup) + (when ,point + (goto-char ,point)) + (should + (equal + (cl-loop for match = ,form + while match + collect (buffer-substring (prop-match-beginning match) + (prop-match-end match))) + ,result)))) + +(ert-deftest text-property-search-forward-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("bold1" "bold2"))) + +(ert-deftest text-property-search-forward-bold-nil () + (with-test (text-property-search-forward 'face 'bold nil) + '("This is " " and this is italic1" "italic2 at the end"))) + +(ert-deftest text-property-search-forward-nil-t () + (with-test (text-property-search-forward 'face nil t) + '("This is " " and this is " " at the end"))) + +(ert-deftest text-property-search-forward-nil-nil () + (with-test (text-property-search-forward 'face nil nil) + '("bold1" "italic1" "bold2" "italic2"))) + +(ert-deftest text-property-search-forward-partial-bold-t () + (with-test (text-property-search-forward 'face 'bold t) + '("old1" "bold2") + 10)) + +(ert-deftest text-property-search-forward-partial-non-current-bold-t () + (with-test (text-property-search-forward 'face 'bold t t) + '("bold2") + 10)) + + +(ert-deftest text-property-search-backward-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("bold2" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-bold-nil () + (with-test (text-property-search-backward 'face 'bold nil) + '( "italic2 at the end" " and this is italic1" "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-t () + (with-test (text-property-search-backward 'face nil t) + '(" at the end" " and this is " "This is ") + (point-max))) + +(ert-deftest text-property-search-backward-nil-nil () + (with-test (text-property-search-backward 'face nil nil) + '("italic2" "bold2" "italic1" "bold1") + (point-max))) + +(ert-deftest text-property-search-backward-partial-bold-t () + (with-test (text-property-search-backward 'face 'bold t) + '("b" "bold1") + 35)) + +(ert-deftest text-property-search-backward-partial-non-current-bold-t () + (with-test (text-property-search-backward 'face 'bold t t) + '("bold1") + 35)) + +(provide 'text-property-search-tests) + +;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el index 9efc2d1f705..caa2c415460 100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -51,5 +51,55 @@ (thunk-force thunk) (should (= x 1)))) + + +;; thunk-let tests + +(ert-deftest thunk-let-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3))) + +(ert-deftest thunk-let*-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3))) + +(ert-deftest thunk-let-bound-vars-cant-be-set-test () + "Test whether setting a `thunk-let' bound variable fails." + (should-error + (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t))) + +(ert-deftest thunk-let-laziness-test () + "Test laziness of `thunk-let'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil)) + (thunk-let ((x (progn (setq x-evalled t) (+ 1 2))) + (y (progn (setq y-evalled t) (+ 3 4)))) + (let ((evalled-y y)) + (list x-evalled y-evalled evalled-y)))) + (list nil t 7)))) + +(ert-deftest thunk-let*-laziness-test () + "Test laziness of `thunk-let*'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil) + (z-evalled nil) + (a-evalled nil)) + (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1))) + (y (progn (setq y-evalled t) (+ x 1))) + (z (progn (setq z-evalled t) (+ y 1))) + (a (progn (setq a-evalled t) (+ z 1)))) + (let ((evalled-z z)) + (list x-evalled y-evalled z-evalled a-evalled evalled-z)))) + (list t t t nil 4)))) + +(ert-deftest thunk-let-bad-binding-test () + "Test whether a bad binding causes an error when expanding." + (should-error (macroexpand '(thunk-let ((x 1 1)) x))) + (should-error (macroexpand '(thunk-let (27) x))) + (should-error (macroexpand '(thunk-let x x)))) + + (provide 'thunk-tests) ;;; thunk-tests.el ends here diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 1d2a83cd7ed..bd2dcbe554e 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -39,4 +39,29 @@ (if (fboundp 'debug-timer-check) (should (debug-timer-check)) t)) +(ert-deftest timer-test-multiple-of-time () + (should (time-equal-p + (timer-next-integral-multiple-of-time '(0 0 0 1) (1+ (ash 1 53))) + (list (ash 1 (- 53 16)) 1)))) + +(ert-deftest timer-next-integral-multiple-of-time-2 () + "Test bug#33071." + (let* ((tc (current-time)) + (delta-ticks 1000) + (hz 128000) + (tce (encode-time tc hz)) + (tc+delta (time-add tce (cons delta-ticks hz))) + (tc+deltae (encode-time tc+delta hz)) + (tc+delta-ticks (car tc+deltae)) + (tc-nexte (cons (- tc+delta-ticks (% tc+delta-ticks delta-ticks)) hz)) + (nt (timer-next-integral-multiple-of-time + tc (/ (float delta-ticks) hz))) + (nte (encode-time nt hz))) + (should (equal tc-nexte nte)))) + +(ert-deftest timer-next-integral-multiple-of-time-3 () + "Test bug#33071." + (let ((nt (timer-next-integral-multiple-of-time '(32770 . 65539) 0.5))) + (should (time-equal-p 1 nt)))) + ;;; timer-tests.el ends here diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 98e08fca750..1a11e418384 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -30,8 +30,28 @@ (expand-file-name "data/epg" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing epg test data.") -(defun epg-tests-find-usable-gpg-configuration (&optional _require-passphrase) - (epg-find-configuration 'OpenPGP 'no-cache)) +(defconst epg-tests--config-program-alist + ;; The default `epg-config--program-alist' requires gpg2 2.1 or + ;; greater due to some practical problems with pinentry. But most + ;; tests here work 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)) + +(defun epg-tests-find-usable-gpg-configuration + (&optional require-passphrase require-public-key) + ;; Clear config cache because we may be using a different + ;; program-alist. We do want to update the cache, so that + ;; `epg-make-context' can use our result. + (setq epg--configurations nil) + (epg-find-configuration 'OpenPGP nil + ;; The symmetric operations fail on Hydra + ;; with gpg 2.0. + (if (or (not require-passphrase) require-public-key) + epg-tests--config-program-alist))) (defun epg-tests-passphrase-callback (_c _k _d) ;; Need to create a copy here, since the string will be wiped out @@ -51,16 +71,18 @@ (format "GNUPGHOME=%s" epg-tests-home-directory)) process-environment))) (unwind-protect - (let ((context (epg-make-context 'OpenPGP))) + ;; 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-tests-find-usable-gpg-configuration - ,(if require-passphrase - `'require-passphrase)))) + (alist-get 'program epg-config)) (setf (epg-context-home-directory context) epg-tests-home-directory) ,(if require-passphrase - `(with-temp-file (expand-file-name + '(with-temp-file (expand-file-name "gpg-agent.conf" epg-tests-home-directory) (insert "pinentry-program " (expand-file-name "dummy-pinentry" @@ -70,11 +92,11 @@ context #'epg-tests-passphrase-callback))) ,(if require-public-key - `(epg-import-keys-from-file + '(epg-import-keys-from-file context (expand-file-name "pubkey.asc" epg-tests-data-directory))) ,(if require-secret-key - `(epg-import-keys-from-file + '(epg-import-keys-from-file context (expand-file-name "seckey.asc" epg-tests-data-directory))) (with-temp-buffer @@ -85,7 +107,7 @@ (delete-directory epg-tests-home-directory t))))) (ert-deftest epg-decrypt-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme (with-epg-tests (:require-passphrase t) (with-temp-file (expand-file-name "gpg.conf" epg-tests-home-directory) (insert "ignore-mdc-error")) @@ -99,14 +121,13 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== -----END PGP MESSAGE-----"))))) (ert-deftest epg-roundtrip-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) + :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme (with-epg-tests (:require-passphrase t) (let ((cipher (epg-encrypt-string epg-tests-context "symmetric" nil))) (should (equal "symmetric" (epg-decrypt-string epg-tests-context cipher)))))) (ert-deftest epg-roundtrip-2 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -117,7 +138,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (epg-decrypt-string epg-tests-context cipher)))))) (ert-deftest epg-sign-verify-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -131,7 +151,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-sign-verify-2 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -147,7 +166,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-sign-verify-3 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase t :require-public-key t :require-secret-key t) @@ -162,7 +180,6 @@ jA0EAwMCE19JBLTvvmhgyRrGGglRbnKkK9PJG8fDwO5ccjysrR7IcdNcnA== (should (eq 'good (epg-signature-status (car verify-result))))))) (ert-deftest epg-import-1 () - (skip-unless (epg-tests-find-usable-gpg-configuration 'require-passphrase)) (with-epg-tests (:require-passphrase nil) (should (= 0 (length (epg-list-keys epg-tests-context)))) (should (= 0 (length (epg-list-keys epg-tests-context nil t))))) diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index a2072d6b392..d5f9d244be0 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -26,6 +26,7 @@ (require 'ert) (require 'em-ls) +(require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." @@ -77,6 +78,11 @@ (ert-deftest em-ls-test-bug27844 () "Test for https://debbugs.gnu.org/27844 ." + ;; FIXME: it would be better to use something other than source-directory + ;; in this test. + (skip-unless (and source-directory + (file-exists-p + (expand-file-name "lisp/subr.el" source-directory)))) (let ((orig eshell-ls-use-in-dired) (dired-use-ls-dired 'unspecified) buf insert-directory-program) @@ -87,7 +93,14 @@ (dired-toggle-marks) (should (cdr (dired-get-marked-files))) (kill-buffer buf) - (setq buf (dired (expand-file-name "lisp/subr.el" source-directory))) + ;; Eshell's default format duplicates the year for non-recent files, + ;; eg "2015-05-06 2015", which doesn't make a lot of sense, + ;; and causes this portion of the test to fail if subr.el + ;; is non-recent (eg if building from a tarfile unpacked + ;; with a fixed early timestamp for reproducibility). Bug#33734. + (let ((eshell-ls-date-format "%b %e")) + (setq buf (dired (expand-file-name "lisp/subr.el" + source-directory)))) (should (looking-at "subr\\.el"))) (customize-set-variable 'eshell-ls-use-in-dired orig) (and (buffer-live-p buf) (kill-buffer))))) diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el new file mode 100644 index 00000000000..13b522b389e --- /dev/null +++ b/test/lisp/eshell/esh-opt-tests.el @@ -0,0 +1,124 @@ +;;; tests/esh-opt-tests.el --- esh-opt test suite + +;; Copyright (C) 2018 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 'esh-opt) + +(ert-deftest esh-opt-process-args-test () + "Unit tests which verify correct behavior of `eshell--process-args'." + (should + (equal '(t) + (eshell--process-args + "sudo" + '("-a") + '((?a "all" nil show-all ""))))) + (should + (equal '(nil) + (eshell--process-args + "sudo" + '("-g") + '((?a "all" nil show-all ""))))) + (should + (equal '("root" "world") + (eshell--process-args + "sudo" + '("-u" "root" "world") + '((?u "user" t user "execute a command as another USER"))))) + (should + (equal '(nil "emerge" "-uDN" "world") + (eshell--process-args + "sudo" + '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only)))) + (should + (equal '("root" "emerge" "-uDN" "world") + (eshell--process-args + "sudo" + '("-u" "root" "emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only)))) + (should + (equal '("world" "emerge") + (eshell--process-args + "sudo" + '("-u" "root" "emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER")))))) + +(ert-deftest test-eshell-eval-using-options () + "Tests for `eshell-eval-using-options'." + (eshell-eval-using-options + "sudo" '("-u" "root" "whoami") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (equal user "root"))) + (eshell-eval-using-options + "sudo" '("--user" "root" "whoami") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (equal user "root"))) + + (eshell-eval-using-options + "sudo" '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER")) + (should (equal user "world"))) + (eshell-eval-using-options + "sudo" '("emerge" "-uDN" "world") + '((?u "user" t user "execute a command as another USER") + :parse-leading-options-only) + (should (eq user nil))) + + (eshell-eval-using-options + "ls" '("-I" "*.txt" "/dev/null") + '((?I "ignore" t ignore-pattern + "do not list implied entries matching pattern")) + (should (equal ignore-pattern "*.txt"))) + + (eshell-eval-using-options + "ls" '("-l" "/dev/null") + '((?l nil long-listing listing-style + "use a long listing format")) + (should (eql listing-style 'long-listing))) + (eshell-eval-using-options + "ls" '("/dev/null") + '((?l nil long-listing listing-style + "use a long listing format")) + (should (eq listing-style nil))) + + (eshell-eval-using-options + "ls" '("/dev/null" "-h") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eql human-readable 1024))) + (eshell-eval-using-options + "ls" '("/dev/null" "--human-readable") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eql human-readable 1024))) + (eshell-eval-using-options + "ls" '("/dev/null") + '((?h "human-readable" 1024 human-readable + "print sizes in human readable format")) + (should (eq human-readable nil)))) + +(provide 'esh-opt-tests) + +;;; esh-opt-tests.el ends here diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 862594541bb..53cf854f210 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -31,6 +31,9 @@ (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 diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 341c5afd6d5..02830791542 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -31,6 +31,21 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. +;; For the remote file-notify library, Tramp checks for the existence +;; of a respective command. The first command found is used. In +;; order to use a dedicated one, the environment variable +;; $REMOTE_FILE_NOTIFY_LIBRARY shall be set, possible values are +;; "inotifywait", "gio-monitor" and "gvfs-monitor-dir". + +;; Local file-notify libraries are auto-detected during Emacs +;; configuration. This can be changed with a respective configuration +;; argument, like +;; +;; --with-file-notification=inotify +;; --with-file-notification=kqueue +;; --with-file-notification=gfile +;; --with-file-notification=w32 + ;; A whole test run can be performed calling the command `file-notify-test-all'. ;;; Code: @@ -57,12 +72,19 @@ 'tramp-default-host-alist `("\\`mock\\'" nil ,(system-name))) ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in - ;; batch mode only, therefore. + ;; batch mode only, therefore. `temporary-file-directory' might + ;; be quoted, so we unquote it just in case. (unless (and (null noninteractive) (file-directory-p "~/")) - (setenv "HOME" temporary-file-directory)) + (setenv "HOME" (file-name-unquote temporary-file-directory))) (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") +;; Filter suppressed remote file-notify libraries. +(when (stringp (getenv "REMOTE_FILE_NOTIFY_LIBRARY")) + (dolist (lib '("inotifywait" "gio-monitor" "gvfs-monitor-dir")) + (unless (string-equal (getenv "REMOTE_FILE_NOTIFY_LIBRARY") lib) + (add-to-list 'tramp-connection-properties `(nil ,lib nil))))) + (defvar file-notify--test-tmpdir nil) (defvar file-notify--test-tmpfile nil) (defvar file-notify--test-tmpfile1 nil) @@ -239,15 +261,18 @@ This returns only for the local case and gfilenotify; otherwise it is nil. (gfile-monitor-name file-notify--test-desc))) (cdr (assq file-notify--test-desc file-notify--test-monitors)))))) -(defmacro file-notify--deftest-remote (test docstring) +(defmacro file-notify--deftest-remote (test docstring &optional expected skip) "Define ert `TEST-remote' for remote files." (declare (indent 1)) `(ert-deftest ,(intern (concat (symbol-name test) "-remote")) () ,docstring :tags '(:expensive-test) + :expected-result (or ,expected :passed) + (skip-unless (not ,skip)) (let* ((temporary-file-directory file-notify-test-remote-temporary-file-directory) - (ert-test (ert-get-test ',test))) + (ert-test (ert-get-test ',test)) + vc-handled-backends) (skip-unless (file-notify--test-remote-enabled)) (tramp-cleanup-connection (tramp-dissect-file-name temporary-file-directory) nil 'keep-password) @@ -566,35 +591,42 @@ delivered." (skip-unless (file-notify--test-local-enabled)) (unwind-protect - (progn - ;; Check file creation, change and deletion. It doesn't work - ;; for kqueue, because we don't use an implicit directory - ;; monitor. - (unless (string-equal (file-notify--test-library) "kqueue") - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) - (should - (setq file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpfile - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) - '(created deleted stopped)) - (t '(created changed deleted stopped))) - (write-region - "another text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (delete-file file-notify--test-tmpfile)) - (file-notify-rm-watch file-notify--test-desc)) + ;; Check file creation, change and deletion. It doesn't work + ;; for kqueue, because we don't use an implicit directory + ;; monitor. + (unless (string-equal (file-notify--test-library) "kqueue") + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + (t '(created changed deleted stopped))) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc) + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn ;; Check file change and deletion. (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) @@ -619,163 +651,191 @@ delivered." (delete-file file-notify--test-tmpfile)) (file-notify-rm-watch file-notify--test-desc) - ;; Check file creation, change and deletion when watching a - ;; directory. There must be a `stopped' event when deleting - ;; the directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not raise `deleted' and `stopped' - ;; events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin does not raise a `changed' event. - ((eq system-type 'cygwin) - '(created deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed deleted stopped)) - (t '(created changed deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check copy of files inside a directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-tmpfile1 (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not distinguish between `changed' and - ;; `attribute-changed'. It does not raise `deleted' - ;; and `stopped' events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed created changed - changed changed changed - deleted deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created created deleted stopped))) - ;; There are three `deleted' events, for two files and - ;; for the directory. Except for cygwin and kqueue. - ((eq system-type 'cygwin) - '(created created changed changed deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed created changed deleted stopped)) - (t '(created changed created changed - deleted deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) - ;; The next two events shall not be visible. - (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) - (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check rename of files inside a directory. - (let ((file-notify--test-tmpdir - (make-temp-file "file-notify-test-parent" t))) - (should - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) - file-notify--test-tmpfile1 (file-notify--test-make-temp-name) - file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpdir - '(change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not raise `deleted' and `stopped' - ;; events for the watched directory. - ((string-equal (file-notify--test-library) "w32notify") - '(created changed renamed deleted)) - ;; gvfs-monitor-dir on cygwin does not detect the - ;; `created' event reliably. - ((string-equal - (file-notify--test-library) "gvfs-monitor-dir.exe") - '((deleted stopped) - (created deleted stopped))) - ;; There are two `deleted' events, for the file and for - ;; the directory. Except for cygwin and kqueue. And - ;; cygwin raises `created' and `deleted' events instead - ;; of a `renamed' event. - ((eq system-type 'cygwin) - '(created created deleted deleted stopped)) - ((string-equal (file-notify--test-library) "kqueue") - '(created changed renamed deleted stopped)) - (t '(created changed renamed deleted deleted stopped))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) - ;; After the rename, we won't get events anymore. - (file-notify--test-read-event) - (delete-directory file-notify--test-tmpdir 'recursive)) - (file-notify-rm-watch file-notify--test-desc)) - - ;; Check attribute change. Does not work for cygwin. - (unless (eq system-type 'cygwin) - (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check file creation, change and deletion when watching a + ;; directory. There must be a `stopped' event when deleting the + ;; directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin does not raise a `changed' event. + ((eq system-type 'cygwin) + '(created deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed deleted stopped)) + (t '(created changed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check copy of files inside a directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. It does not raise `deleted' and + ;; `stopped' events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed created changed + changed changed changed + deleted deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created created deleted stopped))) + ;; There are three `deleted' events, for two files and + ;; for the directory. Except for cygwin and kqueue. + ((eq system-type 'cygwin) + '(created created changed changed deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed created changed deleted stopped)) + (t '(created changed created changed + deleted deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; The next two events shall not be visible. + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check rename of files inside a directory. + (let ((file-notify--test-tmpdir + (make-temp-file "file-notify-test-parent" t))) + (should + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name) + file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpdir + '(change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not raise `deleted' and `stopped' + ;; events for the watched directory. + ((string-equal (file-notify--test-library) "w32notify") + '(created changed renamed deleted)) + ;; gvfs-monitor-dir on cygwin does not detect the + ;; `created' event reliably. + ((string-equal + (file-notify--test-library) "gvfs-monitor-dir.exe") + '((deleted stopped) + (created deleted stopped))) + ;; There are two `deleted' events, for the file and for + ;; the directory. Except for cygwin and kqueue. And + ;; cygwin raises `created' and `deleted' events instead + ;; of a `renamed' event. + ((eq system-type 'cygwin) + '(created created deleted deleted stopped)) + ((string-equal (file-notify--test-library) "kqueue") + '(created changed renamed deleted stopped)) + (t '(created changed renamed deleted deleted stopped))) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (file-notify--test-read-event) + (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) + ;; After the rename, we won't get events anymore. + (file-notify--test-read-event) + (delete-directory file-notify--test-tmpdir 'recursive)) + (file-notify-rm-watch file-notify--test-desc) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check attribute change. Does not work for cygwin. + (unless (eq system-type 'cygwin) + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(attribute-change) #'file-notify--test-event-handler))) + (file-notify--test-with-events + (cond + ;; w32notify does not distinguish between `changed' and + ;; `attribute-changed'. Under MS Windows 7, we get four + ;; `changed' events, and under MS Windows 10 just two. + ;; Strange. + ((string-equal (file-notify--test-library) "w32notify") + '((changed changed) + (changed changed changed changed))) + ;; For kqueue and in the remote case, `write-region' + ;; raises also an `attribute-changed' event. + ((or (string-equal (file-notify--test-library) "kqueue") + (file-remote-p temporary-file-directory)) + '(attribute-changed attribute-changed attribute-changed)) + (t '(attribute-changed attribute-changed))) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (should - (setq file-notify--test-desc - (file-notify-add-watch - file-notify--test-tmpfile - '(attribute-change) #'file-notify--test-event-handler))) - (file-notify--test-with-events - (cond - ;; w32notify does not distinguish between `changed' and - ;; `attribute-changed'. Under MS Windows 7, we get - ;; four `changed' events, and under MS Windows 10 just - ;; two. Strange. - ((string-equal (file-notify--test-library) "w32notify") - '((changed changed) - (changed changed changed changed))) - ;; For kqueue and in the remote case, `write-region' - ;; raises also an `attribute-changed' event. - ((or (string-equal (file-notify--test-library) "kqueue") - (file-remote-p temporary-file-directory)) - '(attribute-changed attribute-changed attribute-changed)) - (t '(attribute-changed attribute-changed))) - (write-region - "any text" nil file-notify--test-tmpfile nil 'no-message) - (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) - (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) - (file-notify--test-read-event) - (delete-file file-notify--test-tmpfile)) - (file-notify-rm-watch file-notify--test-desc)) + (file-notify--test-read-event) + (set-file-modes file-notify--test-tmpfile 000) + (file-notify--test-read-event) + (set-file-times file-notify--test-tmpfile '(0 0)) + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile)) + (file-notify-rm-watch file-notify--test-desc) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -849,15 +909,15 @@ delivered." ;; Stop file notification. Autorevert shall still work via polling. (file-notify-rm-watch auto-revert-notify-watch-descriptor) (file-notify--wait-for-events - timeout (null auto-revert-use-notify)) - (should-not auto-revert-use-notify) + timeout (null auto-revert-notify-watch-descriptor)) + (should auto-revert-use-notify) (should-not auto-revert-notify-watch-descriptor) ;; Modify file. We wait for two seconds, in order to ;; have another timestamp. One second seems to be too - ;; short. + ;; short. And Cygwin sporadically requires more than two. (ert-with-message-capture captured-messages - (sleep-for 2) + (sleep-for (if (eq system-type 'cygwin) 3 2)) (write-region "foo bla" nil file-notify--test-tmpfile nil 'no-message) @@ -867,7 +927,10 @@ delivered." (string-match (format-message "Reverting buffer `%s'." (buffer-name buf)) captured-messages)) - (should (string-match "foo bla" (buffer-string))))) + (should (string-match "foo bla" (buffer-string)))) + + ;; Stop autorevert, in order to cleanup descriptor. + (auto-revert-mode -1)) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -1013,7 +1076,7 @@ delivered." (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) (should-not (file-notify-valid-p file-notify--test-desc)) - (delete-directory file-notify--test-tmpfile t) + (delete-directory file-notify--test-tmpfile 'recursive) ;; The environment shall be cleaned up. (file-notify--test-cleanup-p)) @@ -1033,7 +1096,7 @@ delivered." (should (file-notify-valid-p file-notify--test-desc)) ;; After deleting the directory, the descriptor must not be ;; valid anymore. - (delete-directory file-notify--test-tmpfile t) + (delete-directory file-notify--test-tmpfile 'recursive) (file-notify--wait-for-events (file-notify--test-timeout) (not (file-notify-valid-p file-notify--test-desc))) @@ -1090,14 +1153,16 @@ delivered." ;; w32notify fires both `deleted' and `renamed' events. ((string-equal (file-notify--test-library) "w32notify") (let (r) - (dotimes (_i n r) - (setq r (append '(deleted renamed) r))))) + (dotimes (_i n) + (setq r (append '(deleted renamed) r))) + r)) ;; cygwin fires `changed' and `deleted' events, sometimes ;; in random order. ((eq system-type 'cygwin) (let (r) - (dotimes (_i n (cons :random r)) - (setq r (append '(changed deleted) r))))) + (dotimes (_i n) + (setq r (append '(changed deleted) r))) + (cons :random r))) (t (make-list n 'renamed))) (let ((source-file-list source-file-list) (target-file-list target-file-list)) @@ -1118,8 +1183,10 @@ delivered." ;; Cleanup. (file-notify--test-cleanup))) +;; Unpredictable failures, eg https://hydra.nixos.org/build/86016286 (file-notify--deftest-remote file-notify-test07-many-events - "Check that events are not dropped for remote directories.") + "Check that events are not dropped for remote directories." + :passed (getenv "EMACS_HYDRA_CI")) (ert-deftest file-notify-test08-backup () "Check that backup keeps file notification." diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index f69ab466264..57d8363ef9c 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -21,6 +21,10 @@ (require 'ert) (require 'nadvice) +(eval-when-compile (require 'cl-lib)) +(require 'bytecomp) ; `byte-compiler-base-file-name'. +(require 'dired) ; `dired-uncache'. +(require 'filenotify) ; `file-notify-add-watch'. ;; Set to t if the local variable was set, `query' if the query was ;; triggered. @@ -153,6 +157,9 @@ form.") (ert-deftest files-test-bug-18141 () "Test for https://debbugs.gnu.org/18141 ." (skip-unless (executable-find "gzip")) + ;; 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 @@ -255,14 +262,29 @@ be $HOME." (concat "/:/:" subdir))))) (delete-directory dir 'recursive)))) +(ert-deftest files-tests-file-name-non-special-quote-unquote () + (let (;; Just in case it is quoted, who knows. + (temporary-file-directory (file-name-unquote temporary-file-directory))) + (should-not (file-name-quoted-p temporary-file-directory)) + (should (file-name-quoted-p (file-name-quote temporary-file-directory))) + (should (equal temporary-file-directory + (file-name-unquote + (file-name-quote temporary-file-directory)))) + ;; It does not hurt to quote/unquote a file several times. + (should (equal (file-name-quote temporary-file-directory) + (file-name-quote + (file-name-quote temporary-file-directory)))) + (should (equal (file-name-unquote temporary-file-directory) + (file-name-unquote + (file-name-unquote temporary-file-directory)))))) + (ert-deftest files-tests--file-name-non-special--subprocess () "Check that Bug#25949 is fixed." (skip-unless (executable-find "true")) - (let ((defdir (if (memq system-type '(ms-dos windows-nt)) "/:c:/" "/:/"))) - (should (eq (let ((default-directory defdir)) (process-file "true")) 0)) - (should (processp (let ((default-directory defdir)) - (start-file-process "foo" nil "true")))) - (should (eq (let ((default-directory defdir)) (shell-command "true")) 0)))) + (let ((default-directory (file-name-quote temporary-file-directory))) + (should (zerop (process-file "true"))) + (should (processp (start-file-process "foo" nil "true"))) + (should (zerop (shell-command "true"))))) (defmacro files-tests--with-advice (symbol where function &rest body) (declare (indent 3)) @@ -277,7 +299,7 @@ be $HOME." (advice-remove #',symbol ,function))))) (defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1)) + (declare (indent 1) (debug (symbolp body))) (cl-check-type name symbol) `(let ((,name (make-temp-file "emacs"))) (unwind-protect @@ -297,8 +319,10 @@ be invoked with the right arguments." (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) (log (lambda (&rest args) (push args actual-args)))) - (insert-file-contents (concat "/:" temp-file-name) :visit) + (insert-file-contents (file-name-quote temp-file-name) :visit) (should (stringp buffer-file-name)) + (should (file-name-quoted-p buffer-file-name)) + ;; The following is not true for remote files. (should (string-prefix-p "/:" buffer-file-name)) (should (consp (visited-file-modtime))) (should (equal (find-file-name-handler buffer-file-name @@ -325,6 +349,776 @@ be invoked with the right arguments." `((verify-visited-file-modtime ,buffer-visiting-file) (verify-visited-file-modtime nil)))))))) +(cl-defmacro files-tests--with-temp-non-special + ((name non-special-name &optional dir-flag) &rest body) + "Run tests with quoted file name. +NAME is the symbol which contains the name of a created temporary +file. NON-SPECIAL-NAME is another symbol, which contains the +temporary file name with quoted file name syntax. If DIR-FLAG is +non-nil, a temporary directory is created instead. +After evaluating BODY, the temporary file or directory is deleted." + (declare (indent 1) (debug ((symbolp symbolp &optional form) body))) + (cl-check-type name symbol) + (cl-check-type non-special-name symbol) + `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (,name (make-temp-file "files-tests" ,dir-flag)) + (,non-special-name (file-name-quote ,name))) + (unwind-protect + (progn ,@body) + (when (file-exists-p ,name) + (if ,dir-flag (delete-directory ,name t) + (delete-file ,name))) + (when (file-exists-p ,non-special-name) + (if ,dir-flag (delete-directory ,non-special-name t) + (delete-file ,non-special-name)))))) + +(defconst files-tests--special-file-name-extension ".special" + "Trailing string for test file name handler.") + +(defconst files-tests--special-file-name-regexp + (concat (regexp-quote files-tests--special-file-name-extension) "\\'") + "Regular expression for test file name handler.") + +(defun files-tests--special-file-name-handler (operation &rest args) + "File name handler for files with extension \".special\"." + (let ((arg args) + ;; Avoid cyclic call. + (file-name-handler-alist + (delete + (rassoc + 'files-tests--special-file-name-handler file-name-handler-alist) + file-name-handler-alist))) + ;; Remove trailing "\\.special\\'" from arguments, if they are not quoted. + (while arg + (when (and (stringp (car arg)) + (not (file-name-quoted-p (car arg))) + (string-match files-tests--special-file-name-regexp (car arg))) + (setcar arg (replace-match "" nil nil (car arg)))) + (setq arg (cdr arg))) + ;; Call it. + (apply operation args))) + +(cl-defmacro files-tests--with-temp-non-special-and-file-name-handler + ((name non-special-name &optional dir-flag) &rest body) + "Run tests with quoted file name, see `files-tests--with-temp-non-special'. +Both file names in NAME and NON-SPECIAL-NAME have the extension +\".special\". The created temporary file or directory does not have +that extension. +A file name handler is added which is activated for files with +that extension. It simply removes the extension from file names. +It is expected, that this file name handler works only for +unquoted file names." + (declare (indent 1) (debug ((symbolp symbolp &optional form) body))) + (cl-check-type name symbol) + (cl-check-type non-special-name symbol) + `(let* ((temporary-file-directory (file-truename temporary-file-directory)) + (file-name-handler-alist + `((,files-tests--special-file-name-regexp + . files-tests--special-file-name-handler) + . ,file-name-handler-alist)) + (,name (concat + (make-temp-file "files-tests" ,dir-flag) + files-tests--special-file-name-extension)) + (,non-special-name (file-name-quote ,name))) + (unwind-protect + (progn ,@body) + (when (file-exists-p ,name) + (if ,dir-flag (delete-directory ,name t) + (delete-file ,name))) + (when (file-exists-p ,non-special-name) + (if ,dir-flag (delete-directory ,non-special-name t) + (delete-file ,non-special-name)))))) + +(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-access-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + ;; Both versions of the file name work. + (should-not (access-file tmpfile "test")) + (should-not (access-file nospecial "test"))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (access-file tmpfile "test")) + ;; The quoted file name does not work. + (should-error (access-file nospecial "test")))) + +(ert-deftest files-tests-file-name-non-special-add-name-to-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((newname (files-tests--new-name nospecial "add-name"))) + ;; Both versions work. + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname) + (add-name-to-file nospecial newname) + (should (file-exists-p newname)) + (delete-file newname))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((newname (files-tests--new-name tmpfile "add-name"))) + ;; Using an unquoted file name works. + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname)) + (let ((newname (files-tests--new-name nospecial "add-name"))) + (add-name-to-file tmpfile newname) + (should (file-exists-p newname)) + (delete-file newname) + ;; The quoted special file name does not work. + (should-error (add-name-to-file nospecial newname))))) + +(ert-deftest files-tests-file-name-non-special-byte-compiler-base-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (byte-compiler-base-file-name nospecial) + (byte-compiler-base-file-name tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (byte-compiler-base-file-name nospecial) tmpfile)) + (should-not (equal (byte-compiler-base-file-name tmpfile) tmpfile)))) + +(ert-deftest files-tests-file-name-non-special-copy-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((newname (files-tests--new-name + (directory-file-name nospecial-dir) "copy-dir"))) + (copy-directory nospecial-dir newname) + (should (file-directory-p newname)) + (delete-directory newname) + (should-not (file-directory-p newname)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((newname (files-tests--new-name + (directory-file-name nospecial-dir) "copy-dir"))) + (should-error (copy-directory nospecial-dir newname)) + (delete-directory newname)))) + +(ert-deftest files-tests-file-name-non-special-copy-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((newname + (files-tests--new-name (directory-file-name nospecial) "copy-file"))) + (copy-file nospecial newname) + (should (file-exists-p newname)) + (delete-file newname) + (should-not (file-exists-p newname)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((newname + (files-tests--new-name (directory-file-name nospecial) "copy-file"))) + (should-error (copy-file nospecial newname))))) + +(ert-deftest files-tests-file-name-non-special-delete-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (delete-directory nospecial-dir)) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (delete-directory nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-delete-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (delete-file nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (delete-file nospecial) + (should (file-exists-p tmpfile)))) + +(ert-deftest files-tests-file-name-non-special-diff-latest-backup-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (write-region "foo" nil (make-backup-file-name tmpfile)) + (should (equal (diff-latest-backup-file nospecial) + (diff-latest-backup-file tmpfile))) + (delete-file (diff-latest-backup-file nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (write-region "foo" nil (make-backup-file-name tmpfile)) + (should-not (equal (diff-latest-backup-file nospecial) + (diff-latest-backup-file tmpfile))) + (delete-file (diff-latest-backup-file nospecial)))) + +(ert-deftest files-tests-file-name-non-special-directory-file-name () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (directory-file-name nospecial-dir) + (file-name-quote (directory-file-name tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (equal (directory-file-name nospecial-dir) + (file-name-quote (directory-file-name tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-directory-files () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (directory-files nospecial-dir) + (directory-files tmpdir)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (directory-files nospecial-dir)))) + +(defun files-tests-file-attributes-equal (attr1 attr2) + ;; Element 4 is access time, which may be changed by the act of + ;; checking the attributes. + (setf (nth 4 attr1) nil) + (setf (nth 4 attr2) nil) + ;; Element 9 is unspecified. + (setf (nth 9 attr1) nil) + (setf (nth 9 attr2) nil) + (equal attr1 attr2)) + +(ert-deftest files-tests-file-name-non-special-directory-files-and-attributes () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (cl-loop for (file1 . attr1) in (directory-files-and-attributes nospecial-dir) + for (file2 . attr2) in (directory-files-and-attributes tmpdir) + do + (should (equal file1 file2)) + (should (files-tests-file-attributes-equal attr1 attr2)))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (directory-files-and-attributes nospecial-dir)))) + +(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)) + (ert-skip "FIXME: `dired-compress-file' unreliable when filenames contain `:'.")) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((compressed (dired-compress-file nospecial))) + (when compressed + ;; FIXME: Should it return a still-quoted name? + (should (file-equal-p nospecial (dired-compress-file compressed)))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (dired-compress-file nospecial)))) + +(ert-deftest files-tests-file-name-non-special-dired-uncache () + ;; FIXME: This is not a real test. We need cached values, and check + ;; whether they disappear. + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (dired-uncache nospecial-dir)) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (dired-uncache nospecial-dir))) + +(ert-deftest files-tests-file-name-non-special-expand-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (expand-file-name nospecial) nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (expand-file-name nospecial) nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-accessible-directory-p () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (file-accessible-directory-p nospecial-dir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (file-accessible-directory-p nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-file-acl () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-acl nospecial) (file-acl tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-acl nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-attributes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (files-tests-file-attributes-equal + (file-attributes nospecial) (file-attributes tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-attributes nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-directory-p () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (file-directory-p nospecial-dir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (file-directory-p nospecial-dir)))) + +(ert-deftest files-tests-file-name-non-special-file-equal-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-equal-p nospecial tmpfile)) + (should (file-equal-p tmpfile nospecial)) + (should (file-equal-p nospecial nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-equal-p (file-name-unquote nospecial) tmpfile)) + (should (file-equal-p tmpfile (file-name-unquote nospecial))) + ;; File `nospecial' does not exist, so it cannot be compared. + (should-not (file-equal-p nospecial nospecial)) + (write-region "foo" nil nospecial) + (should (file-equal-p nospecial nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-executable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-executable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-executable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-exists-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-exists-p tmpfile)) + (should (file-exists-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-exists-p tmpfile)) + (should-not (file-exists-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-in-directory-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory))) + (should (file-in-directory-p nospecial temporary-file-directory)) + (should (file-in-directory-p tmpfile nospecial-tempdir)) + (should (file-in-directory-p nospecial nospecial-tempdir)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory))) + (should (file-in-directory-p nospecial temporary-file-directory)) + (should (file-in-directory-p tmpfile nospecial-tempdir)) + (should (file-in-directory-p nospecial nospecial-tempdir))))) + +(ert-deftest files-tests-file-name-non-special-file-local-copy () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-local-copy nospecial))) ; Already local. + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-local-copy nospecial)))) ; Already local. + +(ert-deftest files-tests-file-name-non-special-file-modes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-modes nospecial) (file-modes tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (equal (file-modes nospecial) (file-modes tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-all-completions () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should (string-equal file nospecial-file)) + (should (equal (file-name-all-completions + nospecial-file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions nospecial-file tmpdir) + (file-name-all-completions file tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should-not (string-equal file nospecial-file)) + (should-not (equal (file-name-all-completions + nospecial-file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions file nospecial-tempdir) + (file-name-all-completions file tmpdir))) + (should (equal (file-name-all-completions nospecial-file tmpdir) + (file-name-all-completions file tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-as-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (file-name-as-directory nospecial-dir) + (file-name-quote (file-name-as-directory tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-not (equal (file-name-as-directory nospecial-dir) + (file-name-quote (file-name-as-directory tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-case-insensitive-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-case-insensitive-p nospecial) + (file-name-case-insensitive-p tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-case-insensitive-p nospecial) + (file-name-case-insensitive-p tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-completion () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should (string-equal file nospecial-file)) + (should (equal (file-name-completion nospecial-file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion nospecial-file tmpdir) + (file-name-completion file tmpdir))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((nospecial-tempdir (file-name-quote temporary-file-directory)) + (tmpdir temporary-file-directory) + (file (file-name-nondirectory tmpfile)) + (nospecial-file (file-name-nondirectory nospecial))) + (should-not (string-equal file nospecial-file)) + (should-not (equal (file-name-completion nospecial-file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion file nospecial-tempdir) + (file-name-completion file tmpdir))) + (should (equal (file-name-completion nospecial-file tmpdir) + (file-name-completion file tmpdir)))))) + +(ert-deftest files-tests-file-name-non-special-file-name-directory () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-directory nospecial) + (file-name-quote temporary-file-directory)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-directory nospecial) + (file-name-quote temporary-file-directory))))) + +(ert-deftest files-tests-file-name-non-special-file-name-nondirectory () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-nondirectory nospecial) + (file-name-nondirectory tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (equal (file-name-nondirectory nospecial) + (file-name-nondirectory tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-name-sans-versions () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-name-sans-versions nospecial) nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-name-sans-versions nospecial) nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-newer-than-file-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-newer-than-file-p nospecial tmpfile)) + (should-not (file-newer-than-file-p tmpfile nospecial)) + (should-not (file-newer-than-file-p nospecial nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-newer-than-file-p nospecial tmpfile)) + (should (file-newer-than-file-p tmpfile nospecial)) + (should-not (file-newer-than-file-p nospecial nospecial)))) + +(ert-deftest files-tests-file-name-non-special-notify-handlers () + (skip-unless file-notify--library) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((watch (file-notify-add-watch nospecial '(change) #'ignore))) + (should (file-notify-valid-p watch)) + (file-notify-rm-watch watch) + (should-not (file-notify-valid-p watch)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((watch (file-notify-add-watch nospecial '(change) #'ignore))) + (should (file-notify-valid-p watch)) + (file-notify-rm-watch watch) + (should-not (file-notify-valid-p watch))))) + +(ert-deftest files-tests-file-name-non-special-file-ownership-preserved-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (file-ownership-preserved-p nospecial) + (file-ownership-preserved-p tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (file-ownership-preserved-p nospecial) + (file-ownership-preserved-p tmpfile))))) + +(ert-deftest files-tests-file-name-non-special-file-readable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-readable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-readable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-regular-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-regular-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-regular-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-remote-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-remote-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-remote-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-selinux-context () + (files-tests--with-temp-non-special (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should (equal (file-selinux-context nospecial) + (file-selinux-context tmpfile))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should-not (equal (file-selinux-context nospecial) + (file-selinux-context tmpfile)))))) + +(ert-deftest files-tests-file-name-non-special-file-symlink-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (file-symlink-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (file-symlink-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-file-truename () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal nospecial (file-truename nospecial)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal nospecial (file-truename nospecial))))) + +(ert-deftest files-tests-file-name-non-special-file-writable-p () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (file-writable-p nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (file-writable-p nospecial)))) + +(ert-deftest files-tests-file-name-non-special-find-backup-file-name () + (let (version-control delete-old-versions + (kept-old-versions (default-toplevel-value 'kept-old-versions)) + (kept-new-versions (default-toplevel-value 'kept-new-versions))) + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (find-backup-file-name nospecial) + (mapcar #'file-name-quote + (find-backup-file-name tmpfile))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpfile nospecial) + (should-not (equal (find-backup-file-name nospecial) + (mapcar #'file-name-quote + (find-backup-file-name tmpfile))))))) + +(ert-deftest files-tests-file-name-non-special-get-file-buffer () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should-not (get-file-buffer nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-not (get-file-buffer nospecial)))) + +(ert-deftest files-tests-file-name-non-special-insert-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (should (equal (with-temp-buffer + (insert-directory nospecial-dir "") + (buffer-string)) + (with-temp-buffer + (insert-directory tmpdir "") + (buffer-string))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (should-error (with-temp-buffer (insert-directory nospecial-dir ""))))) + +(ert-deftest files-tests-file-name-non-special-insert-file-contents () + (files-tests--with-temp-non-special (tmpfile nospecial) + (with-temp-buffer + (insert-file-contents nospecial) + (should (zerop (buffer-size))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (with-temp-buffer (insert-file-contents nospecial))))) + +(ert-deftest files-tests-file-name-non-special-load () + (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)))) + +(ert-deftest files-tests-file-name-non-special-make-auto-save-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (save-current-buffer + (should (equal (prog2 (set-buffer (find-file-noselect nospecial)) + (make-auto-save-file-name) + (kill-buffer)) + (prog2 (set-buffer (find-file-noselect tmpfile)) + (make-auto-save-file-name) + (kill-buffer)))))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (save-current-buffer + (should-not (equal (prog2 (set-buffer (find-file-noselect nospecial)) + (make-auto-save-file-name) + (kill-buffer)) + (prog2 (set-buffer (find-file-noselect tmpfile)) + (make-auto-save-file-name) + (kill-buffer))))))) + +(ert-deftest files-tests-file-name-non-special-make-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (make-directory "dir") + (should (file-directory-p "dir")) + (delete-directory "dir"))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (should-error (make-directory "dir"))))) + +(ert-deftest files-tests-file-name-non-special-make-directory-internal () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (make-directory-internal "dir") + (should (file-directory-p "dir")) + (delete-directory "dir"))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (should-error (make-directory-internal "dir"))))) + +(ert-deftest files-tests-file-name-non-special-make-nearby-temp-file () + (let* ((default-directory (file-name-quote temporary-file-directory)) + (near-tmpfile (make-nearby-temp-file "file"))) + (should (file-exists-p near-tmpfile)) + (delete-file near-tmpfile))) + +(ert-deftest files-tests-file-name-non-special-make-symbolic-link () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (files-tests--with-temp-non-special (tmpfile nospecial) + (let* ((linkname (expand-file-name "link" tmpdir)) + (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname) + t))) + (when may-symlink + (should (file-symlink-p linkname)) + (delete-file linkname) + (let ((linkname (expand-file-name "link" nospecial-dir))) + (make-symbolic-link tmpfile linkname) + (should (file-symlink-p linkname)) + (delete-file linkname)))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpfile nospecial) + (let* ((linkname (expand-file-name "link" tmpdir)) + (may-symlink (ignore-errors (make-symbolic-link tmpfile linkname) + t))) + (when may-symlink + (should (file-symlink-p linkname)) + (delete-file linkname) + (let ((linkname (expand-file-name "link" nospecial-dir))) + (should-error (make-symbolic-link tmpfile linkname)))))))) + +;; See `files-tests--file-name-non-special--subprocess'. +;; (ert-deftest files-tests-file-name-non-special-process-file ()) + +(ert-deftest files-tests-file-name-non-special-rename-file () + (files-tests--with-temp-non-special (tmpfile nospecial) + (rename-file nospecial (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file tmpfile (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file nospecial (files-tests--new-name tmpfile "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (rename-file nospecial (files-tests--new-name nospecial "x"))) + (rename-file tmpfile (files-tests--new-name nospecial "x")) + (rename-file (files-tests--new-name nospecial "x") nospecial) + (rename-file nospecial (files-tests--new-name tmpfile "x")) + (should-error (rename-file (files-tests--new-name nospecial "x") nospecial)) + (delete-file (files-tests--new-name tmpfile "x")) + (delete-file (files-tests--new-name nospecial "x")))) + +(ert-deftest files-tests-file-name-non-special-set-file-acl () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-acl nospecial (file-acl nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (set-file-acl nospecial (file-acl nospecial)))) + +(ert-deftest files-tests-file-name-non-special-set-file-modes () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-modes nospecial (file-modes nospecial))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (set-file-modes nospecial (file-modes nospecial))))) + +(ert-deftest files-tests-file-name-non-special-set-file-selinux-context () + (files-tests--with-temp-non-special (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (set-file-selinux-context nospecial (file-selinux-context nospecial)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (unless (equal (file-selinux-context tmpfile) '(nil nil nil nil)) + (should-error + (set-file-selinux-context nospecial (file-selinux-context nospecial)))))) + +(ert-deftest files-tests-file-name-non-special-set-file-times () + (files-tests--with-temp-non-special (tmpfile nospecial) + (set-file-times nospecial)) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should-error (set-file-times nospecial)))) + +(ert-deftest files-tests-file-name-non-special-set-visited-file-modtime () + (files-tests--with-temp-non-special (tmpfile nospecial) + (save-current-buffer + (set-buffer (find-file-noselect nospecial)) + (set-visited-file-modtime) + (kill-buffer))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (save-current-buffer + (set-buffer (find-file-noselect nospecial)) + (set-visited-file-modtime) + (kill-buffer)))) + +(ert-deftest files-tests-file-name-non-special-shell-command () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (shell-command (concat (shell-quote-argument + (concat invocation-directory invocation-name)) + " --version") + (current-buffer)) + (goto-char (point-min)) + (should (search-forward emacs-version nil t))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (should-error + (shell-command (concat (shell-quote-argument + (concat invocation-directory invocation-name)) + " --version") + (current-buffer))))))) + +(ert-deftest files-tests-file-name-non-special-start-file-process () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (let ((proc (start-file-process + "emacs" (current-buffer) + (concat invocation-directory invocation-name) + "--version"))) + (accept-process-output proc) + (goto-char (point-min)) + (should (search-forward emacs-version nil t)) + ;; Don't stop the test run with a query, as the subprocess + ;; may or may not be dead by the time we reach here. + (set-process-query-on-exit-flag proc nil))))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (with-temp-buffer + (let ((default-directory nospecial-dir)) + (should-error (start-file-process + "emacs" (current-buffer) + (concat invocation-directory invocation-name) + "--version")))))) + +(ert-deftest files-tests-file-name-non-special-substitute-in-file-name () + (files-tests--with-temp-non-special (tmpfile nospecial) + (let ((process-environment (cons "FOO=foo" process-environment)) + (nospecial-foo (files-tests--new-name nospecial "$FOO"))) + ;; The "/:" prevents substitution. + (equal (substitute-in-file-name nospecial-foo) nospecial-foo))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (let ((process-environment (cons "FOO=foo" process-environment)) + (nospecial-foo (files-tests--new-name nospecial "$FOO"))) + ;; The "/:" prevents substitution. + (equal (substitute-in-file-name nospecial-foo) nospecial-foo)))) + +(ert-deftest files-tests-file-name-non-special-temporary-file-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (equal (temporary-file-directory) temporary-file-directory))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (let ((default-directory nospecial-dir)) + (equal (temporary-file-directory) temporary-file-directory)))) + +(ert-deftest files-tests-file-name-non-special-unhandled-file-name-directory () + (files-tests--with-temp-non-special (tmpdir nospecial-dir t) + (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir))) + (files-tests--with-temp-non-special-and-file-name-handler + (tmpdir nospecial-dir t) + (equal (unhandled-file-name-directory nospecial-dir) + (file-name-as-directory tmpdir)))) + +(ert-deftest files-tests-file-name-non-special-vc-registered () + (files-tests--with-temp-non-special (tmpfile nospecial) + (should (equal (vc-registered nospecial) (vc-registered tmpfile)))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (should (equal (vc-registered nospecial) (vc-registered tmpfile))))) + +;; See test `files-tests--file-name-non-special--buffers'. +;; (ert-deftest files-tests-file-name-non-special-verify-visited-file-modtime ()) + +(ert-deftest files-tests-file-name-non-special-write-region () + (files-tests--with-temp-non-special (tmpfile nospecial) + (with-temp-buffer + (write-region nil nil nospecial nil :visit))) + (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) + (with-temp-buffer + (write-region nil nil nospecial nil :visit)))) + +(ert-deftest files-tests-file-name-non-special-make-process () + "Check that the ‘:file-handler’ argument of ‘make-process’ +works as expected if the default directory is quoted." + (let ((default-directory (file-name-quote invocation-directory)) + (program (file-name-quote + (expand-file-name invocation-name invocation-directory)))) + (should (processp (make-process :name "name" + :command (list program "--version") + :file-handler t))))) + (ert-deftest files-tests--insert-directory-wildcard-in-dir-p () (let ((alist (list (cons "/home/user/*/.txt" (cons "/home/user/" "*/.txt")) (cons "/home/user/.txt" nil) @@ -373,7 +1167,8 @@ consider the buffer saved, without prompting for a file name (Bug#28412)." (let ((read-file-name-function (lambda (&rest _ignore) - (error "Prompting for file name")))) + (error "Prompting for file name"))) + require-final-newline) ;; With contents function, and no file. (with-temp-buffer (setq write-contents-functions (lambda () t)) diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index 33e438300aa..4b7c91f130d 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -26,8 +26,6 @@ ;;; Code: ;; registry.el is required by gnus-registry.el but this way we're explicit. -(eval-when-compile (require 'cl)) - (require 'registry) (require 'gnus-registry) diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el index c55ccbf34d0..aa3587dddf5 100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@ -29,6 +29,8 @@ (require 'ert) (require 'ert-x) +(require 'cl-lib) + (ert-deftest message-mode-propertize () (with-temp-buffer (unwind-protect @@ -97,6 +99,60 @@ (should (string= stripped-was (message-strip-subject-trailing-was with-was))))))) +(ert-deftest message-all-recipients () + (ert-with-test-buffer (:name "message") + (insert "To: Person 1 <p1@p1.org>, Person 2 <p2@p2.org>\n") + (insert "Cc: Person 3 <p3@p3.org>, Person 4 <p4@p4.org>\n") + (insert "Bcc: Person 5 <p5@p5.org>, Person 6 <p6@p6.org>\n") + (should (equal (message-all-recipients) + '(("Person 1" "p1@p1.org") + ("Person 2" "p2@p2.org") + ("Person 3" "p3@p3.org") + ("Person 4" "p4@p4.org") + ("Person 5" "p5@p5.org") + ("Person 6" "p6@p6.org")))))) + +(ert-deftest message-all-epg-keys-available-p () + (skip-unless (epg-check-configuration (epg-find-configuration 'OpenPGP))) + (let ((person1 '("Person 1" "p1@p1.org")) + (person2 '("Person 2" "p2@p2.org")) + (person3 '("Person 3" "p3@p3.org")) + (recipients nil) + (keyring '("p1@p1.org" "p2@p2.org"))) + (cl-letf (((symbol-function 'epg-list-keys) + (lambda (_ email) (cl-find email keyring :test #'string=))) + ((symbol-function 'message-all-recipients) + (lambda () recipients))) + + (setq recipients (list)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2)) + (should (message-all-epg-keys-available-p)) + + (setq recipients (list person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person3)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person3 person1)) + (should-not (message-all-epg-keys-available-p)) + + (setq recipients (list person1 person2 person3)) + (should-not (message-all-epg-keys-available-p))))) + +(ert-deftest message-alter-repeat-address () + (should (equal (message--alter-repeat-address + "Lars Ingebrigtsen <larsi@gnus.org>") + "Lars Ingebrigtsen <larsi@gnus.org>")) + + (should (equal (message--alter-repeat-address + "\"larsi@gnus.org\" <larsi@gnus.org>") + "larsi@gnus.org"))) (provide 'message-mode-tests) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 66a96e6fa50..e31ac6a4d48 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -81,6 +81,11 @@ Return first line of the output of (describe-function-1 FUNC)." (result (help-fns-tests--describe-function 'search-forward-regexp))) (should (string-match regexp result)))) +(ert-deftest help-fns-test-dangling-alias () + "Make sure we don't burp on bogus aliases." + (let ((f (make-symbol "bogus-alias"))) + (define-obsolete-function-alias f 'help-fns-test--undefined-function "past") + (describe-symbol f))) ;;; Test describe-function over functions with funny names (defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x) diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index 8dd872398e5..c4d25b69e14 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -29,7 +29,7 @@ (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 _x _y _z _hist defaults) (car defaults)))) (dotimes (_ 2) (let ((face (hi-lock-read-face-name))) @@ -41,7 +41,7 @@ (with-temp-buffer (insert "foo bar") (cl-letf (((symbol-function 'completing-read) - (lambda (prompt coll x y z hist defaults) + (lambda (_prompt _coll _x _y _z _hist defaults) (car defaults)))) (hi-lock-set-pattern "9999" (hi-lock-read-face-name)) ; No match (hi-lock-set-pattern "foo" (hi-lock-read-face-name))) diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el index 08163874ac2..ada8294984e 100644 --- a/test/lisp/htmlfontify-tests.el +++ b/test/lisp/htmlfontify-tests.el @@ -36,7 +36,7 @@ available (Bug#25468)." (should (equal (let ((process-environment (cons "SHELL=/does/not/exist" process-environment))) (call-process - (expand-file-name (invocation-name) (invocation-directory)) + (expand-file-name invocation-name invocation-directory) nil nil nil "--quick" "--batch" (concat "--load=" (locate-library "htmlfontify")))) diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index ed6fa417f5f..1de3a0d0627 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -144,4 +144,21 @@ text. (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." + :tags '(:expensive-test) + (require 'info) + (let ((default-directory (car (Info-default-dirs))) + (Info-directory-list '("."))) + (skip-unless (file-readable-p "emacs.info")) + (info-xref-check-all) + (with-current-buffer info-xref-output-buffer + (goto-char (point-max)) + (should (search-backward "done" nil t)) + (should (string-match-p + " [0-9]\\{3,\\} good, 0 bad" + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))))))) + + ;;; info-xref.el ends here diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el new file mode 100644 index 00000000000..7dd7224726b --- /dev/null +++ b/test/lisp/international/ccl-tests.el @@ -0,0 +1,229 @@ +;; Copyright (C) 2018 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 'ccl) +(require 'seq) + + +(ert-deftest shift () + ;; shift left +ve 5628 #x00000000000015fc + (should (= (ash 5628 8) 1440768)) ; #x000000000015fc00 + (should (= (lsh 5628 8) 1440768)) ; #x000000000015fc00 + + ;; shift left -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 8) -1440768)) ; #x3fffffffffea0400 + (should (= (lsh -5628 8) -1440768)) ; #x3fffffffffea0400 + + ;; shift right +ve 5628 #x00000000000015fc + (should (= (ash 5628 -8) 21)) ; #x0000000000000015 + (should (= (lsh 5628 -8) 21)) ; #x0000000000000015 + + ;; shift right -ve -5628 #x3fffffffffffea04 + (should (= (ash -5628 -8) -22)) ; #x3fffffffffffffea + (should (= (lsh -5628 -8) + (ash (- -5628 (ash most-negative-fixnum 1)) -8) + (ash (logand (ash -5628 -1) most-positive-fixnum) -7)))) + +;; CCl program from `pgg-parse-crc24' in lisp/obsolete/pgg-parse.el +(defconst prog-pgg-source + '(1 + ((loop + (read r0) (r1 ^= r0) (r2 ^= 0) + (r5 = 0) + (loop + (r1 <<= 1) + (r1 += ((r2 >> 15) & 1)) + (r2 <<= 1) + (if (r1 & 256) + ((r1 ^= 390) (r2 ^= 19707))) + (if (r5 < 7) + ((r5 += 1) + (repeat)))) + (repeat))))) + +(defconst prog-pgg-code + [1 30 14 114744 114775 0 161 131127 1 148217 15 82167 + 1 1848 131159 1 1595 5 256 114743 390 114775 19707 + 1467 16 7 183 1 -5628 -7164 22]) + +(defconst prog-pgg-dump +"Out-buffer must be as large as in-buffer. +Main-body: + 2:[read-register] read r0 (0 remaining) + 3:[set-assign-expr-register] r1 ^= r0 + 4:[set-assign-expr-const] r2 ^= 0 + 6:[set-short-const] r5 = 0 + 7:[set-assign-expr-const] r1 <<= 1 + 9:[set-expr-const] r7 = r2 >> 15 + 11:[set-assign-expr-const] r7 &= 1 + 13:[set-assign-expr-register] r1 += r7 + 14:[set-assign-expr-const] r2 <<= 1 + 16:[jump-cond-expr-const] if !(r1 & 256), jump to 23(+7) + 19:[set-assign-expr-const] r1 ^= 390 + 21:[set-assign-expr-const] r2 ^= 19707 + 23:[jump-cond-expr-const] if !(r5 < 7), jump to 29(+6) + 26:[set-assign-expr-const] r5 += 1 + 28:[jump] jump to 7(-21) + 29:[jump] jump to 2(-27) +At EOF: + 30:[end] end +") + +(ert-deftest ccl-compile-pgg () + (should (equal (ccl-compile prog-pgg-source) prog-pgg-code))) + +(ert-deftest ccl-dump-pgg () + (with-temp-buffer + (ccl-dump prog-pgg-code) + (should (equal (buffer-string) prog-pgg-dump)))) + +(ert-deftest pgg-parse-crc24 () + ;; Compiler + (require 'pgg) + (should (equal pgg-parse-crc24 prog-pgg-code)) + ;; Interpreter + (should (equal (pgg-parse-crc24-string "foo") (concat [#x4f #xc2 #x55]))) + (should (equal (pgg-parse-crc24-string "bar") (concat [#x51 #xd9 #x53]))) + (should (equal (pgg-parse-crc24-string "baz") (concat [#xf0 #x58 #x6a])))) + +(ert-deftest pgg-parse-crc24-dump () + ;; Disassembler + (require 'pgg) + (with-temp-buffer + (ccl-dump pgg-parse-crc24) + (should (equal (buffer-string) prog-pgg-dump)))) + +;;---------------------------------------------------------------------------- +;; Program from 'midikbd-decoder in midi-kbd-0.2.el GNU ELPA package +(defconst prog-midi-source + '(2 + (loop + (loop + ;; central message receiver loop here. + ;; When it exits, the command to deal with is in r0 + ;; Any arguments are in r1 and r2 + ;; r3 contains: 0 if no arguments are accepted + ;; 1 if 1 argument can be accepted + ;; 2 if 2 arguments can be accepted + ;; 3 if the first of two arguments has been accepted + ;; Arguments are read into r1 and r2. + ;; r4 contains the current running status byte if any. + (read-if (r0 < #x80) + (branch r3 + (repeat) + ((r1 = r0) (r0 = r4) (break)) + ((r1 = r0) (r3 = 3) (repeat)) + ((r2 = r0) (r3 = 2) (r0 = r4) (break)))) + (if (r0 >= #xf8) ; real time message + (break)) + (if (r0 < #xf0) ; channel command + ((r4 = r0) + (if ((r0 & #xe0) == #xc0) + ;; program change and channel pressure take only 1 argument + (r3 = 1) + (r3 = 2)) + (repeat))) + ;; system common message, we swallow those for now + (r3 = 0) + (repeat)) + (if ((r0 & #xf0) == #x90) + (if (r2 == 0) ; Some Midi devices use velocity 0 + ; for switching notes off, + ; so translate into note-off + ; and fall through + (r0 -= #x10) + ((r0 &= #xf) + (write 0) + (write r0 r1 r2) + (repeat)))) + (if ((r0 & #xf0) == #x80) + ((r0 &= #xf) + (write 1) + (write r0 r1 r2) + (repeat))) + (repeat)))) + +(defconst prog-midi-code + [2 72 4893 16 128 1133 5 6 9 12 16 -2556 32 1024 6660 32 865 + -4092 64 609 1024 4868 795 20 248 3844 3099 16 240 128 82169 + 224 1275 18 192 353 260 609 -9468 97 -9980 82169 240 4091 + 18 144 1371 18 0 16407 16 1796 81943 15 20 529 305 81 -14588 + 82169 240 2555 18 128 81943 15 276 529 305 81 -17660 -17916 22]) + +(defconst prog-midi-dump +(concat "Out-buffer must be 2 times bigger than in-buffer. +Main-body: + 2:[read-jump-cond-expr-const] read r0, if !(r0 < 128), jump to 22(+20) + 5:[branch] jump to array[r3] of length 4 + 11 12 15 18 22 "" + 11:[jump] jump to 2(-9) + 12:[set-register] r1 = r0 + 13:[set-register] r0 = r4 + 14:[jump] jump to 41(+27) + 15:[set-register] r1 = r0 + 16:[set-short-const] r3 = 3 + 17:[jump] jump to 2(-15) + 18:[set-register] r2 = r0 + 19:[set-short-const] r3 = 2 + 20:[set-register] r0 = r4 + 21:[jump] jump to 41(+20) + 22:[jump-cond-expr-const] if !(r0 >= 248), jump to 26(+4) + 25:[jump] jump to 41(+16) + 26:[jump-cond-expr-const] if !(r0 < 240), jump to 39(+13) + 29:[set-register] r4 = r0 + 30:[set-expr-const] r7 = r0 & 224 + 32:[jump-cond-expr-const] if !(r7 == 192), jump to 37(+5) + 35:[set-short-const] r3 = 1 + 36:[jump] jump to 38(+2) + 37:[set-short-const] r3 = 2 + 38:[jump] jump to 2(-36) + 39:[set-short-const] r3 = 0 + 40:[jump] jump to 2(-38) + 41:[set-expr-const] r7 = r0 & 240 + 43:[jump-cond-expr-const] if !(r7 == 144), jump to 59(+16) + 46:[jump-cond-expr-const] if !(r2 == 0), jump to 52(+6) + 49:[set-assign-expr-const] r0 -= 16 + 51:[jump] jump to 59(+8) + 52:[set-assign-expr-const] r0 &= 15 + 54:[write-const-string] write char \"\x00\" + 55:[write-register] write r0 (2 remaining) + 56:[write-register] write r1 (1 remaining) + 57:[write-register] write r2 (0 remaining) + 58:[jump] jump to 2(-56) + 59:[set-expr-const] r7 = r0 & 240 + 61:[jump-cond-expr-const] if !(r7 == 128), jump to 71(+10) + 64:[set-assign-expr-const] r0 &= 15 + 66:[write-const-string] write char \"\x01\" + 67:[write-register] write r0 (2 remaining) + 68:[write-register] write r1 (1 remaining) + 69:[write-register] write r2 (0 remaining) + 70:[jump] jump to 2(-68) + 71:[jump] jump to 2(-69) +At EOF: + 72:[end] end +")) + +(ert-deftest ccl-compile-midi () + (should (equal (ccl-compile prog-midi-source) prog-midi-code))) + +(ert-deftest ccl-dump-midi () + (with-temp-buffer + (ccl-dump prog-midi-code) + (should (equal (buffer-string) prog-midi-dump)))) diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index d6098e7237e..8d1978f557c 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -325,5 +325,72 @@ Point is moved to beginning of the buffer." (with-temp-buffer (should-error (json-encode (current-buffer)) :type 'json-error))) +;;; Pretty-print + +(defun json-tests-equal-pretty-print (original &optional expected) + "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. + +Both ORIGINAL and EXPECTED should be strings. If EXPECTED is +nil, ORIGINAL should stay unchanged by pretty-printing." + (with-temp-buffer + (insert original) + (json-pretty-print-buffer) + (should (equal (buffer-string) (or expected original))))) + +(ert-deftest test-json-pretty-print-string () + (json-tests-equal-pretty-print "\"\"") + (json-tests-equal-pretty-print "\"foo\"")) + +(ert-deftest test-json-pretty-print-atom () + (json-tests-equal-pretty-print "true") + (json-tests-equal-pretty-print "false") + (json-tests-equal-pretty-print "null")) + +(ert-deftest test-json-pretty-print-number () + (json-tests-equal-pretty-print "123") + (json-tests-equal-pretty-print "0.123")) + +(ert-deftest test-json-pretty-print-object () + ;; empty (regression test for bug#24252) + (json-tests-equal-pretty-print + "{}" + "{\n}") + ;; one pair + (json-tests-equal-pretty-print + "{\"key\":1}" + "{\n \"key\": 1\n}") + ;; two pairs + (json-tests-equal-pretty-print + "{\"key1\":1,\"key2\":2}" + "{\n \"key1\": 1,\n \"key2\": 2\n}") + ;; embedded object + (json-tests-equal-pretty-print + "{\"foo\":{\"key\":1}}" + "{\n \"foo\": {\n \"key\": 1\n }\n}") + ;; embedded array + (json-tests-equal-pretty-print + "{\"key\":[1,2]}" + "{\n \"key\": [\n 1,\n 2\n ]\n}")) + +(ert-deftest test-json-pretty-print-array () + ;; empty + (json-tests-equal-pretty-print "[]") + ;; one item + (json-tests-equal-pretty-print + "[1]" + "[\n 1\n]") + ;; two items + (json-tests-equal-pretty-print + "[1,2]" + "[\n 1,\n 2\n]") + ;; embedded object + (json-tests-equal-pretty-print + "[{\"key\":1}]" + "[\n {\n \"key\": 1\n }\n]") + ;; embedded array + (json-tests-equal-pretty-print + "[[1,2]]" + "[\n [\n 1,\n 2\n ]\n]")) + (provide 'json-tests) ;;; json-tests.el ends here diff --git a/test/lisp/jsonrpc-tests.el b/test/lisp/jsonrpc-tests.el new file mode 100644 index 00000000000..585eb20bfeb --- /dev/null +++ b/test/lisp/jsonrpc-tests.el @@ -0,0 +1,254 @@ +;;; jsonrpc-tests.el --- tests for jsonrpc.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: João Távora <joaotavora@gmail.com> +;; Maintainer: João Távora <joaotavora@gmail.com> +;; Keywords: tests + +;; 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: + +;; About "deferred" tests, `jsonrpc--test-client' has a flag that we +;; test in its `jsonrpc-connection-ready-p' API method. It holds any +;; `jsonrpc-request's and `jsonrpc-async-request's explicitly passed +;; `:deferred'. After clearing the flag, the held requests are +;; actually sent to the server in the next opportunity (when receiving +;; or sending something to the server). + +;;; Code: + +(require 'ert) +(require 'jsonrpc) +(require 'eieio) + +(defclass jsonrpc--test-endpoint (jsonrpc-process-connection) + ((scp :accessor jsonrpc--shutdown-complete-p))) + +(defclass jsonrpc--test-client (jsonrpc--test-endpoint) + ((hold-deferred :initform t :accessor jsonrpc--hold-deferred))) + +(defun jsonrpc--call-with-emacsrpc-fixture (fn) + "Do work for `jsonrpc--with-emacsrpc-fixture'. Call FN." + (let* (listen-server endpoint) + (unwind-protect + (progn + (setq listen-server + (make-network-process + :name "Emacs RPC server" :server t :host "localhost" + :service (if (version<= emacs-version "26.1") + 44444 + ;; 26.1 can automatically find ports if + ;; one passes 0 here. + 0) + :log (lambda (listen-server client _message) + (push + (make-instance + 'jsonrpc--test-endpoint + :name (process-name client) + :process client + :request-dispatcher + (lambda (_endpoint method params) + (unless (memq method '(+ - * / vconcat append + sit-for ignore)) + (signal 'jsonrpc-error + '((jsonrpc-error-message + . "Sorry, this isn't allowed") + (jsonrpc-error-code . -32601)))) + (apply method (append params nil))) + :on-shutdown + (lambda (conn) + (setf (jsonrpc--shutdown-complete-p conn) t))) + (process-get listen-server 'handlers))))) + (setq endpoint + (make-instance + 'jsonrpc--test-client + "Emacs RPC client" + :process + (open-network-stream "JSONRPC test tcp endpoint" + nil "localhost" + (process-contact listen-server + :service)) + :on-shutdown + (lambda (conn) + (setf (jsonrpc--shutdown-complete-p conn) t)))) + (funcall fn endpoint)) + (unwind-protect + (when endpoint + (kill-buffer (jsonrpc--events-buffer endpoint)) + (jsonrpc-shutdown endpoint)) + (when listen-server + (cl-loop do (delete-process listen-server) + while (progn (accept-process-output nil 0.1) + (process-live-p listen-server)) + do (jsonrpc--message + "test listen-server is still running, waiting")) + (cl-loop for handler in (process-get listen-server 'handlers) + do (ignore-errors (jsonrpc-shutdown handler))) + (mapc #'kill-buffer + (mapcar #'jsonrpc--events-buffer + (process-get listen-server 'handlers)))))))) + +(cl-defmacro jsonrpc--with-emacsrpc-fixture ((endpoint-sym) &body body) + `(jsonrpc--call-with-emacsrpc-fixture (lambda (,endpoint-sym) ,@body))) + +(ert-deftest returns-3 () + "A basic test for adding two numbers in our test RPC." + (jsonrpc--with-emacsrpc-fixture (conn) + (should (= 3 (jsonrpc-request conn '+ [1 2]))))) + +(ert-deftest errors-with--32601 () + "Errors with -32601" + (jsonrpc--with-emacsrpc-fixture (conn) + (condition-case err + (progn + (jsonrpc-request conn 'delete-directory "~/tmp") + (ert-fail "A `jsonrpc-error' should have been signalled!")) + (jsonrpc-error + (should (= -32601 (cdr (assoc 'jsonrpc-error-code (cdr err))))))))) + +(ert-deftest signals-an--32603-JSONRPC-error () + "Signals an -32603 JSONRPC error." + (jsonrpc--with-emacsrpc-fixture (conn) + (condition-case err + (progn + (jsonrpc-request conn '+ ["a" 2]) + (ert-fail "A `jsonrpc-error' should have been signalled!")) + (jsonrpc-error + (should (= -32603 (cdr (assoc 'jsonrpc-error-code (cdr err))))))))) + +(ert-deftest times-out () + "Request for 3-sec sit-for with 1-sec timeout times out." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + (jsonrpc-request conn 'sit-for [3] :timeout 1)))) + +(ert-deftest doesnt-time-out () + :tags '(:expensive-test) + "Request for 1-sec sit-for with 2-sec timeout succeeds." + (jsonrpc--with-emacsrpc-fixture (conn) + (jsonrpc-request conn 'sit-for [1] :timeout 2))) + +(ert-deftest stretching-it-but-works () + "Vector of numbers or vector of vector of numbers are serialized." + (jsonrpc--with-emacsrpc-fixture (conn) + ;; (vconcat [1 2 3] [3 4 5]) => [1 2 3 3 4 5] which can be + ;; serialized. + (should (equal + [1 2 3 3 4 5] + (jsonrpc-request conn 'vconcat [[1 2 3] [3 4 5]]))))) + +(ert-deftest json-el-cant-serialize-this () + "Can't serialize a response that is half-vector/half-list." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + ;; (append [1 2 3] [3 4 5]) => (1 2 3 . [3 4 5]), which can't be + ;; serialized + (jsonrpc-request conn 'append [[1 2 3] [3 4 5]])))) + +(cl-defmethod jsonrpc-connection-ready-p + ((conn jsonrpc--test-client) what) + (and (cl-call-next-method) + (or (not (string-match "deferred" what)) + (not (jsonrpc--hold-deferred conn))))) + +(ert-deftest deferred-action-toolate () + :tags '(:expensive-test) + "Deferred request fails because noone clears the flag." + (jsonrpc--with-emacsrpc-fixture (conn) + (should-error + (jsonrpc-request conn '+ [1 2] + :deferred "deferred-testing" :timeout 0.5) + :type 'jsonrpc-error) + (should + (= 3 (jsonrpc-request conn '+ [1 2] + :timeout 0.5))))) + +(ert-deftest deferred-action-intime () + :tags '(:expensive-test) + "Deferred request barely makes it after event clears a flag." + ;; Send an async request, which returns immediately. However the + ;; success fun which sets the flag only runs after some time. + (jsonrpc--with-emacsrpc-fixture (conn) + (jsonrpc-async-request conn + 'sit-for [0.5] + :success-fn + (lambda (_result) + (setf (jsonrpc--hold-deferred conn) nil))) + ;; Now wait for an answer to this request, which should be sent as + ;; soon as the previous one is answered. + (should + (= 3 (jsonrpc-request conn '+ [1 2] + :deferred "deferred" + :timeout 1))))) + +(ert-deftest deferred-action-complex-tests () + :tags '(:expensive-test) + "Test a more complex situation with deferred requests." + (jsonrpc--with-emacsrpc-fixture (conn) + (let (n-deferred-1 + n-deferred-2 + second-deferred-went-through-p) + ;; This returns immediately + (jsonrpc-async-request + conn + 'sit-for [0.1] + :success-fn + (lambda (_result) + ;; this only gets runs after the "first deferred" is stashed. + (setq n-deferred-1 + (hash-table-count (jsonrpc--deferred-actions conn))))) + (should-error + ;; This stashes the request and waits. It will error because + ;; no-one clears the "hold deferred" flag. + (jsonrpc-request conn 'ignore ["first deferred"] + :deferred "first deferred" + :timeout 0.5) + :type 'jsonrpc-error) + ;; The error means the deferred actions stash is now empty + (should (zerop (hash-table-count (jsonrpc--deferred-actions conn)))) + ;; Again, this returns immediately. + (jsonrpc-async-request + conn + 'sit-for [0.1] + :success-fn + (lambda (_result) + ;; This gets run while "third deferred" below is waiting for + ;; a reply. Notice that we clear the flag in time here. + (setq n-deferred-2 (hash-table-count (jsonrpc--deferred-actions conn))) + (setf (jsonrpc--hold-deferred conn) nil))) + ;; This again stashes a request and returns immediately. + (jsonrpc-async-request conn 'ignore ["second deferred"] + :deferred "second deferred" + :timeout 1 + :success-fn + (lambda (_result) + (setq second-deferred-went-through-p t))) + ;; And this also stashes a request, but waits. Eventually the + ;; flag is cleared in time and both requests go through. + (jsonrpc-request conn 'ignore ["third deferred"] + :deferred "third deferred" + :timeout 1) + ;; Wait another 0.5 secs just in case the success handlers of + ;; one of these last two requests didn't quite have a chance to + ;; run (Emacs 25.2 apparentely needs this). + (accept-process-output nil 0.5) + (should second-deferred-went-through-p) + (should (eq 1 n-deferred-1)) + (should (eq 2 n-deferred-2)) + (should (eq 0 (hash-table-count (jsonrpc--deferred-actions conn))))))) + +(provide 'jsonrpc-tests) +;;; jsonrpc-tests.el ends here diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index 2c1e46e5c5d..e97c0fcd004 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -26,6 +26,7 @@ ;;; Code: (require 'ert) (require 'ls-lisp) +(require 'dired) (ert-deftest ls-lisp-unload () "Test for https://debbugs.gnu.org/xxxxx ." diff --git a/test/lisp/mouse-tests.el b/test/lisp/mouse-tests.el index 68181b3b8e7..aa7b14545b9 100644 --- a/test/lisp/mouse-tests.el +++ b/test/lisp/mouse-tests.el @@ -27,24 +27,22 @@ (ert-deftest bug23288-use-return-value () "If `mouse-on-link-p' returns a string, its first character is used." - (cl-letf ((last-input-event '(down-mouse-1 nil 1)) - (unread-command-events '((mouse-1 nil 1))) + (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1))) (mouse-1-click-follows-link t) (mouse-1-click-in-non-selected-windows t) ((symbol-function 'mouse-on-link-p) (lambda (_pos) "abc"))) - (should-not (mouse--down-1-maybe-follows-link)) - (should (equal unread-command-events '(?a))))) + (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0)))) + (should (eq ?a (aref (read-key-sequence "") 0))))) (ert-deftest bug23288-translate-to-mouse-2 () "If `mouse-on-link-p' doesn't return a string or vector, translate `mouse-1' events into `mouse-2' events." - (cl-letf ((last-input-event '(down-mouse-1 nil 1)) - (unread-command-events '((mouse-1 nil 1))) + (cl-letf ((unread-command-events '((down-mouse-1 nil 1) (mouse-1 nil 1))) (mouse-1-click-follows-link t) (mouse-1-click-in-non-selected-windows t) ((symbol-function 'mouse-on-link-p) (lambda (_pos) t))) - (should-not (mouse--down-1-maybe-follows-link)) - (should (equal unread-command-events '((mouse-2 nil 1)))))) + (should (eq 'down-mouse-1 (car-safe (aref (read-key-sequence "") 0)))) + (should (eq 'mouse-2 (car-safe (aref (read-key-sequence "") 0)))))) (ert-deftest bug26816-mouse-frame-movement () "Mouse moves relative to frame." diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index b74594fb295..ea8dd7eb668 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -26,7 +26,7 @@ ;;; Code: (require 'ert) -(require 'cl) +(require 'cl-lib) (require 'gnutls) (require 'hex-util) @@ -46,22 +46,22 @@ (defvar gnutls-tests-tested-macs (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-macs)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-macs)))))) (defvar gnutls-tests-tested-digests (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-digests)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-digests)))))) (defvar gnutls-tests-tested-ciphers (when (gnutls-available-p) - (remove-duplicates - ; these cause FPEs or SEGVs - (remove-if (lambda (e) (memq e '(ARCFOUR-128))) - (mapcar 'car (gnutls-ciphers)))))) + (cl-remove-duplicates + ;; these cause FPEs or SEGVs + (cl-remove-if (lambda (e) (memq e '(ARCFOUR-128))) + (mapcar #'car (gnutls-ciphers)))))) (defvar gnutls-tests-mondo-strings (list @@ -154,7 +154,7 @@ ("0cc175b9c0f1b6a831c399e269772661" "a" MD5) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" SHA1) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" "SHA1"))) ; check string ID for digest - (destructuring-bind (hash input mac) test + (pcase-let ((`(,hash ,input ,mac) test)) (let ((plist (cdr (assq mac macs))) result resultb) (gnutls-tests-message "%s %S" mac plist) @@ -178,7 +178,7 @@ ("81568ba71fa2c5f33cc84bf362466988f98eba3735479100b4e8908acad87ac4" "more and more data goes into a file to exceed the buffer size" "very long key goes here to exceed the key size" SHA256) ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" "SHA256") ; check string ID for HMAC ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" SHA256))) - (destructuring-bind (hash input key mac) test + (pcase-let ((`(,hash ,input ,key ,mac) test)) (let ((plist (cdr (assq mac macs))) result) (gnutls-tests-message "%s %S" mac plist) @@ -214,7 +214,7 @@ (let ((keys '("mykey" "mykey2")) (inputs gnutls-tests-mondo-strings) (ivs '("" "-abc123-" "init" "ini2")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)) gnutls-tests-tested-ciphers))) @@ -252,7 +252,7 @@ "auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data " "AUTH data and more data to go over the block limit!" "AUTH data and more data to go over the block limit")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (or (null (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)))) gnutls-tests-tested-ciphers)) diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el new file mode 100644 index 00000000000..d34b0021952 --- /dev/null +++ b/test/lisp/net/secrets-tests.el @@ -0,0 +1,268 @@ +;;; secrets-tests.el --- Tests of Secret Service API + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Code: + +(require 'ert) +(require 'secrets) +(require 'notifications) + +;; We do not want chatty messages. +(setq secrets-debug nil) + +(ert-deftest secrets-test00-availability () + "Test availability of Secret Service API." + :expected-result (if secrets-enabled :passed :failed) + (should secrets-enabled) + (should (dbus-ping :session secrets-service)) + + ;; Exit. + (secrets--test-close-all-sessions)) + +(defun secrets--test-get-all-sessions () + "Return all object paths for existing secrets sessions." + (let ((session-path (concat secrets-path "/session"))) + (delete + session-path + (dbus-introspect-get-all-nodes :session secrets-service session-path)))) + +(defun secrets--test-close-all-sessions () + "Close all secrets sessions which are bound to this Emacs." + (secrets-close-session) + ;; We loop over all other sessions. If a session does not belong to + ;; us, a `dbus-error' is fired, which we ignore. + (dolist (path (secrets--test-get-all-sessions)) + (dbus-ignore-errors + (dbus-call-method + :session secrets-service path secrets-interface-session "Close")))) + +(defun secrets--test-delete-all-session-items () + "Delete all items of collection \"session\" bound to this Emacs." + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item))) + +(ert-deftest secrets-test01-sessions () + "Test opening / closing a secrets session." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + ;; Simple opening / closing of a session. + (should (secrets-open-session)) + (should-not (secrets-empty-path secrets-session-path)) + (should (secrets-close-session)) + (should (secrets-empty-path secrets-session-path)) + + ;; Reopening a new session. + (should (string-equal (secrets-open-session) (secrets-open-session))) + (should (string-equal secrets-session-path (secrets-open-session))) + (should-not + (string-equal (secrets-open-session) (secrets-open-session 'reopen))) + (should-not + (string-equal secrets-session-path (secrets-open-session 'reopen)))) + + ;; Exit. + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test02-collections () + "Test creation / deletion a secrets collections." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + (should (secrets-open-session)) + (should (member "session" (secrets-list-collections))) + + ;; Create a random collection. This asks for a password + ;; outside our control, so we make it in the interactive case + ;; only. + (unless noninteractive + (let ((collection (md5 (concat (prin1-to-string process-environment) + (current-time-string)))) + (alias (secrets-get-alias "default"))) + (notifications-notify + :title (symbol-name (ert-test-name (ert-running-test))) + :body "Please enter the password \"secret\" twice") + ;; The optional argument ALIAS does not seem to work. + (should (secrets-create-collection collection)) + (should (member collection (secrets-list-collections))) + + ;; We reset the alias. The temporary collection "session" + ;; is not accepted. + (secrets-set-alias collection "default") + (should (string-equal (secrets-get-alias "default") collection)) + + ;; Delete alias. + (secrets-delete-alias "default") + (should-not (secrets-get-alias "default")) + + ;; Lock / unlock the collection. + (secrets-lock-collection collection) + (should + (secrets-get-collection-property + (secrets-collection-path collection) "Locked")) + (notifications-notify + :title (symbol-name (ert-test-name (ert-running-test))) + :body "Please enter the password \"secret\"") + (secrets-unlock-collection collection) + (should-not + (secrets-get-collection-property + (secrets-collection-path collection) "Locked")) + + ;; Delete the collection. The alias disappears as well. + (secrets-set-alias collection "default") + (secrets-delete-collection collection) + (should-not (secrets-get-alias "default")) + + ;; Reset alias. + (when alias + (secrets-set-alias alias "default") + (should (string-equal (secrets-get-alias "default") alias)))))) + + ;; Exit. + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test03-items () + "Test creation / deletion a secret item." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (let (item-path) + (should (secrets-open-session)) + + ;; Cleanup. There could be items in the "session" collection. + (secrets--test-delete-all-session-items) + + ;; There shall be no items in the "session" collection. + (should-not (secrets-list-items "session")) + + ;; Create a new item. + (should (setq item-path (secrets-create-item "session" "foo" "secret"))) + (dolist (item `("foo" ,item-path)) + (should (string-equal (secrets-get-secret "session" item) "secret"))) + + ;; Create another item with same label. + (should (secrets-create-item "session" "foo" "geheim")) + (should (equal (secrets-list-items "session") '("foo" "foo"))) + + ;; Create an item with attributes. + (should + (setq item-path + (secrets-create-item + "session" "bar" "secret" + :method "sudo" :user "joe" :host "remote-host"))) + (dolist (item `("bar" ,item-path)) + (should + (string-equal (secrets-get-attribute "session" item :method) "sudo")) + ;; The attributes are collected in reverse order. + ;; :xdg:schema is added silently. + (should + (equal + (secrets-get-attributes "session" item) + '((:xdg:schema . "org.freedesktop.Secret.Generic") + (:host . "remote-host") (:user . "joe") (:method . "sudo"))))) + + ;; Create an item with another schema. + (should + (setq item-path + (secrets-create-item + "session" "baz" "secret" :xdg:schema "org.gnu.Emacs.foo"))) + (dolist (item `("baz" ,item-path)) + (should + (equal + (secrets-get-attributes "session" item) + '((:xdg:schema . "org.gnu.Emacs.foo"))))) + + ;; Delete them. + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item)) + (should-not (secrets-list-items "session"))) + + ;; Exit. + (secrets--test-delete-all-session-items) + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(ert-deftest secrets-test04-search () + "Test searching of secret items." + (skip-unless secrets-enabled) + (skip-unless (secrets-empty-path secrets-session-path)) + + (unwind-protect + (progn + (should (secrets-open-session)) + + ;; Cleanup. There could be items in the "session" collection. + (secrets--test-delete-all-session-items) + + ;; There shall be no items in the "session" collection. + (should-not (secrets-list-items "session")) + + ;; Create some items. + (should + (secrets-create-item + "session" "foo" "secret" + :method "sudo" :user "joe" :host "remote-host")) + (should + (secrets-create-item + "session" "bar" "secret" + :method "sudo" :user "smith" :host "remote-host")) + (should + (secrets-create-item + "session" "baz" "secret" + :method "ssh" :user "joe" :host "other-host")) + + ;; Search the items. `secrets-search-items' uses + ;; `secrets-search-item-paths' internally, it is sufficient to + ;; test only one of them. + (should-not (secrets-search-item-paths "session" :user "john")) + (should-not (secrets-search-items "session" :user "john")) + (should-not + (secrets-search-items "session" :xdg:schema "org.gnu.Emacs.foo")) + (should + (equal + (sort (secrets-search-items "session" :user "joe") 'string-lessp) + '("baz" "foo"))) + (should + (equal + (secrets-search-items "session":method "sudo" :user "joe") '("foo"))) + (should + (equal + (sort (secrets-search-items "session") 'string-lessp) + '("bar" "baz" "foo")))) + + ;; Exit. + (secrets--test-delete-all-session-items) + (should (secrets-close-session)) + (secrets--test-close-all-sessions))) + +(defun secrets-test-all (&optional interactive) + "Run all tests for \\[secrets]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^secrets")) + +(provide 'secrets-tests) +;;; secrets-tests.el ends here diff --git a/test/lisp/net/tramp-archive-resources/foo.iso/foo b/test/lisp/net/tramp-archive-resources/foo.iso/foo new file mode 100644 index 00000000000..257cc5642cb --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.iso/foo @@ -0,0 +1 @@ +foo diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz Binary files differnew file mode 100644 index 00000000000..0d2e9878dd7 --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.tar.gz diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el new file mode 100644 index 00000000000..f902ed5e755 --- /dev/null +++ b/test/lisp/net/tramp-archive-tests.el @@ -0,0 +1,950 @@ +;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `https://www.gnu.org/licenses/'. + +;;; Code: + +;; The `tramp-archive-testnn-*' tests correspond to the respective +;; tests in tramp-tests.el. + +(require 'ert) +(require 'tramp-archive) +(defvar tramp-copy-size-limit) +(defvar tramp-persistency-file-name) + +(defconst tramp-archive-test-resource-directory + (let ((default-directory + (if load-in-progress + (file-name-directory load-file-name) + default-directory))) + (cond + ((file-accessible-directory-p (expand-file-name "resources")) + (expand-file-name "resources")) + ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) + (expand-file-name "tramp-archive-resources")))) + "The resources directory test files are located in.") + +(defconst tramp-archive-test-file-archive + (file-truename + (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) + "The test file archive.") + +(defconst tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive) + "The test archive.") + +(defconst tramp-archive-test-directory + (file-truename + (expand-file-name "foo.iso" tramp-archive-test-resource-directory)) + "A directory file name, which looks like an archive.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-cache-read-persistent-data t ;; For auth-sources. + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +(defun tramp-archive--test-make-temp-name () + "Return a temporary file name for test. +The temporary file is not created." + (expand-file-name + (make-temp-name "tramp-archive-test") temporary-file-directory)) + +(defun tramp-archive--test-delete (tmpfile) + "Delete temporary file or directory TMPFILE. +This needs special support, because archive file names, which are +the origin of the temporary TMPFILE, have no write permissions." + (unless (file-writable-p (file-name-directory tmpfile)) + (set-file-modes + (file-name-directory tmpfile) + (logior (file-modes (file-name-directory tmpfile)) #o0700))) + (set-file-modes tmpfile #o0700) + (if (file-regular-p tmpfile) + (delete-file tmpfile) + (mapc + 'tramp-archive--test-delete + (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) + (delete-directory tmpfile))) + +(defun tramp-archive--test-emacs26-p () + "Check for Emacs version >= 26.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 26)) + +(defun tramp-archive--test-emacs27-p () + "Check for Emacs version >= 27.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 27)) + +(ert-deftest tramp-archive-test00-availability () + "Test availability of archive file name functions." + :expected-result (if tramp-archive-enabled :passed :failed) + (should + (and + tramp-archive-enabled + (file-exists-p tramp-archive-test-file-archive) + (tramp-archive-file-name-p tramp-archive-test-archive)))) + +(ert-deftest tramp-archive-test01-file-name-syntax () + "Check archive file name syntax." + (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive)) + (should (tramp-archive-file-name-p tramp-archive-test-archive)) + (should + (string-equal + (tramp-archive-file-name-archive tramp-archive-test-archive) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname tramp-archive-test-archive) "/")) + (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo")) + "/foo")) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "foo/bar")) + "/foo/bar")) + ;; A file archive inside a file archive. + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar"))) + (should + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar")) + tramp-archive-test-file-archive)) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar")) + "/baz.tar")) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "baz.tar/"))) + (should + (string-equal + (tramp-archive-file-name-archive + (concat tramp-archive-test-archive "baz.tar/")) + (concat tramp-archive-test-archive "baz.tar"))) + (should + (string-equal + (tramp-archive-file-name-localname + (concat tramp-archive-test-archive "baz.tar/")) + "/"))) + +(ert-deftest tramp-archive-test02-file-name-dissect () + "Check archive file name components." + (skip-unless tramp-archive-enabled) + + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Localname. + (with-parsed-tramp-archive-file-name + (concat tramp-archive-test-archive "foo") nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/foo")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; File archive in file archive. + (let* ((tramp-archive-test-file-archive + (concat tramp-archive-test-archive "baz.tar")) + (tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive)) + (tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods)) + (unwind-protect + (with-parsed-tramp-archive-file-name + (expand-file-name "bar" tramp-archive-test-archive) nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + ;; We reimplement the logic of tramp-archive.el here. Don't + ;; know, whether it is worth the test. + (should + (string-equal + host + (url-hexify-string + (concat + (tramp-gvfs-url-file-name + (tramp-make-tramp-file-name + tramp-archive-method + ;; User and Domain. + nil nil + ;; Host. + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file archive + ;; boundaries. So we must cut the trailing slash + ;; ourselves. + (substring + (file-name-directory tramp-archive-test-file-archive) 0 -1))) + nil "/")) + (file-name-nondirectory tramp-archive-test-file-archive))))) + (should-not port) + (should (string-equal localname "/bar")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file")) + (should + (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file")) + ;; `expand-file-name' does not care "~/" in archive file names. + (should + (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file")) + ;; `expand-file-name' does not care file archive boundaries. + (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) + (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) + +;; This test is inspired by Bug#30293. +(ert-deftest tramp-archive-test05-expand-file-name-non-archive-directory () + "Check existing directories with archive file name syntax. +They shall still be supported" + (should (file-directory-p tramp-archive-test-directory)) + ;; `tramp-archive-file-name-p' tests only for file name syntax. It + ;; doesn't test, whether it is really a file archive. + (should + (tramp-archive-file-name-p + (file-name-as-directory tramp-archive-test-directory))) + (should + (file-directory-p (file-name-as-directory tramp-archive-test-directory))) + (should + (file-exists-p (expand-file-name "foo" tramp-archive-test-directory)))) + +(ert-deftest tramp-archive-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (skip-unless tramp-archive-enabled) + + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file")) + ;; `directory-file-name' does not leave file archive boundaries. + (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/")) + + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/")) + (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/")) + + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/")) + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/")) + + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") "")) + (should (string-equal (file-name-nondirectory "/foo.tar/") "")) + + (should-not + (unhandled-file-name-directory "/foo.tar/path/to/file"))) + +(ert-deftest tramp-archive-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (unwind-protect + (let ((default-directory tramp-archive-test-archive)) + (should (file-exists-p tramp-archive-test-file-archive)) + (should (file-exists-p tramp-archive-test-archive)) + (should (file-exists-p "foo.txt")) + (should (file-exists-p "foo.lnk")) + (should (file-exists-p "bar")) + (should (file-exists-p "bar/bar")) + (should-error + (write-region "foo" nil "baz") + :type 'file-error) + (should-error + (delete-file "baz") + :type 'file-error)) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(ert-deftest tramp-archive-test08-file-local-copy () + "Check `file-local-copy'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let (tmp-name) + (unwind-protect + (progn + (should + (setq tmp-name + (file-local-copy + (expand-file-name "bar/bar" tramp-archive-test-archive)))) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n"))) + ;; Error case. + (tramp-archive--test-delete tmp-name) + (should-error + (setq tmp-name + (file-local-copy + (expand-file-name "what" tramp-archive-test-archive))) + :type tramp-file-missing)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test09-insert-file-contents () + "Check `insert-file-contents'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive))) + (unwind-protect + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\nbar\n")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "arbar\nbar\n")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "bar\n")) + ;; Error case. + (should-error + (insert-file-contents + (expand-file-name "what" tramp-archive-test-archive)) + :type tramp-file-missing)) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test11-copy-file () + "Check `copy-file'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + ;; Copy simple file. + (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "bar\n"))) + (should-error + (copy-file tmp-name1 tmp-name2) + :type 'file-already-exists) + (copy-file tmp-name1 tmp-name2 'ok) + ;; The file archive is not writable. + (should-error + (copy-file tmp-name2 tmp-name1 'ok) + :type 'file-error)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory to existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + ;; Directory `tmp-name2' exists already, so we must use + ;; `file-name-as-directory'. + (copy-file tmp-name1 (file-name-as-directory tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory/file to non-existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-file + tmp-name1 + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test15-copy-directory () + "Check `copy-directory'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "bar" tmp-name2)) + (tmp-name5 (expand-file-name "bar" tmp-name3))) + + ;; Copy complete directory. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + ;; This has been changed in Emacs 26.1. + (when (tramp-archive--test-emacs26-p) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error)) + (tramp-archive--test-delete tmp-name4) + (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)) + + ;; Copy directory contents. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2 nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + (tramp-archive--test-delete tmp-name4) + (copy-directory + tmp-name1 (file-name-as-directory tmp-name2) + nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + (should-not (file-directory-p tmp-name3)) + (should-not (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test16-directory-files () + "Check `directory-files'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name tramp-archive-test-archive) + (files '("." ".." "bar" "baz.tar" "foo.hrd" "foo.lnk" "foo.txt"))) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (should (equal (directory-files tmp-name) files)) + (should (equal (directory-files tmp-name 'full) + (mapcar (lambda (x) (concat tmp-name x)) files))) + (should (equal (directory-files + tmp-name nil directory-files-no-dot-files-regexp) + (delete "." (delete ".." files)))) + (should (equal (directory-files + tmp-name 'full directory-files-no-dot-files-regexp) + (mapcar (lambda (x) (concat tmp-name x)) + (delete "." (delete ".." files)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test17-insert-directory () + "Check `insert-directory'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let (;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + ;; Due to Bug#29423, this works only since for Emacs 26.1. + (when nil ;; TODO (tramp-archive--test-emacs26-p) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive "-al") + (goto-char (point-min)) + (should + (looking-at-p + (format "^.+ %s$" (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tramp-archive-test-archive) + "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order the files appear. + (format + "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" + (regexp-opt (directory-files tramp-archive-test-archive)) + (length (directory-files tramp-archive-test-archive)))))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test18-file-attributes () + "Check `file-attributes'. +This tests also `file-readable-p' and `file-regular-p'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)) + (tmp-name3 (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + + ;; We do not test inodes and device numbers. + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + ;; Symlink. + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal (car attr) (file-name-nondirectory tmp-name1))) + + ;; Directory. + (should (file-exists-p tmp-name3)) + (should (file-readable-p tmp-name3)) + (should-not (file-regular-p tmp-name3)) + (setq attr (file-attributes tmp-name3)) + (should (eq (car attr) t))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (setq attr (directory-files-and-attributes tmp-name)) + (should (consp attr)) + (dolist (elt attr) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name)) + (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name 'full)) + (dolist (elt attr) + (should (equal (file-attributes (car elt)) (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name nil "^b")) + (should (equal (mapcar 'car attr) '("bar")))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test20-file-modes () + "Check `file-modes'. +This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive))) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name1 #o777) + :type 'file-error) + (should (= (file-modes tmp-name1) #o400)) + (should-not (file-executable-p tmp-name1)) + (should-not (file-writable-p tmp-name1)) + + (should (file-exists-p tmp-name2)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name2 #o777) + :type 'file-error) + (should (= (file-modes tmp-name2) #o500)) + (should (file-executable-p tmp-name2)) + (should-not (file-writable-p tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test21-file-links () + "Check `file-symlink-p' and `file-truename'" + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + ;; We must use `file-truename' for the file archive, because it + ;; could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive)) + (tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))) + + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (string-equal tmp-name1 (file-truename tmp-name1))) + ;; `make-symbolic-link' is not implemented. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (should (file-symlink-p tmp-name2)) + (should + (string-equal + ;; This is "/foo.txt". + (with-parsed-tramp-archive-file-name tmp-name1 nil localname) + ;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore. + (with-parsed-tramp-archive-file-name + (expand-file-name + (file-symlink-p tmp-name2) tramp-archive-test-archive) + nil + localname))) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test26-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + + (let ((tmp-name tramp-archive-test-archive)) + (unwind-protect + (progn + ;; Local files. + (should (equal (file-name-completion "fo" tmp-name) "foo.")) + (should (equal (file-name-completion "foo.txt" tmp-name) t)) + (should (equal (file-name-completion "b" tmp-name) "ba")) + (should-not (file-name-completion "a" tmp-name)) + (should + (equal + (file-name-completion "b" tmp-name 'file-directory-p) "bar/")) + (should + (equal + (sort (file-name-all-completions "fo" tmp-name) 'string-lessp) + '("foo.hrd" "foo.lnk" "foo.txt"))) + (should + (equal + (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bar/" "baz.tar"))) + (should-not (file-name-all-completions "a" tmp-name)) + ;; `completion-regexp-list' restricts the completion to + ;; files which match all expressions in this list. + (let ((completion-regexp-list + `(,directory-files-no-dot-files-regexp "b"))) + (should + (equal (file-name-completion "" tmp-name) "ba")) + (should + (equal + (sort (file-name-all-completions "" tmp-name) 'string-lessp) + '("bar/" "baz.tar"))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +;; The functions were introduced in Emacs 26.1. +(ert-deftest tramp-archive-test38-make-nearby-temp-file () + "Check `make-nearby-temp-file' and `temporary-file-directory'." + (skip-unless tramp-archive-enabled) + ;; Since Emacs 26.1. + (skip-unless + (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) + + ;; `make-nearby-temp-file' and `temporary-file-directory' exists + ;; since Emacs 26.1. We don't want to see compiler warnings for + ;; older Emacsen. + (let ((default-directory tramp-archive-test-archive) + tmp-file) + ;; The file archive shall know a temporary file directory. It is + ;; not in the archive itself. + (should + (stringp (with-no-warnings (with-no-warnings (temporary-file-directory))))) + (should-not + (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + + ;; A temporary file or directory shall not be located in the + ;; archive itself. + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (should (file-exists-p tmp-file)) + (should (file-regular-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-file tmp-file) + (should-not (file-exists-p tmp-file)) + + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (should (file-exists-p tmp-file)) + (should (file-directory-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-directory tmp-file) + (should-not (file-exists-p tmp-file)))) + +(ert-deftest tramp-archive-test41-file-system-info () + "Check that `file-system-info' returns proper values." + (skip-unless tramp-archive-enabled) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'file-system-info)) + + ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; compiler warnings for older Emacsen. + (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive)))) + (skip-unless fsi) + (should (and (consp fsi) + (= (length fsi) 3) + (numberp (nth 0 fsi)) + ;; FREE and AVAIL are always 0. + (zerop (nth 1 fsi)) + (zerop (nth 2 fsi)))))) + +(ert-deftest tramp-archive-test44-auto-load () + "Check that `tramp-archive' autoloads properly." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + ;; Autoloading tramp-archive works since Emacs 27.1. + (skip-unless (tramp-archive--test-emacs27-p)) + + ;; tramp-archive is neither loaded at Emacs startup, nor when + ;; loading a file like "/mock::foo" (which loads Tramp). + (let ((default-directory (expand-file-name temporary-file-directory)) + (code + "(progn \ + (message \"tramp-archive loaded: %%s %%s\" \ + (featurep 'tramp) (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s %%s\" \ + (featurep 'tramp) (featurep 'tramp-archive)))")) + (dolist (file `("/mock::foo" ,(concat tramp-archive-test-archive "foo"))) + (should + (string-match + (format + "tramp-archive loaded: nil nil[[:ascii:]]+tramp-archive loaded: t %s" + (tramp-archive-file-name-p file)) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument (format code file))))))))) + +(ert-deftest tramp-archive-test44-delay-load () + "Check that `tramp-archive' is loaded lazily, only when needed." + :tags '(:expensive-test) + (skip-unless tramp-archive-enabled) + ;; Autoloading tramp-archive works since Emacs 27.1. + (skip-unless (tramp-archive--test-emacs27-p)) + + ;; tramp-archive is neither loaded at Emacs startup, nor when + ;; loading a file like "/foo.tar". It is loaded only when + ;; `tramp-archive-enabled' is t. + (let ((default-directory (expand-file-name temporary-file-directory)) + (code + "(progn \ + (setq tramp-archive-enabled %s) \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)) \ + (file-attributes %S \"/\") \ + (message \"tramp-archive loaded: %%s\" \ + (featurep 'tramp-archive)))")) + ;; tramp-archive doesn't load when `tramp-archive-enabled' is nil. + (dolist (tae '(t nil)) + (should + (string-match + (format + "tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: nil[[:ascii:]]+tramp-archive loaded: %s" + tae) + (shell-command-to-string + (format + "%s -batch -Q -L %s --eval %s" + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) + (mapconcat 'shell-quote-argument load-path " -L ") + (shell-quote-argument + (format + code tae tramp-archive-test-file-archive + (concat tramp-archive-test-archive "foo")))))))))) + +(ert-deftest tramp-archive-test99-libarchive-tests () + "Run tests of libarchive test files." + :tags '(:expensive-test :unstable) + (skip-unless tramp-archive-enabled) + ;; We do not want to run unless chosen explicitly. This test makes + ;; sense only in my local environment. Michael Albinus. + (skip-unless + (equal + (ert--stats-selector ert--current-run-stats) + (ert-test-name (ert-running-test)))) + + (url-handler-mode) + (unwind-protect + (dolist (dir + '("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads" + "http://ftp.debian.org/debian/pool/main/c/coreutils")) + (dolist + (file + '("coreutils_8.26-3_amd64.deb" + "coreutils_8.26-3ubuntu3_amd64.deb")) + (setq file (expand-file-name file dir)) + (when (file-exists-p file) + (setq file (expand-file-name "control.tar.gz/control" file)) + (message "%s" file) + (should (file-attributes (file-name-as-directory file)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)) + + (unwind-protect + (dolist (dir '("" "/sftp::" "/ssh::")) + (dolist + (file + (apply + 'append + (mapcar + (lambda (x) (directory-files (concat dir x) 'full "uu\\'" 'sort)) + '("~/src/libarchive-3.2.2/libarchive/test" + "~/src/libarchive-3.2.2/cpio/test" + "~/src/libarchive-3.2.2/tar/test")))) + (setq file (file-name-as-directory file)) + (cond + ((not (tramp-archive-file-name-p file)) + (message "skipped: %s" file)) + ((file-attributes file) + (message "%s" file)) + (t (message "failed: %s" file))) + (tramp-archive-cleanup-hash))) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(defun tramp-archive-test-all (&optional interactive) + "Run all tests for \\[tramp-archive]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^tramp-archive")) + +(provide 'tramp-archive-tests) +;;; tramp-archive-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 70b2646cc89..ff63dc18fbc 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,7 +33,7 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. -;; For slow remote connections, `tramp-test41-asynchronous-requests' +;; For slow remote connections, `tramp-test43-asynchronous-requests' ;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper ;; value less than 10 could help. @@ -52,14 +52,27 @@ (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") -(declare-function tramp-get-remote-stat "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") +(declare-function tramp-get-remote-stat "tramp-sh") +(declare-function tramp-method-out-of-band-p "tramp-sh") +(declare-function tramp-smb-get-localname "tramp-smb") (defvar auto-save-file-name-transforms) +(defvar tramp-connection-properties) (defvar tramp-copy-size-limit) +(defvar tramp-display-escape-sequence-regexp) +(defvar tramp-inline-compress-start-size) (defvar tramp-persistency-file-name) +(defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Suppress nasty messages. -(fset 'shell-command-sentinel 'ignore) + +;; Beautify batch mode. +(when noninteractive + ;; Suppress nasty messages. + (fset 'shell-command-sentinel 'ignore) + ;; We do not want to be interrupted. + (eval-after-load 'tramp-gvfs + '(fset 'tramp-gvfs-handler-askquestion + (lambda (_message _choices) '(t nil 0))))) ;; There is no default value on w32 systems, which could work out of the box. (defconst tramp-test-temporary-file-directory @@ -84,7 +97,8 @@ (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") -(setq password-cache-expiry nil +(setq auth-source-save-behavior nil + password-cache-expiry nil tramp-verbose 0 tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil @@ -95,11 +109,6 @@ (when (getenv "EMACS_HYDRA_CI") (add-to-list 'tramp-remote-path 'tramp-own-remote-path)) -(defvar tramp--test-expensive-test - (null - (string-equal (getenv "SELECTOR") "(quote (not (tag :expensive-test)))")) - "Whether expensive tests are run.") - (defvar tramp--test-enabled-checked nil "Cached result of `tramp--test-enabled'. If the function did run, the value is a cons cell, the `cdr' @@ -127,6 +136,13 @@ being the result.") ;; Return result. (cdr tramp--test-enabled-checked)) +(defsubst tramp--test-expensive-test () + "Whether expensive tests are run." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:expensive-test))))) + (defun tramp--test-make-temp-name (&optional local quoted) "Return a temporary file name for test. If LOCAL is non-nil, a local file name is returned. @@ -179,6 +195,16 @@ handled properly. BODY shall not contain a timeout." (tramp-backtrace (tramp-dissect-file-name tramp-test-temporary-file-directory)))) +(defmacro tramp--test-print-duration (message &rest body) + "Run BODY and print a message with duration, prompted by MESSAGE." + (declare (indent 1) (debug (stringp body))) + `(let ((start (current-time))) + (unwind-protect + (progn ,@body) + (tramp--test-message + "%s %f sec" + ,message (float-time (time-subtract (current-time) start)))))) + (ert-deftest tramp-test00-availability () "Test availability of Tramp functions." :expected-result (if (tramp--test-enabled) :passed :failed) @@ -229,6 +255,9 @@ handled properly. BODY shall not contain a timeout." ;; No strings. (should-not (tramp-tramp-file-p nil)) (should-not (tramp-tramp-file-p 'symbol)) + ;; No newline or linefeed. + (should-not (tramp-tramp-file-p "/method::file\nname")) + (should-not (tramp-tramp-file-p "/method::file\rname")) ;; Ange-ftp syntax. (should-not (tramp-tramp-file-p "/host:")) (should-not (tramp-tramp-file-p "/user@host:")) @@ -242,6 +271,12 @@ handled properly. BODY shall not contain a timeout." (should-not (tramp-tramp-file-p "/::")) (should-not (tramp-tramp-file-p "/:@:")) (should-not (tramp-tramp-file-p "/:[]:")) + ;; When `tramp-mode' is nil, Tramp is not activated. + (let (tramp-mode) + (should-not (tramp-tramp-file-p "/method:user@host:"))) + ;; `tramp-ignored-file-name-regexp' suppresses Tramp. + (let ((tramp-ignored-file-name-regexp "^/method:user@host:")) + (should-not (tramp-tramp-file-p "/method:user@host:"))) ;; Methods shall be at least two characters on MS Windows, except ;; the default method. (let ((system-type 'windows-nt)) @@ -365,7 +400,13 @@ handled properly. BODY shall not contain a timeout." "Check remote file name components." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") - (tramp-default-host "default-host")) + (tramp-default-host "default-host") + tramp-default-method-alist + tramp-default-user-alist + tramp-default-host-alist + ;; Suppress check for multihops. + (tramp-cache-data (make-hash-table :test 'equal)) + (tramp-connection-properties '((nil "login-program" t)))) ;; Expand `tramp-default-user' and `tramp-default-host'. (should (string-equal (file-remote-p "/method::") @@ -715,7 +756,84 @@ handled properly. BODY shall not contain a timeout." "|method3:user3@host3:/path/to/file") 'hop) (format "%s:%s@%s|%s:%s@%s|" - "method1" "user1" "host1" "method2" "user2" "host2"))))) + "method1" "user1" "host1" "method2" "user2" "host2"))) + + ;; Expand `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1")) + (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2")) + (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3")) + (should + (string-equal + (file-remote-p + (concat + "/-:user1@host1" + "|-:user2@host2" + "|-:user3@host3:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1")) + (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2")) + (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/method1:host1" + "|method2:host2" + "|method3:host3:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1")) + (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2")) + (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/method1:user1@" + "|method2:user2@" + "|method3:user3@:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Ad-hoc user name and host name expansion. + (setq tramp-default-method-alist nil + tramp-default-user-alist nil + tramp-default-host-alist nil) + (should + (string-equal + (file-remote-p + (concat + "/method1:user1@host1" + "|method2:user2@" + "|method3:user3@:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user1" "host1" + "method2" "user2" "host1" + "method3" "user3" "host1"))) + (should + (string-equal + (file-remote-p + (concat + "/method1:%u@%h" + "|method2:user2@host2" + "|method3:%u@%h" + "|method4:user4%domain4@host4#1234:/path/to/file")) + (format "/%s:%s@%s|%s:%s@%s|%s:%s@%s|%s:%s@%s:" + "method1" "user2" "host2" + "method2" "user2" "host2" + "method3" "user4" "host4" + "method4" "user4%domain4" "host4#1234"))))) (ert-deftest tramp-test02-file-name-dissect-simplified () "Check simplified file name components." @@ -723,6 +841,11 @@ handled properly. BODY shall not contain a timeout." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") + tramp-default-user-alist + tramp-default-host-alist + ;; Suppress check for multihops. + (tramp-cache-data (make-hash-table :test 'equal)) + (tramp-connection-properties '((nil "login-program" t))) (syntax tramp-syntax)) (unwind-protect (progn @@ -970,7 +1093,67 @@ handled properly. BODY shall not contain a timeout." "|user3@host3:/path/to/file") 'hop) (format "%s@%s|%s@%s|" - "user1" "host1" "user2" "host2")))) + "user1" "host1" "user2" "host2"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '(nil "host1" "user1")) + (add-to-list 'tramp-default-user-alist '(nil "host2" "user2")) + (add-to-list 'tramp-default-user-alist '(nil "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/host1" + "|host2" + "|host3:/path/to/file")) + (format "/%s@%s|%s@%s|%s@%s:" + "user1" "host1" + "user2" "host2" + "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '(nil "user1" "host1")) + (add-to-list 'tramp-default-host-alist '(nil "user2" "host2")) + (add-to-list 'tramp-default-host-alist '(nil "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/user1@" + "|user2@" + "|user3@:/path/to/file")) + (format "/%s@%s|%s@%s|%s@%s:" + "user1" "host1" + "user2" "host2" + "user3" "host3"))) + + ;; Ad-hoc user name and host name expansion. + (setq tramp-default-user-alist nil + tramp-default-host-alist nil) + (should + (string-equal + (file-remote-p + (concat + "/user1@host1" + "|user2@" + "|user3@:/path/to/file")) + (format "/%s@%s|%s@%s|%s@%s:" + "user1" "host1" + "user2" "host1" + "user3" "host1"))) + (should + (string-equal + (file-remote-p + (concat + "/%u@%h" + "|user2@host2" + "|%u@%h" + "|user4%domain4@host4#1234:/path/to/file")) + (format "/%s@%s|%s@%s|%s@%s|%s@%s:" + "user2" "host2" + "user2" "host2" + "user4" "host4" + "user4%domain4" "host4#1234")))) ;; Exit. (tramp-change-syntax syntax)))) @@ -981,6 +1164,12 @@ handled properly. BODY shall not contain a timeout." (let ((tramp-default-method "default-method") (tramp-default-user "default-user") (tramp-default-host "default-host") + tramp-default-method-alist + tramp-default-user-alist + tramp-default-host-alist + ;; Suppress check for multihops. + (tramp-cache-data (make-hash-table :test 'equal)) + (tramp-connection-properties '((nil "login-program" t))) (syntax tramp-syntax)) (unwind-protect (progn @@ -1538,7 +1727,84 @@ handled properly. BODY shall not contain a timeout." "|method3/user3@host3]/path/to/file") 'hop) (format "%s/%s@%s|%s/%s@%s|" - "method1" "user1" "host1" "method2" "user2" "host2")))) + "method1" "user1" "host1" "method2" "user2" "host2"))) + + ;; Expand `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist '("host1" "user1" "method1")) + (add-to-list 'tramp-default-method-alist '("host2" "user2" "method2")) + (add-to-list 'tramp-default-method-alist '("host3" "user3" "method3")) + (should + (string-equal + (file-remote-p + (concat + "/[/user1@host1" + "|/user2@host2" + "|/user3@host3]/path/to/file")) + (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-user-alist'. + (add-to-list 'tramp-default-user-alist '("method1" "host1" "user1")) + (add-to-list 'tramp-default-user-alist '("method2" "host2" "user2")) + (add-to-list 'tramp-default-user-alist '("method3" "host3" "user3")) + (should + (string-equal + (file-remote-p + (concat + "/[method1/host1" + "|method2/host2" + "|method3/host3]/path/to/file")) + (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Expand `tramp-default-host-alist'. + (add-to-list 'tramp-default-host-alist '("method1" "user1" "host1")) + (add-to-list 'tramp-default-host-alist '("method2" "user2" "host2")) + (add-to-list 'tramp-default-host-alist '("method3" "user3" "host3")) + (should + (string-equal + (file-remote-p + (concat + "/[method1/user1@" + "|method2/user2@" + "|method3/user3@]/path/to/file")) + (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]" + "method1" "user1" "host1" + "method2" "user2" "host2" + "method3" "user3" "host3"))) + + ;; Ad-hoc user name and host name expansion. + (setq tramp-default-method-alist nil + tramp-default-user-alist nil + tramp-default-host-alist nil) + (should + (string-equal + (file-remote-p + (concat + "/[method1/user1@host1" + "|method2/user2@" + "|method3/user3@]/path/to/file")) + (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s]" + "method1" "user1" "host1" + "method2" "user2" "host1" + "method3" "user3" "host1"))) + (should + (string-equal + (file-remote-p + (concat + "/[method1/%u@%h" + "|method2/user2@host2" + "|method3/%u@%h" + "|method4/user4%domain4@host4#1234]/path/to/file")) + (format "/[%s/%s@%s|%s/%s@%s|%s/%s@%s|%s/%s@%s]" + "method1" "user2" "host2" + "method2" "user2" "host2" + "method3" "user4" "host4" + "method4" "user4%domain4" "host4#1234")))) ;; Exit. (tramp-change-syntax syntax)))) @@ -1567,41 +1833,112 @@ handled properly. BODY shall not contain a timeout." ;; Default values in tramp-smb.el. (should (string-equal (file-remote-p "/smb::" 'user) nil))) +;; The following test is inspired by Bug#30946. +(ert-deftest tramp-test03-file-name-host-rules () + "Check host name rules for host-less methods." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + + ;; Host names must match rules in case the command template of a + ;; method doesn't use them. + (dolist (m '("su" "sg" "sudo" "doas" "ksu")) + (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) + tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors (tramp-cleanup-connection vec nil 'keep-password)) + ;; Single hop. The host name must match `tramp-local-host-regexp'. + (should-error + (find-file (format "/%s:foo:" m)) + :type 'user-error) + ;; Multi hop. The host name must match the previous hop. + (should-error + (find-file + (format + "%s|%s:foo:" + (substring (file-remote-p tramp-test-temporary-file-directory) 0 -1) + m)) + :type 'user-error)))) + +(ert-deftest tramp-test03-file-name-method-rules () + "Check file name rules for some methods." + (skip-unless (tramp--test-enabled)) + ;; `user-error' has appeared in Emacs 24.3. + (skip-unless (fboundp 'user-error)) + + ;; Multi hops are allowed for inline methods only. + (should-error + (file-remote-p "/ssh:user1@host1|method:user2@host2:/path/to/file") + :type 'user-error) + (should-error + (file-remote-p "/method:user1@host1|ssh:user2@host2:/path/to/file") + :type 'user-error) + + ;; Samba does not support file names with periods followed by + ;; spaces, and trailing periods or spaces. + (when (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (dolist (file '("foo." "foo. bar" "foo ")) + (should-error + (tramp-smb-get-localname + (tramp-dissect-file-name + (expand-file-name file tramp-test-temporary-file-directory))) + :type 'file-error)))) + (ert-deftest tramp-test04-substitute-in-file-name () "Check `substitute-in-file-name'." - (should (string-equal (substitute-in-file-name "/method:host://foo") "/foo")) + (should (string-equal (substitute-in-file-name "/method:host:///foo") "/foo")) (should (string-equal - (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) + (substitute-in-file-name "/method:host://foo") "/method:host:/foo")) (should (string-equal (substitute-in-file-name "/method:host:/path///foo") "/foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/path//foo") "/method:host:/foo")) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) + (substitute-in-file-name "/method:host:/:///foo") "/method:host:/:///foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//foo") - "/method:host:/:/path//foo")) + (substitute-in-file-name "/method:host:/://foo") "/method:host:/://foo")) (should (string-equal (substitute-in-file-name "/method:host:/:/path///foo") "/method:host:/:/path///foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/path//foo") + "/method:host:/:/path//foo")) (should + (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) + (should (string-equal - (substitute-in-file-name "/method:host:/path/~/foo") "/method:host:~/foo")) + (substitute-in-file-name "/method:host:/~foo") "/method:host:/~foo")) + (should + (string-equal (substitute-in-file-name "/method:host:/path//~foo") "/~foo")) + ;; (substitute-in-file-name "/path/~foo") expands only for a local + ;; user "foo" to "/~foo"". Otherwise, it doesn't expand. (should - (string-equal (substitute-in-file-name "/method:host:/path//~/foo") "~/foo")) + (string-equal + (substitute-in-file-name + "/method:host:/path/~foo") "/method:host:/path/~foo")) ;; Quoting local part. (should (string-equal - (substitute-in-file-name "/method:host:/:/path/~/foo") - "/method:host:/:/path/~/foo")) + (substitute-in-file-name "/method:host:/://~foo") "/method:host:/://~foo")) + (should + (string-equal + (substitute-in-file-name "/method:host:/:/~foo") "/method:host:/:/~foo")) (should (string-equal - (substitute-in-file-name "/method:host:/:/path//~/foo") - "/method:host:/:/path//~/foo")) + (substitute-in-file-name + "/method:host:/:/path//~foo") "/method:host:/:/path//~foo")) + (should + (string-equal + (substitute-in-file-name + "/method:host:/:/path/~foo") "/method:host:/:/path/~foo")) (let (process-environment) (should @@ -1661,8 +1998,9 @@ handled properly. BODY shall not contain a timeout." ;; Mark as failed until bug has been fixed. :expected-result :failed (skip-unless (tramp--test-enabled)) + ;; These are the methods the test doesn't fail. - (when (or (tramp--test-adb-p) (tramp--test-gvfs-p) + (when (or (tramp--test-adb-p) (tramp--test-gvfs-p) (tramp--test-rclone-p) (tramp-smb-file-name-p tramp-test-temporary-file-directory)) (setf (ert-test-expected-result-type (ert-get-test 'tramp-test05-expand-file-name-relative)) @@ -1709,6 +2047,14 @@ This checks also `file-name-as-directory', `file-name-directory', (file-name-directory "/method:host:/path/to/file/") "/method:host:/path/to/file/")) (should + (string-equal (file-name-directory "/method:host:file") "/method:host:")) + (should + (string-equal + (file-name-directory "/method:host:path/") "/method:host:path/")) + (should + (string-equal + (file-name-directory "/method:host:path/to") "/method:host:path/")) + (should (string-equal (file-name-nondirectory "/method:host:/path/to/file") "file")) (should (string-equal (file-name-nondirectory "/method:host:/path/to/file/") "")) @@ -1743,7 +2089,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-exist-p', `write-region' and `delete-file'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (should-not (file-exists-p tmp-name)) (write-region "foo" nil tmp-name) @@ -1755,7 +2101,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `file-local-copy'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) tmp-name2) (unwind-protect @@ -1787,7 +2133,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `insert-file-contents'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (with-temp-buffer @@ -1815,7 +2161,7 @@ This checks also `file-name-as-directory', `file-name-directory', "Check `write-region'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -1905,7 +2251,7 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -1930,9 +2276,10 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-file-contents target) (should (string-equal (buffer-string) "foo"))) - (should-error - (copy-file source target) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (copy-file source target) + :type 'file-already-exists)) (copy-file source target 'ok)) ;; Cleanup. @@ -1941,13 +2288,15 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy file to directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (write-region "foo" nil source) (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) + (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) (should-error (copy-file source target) :type 'file-already-exists)) @@ -1962,7 +2311,11 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (and (tramp--test-nextcloud-p) + (or (not (file-remote-p source)) + (not (file-remote-p target)))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -1983,7 +2336,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless + (and (tramp--test-nextcloud-p) (not (file-remote-p source))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2007,7 +2363,7 @@ This checks also `file-name-as-directory', `file-name-directory', (skip-unless (tramp--test-enabled)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -2035,9 +2391,10 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "foo"))) (write-region "foo" nil source) (should (file-exists-p source)) - (should-error - (rename-file source target) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (rename-file source target) + :type 'file-already-exists)) (rename-file source target 'ok) (should-not (file-exists-p source))) @@ -2053,7 +2410,7 @@ This checks also `file-name-as-directory', `file-name-directory', (make-directory target) (should (file-directory-p target)) ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) + (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) (should-error (rename-file source target) :type 'file-already-exists)) @@ -2069,7 +2426,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2091,7 +2450,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-nextcloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2116,7 +2477,7 @@ This checks also `file-name-as-directory', `file-name-directory', This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (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))) (unwind-protect @@ -2139,7 +2500,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `delete-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) ;; Delete empty directory. (make-directory tmp-name) @@ -2159,7 +2520,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `copy-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (expand-file-name @@ -2225,7 +2586,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `directory-files'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (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 "bla" tmp-name1)) (tmp-name3 (expand-file-name "foo" tmp-name1))) @@ -2258,7 +2619,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `file-expand-wildcards'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (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" tmp-name1)) (tmp-name3 (expand-file-name "bar" tmp-name1)) @@ -2322,7 +2683,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." "Check `insert-directory'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -2383,7 +2744,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 @@ -2500,7 +2861,7 @@ This tests also `file-readable-p', `file-regular-p' and `file-ownership-preserved-p'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -2607,7 +2968,7 @@ This tests also `file-readable-p', `file-regular-p' and "Check `directory-files-and-attributes'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; `directory-files-and-attributes' contains also values for ;; "../". Ensure that this doesn't change during tests, for ;; example due to handling temporary files. @@ -2629,16 +2990,17 @@ This tests also `file-readable-p', `file-regular-p' and ;; able to return the date correctly. They say "don't know". (dolist (elt attr) (unless - (equal + (tramp-compat-time-equal-p (nth 5 (file-attributes (expand-file-name (car elt) tmp-name2))) - '(0 0)) + tramp-time-dont-know) (should (equal (file-attributes (expand-file-name (car elt) tmp-name2)) (cdr elt))))) (setq attr (directory-files-and-attributes tmp-name2 'full)) (dolist (elt attr) - (unless (equal (nth 5 (file-attributes (car elt))) '(0 0)) + (unless (tramp-compat-time-equal-p + (nth 5 (file-attributes (car elt))) tramp-time-dont-know) (should (equal (file-attributes (car elt)) (cdr elt))))) (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) @@ -2651,9 +3013,9 @@ This tests also `file-readable-p', `file-regular-p' and "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) - (skip-unless (tramp--test-sh-p)) + (skip-unless (or (tramp--test-sh-p) (tramp--test-sudoedit-p))) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -2673,15 +3035,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) +;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error. +(defmacro tramp--test-ignore-add-name-to-file-error (&rest body) + "Run BODY, ignoring \"error with add-name-to-file\" file error." + (declare (indent defun) (debug t)) + `(condition-case err + (progn ,@body) + ((error quit debug) + (unless (and (eq (car err) 'file-error) + (string-match "^error with add-name-to-file" + (error-message-string err))) + (signal (car err) (cdr err)))))) + (ert-deftest tramp-test21-file-links () "Check `file-symlink-p'. This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - ;; The semantics has changed heavily in Emacs 26.1. We cannot test + ;; The semantics have changed heavily in Emacs 26.1. We cannot test ;; older Emacsen, therefore. (skip-unless (tramp--test-emacs26-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This ;; would let the test fail. @@ -2705,14 +3079,16 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if quoted 'tramp-compat-file-name-unquote 'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) - (should-error - (make-symbolic-link tmp-name1 tmp-name2) - :type 'file-already-exists) - ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (when (tramp--test-expensive-test) (should-error - (make-symbolic-link tmp-name1 tmp-name2 0) + (make-symbolic-link tmp-name1 tmp-name2) :type 'file-already-exists)) + (when (tramp--test-expensive-test) + ;; A number means interactive case. + (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (should-error + (make-symbolic-link tmp-name1 tmp-name2 0) + :type 'file-already-exists))) (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should @@ -2747,9 +3123,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Check directory as newname. (make-directory tmp-name4) - (should-error - (make-symbolic-link tmp-name1 tmp-name4) - :type 'file-already-exists) + (when (tramp--test-expensive-test) + (should-error + (make-symbolic-link tmp-name1 tmp-name4) + :type 'file-already-exists)) (make-symbolic-link tmp-name1 (file-name-as-directory tmp-name4)) (should (string-equal @@ -2771,38 +3148,40 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Check `add-name-to-file'. (unwind-protect - (unless (tramp-smb-file-name-p tramp-test-temporary-file-directory) - (write-region "foo" nil tmp-name1) - (should (file-exists-p tmp-name1)) - (add-name-to-file tmp-name1 tmp-name2) - (should (file-regular-p tmp-name2)) - (should-error + (when (tramp--test-expensive-test) + (tramp--test-ignore-add-name-to-file-error + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) (add-name-to-file tmp-name1 tmp-name2) - :type 'file-already-exists) - ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) - (should-error - (add-name-to-file tmp-name1 tmp-name2 0) - :type 'file-already-exists)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (should (file-regular-p tmp-name2)) + (should-error + (add-name-to-file tmp-name1 tmp-name2) + :type 'file-already-exists) + ;; A number means interactive case. + (cl-letf (((symbol-function 'yes-or-no-p) 'ignore)) + (should-error + (add-name-to-file tmp-name1 tmp-name2 0) + :type 'file-already-exists)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) - (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) - (should-not (file-symlink-p tmp-name2)) - (should (file-regular-p tmp-name2)) - ;; `tmp-name3' is a local file name. - (should-error - (add-name-to-file tmp-name1 tmp-name3) - :type 'file-error) - ;; Check directory as newname. - (make-directory tmp-name4) - (should-error - (add-name-to-file tmp-name1 tmp-name4) - :type 'file-already-exists) - (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4)) - (should - (file-regular-p - (expand-file-name (file-name-nondirectory tmp-name1) tmp-name4)))) + (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) + (should-not (file-symlink-p tmp-name2)) + (should (file-regular-p tmp-name2)) + ;; `tmp-name3' is a local file name. + (should-error + (add-name-to-file tmp-name1 tmp-name3) + :type 'file-error) + ;; Check directory as newname. + (make-directory tmp-name4) + (should-error + (add-name-to-file tmp-name1 tmp-name4) + :type 'file-already-exists) + (add-name-to-file tmp-name1 (file-name-as-directory tmp-name4)) + (should + (file-regular-p + (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name4))))) ;; Cleanup. (ignore-errors @@ -2882,12 +3261,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (file-truename tmp-name2) (file-truename tmp-name3))) - (should-error - (with-temp-buffer (insert-file-contents tmp-name2)) - :type tramp-file-missing) - (should-error - (with-temp-buffer (insert-file-contents tmp-name3)) - :type tramp-file-missing) + (when (tramp--test-expensive-test) + (should-error + (with-temp-buffer (insert-file-contents tmp-name2)) + :type tramp-file-missing)) + (when (tramp--test-expensive-test) + (should-error + (with-temp-buffer (insert-file-contents tmp-name3)) + :type tramp-file-missing)) ;; `directory-files' does not show symlinks to ;; non-existing targets in the "smb" case. So we remove ;; the symlinks manually. @@ -2900,32 +3281,42 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Detect cyclic symbolic links. (unwind-protect - (tramp--test-ignore-make-symbolic-link-error - (make-symbolic-link tmp-name2 tmp-name1) - (should (file-symlink-p tmp-name1)) - (make-symbolic-link tmp-name1 tmp-name2) - (should (file-symlink-p tmp-name2)) - (should-error (file-truename tmp-name1) :type 'file-error)) + (when (tramp--test-expensive-test) + (tramp--test-ignore-make-symbolic-link-error + (make-symbolic-link tmp-name2 tmp-name1) + (should (file-symlink-p tmp-name1)) + (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + ;; The symlink command of `smbclient' detects the + ;; cycle already. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-error (file-truename tmp-name1) :type 'file-error)))) ;; Cleanup. (ignore-errors (delete-file tmp-name1) (delete-file tmp-name2))) - ;; `file-truename' shall preserve trailing link of directories. - (unless (file-symlink-p tramp-test-temporary-file-directory) - (let* ((dir1 (directory-file-name tramp-test-temporary-file-directory)) - (dir2 (file-name-as-directory dir1))) - (should (string-equal (file-truename dir1) (expand-file-name dir1))) - (should - (string-equal (file-truename dir2) (expand-file-name dir2)))))))) + ;; `file-truename' shall preserve trailing slash of directories. + (let* ((dir1 + (directory-file-name + (funcall + (if quoted 'tramp-compat-file-name-quote 'identity) + tramp-test-temporary-file-directory))) + (dir2 (file-name-as-directory dir1))) + (should (string-equal (file-truename dir1) (expand-file-name dir1))) + (should (string-equal (file-truename dir2) (expand-file-name dir2))))))) (ert-deftest tramp-test22-file-times () "Check `set-file-times' and `file-newer-than-file-p'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless + (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sudoedit-p))) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (tmp-name3 (tramp--test-make-temp-name nil quoted))) @@ -2934,15 +3325,15 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (consp (nth 5 (file-attributes tmp-name1)))) - ;; '(0 0) means don't know, and will be replaced by - ;; `current-time'. Therefore, we use '(0 1). We skip the - ;; test, if the remote handler is not able to set the - ;; correct time. - (skip-unless (set-file-times tmp-name1 '(0 1))) + ;; Skip the test, if the remote handler is not able to set + ;; the correct time. + (skip-unless (set-file-times tmp-name1 (seconds-to-time 1))) ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". - (unless (equal (nth 5 (file-attributes tmp-name1)) '(0 0)) - (should (equal (nth 5 (file-attributes tmp-name1)) '(0 1))) + (unless (tramp-compat-time-equal-p + (nth 5 (file-attributes tmp-name1)) tramp-time-dont-know) + (should + (equal (nth 5 (file-attributes tmp-name1)) (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) (should (file-newer-than-file-p tmp-name2 tmp-name1)) @@ -2959,7 +3350,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `set-visited-file-modtime' and `verify-visited-file-modtime'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -2968,9 +3359,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (with-temp-buffer (insert-file-contents tmp-name) (should (verify-visited-file-modtime)) - (set-visited-file-modtime '(0 1)) + (set-visited-file-modtime (seconds-to-time 1)) (should (verify-visited-file-modtime)) - (should (equal (visited-file-modtime) '(0 1 0 0))))) + (should (= 1 (float-time (visited-file-modtime)))) + + ;; Checks with deleted file. + (delete-file tmp-name) + (dired-uncache tmp-name) + (should (verify-visited-file-modtime)) + (set-visited-file-modtime (seconds-to-time 1)) + (should (verify-visited-file-modtime)) + (should (= 1 (float-time (visited-file-modtime)))))) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2982,7 +3381,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (file-acl tramp-test-temporary-file-directory)) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -3060,7 +3459,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." '(nil nil nil nil)))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) @@ -3201,6 +3600,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (when (not (memq system-type '(cygwin windows-nt))) (let ((method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host)) + (vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) (orig-syntax tramp-syntax)) (when (and (stringp host) (string-match tramp-host-with-port-regexp host)) (setq host (match-string 1 host))) @@ -3208,9 +3608,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (unwind-protect (dolist (syntax - (if tramp--test-expensive-test + (if (tramp--test-expensive-test) (tramp-syntax-values) `(,orig-syntax))) (tramp-change-syntax syntax) + ;; This has cleaned up all connection data, which are used + ;; for completion. We must refill the cache. + (tramp-set-connection-property vec "property" nil) + (let ;; This is needed for the `simplified' syntax. ((method-marker (if (zerop (length tramp-method-regexp)) @@ -3259,7 +3663,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax orig-syntax)))) (dolist (n-e '(nil t)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((non-essential n-e) (tmp-name (tramp--test-make-temp-name nil quoted))) @@ -3321,7 +3725,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `load'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -3346,7 +3750,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) (fnnd (file-name-nondirectory tmp-name)) (default-directory tramp-test-temporary-file-directory) @@ -3392,7 +3796,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) @@ -3451,7 +3855,133 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc)))))) -(ert-deftest tramp-test30-interrupt-process () +(ert-deftest tramp-test30-make-process () + "Check `make-process'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (tramp--test-emacs27-p)) + + (tramp--test-instrument-test-case 0 + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name nil quoted)) + kill-buffer-query-functions proc) + (should-not (make-process)) + + ;; Simple process. + (unwind-protect + (with-temp-buffer + (setq proc + (make-process + :name "test1" :buffer (current-buffer) :command '("cat") + :file-handler t)) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`make-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 0.1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + ;; Simple process using a file. + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (setq proc + (make-process + :name "test2" :buffer (current-buffer) + :command `("cat" ,(file-name-nondirectory tmp-name)) + :file-handler t)) + (should (processp proc)) + ;; Read output. + (with-timeout (10 (ert-fail "`make-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 0.1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors + (delete-process proc) + (delete-file tmp-name))) + + ;; Process filter. + (unwind-protect + (with-temp-buffer + (setq proc + (make-process + :name "test3" :buffer (current-buffer) :command '("cat") + :filter + (lambda (p s) + (with-current-buffer (process-buffer p) (insert s))) + :file-handler t)) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (ert-fail "`make-process' timed out")) + (while (< (- (point-max) (point-min)) (length "foo")) + (accept-process-output proc 0.1))) + (should (string-equal (buffer-string) "foo"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + ;; Process sentinel. + (unwind-protect + (with-temp-buffer + (setq proc + (make-process + :name "test4" :buffer (current-buffer) :command '("cat") + :sentinel + (lambda (p s) + (with-current-buffer (process-buffer p) (insert s))) + :file-handler t)) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo") + (process-send-eof proc) + (delete-process proc) + ;; Read output. + (with-timeout (10 (ert-fail "`make-process' timed out")) + (while (process-live-p proc) + (accept-process-output proc 0.1))) + (should (string-equal (buffer-string) "killed\n"))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + ;; Process with stderr. + (let ((stderr (generate-new-buffer (generate-new-buffer-name "stderr")))) + (unwind-protect + (with-temp-buffer + (setq proc + (make-process + :name "test5" :buffer (current-buffer) + :command '("cat" "/") + :stderr stderr + :file-handler t)) + (should (processp proc)) + ;; Read stderr. + (with-current-buffer stderr + (with-timeout (10 (ert-fail "`make-process' timed out")) + (while (= (point-min) (point-max)) + (accept-process-output proc 0.1))) + (should + (string-equal (buffer-string) "cat: /: Is a directory\n")))) + + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (kill-buffer stderr)))))))) + +(ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) @@ -3478,13 +4008,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))))) -(ert-deftest tramp-test31-shell-command () +(ert-deftest tramp-test32-shell-command () "Check `shell-command'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) ;; Suppress nasty messages. @@ -3582,7 +4112,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (buffer-substring-no-properties (point-min) (point-max)))) ;; This test is inspired by Bug#23952. -(ert-deftest tramp-test32-environment-variables () +(ert-deftest tramp-test33-environment-variables () "Check that remote processes set / unset environment variables properly." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) @@ -3660,7 +4190,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (funcall this-shell-command-to-string "set"))))))))) ;; This test is inspired by Bug#27009. -(ert-deftest tramp-test32-environment-variables-and-port-numbers () +(ert-deftest tramp-test33-environment-variables-and-port-numbers () "Check that two connections with separate ports are different." (skip-unless (tramp--test-enabled)) ;; We test it only for the mock-up connection; otherwise there might @@ -3696,7 +4226,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-cleanup-connection (tramp-dissect-file-name dir))))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test33-explicit-shell-file-name () +(ert-deftest tramp-test34-explicit-shell-file-name () "Check that connection-local `explicit-shell-file-name' is set." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) @@ -3740,13 +4270,121 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (put 'explicit-shell-file-name 'permanent-local nil) (kill-buffer "*shell*")))) -(ert-deftest tramp-test34-vc-registered () +;; `exec-path' was introduced in Emacs 27.1. `executable-find' has +;; changed the number of parameters, so we use `apply' for older +;; Emacsen. +(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))) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'exec-path)) + + (let ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory)) + (unwind-protect + (progn + (should (consp (with-no-warnings (exec-path)))) + ;; Last element is the `exec-directory'. + (should + (string-equal + (car (last (with-no-warnings (exec-path)))) + (file-remote-p default-directory 'localname))) + ;; The shell "sh" shall always exist. + (should (apply 'executable-find '("sh" remote))) + ;; Since the last element in `exec-path' is the current + ;; directory, an executable file in that directory will be + ;; 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 + (string-equal + (apply + 'executable-find `(,(file-name-nondirectory tmp-name) remote)) + (file-remote-p tmp-name 'localname))) + (should-not + (apply + 'executable-find + `(,(concat (file-name-nondirectory tmp-name) "foo") remote)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name))))) + +;; This test is inspired by Bug#33781. +;; `exec-path' was introduced in Emacs 27.1. `executable-find' has +;; changed the number of parameters, so we use `apply' for older +;; Emacsen. +(ert-deftest tramp-test35-remote-path () + "Check loooong `tramp-remote-path'." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'exec-path)) + + (let* ((tmp-name (tramp--test-make-temp-name)) + (default-directory tramp-test-temporary-file-directory) + (orig-exec-path (exec-path)) + (tramp-remote-path tramp-remote-path) + (orig-tramp-remote-path tramp-remote-path)) + (unwind-protect + (progn + ;; Non existing directories are removed. + (setq tramp-remote-path + (cons (file-remote-p tmp-name 'localname) tramp-remote-path)) + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + 'keep-debug 'keep-password) + (should (equal (with-no-warnings (exec-path)) orig-exec-path)) + (setq tramp-remote-path orig-tramp-remote-path) + + ;; Double entries are removed. + (setq tramp-remote-path (append '("/" "/") tramp-remote-path)) + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + 'keep-debug 'keep-password) + (should + (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path))) + (setq tramp-remote-path orig-tramp-remote-path) + + ;; We make a super long `tramp-remote-path'. + (make-directory tmp-name) + (should (file-directory-p tmp-name)) + (while (< (length (mapconcat 'identity orig-exec-path ":")) 5000) + (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) + (should (file-directory-p dir)) + (setq tramp-remote-path + (cons (file-remote-p dir 'localname) tramp-remote-path) + orig-exec-path + (cons (file-remote-p dir 'localname) orig-exec-path)))) + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + 'keep-debug 'keep-password) + (should (equal (with-no-warnings (exec-path)) orig-exec-path)) + (should + (string-equal + ;; Ignore trailing newline. + (substring (shell-command-to-string "echo $PATH") nil -1) + ;; The last element of `exec-path' is `exec-directory'. + (mapconcat 'identity (butlast orig-exec-path) ":"))) + ;; The shell "sh" shall always exist. + (should (apply 'executable-find '("sh" remote)))) + + ;; Cleanup. + (tramp-cleanup-connection + (tramp-dissect-file-name tramp-test-temporary-file-directory) + 'keep-debug 'keep-password) + (setq tramp-remote-path orig-tramp-remote-path) + (ignore-errors (delete-directory tmp-name 'recursive))))) + +(ert-deftest tramp-test36-vc-registered () "Check `vc-registered'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((default-directory tramp-test-temporary-file-directory) (tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3810,11 +4448,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) -(ert-deftest tramp-test35-make-auto-save-file-name () +(ert-deftest tramp-test37-make-auto-save-file-name () "Check `make-auto-save-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted))) @@ -3901,11 +4539,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-directory tmp-name2 'recursive)))))) -(ert-deftest tramp-test36-find-backup-file-name () +(ert-deftest tramp-test38-find-backup-file-name () "Check `find-backup-file-name'." (skip-unless (tramp--test-enabled)) - (dolist (quoted (if tramp--test-expensive-test '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) ;; These settings are not used by Tramp, so we ignore them. @@ -4012,7 +4650,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ignore-errors (delete-directory tmp-name2 'recursive)))))) ;; The functions were introduced in Emacs 26.1. -(ert-deftest tramp-test37-make-nearby-temp-file () +(ert-deftest tramp-test39-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) ;; Since Emacs 26.1. @@ -4104,6 +4742,16 @@ This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-nextcloud-p () + "Check, whether the nextcloud method is used." + (string-equal + "nextcloud" (file-remote-p tramp-test-temporary-file-directory 'method))) + +(defun tramp--test-rclone-p () + "Check, whether the remote host is offered by rclone. +This requires restrictions of file name syntax." + (tramp-rclone-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-rsync-p () "Check, whether the rsync method is used. This does not support special file names." @@ -4116,6 +4764,10 @@ This does not support special file names." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-sh-file-name-handler)) +(defun tramp--test-sudoedit-p () + "Check, whether the sudoedit method is used." + (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-windows-nt () "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) @@ -4142,7 +4794,7 @@ This requires restrictions of file name syntax." (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. - (dolist (quoted (if (and tramp--test-expensive-test (tramp--test-emacs27-p)) + (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, ;; because it could be located on a symlinked directory. This @@ -4275,9 +4927,10 @@ This requires restrictions of file name syntax." (should-not (file-exists-p file1)))) ;; Check, that environment variables are set correctly. - (when (and tramp--test-expensive-test (tramp--test-sh-p)) + (when (and (tramp--test-expensive-test) (tramp--test-sh-p)) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) + (elt (encode-coding-string elt coding-system-for-read)) (default-directory tramp-test-temporary-file-directory) (process-environment process-environment)) (setenv envvar elt) @@ -4299,50 +4952,60 @@ This requires restrictions of file name syntax." (ignore-errors (delete-directory tmp-name2 'recursive)))))) (defun tramp--test-special-characters () - "Perform the test in `tramp-test38-special-characters*'." + "Perform the test in `tramp-test40-special-characters*'." ;; Newlines, slashes and backslashes in file names are not ;; supported. So we don't test. And we don't test the tab ;; character on Windows or Cygwin, because the backslash is ;; interpreted as a path separator, preventing "\t" from being ;; expanded to <TAB>. - (tramp--test-check-files - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "foo bar baz" - (if (or (tramp--test-adb-p) - (tramp--test-docker-p) - (eq system-type 'cygwin)) - " foo bar baz " - " foo\tbar baz\t")) - "$foo$bar$$baz$" - "-foo-bar-baz-" - "%foo%bar%baz%" - "&foo&bar&baz&" - (unless (or (tramp--test-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-windows-nt-or-smb-p)) - "?foo?bar?baz?") - (unless (or (tramp--test-ftp-p) - (tramp--test-gvfs-p) - (tramp--test-windows-nt-or-smb-p)) - "*foo*bar*baz*") - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "'foo'bar'baz'" - "'foo\"bar'baz\"") - "#foo~bar#baz~" - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "!foo!bar!baz!" - "!foo|bar!baz|") - (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - ";foo;bar;baz;" - ":foo;bar:baz;") - (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) - "<foo>bar<baz>") - "(foo)bar(baz)" - (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") - "{foo}bar{baz}")) + (let ((files + (list + (if (or (tramp--test-gvfs-p) + (tramp--test-rclone-p) + (tramp--test-sudoedit-p) + (tramp--test-windows-nt-or-smb-p)) + "foo bar baz" + (if (or (tramp--test-adb-p) + (tramp--test-docker-p) + (eq system-type 'cygwin)) + " foo bar baz " + " foo\tbar baz\t")) + "$foo$bar$$baz$" + "-foo-bar-baz-" + "%foo%bar%baz%" + "&foo&bar&baz&" + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-windows-nt-or-smb-p)) + "?foo?bar?baz?") + (unless (or (tramp--test-ftp-p) + (tramp--test-gvfs-p) + (tramp--test-windows-nt-or-smb-p)) + "*foo*bar*baz*") + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "'foo'bar'baz'" + "'foo\"bar'baz\"") + "#foo~bar#baz~" + (if (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "!foo!bar!baz!" + "!foo|bar!baz|") + (if (or (tramp--test-gvfs-p) + (tramp--test-rclone-p) + (tramp--test-windows-nt-or-smb-p)) + ";foo;bar;baz;" + ":foo;bar:baz;") + (unless (or (tramp--test-gvfs-p) (tramp--test-windows-nt-or-smb-p)) + "<foo>bar<baz>") + "(foo)bar(baz)" + (unless (or (tramp--test-ftp-p) (tramp--test-gvfs-p)) "[foo]bar[baz]") + "{foo}bar{baz}"))) + ;; Simplify test in order to speed up. + (apply 'tramp--test-check-files + (if (tramp--test-expensive-test) + files (list (mapconcat 'identity files "")))))) ;; These tests are inspired by Bug#17238. -(ert-deftest tramp-test38-special-characters () +(ert-deftest tramp-test40-special-characters () "Check special characters in file names." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) @@ -4350,7 +5013,7 @@ This requires restrictions of file name syntax." (tramp--test-special-characters)) -(ert-deftest tramp-test38-special-characters-with-stat () +(ert-deftest tramp-test40-special-characters-with-stat () "Check special characters in file names. Use the `stat' command." :tags '(:expensive-test) @@ -4368,7 +5031,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test38-special-characters-with-perl () +(ert-deftest tramp-test40-special-characters-with-perl () "Check special characters in file names. Use the `perl' command." :tags '(:expensive-test) @@ -4389,7 +5052,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-special-characters))) -(ert-deftest tramp-test38-special-characters-with-ls () +(ert-deftest tramp-test40-special-characters-with-ls () "Check special characters in file names. Use the `ls' command." :tags '(:expensive-test) @@ -4412,7 +5075,7 @@ Use the `ls' command." (tramp--test-special-characters))) (defun tramp--test-utf8 () - "Perform the test in `tramp-test39-utf8*'." + "Perform the test in `tramp-test41-utf8*'." (let* ((utf8 (if (and (eq system-type 'darwin) (memq 'utf-8-hfs (coding-system-list))) 'utf-8-hfs 'utf-8)) @@ -4420,14 +5083,34 @@ Use the `ls' command." (coding-system-for-write utf8) (file-name-coding-system (coding-system-change-eol-conversion utf8 'unix))) - (tramp--test-check-files - (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") - (unless (tramp--test-hpux-p) - "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") - "银河系漫游指南系列" - "Автостопом по гала́ктике"))) - -(ert-deftest tramp-test39-utf8 () + (apply + 'tramp--test-check-files + (append + (list + (unless (tramp--test-hpux-p) "Γυρίστε το Γαλαξία με Ώτο Στοπ") + (unless (tramp--test-hpux-p) + "أصبح بوسعك الآن تنزيل نسخة كاملة من موسوعة ويكيبيديا العربية لتصفحها بلا اتصال بالإنترنت") + "银河系漫游指南系列" + "Автостопом по гала́ктике" + ;; Use codepoints without a name. See Bug#31272. + "bung") + + (when (tramp--test-expensive-test) + (delete-dups + (mapcar + ;; Use all available language specific snippets. Filter out + ;; strings which use unencodable characters. + (lambda (x) + (and + (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) + (not (unencodable-char-position + 0 (length x) file-name-coding-system nil x)) + ;; ?\n and ?/ shouldn't be part of any file name. ?\t, + ;; ?. and ?? do not work for "smb" method. + (replace-regexp-in-string "[\t\n/.?]" "" x))) + language-info-alist))))))) + +(ert-deftest tramp-test41-utf8 () "Check UTF8 encoding in file names and file contents." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) @@ -4437,7 +5120,7 @@ Use the `ls' command." (tramp--test-utf8)) -(ert-deftest tramp-test39-utf8-with-stat () +(ert-deftest tramp-test41-utf8-with-stat () "Check UTF8 encoding in file names and file contents. Use the `stat' command." :tags '(:expensive-test) @@ -4457,7 +5140,7 @@ Use the `stat' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test39-utf8-with-perl () +(ert-deftest tramp-test41-utf8-with-perl () "Check UTF8 encoding in file names and file contents. Use the `perl' command." :tags '(:expensive-test) @@ -4480,7 +5163,7 @@ Use the `perl' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test39-utf8-with-ls () +(ert-deftest tramp-test41-utf8-with-ls () "Check UTF8 encoding in file names and file contents. Use the `ls' command." :tags '(:expensive-test) @@ -4503,7 +5186,7 @@ Use the `ls' command." tramp-connection-properties))) (tramp--test-utf8))) -(ert-deftest tramp-test40-file-system-info () +(ert-deftest tramp-test42-file-system-info () "Check that `file-system-info' returns proper values." (skip-unless (tramp--test-enabled)) ;; Since Emacs 27.1. @@ -4521,22 +5204,25 @@ Use the `ls' command." (numberp (nth 2 fsi)))))) (defun tramp--test-timeout-handler () - (interactive) + "Timeout handler, reporting a failed test." (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) ;; This test is inspired by Bug#16928. -(ert-deftest tramp-test41-asynchronous-requests () +(ert-deftest tramp-test43-asynchronous-requests () "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags '(:expensive-test) + :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) ;; This test could be blocked on hydra. So we set a timeout of 300 ;; seconds, and we send a SIGUSR1 signal after 300 seconds. + ;; This clearly doesn't work though, because the test not + ;; infrequently hangs for hours until killed by the infrastructure. (with-timeout (300 (tramp--test-timeout-handler)) (define-key special-event-map [sigusr1] 'tramp--test-timeout-handler) + (tramp--test-instrument-test-case (if (getenv "EMACS_HYDRA_CI") 10 0) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) (watchdog @@ -4555,10 +5241,11 @@ process sentinels. They shall not disturb each other." ;; Number of asynchronous processes for test. Tests on ;; some machines handle less parallel processes. (number-proc - (or - (ignore-errors - (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES"))) - 10)) + (cond + ((ignore-errors + (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES")))) + ((getenv "EMACS_HYDRA_CI") 5) + (t 10))) ;; On hydra, timings are bad. (timer-repeat (cond @@ -4588,11 +5275,16 @@ process sentinels. They shall not disturb each other." (default-directory tmp-name) (file (buffer-name (nth (random (length buffers)) buffers)))) + (tramp--test-message + "Start timer %s %s" file (current-time-string)) (funcall timer-operation file) ;; Adjust timer if it takes too much time. (when (> (- (float-time) time) timer-repeat) (setq timer-repeat (* 1.5 timer-repeat)) - (setf (timer--repeat-delay timer) timer-repeat))))))) + (setf (timer--repeat-delay timer) timer-repeat) + (tramp--test-message "Increase timer %s" timer-repeat)) + (tramp--test-message + "Stop timer %s %s" file (current-time-string))))))) ;; Create temporary buffers. The number of buffers ;; corresponds to the number of processes; it could be @@ -4619,6 +5311,8 @@ process sentinels. They shall not disturb each other." (set-process-filter proc (lambda (proc string) + (tramp--test-message + "Process filter %s %s %s" proc string (current-time-string)) (with-current-buffer (process-buffer proc) (insert string)) (unless (zerop (length string)) @@ -4628,6 +5322,8 @@ process sentinels. They shall not disturb each other." (set-process-sentinel proc (lambda (proc _state) + (tramp--test-message + "Process sentinel %s %s" proc (current-time-string)) (dired-uncache (process-get proc 'foo)) (should-not (file-attributes (process-get proc 'foo))))))) @@ -4641,6 +5337,8 @@ process sentinels. They shall not disturb each other." (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) + (tramp--test-message + "Start action %d %s %s" count buf (current-time-string)) ;; Regular operation prior process action. (dired-uncache file) (if (= count 0) @@ -4651,11 +5349,15 @@ process sentinels. They shall not disturb each other." (accept-process-output proc 0.1 nil 0) ;; Give the watchdog a chance. (read-event nil nil 0.01) + (tramp--test-message + "Continue action %d %s %s" count buf (current-time-string)) ;; Regular operation post process action. (dired-uncache file) (if (= count 2) (should-not (file-attributes file)) (should (file-attributes file))) + (tramp--test-message + "Stop action %d %s %s" count buf (current-time-string)) (process-put proc 'bar (1+ count)) (unless (process-live-p proc) (setq buffers (delq buf buffers)))))) @@ -4663,6 +5365,7 @@ process sentinels. They shall not disturb each other." ;; Checks. All process output shall exists in the ;; respective buffers. All created files shall be ;; deleted. + (tramp--test-message "Check %s" (current-time-string)) (dolist (buf buffers) (with-current-buffer buf (should (string-equal (format "%s\n" buf) (buffer-string))))) @@ -4677,11 +5380,13 @@ process sentinels. They shall not disturb each other." (ignore-errors (delete-process (get-buffer-process buf))) (ignore-errors (kill-buffer buf))) (ignore-errors (cancel-timer timer)) - (ignore-errors (delete-directory tmp-name 'recursive)))))) + (ignore-errors (delete-directory tmp-name 'recursive))))))) ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test42-auto-load () +(ert-deftest tramp-test44-auto-load () "Check that Tramp autoloads properly." + (skip-unless (tramp--test-enabled)) + (let ((default-directory (expand-file-name temporary-file-directory)) (code (format @@ -4698,7 +5403,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test42-delay-load () +(ert-deftest tramp-test44-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. @@ -4731,7 +5436,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-test42-recursive-load () +(ert-deftest tramp-test44-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -4755,7 +5460,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test42-remote-load-path () +(ert-deftest tramp-test44-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. @@ -4784,7 +5489,7 @@ process sentinels. They shall not disturb each other." (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test43-unload () +(ert-deftest tramp-test45-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -4793,42 +5498,52 @@ Since it unloads Tramp, it shall be the last test to run." ;; cannot test older Emacsen, therefore. (skip-unless (tramp--test-emacs26-p)) - (when (featurep 'tramp) - (unload-feature 'tramp 'force) - ;; No Tramp feature must be left. - (should-not (featurep 'tramp)) - (should-not (all-completions "tramp" (delq 'tramp-tests features))) - ;; `file-name-handler-alist' must be clean. - (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) - ;; There shouldn't be left a bound symbol, except buffer-local - ;; variables, and autoload functions. We do not regard our test - ;; symbols, and the Tramp unload hooks. - (mapatoms - (lambda (x) - (and (or (and (boundp x) (null (local-variable-if-set-p x))) - (and (functionp x) (null (autoloadp (symbol-function x))))) - (string-match "^tramp" (symbol-name x)) - (not (string-match "^tramp--?test" (symbol-name x))) - (not (string-match "unload-hook$" (symbol-name x))) - (ert-fail (format "`%s' still bound" x))))) - ;; The defstruct `tramp-file-name' and all its internal functions - ;; shall be purged. - (should-not (cl--find-class 'tramp-file-name)) - (mapatoms - (lambda (x) - (and (functionp x) - (string-match "tramp-file-name" (symbol-name x)) - (ert-fail (format "Structure function `%s' still exists" x))))) - ;; There shouldn't be left a hook function containing a Tramp - ;; function. We do not regard the Tramp unload hooks. - (mapatoms - (lambda (x) - (and (boundp x) - (string-match "-\\(hook\\|function\\)s?$" (symbol-name x)) - (not (string-match "unload-hook$" (symbol-name x))) - (consp (symbol-value x)) - (ignore-errors (all-completions "tramp" (symbol-value x))) - (ert-fail (format "Hook `%s' still contains Tramp function" x))))))) + ;; We have autoloaded objects from tramp.el and tramp-archive.el. + ;; In order to remove them, we first need to load both packages. + (require 'tramp) + (require 'tramp-archive) + (should (featurep 'tramp)) + (should (featurep 'tramp-archive)) + ;; This unloads also tramp-archive.el and tramp-theme.el if needed. + (unload-feature 'tramp 'force) + ;; No Tramp feature must be left. + (should-not (featurep 'tramp)) + (should-not (featurep 'tramp-archive)) + (should-not (featurep 'tramp-theme)) + (should-not + (all-completions + "tramp" (delq 'tramp-tests (delq 'tramp-archive-tests features)))) + ;; `file-name-handler-alist' must be clean. + (should-not (all-completions "tramp" (mapcar 'cdr file-name-handler-alist))) + ;; There shouldn't be left a bound symbol, except buffer-local + ;; variables, and autoload functions. We do not regard our test + ;; symbols, and the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (or (and (boundp x) (null (local-variable-if-set-p x))) + (and (functionp x) (null (autoloadp (symbol-function x))))) + (string-match "^tramp" (symbol-name x)) + (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) + (not (string-match "unload-hook$" (symbol-name x))) + (ert-fail (format "`%s' still bound" x))))) + ;; The defstruct `tramp-file-name' and all its internal functions + ;; shall be purged. + (should-not (cl--find-class 'tramp-file-name)) + (mapatoms + (lambda (x) + (and (functionp x) + (string-match "tramp-file-name" (symbol-name x)) + (ert-fail (format "Structure function `%s' still exists" x))))) + ;; There shouldn't be left a hook function containing a Tramp + ;; function. We do not regard the Tramp unload hooks. + (mapatoms + (lambda (x) + (and (boundp x) + (string-match "-\\(hook\\|function\\)s?$" (symbol-name x)) + (not (string-match "unload-hook$" (symbol-name x))) + (consp (symbol-value x)) + (ignore-errors (all-completions "tramp" (symbol-value x))) + (ert-fail (format "Hook `%s' still contains Tramp function" x)))))) (defun tramp-test-all (&optional interactive) "Run all tests for \\[tramp]." @@ -4845,11 +5560,14 @@ Since it unloads Tramp, it shall be the last test to run." ;; * file-name-case-insensitive-p ;; * Work on skipped tests. Make a comment, when it is impossible. +;; * Revisit expensive tests, once problems in `tramp-error' are solved. ;; * Fix `tramp-test05-expand-file-name-relative' in `expand-file-name'. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. +;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' +;; do not work properly for `nextcloud'. ;; * Fix `tramp-test29-start-file-process' on MS Windows (`process-send-eof'?). -;; * Fix `tramp-test30-interrupt-process', timeout doesn't work reliably. -;; * Fix Bug#16928 in `tramp-test41-asynchronous-requests'. +;; * Fix `tramp-test31-interrupt-process', timeout doesn't work reliably. +;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. (provide 'tramp-tests) ;;; tramp-tests.el ends here diff --git a/test/lisp/progmodes/bat-mode-tests.el b/test/lisp/progmodes/bat-mode-tests.el index a437d5e8010..05b8459b116 100644 --- a/test/lisp/progmodes/bat-mode-tests.el +++ b/test/lisp/progmodes/bat-mode-tests.el @@ -63,10 +63,11 @@ "Test fontification of iteration variables." (should (equal - (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I") + (bat-test-fontify "echo %%a\necho %%~dp1\necho %%~$PATH:I\necho %%~1") "<span class=\"builtin\">echo</span> %%<span class=\"variable-name\">a</span> <span class=\"builtin\">echo</span> %%~dp<span class=\"variable-name\">1</span> -<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span>"))) +<span class=\"builtin\">echo</span> %%~$<span class=\"variable-name\">PATH</span>:<span class=\"variable-name\">I</span> +<span class=\"builtin\">echo</span> %%~<span class=\"variable-name\">1</span>"))) (defun bat-test-fill-paragraph (str) "Return the result of invoking `fill-paragraph' on STR in a `bat-mode' buffer." diff --git a/test/lisp/progmodes/flymake-resources/Makefile b/test/lisp/progmodes/flymake-resources/Makefile index 494407567f2..05399ba388b 100644 --- a/test/lisp/progmodes/flymake-resources/Makefile +++ b/test/lisp/progmodes/flymake-resources/Makefile @@ -8,6 +8,6 @@ CC_OPTS = -Wall -Wextra ## normally use flymake, so it seems like just avoiding the issue ## in this test is fine. Set flymake-log-level to 3 to investigate. check-syntax: - GCC_COLORS= $(CC) $(CC_OPTS) ${CHK_SOURCES} || true + GCC_COLORS= gcc $(CC_OPTS) ${CHK_SOURCES} || true # eof diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index f5aa5d76a1e..629cdf9a137 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -53,7 +53,7 @@ while notdone unless noninteractive do (read-event "" nil 0.1) do (sleep-for (+ 0.5 flymake-no-changes-timeout)) - finally (when notdone (ert-fail + finally (when notdone (ert-skip (format "Some backends not reporting yet %s" notdone))))) @@ -118,6 +118,7 @@ SEVERITY-PREDICATE is used to setup (flymake-goto-prev-error) (should (eq 'flymake-error (face-at-point))))) +(defvar ruby-mode-hook) (ert-deftest ruby-backend () "Test the ruby backend" (skip-unless (executable-find "ruby")) @@ -129,11 +130,14 @@ SEVERITY-PREDICATE is used to setup ;; for this particular yuckiness (abbreviated-home-dir nil)) (unwind-protect - (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)))) + (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-deftest different-diagnostic-types () diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 3ce27a687da..34a05194dfa 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -2004,6 +2004,12 @@ string (python-util-forward-comment -1) (point)))))) +(ert-deftest python-nav-end-of-statement-2 () + "Test the string overlap assertion (Bug#30964)." + (python-tests-with-temp-buffer + "'\n''\n" + (python-nav-end-of-statement))) + (ert-deftest python-nav-forward-statement-1 () (python-tests-with-temp-buffer " @@ -5352,6 +5358,15 @@ buffer with overlapping strings." (python-nav-end-of-statement))) (should (eolp)))) +;; After call `run-python' the buffer running the python process is current. +(ert-deftest python-tests--bug31398 () + "Test for https://debbugs.gnu.org/31398 ." + (skip-unless (executable-find python-tests-shell-interpreter)) + (let ((buffer (process-buffer (run-python nil nil 'show)))) + (should (eq buffer (current-buffer))) + (pop-to-buffer (other-buffer)) + (run-python nil nil 'show) + (should (eq buffer (current-buffer))))) (provide 'python-tests) diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index 97faad4c329..efbe012427f 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -705,17 +705,109 @@ VALUES-PLIST is a list with alternating index and value elements." (ert-deftest ruby-forward-sexp-skips-method-calls-with-keyword-names () (ruby-with-temp-buffer ruby-sexp-test-example - (goto-line 2) + (goto-char (point-min)) + (forward-line 1) (ruby-forward-sexp) (should (= 8 (line-number-at-pos))))) (ert-deftest ruby-backward-sexp-skips-method-calls-with-keyword-names () (ruby-with-temp-buffer ruby-sexp-test-example - (goto-line 8) + (goto-char (point-min)) + (forward-line 7) (end-of-line) (ruby-backward-sexp) (should (= 2 (line-number-at-pos))))) +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-no-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do + |end") + (search-backward "do\n") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-no-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do + |end") + (goto-char (point-max)) + (ruby-backward-sexp) + (should (looking-at "do$")))) + +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-empty-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do || + |end") + (search-backward "do ") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-empty-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do || + |end") + (goto-char (point-max)) + (ruby-backward-sexp) + (should (looking-at "do ")))) + +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |a,b| + |end") + (search-backward "do ") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |a,b| + |end") + (goto-char (point-max)) + (ruby-backward-sexp) + (should (looking-at "do ")))) + +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-any-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |*| + |end") + (search-backward "do ") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-expanded-one-arg () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |a,| + |end") + (search-backward "do ") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-forward-sexp-jumps-do-end-block-with-one-and-any-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |a,*| + |end") + (search-backward "do ") + (ruby-forward-sexp) + (should (eobp)))) + +(ert-deftest ruby-backward-sexp-jumps-do-end-block-with-one-and-any-args () + (ruby-with-temp-buffer + (ruby-test-string + "proc do |a,*| + |end") + (goto-char (point-max)) + (ruby-backward-sexp) + (should (looking-at "do ")))) + (ert-deftest ruby-toggle-string-quotes-quotes-correctly () (let ((pairs '(("puts '\"foo\"\\''" . "puts \"\\\"foo\\\"'\"") diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el new file mode 100644 index 00000000000..061488636d0 --- /dev/null +++ b/test/lisp/progmodes/tcl-tests.el @@ -0,0 +1,77 @@ +;;; tcl-tests.el --- Test suite for tcl-mode + +;; Copyright (C) 2018 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 'tcl) + +;; From bug#23565 +(ert-deftest tcl-mode-beginning-of-defun-1 () + (with-temp-buffer + (tcl-mode) + (insert "proc bad {{value \"\"}} {\n # do something\n}") + (should (beginning-of-defun)) + (should (= (point) (point-min))) + (end-of-defun) + (should (= (point) (point-max))))) + +;; From bug#23565 +(ert-deftest tcl-mode-beginning-of-defun-2 () + (with-temp-buffer + (tcl-mode) + (insert "proc good {{value}} {\n # do something\n}") + (should (beginning-of-defun)) + (should (= (point) (point-min))) + (end-of-defun) + (should (= (point) (point-max))))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc notinthis {} {\n # nothing\n}\n\n") + (should-not (add-log-current-defun)))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc simple {} {\n # nothing\n}") + (backward-char 3) + (should (equal "simple" (add-log-current-defun))))) + +(ert-deftest tcl-mode-function-name () + (with-temp-buffer + (tcl-mode) + (insert "proc inthis {} {\n # nothing\n") + (should (equal "inthis" (add-log-current-defun))))) + +;; From bug#32035 +(ert-deftest tcl-mode-namespace-indent () + (with-temp-buffer + (tcl-mode) + (let ((text "namespace eval Foo {\n variable foo\n}\n")) + (insert text) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) text))))) + +(provide 'tcl-tests) + +;;; tcl-tests.el ends here diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index cd30633e377..ed948ad8554 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -359,6 +359,52 @@ Each element has the format: (dotimes (i (length replace-occur-tests)) (replace-occur-test-create i)) +(ert-deftest replace-occur-revert-bug32543 () + "Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'." + (let ((temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (setq list-matching-lines-jump-to-current-line t) + (insert +";; This buffer is for text that is not saved, and for Lisp evaluation. +;; To create a file, visit it with C-x C-f and enter text in its buffer. + +") + (occur "and") + (with-current-buffer "*Occur*" + (revert-buffer) + (goto-char (point-min)) + (should (string-match "\\`2 matches for \"and\" in buffer: " + (buffer-substring-no-properties + (point) (line-end-position))))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + +(ert-deftest replace-occur-revert-bug32987 () + "Test `occur-revert' with non-nil `list-matching-lines-jump-to-current-line'." + (let ((temp-buffer (get-buffer-create " *test-occur*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer temp-buffer + (erase-buffer) + (setq list-matching-lines-jump-to-current-line nil) + (insert +";; This buffer is for text that is not saved, and for Lisp evaluation. +;; To create a file, visit it with C-x C-f and enter text in its buffer. + +") + (occur "and") + (with-current-buffer "*Occur*" + (revert-buffer) + (goto-char (point-min)) + (should (string-match "\\`2 matches for \"and\" in buffer: " + (buffer-substring-no-properties + (point) (line-end-position))))))) + (and (buffer-name temp-buffer) + (kill-buffer temp-buffer))))) + ;;; Tests for `query-replace' undo feature. @@ -454,5 +500,4 @@ Return the last evalled form in BODY." input "a" "B" ((?\s . (1 2 3)) (?E . (4)) (?U . (5))) ?q (string= input (buffer-string)))))) - ;;; replace-tests.el ends here diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index c60b59a4332..8b07a550df6 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -38,7 +38,7 @@ interactively." (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'ses-cell-set-formula c) (apply 'ses-calculate-cell (list (car c) (cadr c) nil))) - (should (eq A2 2))))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-plain-formula () "Check that setting A1 to 1 and A2 to (1+ A1), makes A2 value @@ -49,13 +49,16 @@ equal to 2. This is done using interactive calls." (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) - (should (eq A2 2))))) + (should (eq (bound-and-true-p A2) 2))))) ;; PLAIN CELL RENAMING TESTS ;; ====================================================================== +(defvar ses--foo) +(defvar ses--cells) + (ert-deftest ses-tests-lowlevel-renamed-cell () - "Check that renaming A1 to `foo' and setting `foo' to 1 and A2 to (1+ foo), makes A2 value equal to 2. + "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 to (1+ ses--foo), makes A2 value equal to 2. This is done using low level functions, `ses-rename-cell' is not called but instead we use text replacement in the buffer previously passed in text mode." @@ -69,63 +72,63 @@ previously passed in text mode." (text-mode) (goto-char (point-min)) (while (re-search-forward "\\<A1\\>" nil t) - (replace-match "foo" t t)) + (replace-match "ses--foo" t t)) (ses-mode) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ foo)))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(ses-safe-formula (1+ ses--foo)))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renamed-cell () - "Check that renaming A1 to `foo' and setting `foo' to 1 and A2 -to (1+ foo), makes A2 value equal to 2." + "Check that renaming A1 to `ses--foo' and setting `ses--foo' to 1 and A2 +to (1+ ses--foo), makes A2 value equal to 2." (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) - (ses-rename-cell 'foo (ses-get-cell 0 0)) - (dolist (c '((0 0 1) (1 0 (1+ foo)))) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) + (dolist (c '((0 0 1) (1 0 (1+ ses--foo)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(1+ foo))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(1+ ses--foo))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renamed-cell-after-setting () "Check that setting A1 to 1 and A2 to (1+ A1), and then -renaming A1 to `foo' makes `foo' value equal to 2." +renaming A1 to `ses--foo' makes `ses--foo' value equal to 2." (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook); deferred recalc - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) '(1+ foo))) - (should (eq A2 2))))) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) '(1+ ses--foo))) + (should (eq (bound-and-true-p A2) 2))))) (ert-deftest ses-tests-renaming-cell-with-one-symbol-formula () "Check that setting A1 to 1 and A2 to A1, and then renaming A1 -to `foo' makes `foo' value equal to 1. Then set A1 to 2 and check -that `foo' becomes 2." +to `ses--foo' makes `ses--foo' value equal to 1. Then set A1 to 2 and check +that `ses--foo' becomes 2." (let ((ses-initial-size '(3 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 A1))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook); deferred recalc - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (ses-command-hook); deferred recalc (should-not (local-variable-p 'A1)) - (should (eq foo 1)) - (should (equal (ses-cell-formula 1 0) 'foo)) - (should (eq A2 1)) + (should (eq ses--foo 1)) + (should (equal (ses-cell-formula 1 0) 'ses--foo)) + (should (eq (bound-and-true-p A2) 1)) (funcall-interactively 'ses-edit-cell 0 0 2) (ses-command-hook); deferred recalc - (should (eq A2 2)) - (should (eq foo 2))))) + (should (eq (bound-and-true-p A2) 2)) + (should (eq ses--foo 2))))) ;; ROW INSERTION TESTS @@ -144,32 +147,31 @@ to A2 and inserting a row, makes A2 value empty, and A3 equal to (ses-jump 'A2) (ses-insert-row 1) (ses-command-hook) - (should-not A2) - (should (eq A3 2))))) + (should-not (bound-and-true-p A2)) + (should (eq (bound-and-true-p A3) 2))))) -; (defvar ses-tests-trigger nil) +(defvar ses--bar) (ert-deftest ses-tests-renamed-cells-row-insertion () - "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `foo' and A2 to `bar' jumping -to `bar' and inserting a row, makes A2 value empty, and `bar' equal to + "Check that setting A1 to 1 and A2 to (1+ A1), and then renaming A1 to `ses--foo' and A2 to `ses--bar' jumping +to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to 2." - (setq ses-tests-trigger nil) (let ((ses-initial-size '(2 . 1))) (with-temp-buffer (ses-mode) (dolist (c '((0 0 1) (1 0 (1+ A1)))) (apply 'funcall-interactively 'ses-edit-cell c)) (ses-command-hook) - (ses-rename-cell 'foo (ses-get-cell 0 0)) + (ses-rename-cell 'ses--foo (ses-get-cell 0 0)) (ses-command-hook) - (ses-rename-cell 'bar (ses-get-cell 1 0)) + (ses-rename-cell 'ses--bar (ses-get-cell 1 0)) (ses-command-hook) - (should (eq bar 2)) - (ses-jump 'bar) + (should (eq ses--bar 2)) + (ses-jump 'ses--bar) (ses-insert-row 1) (ses-command-hook) - (should-not A2) - (should (eq bar 2))))) + (should-not (bound-and-true-p A2)) + (should (eq ses--bar 2))))) (provide 'ses-tests) diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el index c4ec6cca416..329f5cf1129 100644 --- a/test/lisp/shell-tests.el +++ b/test/lisp/shell-tests.el @@ -30,4 +30,12 @@ "Test problem found by Filipp Gunbin in emacs-devel." (should (equal (car (shell--unquote&requote-argument "te'st" 2)) "test"))) +(ert-deftest shell-tests-completion-before-semi () + (with-temp-buffer + (shell-mode) + (insert "cd ba;") + (forward-char -1) + (should (equal (shell--parse-pcomplete-arguments) + '(("cd" "ba") 1 4))))) + ;;; shell-tests.el ends here diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 0103409a636..08e81a7fefb 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -448,6 +448,17 @@ See Bug#21722." (call-interactively #'eval-expression) (should (equal (current-message) "66 (#o102, #x42, ?B)")))))) +(ert-deftest command-execute-prune-command-history () + "Check that Bug#31211 is fixed." + (let ((history-length 1) + (command-history ())) + (dotimes (_ (1+ history-length)) + (command-execute "" t)) + (should (= (length command-history) history-length)))) + + +;;; `line-number-at-pos' + (ert-deftest line-number-at-pos-in-widen-buffer () (let ((target-line 3)) (with-temp-buffer @@ -489,13 +500,12 @@ See Bug#21722." (should (equal pos (point)))))) (ert-deftest line-number-at-pos-when-passing-point () - (let (pos) - (with-temp-buffer - (insert "a\nb\nc\nd\n") - (should (equal (line-number-at-pos 1) 1)) - (should (equal (line-number-at-pos 3) 2)) - (should (equal (line-number-at-pos 5) 3)) - (should (equal (line-number-at-pos 7) 4))))) + (with-temp-buffer + (insert "a\nb\nc\nd\n") + (should (equal (line-number-at-pos 1) 1)) + (should (equal (line-number-at-pos 3) 2)) + (should (equal (line-number-at-pos 5) 3)) + (should (equal (line-number-at-pos 7) 4)))) ;;; Auto fill. @@ -511,5 +521,53 @@ See Bug#21722." (do-auto-fill) (should (string-equal (buffer-string) "foo bar")))) + +;;; Shell command. + +(ert-deftest simple-tests-async-shell-command-30280 () + "Test for https://debbugs.gnu.org/30280 ." + (let* ((async-shell-command-buffer 'new-buffer) + (async-shell-command-display-buffer nil) + (base "name") + (first (buffer-name (generate-new-buffer base))) + (second (generate-new-buffer-name base)) + ;; `save-window-excursion' doesn't restore frame configurations. + (pop-up-frames nil) + (inhibit-message t) + (emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + ;; Let `shell-command' create the buffer as needed. + (kill-buffer first) + (unwind-protect + (save-window-excursion + ;; One command has no output, the other does. + ;; Removing the -eval argument also yields no output, but + ;; then both commands exit simultaneously when + ;; `accept-process-output' is called on the second command. + (dolist (form '("(sleep-for 8)" "(message \"\")")) + (async-shell-command (format "%s -Q -batch -eval '%s'" + emacs form) + first)) + ;; First command should neither have nor display output. + (let* ((buffer (get-buffer first)) + (process (get-buffer-process buffer))) + (should (buffer-live-p buffer)) + (should process) + (should (zerop (buffer-size buffer))) + (should (not (get-buffer-window buffer)))) + ;; Second command should both have and display output. + (let* ((buffer (get-buffer second)) + (process (get-buffer-process buffer))) + (should (buffer-live-p buffer)) + (should process) + (should (accept-process-output process 4 nil t)) + (should (> (buffer-size buffer) 0)) + (should (get-buffer-window buffer)))) + (dolist (name (list first second)) + (let* ((buffer (get-buffer name)) + (process (and buffer (get-buffer-process buffer)))) + (when process (delete-process process)) + (when buffer (kill-buffer buffer))))))) + (provide 'simple-test) ;;; simple-test.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index aa16a0da34e..7465aac5ea5 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -26,7 +26,6 @@ ;; ;;; Code: - (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -62,6 +61,18 @@ (quote (0 font-lock-keyword-face)))))))) +(ert-deftest provided-mode-derived-p () + ;; base case: `derived-mode' directly derives `prog-mode' + (should (progn + (define-derived-mode derived-mode prog-mode "test") + (provided-mode-derived-p 'derived-mode 'prog-mode))) + ;; edge case: `derived-mode' derives an alias of `prog-mode' + (should (progn + (defalias 'parent-mode + (if (fboundp 'prog-mode) 'prog-mode 'fundamental-mode)) + (define-derived-mode derived-mode parent-mode "test") + (provided-mode-derived-p 'derived-mode 'prog-mode)))) + (ert-deftest number-sequence-test () (should (= (length (number-sequence (1- most-positive-fixnum) most-positive-fixnum)) @@ -307,6 +318,43 @@ cf. Bug#25477." (should (eq (string-to-char (symbol-name (gensym))) ?g)) (should (eq (string-to-char (symbol-name (gensym "X"))) ?X))) +(ert-deftest subr-tests--proper-list-p () + "Test `proper-list-p' behavior." + (dotimes (length 4) + ;; Proper and dotted lists. + (let ((list (make-list length 0))) + (should (= (proper-list-p list) length)) + (should (not (proper-list-p (nconc list 0))))) + ;; Circular lists. + (dotimes (n (1+ length)) + (let ((circle (make-list (1+ length) 0))) + (should (not (proper-list-p (nconc circle (nthcdr n circle)))))))) + ;; Atoms. + (should (not (proper-list-p 0))) + (should (not (proper-list-p ""))) + (should (not (proper-list-p []))) + (should (not (proper-list-p (make-bool-vector 0 nil)))) + (should (not (proper-list-p (make-symbol "a"))))) + +(ert-deftest subr-tests--assq-delete-all () + "Test `assq-delete-all' behavior." + (cl-flet ((new-list-fn + () + (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar")))) + (should (equal (cdr (new-list-fn)) (assq-delete-all 'a (new-list-fn)))) + (should (equal (new-list-fn) (assq-delete-all 'd (new-list-fn)))) + (should (equal (new-list-fn) (assq-delete-all "foo" (new-list-fn)))))) + +(ert-deftest subr-tests--assoc-delete-all () + "Test `assoc-delete-all' behavior." + (cl-flet ((new-list-fn + () + (list (cons 'a 1) (cons 'b 2) (cons 'c 3) 'd (cons "foo" "bar")))) + (should (equal (cdr (new-list-fn)) (assoc-delete-all 'a (new-list-fn)))) + (should (equal (new-list-fn) (assoc-delete-all 'd (new-list-fn)))) + (should (equal (butlast (new-list-fn)) + (assoc-delete-all "foo" (new-list-fn)))))) + (ert-deftest shell-quote-argument-%-on-w32 () "Quoting of `%' in w32 shells isn't perfect. See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." @@ -324,5 +372,24 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (shell-quote-argument "%ca%"))) "without-caret %ca%")))) +(ert-deftest subr-tests-flatten-tree () + "Test `flatten-tree' behavior." + (should (equal (flatten-tree '(1 (2 . 3) nil (4 5 (6)) 7)) + '(1 2 3 4 5 6 7))) + (should (equal (flatten-tree '((1 . 2))) + '(1 2))) + (should (equal (flatten-tree '(1 nil 2)) + '(1 2))) + (should (equal (flatten-tree 42) + '(42))) + (should (equal (flatten-tree t) + '(t))) + (should (equal (flatten-tree nil) + nil)) + (should (equal (flatten-tree '((nil) ((((nil)))) nil)) + nil)) + (should (equal (flatten-tree '(1 ("foo" "bar") 2)) + '(1 "foo" "bar" 2)))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index c2b90dea604..9f5dcd559eb 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -89,6 +89,13 @@ first line\r_next line\r\n")) "\e[2;1Hc" "\e[1;2Hb" "\e[1;1Ha") "" t)))) + (should (equal "abcde j" + (term-test-screen-from-input + 10 12 '("abcdefghij" + "\e[H" ;move back to point-min + "abcde" + " j")))) + ;; Relative positioning. (should (equal "ab\ncd" (term-test-screen-from-input @@ -124,6 +131,18 @@ line6\r 40 12 (list "\eAnSiTc /f" "oo/\n") 'default-directory) "/foo/")))) +(ert-deftest term-line-wrapping-then-motion () + "Make sure we reset the line-wrapping state after moving cursor. +A real-life example is the default zsh prompt which writes spaces +to the end of line (triggering line-wrapping state), and then +sends a carriage return followed by another space to overwrite +the first character of the line." + (let* ((width 10) + (strs (list "x" (make-string (1- width) ?_) + "\r_"))) + (should (equal (term-test-screen-from-input width 12 strs) + (make-string width ?_))))) + (ert-deftest term-to-margin () "Test cursor movement at the scroll margin. This is a reduced example from GNU nano's initial screen." @@ -144,7 +163,6 @@ This is a reduced example from GNU nano's initial screen." `("\e[1;3r" "\e[2;1H" ,x "\r\e[1A" ,y)) (concat y "\n" x))))) - (provide 'term-tests) ;;; term-tests.el ends here diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index c16ad3ac287..98dac7478f2 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -85,7 +85,7 @@ (insert "body { top: 0; }") (goto-char 7) (should (equal (css-current-defun-name) "body")) - (goto-char 18) + (goto-char 15) (should (equal (css-current-defun-name) "body")))) (ert-deftest css-test-current-defun-name-nested () @@ -244,6 +244,99 @@ (should (member "body" completions)) (should-not (member "article" completions))))) +(ert-deftest css-test-color-to-4-dpc () + (should (equal (css--color-to-4-dpc "#ffffff") + (css--color-to-4-dpc "#fff"))) + (should (equal (css--color-to-4-dpc "#aabbcc") + (css--color-to-4-dpc "#abc"))) + (should (equal (css--color-to-4-dpc "#fab") + "#ffffaaaabbbb")) + (should (equal (css--color-to-4-dpc "#fafbfc") + "#fafafbfbfcfc"))) + +(ert-deftest css-test-format-hex () + (should (equal (css--format-hex "#fff") "#fff")) + (should (equal (css--format-hex "#ffffff") "#fff")) + (should (equal (css--format-hex "#aabbcc") "#abc")) + (should (equal (css--format-hex "#12ff34") "#12ff34")) + (should (equal (css--format-hex "#aabbccdd") "#abcd")) + (should (equal (css--format-hex "#aabbccde") "#aabbccde")) + (should (equal (css--format-hex "#abcdef") "#abcdef"))) + +(ert-deftest css-test-named-color-to-hex () + (dolist (item '(("black" "#000") + ("white" "#fff") + ("salmon" "#fa8072"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--named-color-to-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-format-rgba-alpha () + (should (equal (css--format-rgba-alpha 0) "0")) + (should (equal (css--format-rgba-alpha 0.0) "0")) + (should (equal (css--format-rgba-alpha 0.00001) "0")) + (should (equal (css--format-rgba-alpha 1) "1")) + (should (equal (css--format-rgba-alpha 1.0) "1")) + (should (equal (css--format-rgba-alpha 1.00001) "1")) + (should (equal (css--format-rgba-alpha 0.10000) "0.1")) + (should (equal (css--format-rgba-alpha 0.100001) "0.1")) + (should (equal (css--format-rgba-alpha 0.2524334) "0.25"))) + +(ert-deftest css-test-hex-to-rgb () + (dolist (item '(("#000" "rgb(0, 0, 0)") + ("#000000" "rgb(0, 0, 0)") + ("#fff" "rgb(255, 255, 255)") + ("#ffffff" "rgb(255, 255, 255)") + ("#ffffff80" "rgba(255, 255, 255, 0.5)") + ("#fff0" "rgba(255, 255, 255, 0)") + ("#fff8" "rgba(255, 255, 255, 0.53)") + ("#ffff" "rgba(255, 255, 255, 1)"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--hex-to-rgb) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-rgb-to-named-color-or-hex () + (dolist (item '(("rgb(0, 0, 0)" "black") + ("rgb(255, 255, 255)" "white") + ("rgb(255, 255, 240)" "ivory") + ("rgb(18, 52, 86)" "#123456") + ("rgba(18, 52, 86, 0.5)" "#12345680") + ("rgba(18, 52, 86, 50%)" "#12345680") + ("rgba(50%, 50%, 50%, 50%)" "#80808080"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--rgb-to-named-color-or-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-cycle-color-format () + (with-temp-buffer + (css-mode) + (insert "black") + (css-cycle-color-format) + (should (equal (buffer-string) "#000")) + (css-cycle-color-format) + (should (equal (buffer-string) "rgb(0, 0, 0)")) + (css-cycle-color-format) + (should (equal (buffer-string) "black")))) + +(ert-deftest css-test-join-nested-selectors () + (should (equal (css--join-nested-selectors '("div" "&:hover")) + "div:hover")) + (should + (equal (css--join-nested-selectors '("a" "&::before, &::after")) + "a::before, a::after")) + (should + (equal (css--join-nested-selectors + '("article" "& > .front-page" "& h1, & h2")) + "article > .front-page h1, article > .front-page h2")) + (should (equal (css--join-nested-selectors '(".link" "& + &")) + ".link + .link"))) + (ert-deftest css-mdn-symbol-guessing () (dolist (item '(("@med" "ia" "@media") ("@keyframes " "{" "@keyframes") @@ -263,11 +356,11 @@ (ert-deftest css-test-rgb-parser () (with-temp-buffer (css-mode) - (dolist (input '("255, 0, 127" - "255, /* comment */ 0, 127" - "255 0 127" - "255, 0, 127, 0.75" - "255 0 127 / 0.75" + (dolist (input '("255, 0, 128" + "255, /* comment */ 0, 128" + "255 0 128" + "255, 0, 128, 0.75" + "255 0 128 / 0.75" "100%, 0%, 50%" "100%, 0%, 50%, 0.115" "100% 0% 50%" @@ -275,7 +368,7 @@ (erase-buffer) (save-excursion (insert input ")")) - (should (equal (css--rgb-color) "#ff007f"))))) + (should (equal (css--rgb-color) "#ff0080"))))) (ert-deftest css-test-hsl-parser () (with-temp-buffer @@ -301,6 +394,12 @@ (should (equal (css--hex-color "#aabbcc") "#aabbcc")) (should (equal (css--hex-color "#aabbccdd") "#aabbcc"))) +(ert-deftest css-test-hex-alpha () + (should (equal (css--hex-alpha "#abcd") "d")) + (should-not (css--hex-alpha "#abc")) + (should (equal (css--hex-alpha "#aabbccdd") "dd")) + (should-not (css--hex-alpha "#aabbcc"))) + (ert-deftest css-test-named-color () (dolist (text '("@mixin black" "@include black")) (with-temp-buffer diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el new file mode 100644 index 00000000000..a2bcde44b99 --- /dev/null +++ b/test/lisp/textmodes/fill-tests.el @@ -0,0 +1,50 @@ +;;; fill-test.el --- ERT tests for fill.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. + +;; Author: Marcin Borkowski <mbork@mbork.pl> +;; Keywords: text, wp + +;; 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 package defines tests for the filling feature, specifically +;; the `fill-polish-nobreak-p' function. + +;;; Code: + +(require 'ert) + +(ert-deftest fill-test-no-fill-polish-nobreak-p nil + "Tests of the `fill-polish-nobreak-p' function." + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '()) + (fill-paragraph) + (should (string= (buffer-string) "Abc d\nefg (h\nijk)."))) + (with-temp-buffer + (insert "Abc d efg (h ijk).") + (setq fill-column 8) + (setq-local fill-nobreak-predicate '(fill-polish-nobreak-p)) + (fill-paragraph) + (should (string= (buffer-string) "Abc\nd efg\n(h ijk).")))) + + +(provide 'fill-tests) + +;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el index 20b5e27ff5d..61ae87e36db 100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@ -131,5 +131,35 @@ The point is set to the beginning of the buffer." (sgml-delete-tag 1) (should (string= "Winter is comin'" (buffer-string))))) +(ert-deftest sgml-quote-works () + (let ((text "Foo<Bar> \"Baz\" 'Qux'\n")) + (with-temp-buffer + ;; Back and forth transformation. + (insert text) + (sgml-quote (point-min) (point-max)) + (should (string= "Foo<Bar> "Baz" 'Qux'\n" + (buffer-string))) + (sgml-quote (point-min) (point-max) t) + (should (string= text (buffer-string))) + + ;; The same text escaped differently. + (erase-buffer) + (insert "Foo<Bar> "Baz" 'Qux'\n") + (sgml-quote (point-min) (point-max) t) + (should (string= text (buffer-string))) + + ;; Lack of semicolon. + (erase-buffer) + (insert "&&") + (sgml-quote (point-min) (point-max) t) + (should (string= "&&" (buffer-string))) + + ;; Double quoting + (sgml-quote (point-min) (point-max)) + (sgml-quote (point-min) (point-max)) + (sgml-quote (point-min) (point-max) t) + (sgml-quote (point-min) (point-max) t) + (should (string= "&&" (buffer-string)))))) + (provide 'sgml-mode-tests) ;;; sgml-mode-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 452fcc6895b..347cc7f12cb 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -65,7 +65,10 @@ ("http://example.com/ab)c" 4 url "http://example.com/ab)c") ;; URL markup, lacking schema ("<url:foo@example.com>" 1 url "mailto:foo@example.com") - ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/")) + ("<url:ftp.example.net/abc/>" 1 url "ftp://ftp.example.net/abc/") + ;; 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. Each list element should have the form diff --git a/test/lisp/thread-tests.el b/test/lisp/thread-tests.el new file mode 100644 index 00000000000..0d57d38779f --- /dev/null +++ b/test/lisp/thread-tests.el @@ -0,0 +1,96 @@ +;;; thread-tests.el --- Test suite for thread.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Gemini Lasswell <gazally@runbox.com> +;; Keywords: threads + +;; 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 'thread) + +;; Declare the functions used here in case Emacs has been configured +;; --without-threads. +(declare-function make-mutex "thread.c" (&optional name)) +(declare-function mutex-lock "thread.c" (mutex)) +(declare-function mutex-unlock "thread.c" (mutex)) +(declare-function make-thread "thread.c" (function &optional name)) +(declare-function thread-join "thread.c" (thread)) +(declare-function thread-yield "thread.c" ()) + +(defvar thread-tests-flag) +(defvar thread-tests-mutex (when (featurep 'threads) (make-mutex "mutex1"))) + +(defun thread-tests--thread-function () + (setq thread-tests-flag t) + (with-mutex thread-tests-mutex + (sleep-for 0.01))) + +(ert-deftest thread-tests-thread-list-send-error () + "A thread can be sent an error signal from the *Thread List* buffer." + (skip-unless (featurep 'threads)) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) + (with-mutex thread-tests-mutex + (setq thread-tests-flag nil) + (let ((thread (make-thread #'thread-tests--thread-function + "thread-tests-wait"))) + (while (not thread-tests-flag) + (thread-yield)) + (list-threads) + (goto-char (point-min)) + (re-search-forward + "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?") + (thread-list-send-error-signal) + (should-error (thread-join thread)) + (list-threads) + (goto-char (point-min)) + (should-error (re-search-forward "thread-tests")))))) + +(ert-deftest thread-tests-thread-list-show-backtrace () + "Show a backtrace for another thread from the *Thread List* buffer." + (skip-unless (featurep 'threads)) + (let (thread) + (with-mutex thread-tests-mutex + (setq thread-tests-flag nil) + (setq thread + (make-thread #'thread-tests--thread-function "thread-tests-back")) + (while (not thread-tests-flag) + (thread-yield)) + (list-threads) + (goto-char (point-min)) + (re-search-forward + "^thread-tests.+[[:blank:]]+Blocked[[:blank:]]+.+mutex1.+?") + (thread-list-pop-to-backtrace) + (goto-char (point-min)) + (re-search-forward "thread-tests-back") + (re-search-forward "mutex-lock") + (re-search-forward "thread-tests--thread-function")) + (thread-join thread))) + +(ert-deftest thread-tests-list-threads-error-when-not-configured () + "Signal an error running `list-threads' if threads are not configured." + (skip-unless (not (featurep 'threads))) + (should-error (list-threads))) + +(provide 'thread-tests) + +;;; thread-tests.el ends here diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-test.el new file mode 100644 index 00000000000..5822e16a88a --- /dev/null +++ b/test/lisp/url/url-handlers-test.el @@ -0,0 +1,75 @@ +;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Nicolas Petton <nicolas@petton.fr> + +;; 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 'url-handlers) + +(defmacro with-url-handler-mode (&rest body) + "Evaluate BODY with `url-handler-mode' turned on." + (declare (indent 0) (debug t)) + (let ((url-handler-mode-active (make-symbol "url-handler-mode-active"))) + `(let ((,url-handler-mode-active url-handler-mode)) + (unwind-protect + (progn + (unless ,url-handler-mode-active + (url-handler-mode)) + ,@body) + (unless ,url-handler-mode-active + (url-handler-mode -1)))))) + +(ert-deftest url-handlers-file-name-directory/preserve-url-types () + (with-url-handler-mode + (should (equal (file-name-directory "https://gnu.org/index.html") + "https://gnu.org/")) + (should (equal (file-name-directory "http://gnu.org/index.html") + "http://gnu.org/")) + (should (equal (file-name-directory "ftp://gnu.org/index.html") + "ftp://gnu.org/")))) + +(ert-deftest url-handlers-file-name-directory/should-not-handle-non-url-file-names () + (with-url-handler-mode + (should-not (equal (file-name-directory "not-uri://gnu.org") + "not-uri://gnu.org/")))) + +(ert-deftest url-handlers-file-name-directory/sub-directories () + (with-url-handler-mode + (should (equal (file-name-directory "https://foo/bar/baz/index.html") + "https://foo/bar/baz/")))) + +(ert-deftest url-handlers-file-name-directory/file-urls () + (with-url-handler-mode + (should (equal (file-name-directory "file:///foo/bar/baz.txt") + "file:///foo/bar/")) + (should (equal (file-name-directory "file:///") + "file:///")))) + +;; Regression test for bug#30444 +(ert-deftest url-handlers-file-name-directory/no-filename () + (with-url-handler-mode + (should (equal (file-name-directory "https://foo.org") + "https://foo.org/")) + (should (equal (file-name-directory "https://foo.org/") + "https://foo.org/")))) + +(provide 'url-handlers-test) +;;; url-handlers-test.el ends here diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el index 8af2b2cd55d..69117b81f42 100644 --- a/test/lisp/url/url-util-tests.el +++ b/test/lisp/url/url-util-tests.el @@ -46,6 +46,18 @@ ("key2" "val2") ("key1" "val1"))))) +(ert-deftest url-domain-tests () + (should (equal (url-domain (url-generic-parse-url "http://www.fsf.co.uk")) + "fsf.co.uk")) + (should (equal (url-domain (url-generic-parse-url "http://fsf.co.uk")) + "fsf.co.uk")) + (should (equal (url-domain (url-generic-parse-url "http://co.uk")) + nil)) + (should (equal (url-domain (url-generic-parse-url "http://www.fsf.com")) + "fsf.com")) + (should (equal (url-domain (url-generic-parse-url "http://192.168.0.1")) + nil))) + (provide 'url-util-tests) ;;; url-util-tests.el ends here diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 54cabe6e48a..4276974c2ac 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -182,7 +182,7 @@ youthfulness (with-temp-buffer (cd temp-dir) (insert patch) - (beginning-of-buffer) + (goto-char (point-min)) (diff-apply-hunk) (diff-apply-hunk) (diff-apply-hunk)) diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index af65cd1c205..8fa16cdccb1 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -112,9 +112,6 @@ (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)) - ;; Avoid vc-mode-line bug; - ;; http://lists.gnu.org/r/emacs-devel/2018-12/msg00368.html - (skip-unless (not (eq 0 (user-real-uid)))) (let* ((homedir (make-temp-file "vc-bzr-test" t)) (bzrdir (expand-file-name "bzr" homedir)) (file (progn diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 2bc65198645..0e61d2a767a 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -109,7 +109,7 @@ (require 'ert) (require 'vc) -(declare-function w32-application-type "w32proc") +(declare-function w32-application-type "w32proc.c") ;; The working horses. diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el index 65084926203..9c815065b2a 100644 --- a/test/lisp/xdg-tests.el +++ b/test/lisp/xdg-tests.el @@ -65,4 +65,16 @@ (should (equal (xdg-desktop-strings " ") nil)) (should (equal (xdg-desktop-strings "a; ;") '("a" " ")))) +(ert-deftest xdg-mime-associations () + "Test reading MIME associations from files." + (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir)) + (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir)) + (fs (list apps cache))) + (should (equal (xdg-mime-collect-associations "x-test/foo" fs) + '("a.desktop" "b.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/bar" fs) + '("a.desktop" "c.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/baz" fs) + '("a.desktop" "b.desktop" "d.desktop"))))) + ;;; xdg-tests.el ends here diff --git a/test/manual/cedet/semantic-ia-utest.el b/test/manual/cedet/semantic-ia-utest.el index 07f8118f32a..665a5382440 100644 --- a/test/manual/cedet/semantic-ia-utest.el +++ b/test/manual/cedet/semantic-ia-utest.el @@ -434,7 +434,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) (defun semantic-src-utest-buffer-refs () diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index a98e01816ef..9109d665fa3 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -178,9 +178,8 @@ Optional argument ARG specifies not to use color." "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it." (interactive) (let ((start (current-time)) - (junk (semantic-idle-scheduler-work-parse-neighboring-files)) - (end (current-time))) - (message "Work took %.2f seconds." (semantic-elapsed-time start end)))) + (junk (semantic-idle-scheduler-work-parse-neighboring-files))) + (message "Work took %.2f seconds." (semantic-elapsed-time start nil)))) ;;; From semantic-lex: @@ -195,10 +194,9 @@ If universal argument ARG, then try the whole buffer." (result (semantic-lex (if arg (point-min) (point)) (point-max) - 100)) - (end (current-time))) + 100))) (message "Elapsed Time: %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (pop-to-buffer "*Lexer Output*") (require 'pp) (erase-buffer) @@ -278,7 +276,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) ;;; From bovine-gcc: diff --git a/test/manual/indent/css-mode.css b/test/manual/indent/css-mode.css index 640418b022d..ecf6c3c0ca5 100644 --- a/test/manual/indent/css-mode.css +++ b/test/manual/indent/css-mode.css @@ -56,6 +56,8 @@ div::before { sans-serif; font: 15px "Helvetica Neue", Helvetica, Arial, "Nimbus Sans L", sans-serif; + background: no-repeat right + 5px center; transform: matrix(1.0, 2.0, 3.0, 4.0, 5.0, 6.0); diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 43b7ea75d50..845d41f9d60 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -69,4 +69,29 @@ with parameters from the *Messages* buffer modification." (progn (get-buffer-create "nil") (generate-new-buffer-name "nil"))))) +(ert-deftest test-buffer-base-buffer-indirect () + (with-temp-buffer + (let* ((ind-buf-name (generate-new-buffer-name "indbuf")) + (ind-buf (make-indirect-buffer (current-buffer) ind-buf-name))) + (should (eq (buffer-base-buffer ind-buf) (current-buffer)))))) + +(ert-deftest test-buffer-base-buffer-non-indirect () + (with-temp-buffer + (should (eq (buffer-base-buffer (current-buffer)) nil)))) + +(ert-deftest overlay-evaporation-after-killed-buffer () + (let* ((ols (with-temp-buffer + (insert "toto") + (list + (make-overlay (point-min) (point-max)) + (make-overlay (point-min) (point-max)) + (make-overlay (point-min) (point-max))))) + (ol (nth 1 ols))) + (overlay-put ol 'evaporate t) + ;; Evaporation within move-overlay of an overlay that was deleted because + ;; of a kill-buffer, triggered an assertion failure in unchain_both. + (with-temp-buffer + (insert "toto") + (move-overlay ol (point-min) (point-min))))) + ;;; buffer-tests.el ends here diff --git a/test/src/callint-tests.el b/test/src/callint-tests.el new file mode 100644 index 00000000000..feee9b692b7 --- /dev/null +++ b/test/src/callint-tests.el @@ -0,0 +1,54 @@ +;;; callint-tests.el --- unit tests for callint.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2018 Free Software Foundation, Inc. + +;; Author: Philipp Stephani <phst@google.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for src/callint.c. + +;;; Code: + +(require 'ert) + +(ert-deftest call-interactively/incomplete-multibyte-sequence () + "Check that Bug#30004 is fixed." + (let ((data (should-error (call-interactively (lambda () (interactive "\xFF")))))) + (should + (equal + (cdr data) + '("Invalid control letter `\u00FF' (#o377, #x00ff) in interactive calling string"))))) + +(ert-deftest call-interactively/embedded-nulls () + "Check that Bug#30005 is fixed." + (should (equal (let ((unread-command-events '(?a ?b))) + (call-interactively (lambda (a b) + (interactive "ka\0a: \nkb: ") + (list a b)))) + '("a" "b")))) + +(ert-deftest call-interactively-prune-command-history () + "Check that Bug#31211 is fixed." + (let ((history-length 1) + (command-history ())) + (dotimes (_ (1+ history-length)) + (call-interactively #'ignore t)) + (should (= (length command-history) history-length)))) + +;;; callint-tests.el ends here diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 0069ee84fe1..bc77a7be94e 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -113,7 +113,24 @@ most-positive-fixnum, which is just less than a power of 2.") (should (isnan (min 0.0e+NaN))) (should (isnan (min 0.0e+NaN 1 2))) (should (isnan (min 1.0 0.0e+NaN))) - (should (isnan (min 1.0 0.0e+NaN 1.1)))) + (should (isnan (min 1.0 0.0e+NaN 1.1))) + (should (isnan (min 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum)))) + (should (isnan (max 1.0 0.0e+NaN 1.1 (1+ most-positive-fixnum))))) + +(defun data-tests-popcnt (byte) + "Calculate the Hamming weight of BYTE." + (if (< byte 0) + (setq byte (lognot byte))) + (if (zerop byte) + 0 + (+ (logand byte 1) (data-tests-popcnt (ash byte -1))))) + +(ert-deftest data-tests-logcount () + (should (cl-loop for n in (number-sequence -255 255) + always (= (logcount n) (data-tests-popcnt n)))) + ;; https://oeis.org/A000120 + (should (= 11 (logcount 9727))) + (should (= 8 (logcount 9999)))) ;; Bool vector tests. Compactly represent bool vectors as hex ;; strings. @@ -169,17 +186,17 @@ most-positive-fixnum, which is just less than a power of 2.") (dotimes (_ 4) (aset bv i (> (logand 1 n) 0)) (cl-incf i) - (setf n (lsh n -1))))) + (setf n (ash n -1))))) bv)) (defun test-bool-vector-to-hex-string (bv) (let (nibbles (v (cl-coerce bv 'list))) (while v (push (logior - (lsh (if (nth 0 v) 1 0) 0) - (lsh (if (nth 1 v) 1 0) 1) - (lsh (if (nth 2 v) 1 0) 2) - (lsh (if (nth 3 v) 1 0) 3)) + (ash (if (nth 0 v) 1 0) 0) + (ash (if (nth 1 v) 1 0) 1) + (ash (if (nth 2 v) 1 0) 2) + (ash (if (nth 3 v) 1 0) 3)) nibbles) (setf v (nthcdr 4 v))) (mapconcat (lambda (n) (format "%X" n)) @@ -467,7 +484,7 @@ comparing the subr with a much slower lisp implementation." (should-have-watch-data `(data-tests-lvar 3 set ,buf1))) (should-have-watch-data `(data-tests-lvar 1 unlet ,buf1)) (setq-default data-tests-lvar 4) - (should-have-watch-data `(data-tests-lvar 4 set nil)) + (should-have-watch-data '(data-tests-lvar 4 set nil)) (with-temp-buffer (setq buf2 (current-buffer)) (setq data-tests-lvar 1) @@ -484,7 +501,7 @@ comparing the subr with a much slower lisp implementation." (kill-all-local-variables) (should-have-watch-data `(data-tests-lvar nil makunbound ,buf2))) (setq-default data-tests-lvar 4) - (should-have-watch-data `(data-tests-lvar 4 set nil)) + (should-have-watch-data '(data-tests-lvar 4 set nil)) (makunbound 'data-tests-lvar) (should-have-watch-data '(data-tests-lvar nil makunbound nil)) (setq data-tests-lvar 5) @@ -508,4 +525,148 @@ comparing the subr with a much slower lisp implementation." (bound-and-true-p data-tests-foo2) (bound-and-true-p data-tests-foo3))))))) +(ert-deftest data-tests-bignum () + (should (bignump (+ most-positive-fixnum 1))) + (let ((f0 (+ (float most-positive-fixnum) 1)) + (f-1 (- (float most-negative-fixnum) 1)) + (b0 (+ most-positive-fixnum 1)) + (b-1 (- most-negative-fixnum 1))) + (should (> b0 -1)) + (should (> b0 f-1)) + (should (> b0 b-1)) + (should (>= b0 -1)) + (should (>= b0 f-1)) + (should (>= b0 b-1)) + (should (>= b-1 b-1)) + + (should (< -1 b0)) + (should (< f-1 b0)) + (should (< b-1 b0)) + (should (<= -1 b0)) + (should (<= f-1 b0)) + (should (<= b-1 b0)) + (should (<= b-1 b-1)) + + (should (= (+ f0 b0) (+ b0 f0))) + (should (= (+ f0 b-1) (+ b-1 f0))) + (should (= (+ f-1 b0) (+ b0 f-1))) + (should (= (+ f-1 b-1) (+ b-1 f-1))) + + (should (= (* f0 b0) (* b0 f0))) + (should (= (* f0 b-1) (* b-1 f0))) + (should (= (* f-1 b0) (* b0 f-1))) + (should (= (* f-1 b-1) (* b-1 f-1))) + + (should (= b0 f0)) + (should (= b0 b0)) + + (should (/= b0 f-1)) + (should (/= b0 b-1)) + + (should (/= b0 0.0e+NaN)) + (should (/= b-1 0.0e+NaN)))) + +(ert-deftest data-tests-+ () + (should-not (fixnump (+ most-positive-fixnum most-positive-fixnum))) + (should (> (+ most-positive-fixnum most-positive-fixnum) most-positive-fixnum)) + (should (eq (- (+ most-positive-fixnum most-positive-fixnum) + (+ most-positive-fixnum most-positive-fixnum)) + 0))) + +(ert-deftest data-tests-/ () + (let* ((x (* most-positive-fixnum 8)) + (y (* most-negative-fixnum 8)) + (z (- y))) + (should (= most-positive-fixnum (/ x 8))) + (should (= most-negative-fixnum (/ y 8))) + (should (= -1 (/ y z))) + (should (= -1 (/ z y))) + (should (= 0 (/ x (* 2 x)))) + (should (= 0 (/ y (* 2 y)))) + (should (= 0 (/ z (* 2 z)))))) + +(ert-deftest data-tests-number-predicates () + (should (fixnump 0)) + (should (fixnump most-negative-fixnum)) + (should (fixnump most-positive-fixnum)) + (should (integerp (+ most-positive-fixnum 1))) + (should (integer-or-marker-p (+ most-positive-fixnum 1))) + (should (numberp (+ most-positive-fixnum 1))) + (should (number-or-marker-p (+ most-positive-fixnum 1))) + (should (natnump (+ most-positive-fixnum 1))) + (should-not (fixnump (+ most-positive-fixnum 1))) + (should (bignump (+ most-positive-fixnum 1)))) + +(ert-deftest data-tests-number-to-string () + (let* ((s "99999999999999999999999999999") + (v (read s))) + (should (equal (number-to-string v) s)))) + +(ert-deftest data-tests-1+ () + (should (> (1+ most-positive-fixnum) most-positive-fixnum)) + (should (fixnump (1+ (1- most-negative-fixnum))))) + +(ert-deftest data-tests-1- () + (should (< (1- most-negative-fixnum) most-negative-fixnum)) + (should (fixnump (1- (1+ most-positive-fixnum))))) + +(ert-deftest data-tests-logand () + (should (= -1 (logand) (logand -1) (logand -1 -1))) + (let ((n (1+ most-positive-fixnum))) + (should (= (logand -1 n) n))) + (let ((n (* 2 most-negative-fixnum))) + (should (= (logand -1 n) n)))) + +(ert-deftest data-tests-logcount () + (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) + +(ert-deftest data-tests-logior () + (should (= -1 (logior -1) (logior -1 -1))) + (should (= -1 (logior most-positive-fixnum most-negative-fixnum)))) + +(ert-deftest data-tests-logxor () + (should (= -1 (logxor -1) (logxor -1 -1 -1))) + (let ((n (1+ most-positive-fixnum))) + (should (= (logxor -1 n) (lognot n))))) + +(ert-deftest data-tests-minmax () + (let ((a (- most-negative-fixnum 1)) + (b (+ most-positive-fixnum 1)) + (c 0)) + (should (= (min a b c) a)) + (should (= (max a b c) b)))) + +(defun data-tests-check-sign (x y) + (should (eq (cl-signum x) (cl-signum y)))) + +(ert-deftest data-tests-%-mod () + (let* ((b1 (+ most-positive-fixnum 1)) + (nb1 (- b1)) + (b3 (+ most-positive-fixnum 3)) + (nb3 (- b3))) + (data-tests-check-sign (% 1 3) (% b1 b3)) + (data-tests-check-sign (mod 1 3) (mod b1 b3)) + (data-tests-check-sign (% 1 -3) (% b1 nb3)) + (data-tests-check-sign (mod 1 -3) (mod b1 nb3)) + (data-tests-check-sign (% -1 3) (% nb1 b3)) + (data-tests-check-sign (mod -1 3) (mod nb1 b3)) + (data-tests-check-sign (% -1 -3) (% nb1 nb3)) + (data-tests-check-sign (mod -1 -3) (mod nb1 nb3)))) + +(ert-deftest data-tests-ash-lsh () + (should (= (ash most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (ash 0 (* 2 most-positive-fixnum)) 0)) + (should (= (ash 1000 (* 2 most-negative-fixnum)) 0)) + (should (= (ash -1000 (* 2 most-negative-fixnum)) -1)) + (should (= (ash (* 2 most-negative-fixnum) (* 2 most-negative-fixnum)) -1)) + (should (= (lsh most-negative-fixnum 1) + (* most-negative-fixnum 2))) + (should (= (ash (* 2 most-negative-fixnum) -1) + most-negative-fixnum)) + (should (= (lsh most-positive-fixnum -1) (/ most-positive-fixnum 2))) + (should (= (lsh most-negative-fixnum -1) (lsh (- most-negative-fixnum) -1))) + (should (= (lsh -1 -1) most-positive-fixnum)) + (should-error (lsh (1- most-negative-fixnum) -1))) + ;;; data-tests.el ends here diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index 041d21d9c16..d3b0a11d836 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -150,54 +150,59 @@ (ert-deftest format-c-float () (should-error (format "%c" 0.5))) -;;; Check format-time-string with various TZ settings. -;;; Use only POSIX-compatible TZ values, since the tests should work -;;; even if tzdb is not in use. -(ert-deftest format-time-string-with-zone () - ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs - ;; in MS-Windows (and presumably other) C libraries when formatting - ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this - ;; test is for GNU Emacs, not for C runtimes. Instead, look before - ;; you leap: "look" is the timestamp just before the first leap - ;; second on 1972-06-30 23:59:60 UTC, so it should format to the - ;; same string regardless of whether the underlying C library - ;; ignores leap seconds, while avoiding circa-1970 glitches. - ;; - ;; Similarly, stick to the limited set of time zones that are - ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters - ;; in the abbreviation, and no DST. - (let ((look '(1202 22527 999999 999999)) - (format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)")) - ;; UTC. - (should (string-equal - (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) - "1972-06-30 23:59:59.999 +0000")) - ;; "UTC0". - (should (string-equal - (format-time-string format look "UTC0") - "1972-06-30 23:59:59.999 +0000 (UTC)")) - ;; Negative UTC offset, as a Lisp list. - (should (string-equal - (format-time-string format look '(-28800 "PST")) - "1972-06-30 15:59:59.999 -0800 (PST)")) - ;; Negative UTC offset, as a Lisp integer. - (should (string-equal - (format-time-string format look -28800) - ;; MS-Windows build replaces unrecognizable TZ values, - ;; such as "-08", with "ZZZ". - (if (eq system-type 'windows-nt) - "1972-06-30 15:59:59.999 -0800 (ZZZ)" - "1972-06-30 15:59:59.999 -0800 (-08)"))) - ;; Positive UTC offset that is not an hour multiple, as a string. - (should (string-equal - (format-time-string format look "IST-5:30") - "1972-07-01 05:29:59.999 +0530 (IST)")))) - -;;; This should not dump core. -(ert-deftest format-time-string-with-outlandish-zone () - (should (stringp - (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil - (concat (make-string 2048 ?X) "0"))))) +;;; Test for Bug#29609. +(ert-deftest format-sharp-0-x () + (should (string-equal (format "%#08x" #x10) "0x000010")) + (should (string-equal (format "%#05X" #x10) "0X010")) + (should (string-equal (format "%#04x" 0) "0000"))) + + +;;; Tests for Bug#30408. + +(ert-deftest format-%d-large-float () + (should (string-equal (format "%d" 18446744073709551616.0) + "18446744073709551616")) + (should (string-equal (format "%d" -18446744073709551616.0) + "-18446744073709551616"))) + +;;; Perhaps Emacs will be improved someday to return the correct +;;; answer for positive numbers instead of overflowing; in +;;; that case these tests will need to be changed. In the meantime make +;;; sure Emacs is reporting the overflow correctly. +(ert-deftest format-%x-large-float () + (should-error (format "%x" 18446744073709551616.0) + :type 'overflow-error)) +(ert-deftest read-large-integer () + (should (eq (type-of (read (format "%d0" most-negative-fixnum))) 'integer)) + (should (eq (type-of (read (format "%+d" (* -8.0 most-negative-fixnum)))) + 'integer)) + (should (eq (type-of (read (substring (format "%d" most-negative-fixnum) 1))) + 'integer)) + (should (eq (type-of (read (format "#x%x" most-negative-fixnum))) + 'integer)) + (should (eq (type-of (read (format "#o%o" most-negative-fixnum))) + 'integer)) + (should (eq (type-of (read (format "#32rG%x" most-positive-fixnum))) + 'integer)) + (let ((binary-as-unsigned nil)) + (dolist (fmt '("%d" "%s" "#o%o" "#x%x")) + (dolist (val (list most-negative-fixnum (1+ most-negative-fixnum) + -1 0 1 + (1- most-positive-fixnum) most-positive-fixnum)) + (should (eq val (read (format fmt val)))))))) + +(ert-deftest format-%o-invalid-float () + (should-error (format "%o" -1e-37) + :type 'overflow-error)) + +;; Bug#31938 +(ert-deftest format-%d-float () + (should (string-equal (format "%d" -1.1) "-1")) + (should (string-equal (format "%d" -0.9) "0")) + (should (string-equal (format "%d" -0.0) "0")) + (should (string-equal (format "%d" 0.0) "0")) + (should (string-equal (format "%d" 0.9) "0")) + (should (string-equal (format "%d" 1.1) "1"))) (ert-deftest format-with-field () (should (equal (format "First argument %2$s, then %3$s, then %1$s" 1 2 3) @@ -323,4 +328,49 @@ (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker)) (garbage-collect))) +(ert-deftest format-bignum () + (let* ((s1 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF") + (v1 (read (concat "#x" s1))) + (s2 "99999999999999999999999999999999") + (v2 (read s2)) + (v3 #x-3ffffffffffffffe000000000000000)) + (should (> v1 most-positive-fixnum)) + (should (equal (format "%X" v1) s1)) + (should (> v2 most-positive-fixnum)) + (should (equal (format "%d" v2) s2)) + (should (equal (format "%d" v3) "-5316911983139663489309385231907684352")) + (should (equal (format "%+d" v3) "-5316911983139663489309385231907684352")) + (should (equal (format "%+d" (- v3)) + "+5316911983139663489309385231907684352")) + (should (equal (format "% d" (- v3)) + " 5316911983139663489309385231907684352")) + (should (equal (format "%o" v3) + "-37777777777777777777600000000000000000000")) + (should (equal (format "%#50.40x" v3) + " -0x000000003ffffffffffffffe000000000000000")) + (should (equal (format "%-#50.40x" v3) + "-0x000000003ffffffffffffffe000000000000000 ")))) + +(ert-deftest test-group-name () + (should (stringp (group-name (group-gid)))) + (should-error (group-name 'foo)) + (cond + ((memq system-type '(windows-nt ms-dos)) + (should-not (group-name 123456789))) + ((executable-find "getent") + (with-temp-buffer + (let (stat name) + (dolist (gid (list 0 1212345 (group-gid))) + (erase-buffer) + (setq stat (ignore-errors + (call-process "getent" nil '(t nil) nil "group" + (number-to-string gid)))) + (setq name (group-name gid)) + (goto-char (point-min)) + (cond ((eq stat 0) + (if (looking-at "\\([[:alnum:]_-]+\\):") + (should (string= (match-string 1) name)))) + ((eq stat 2) + (should-not name))))))))) + ;;; editfns-tests.el ends here diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 6f4490d9d12..e4593044ecd 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -17,7 +17,9 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ +(require 'cl-lib) (require 'ert) +(require 'help-fns) (defconst mod-test-emacs (expand-file-name invocation-name invocation-directory) @@ -25,12 +27,19 @@ (eval-and-compile (defconst mod-test-file - (substitute-in-file-name - "$EMACS_TEST_DIRECTORY/data/emacs-module/mod-test") + (expand-file-name "../test/data/emacs-module/mod-test" invocation-directory) "File name of the module test file.")) (require 'mod-test mod-test-file) +(cl-defgeneric emacs-module-tests--generic (_)) + +(cl-defmethod emacs-module-tests--generic ((_ module-function)) + 'module-function) + +(cl-defmethod emacs-module-tests--generic ((_ user-ptr)) + 'user-ptr) + ;; ;; Basic tests. ;; @@ -57,12 +66,12 @@ (when (< #x1fffffff most-positive-fixnum) (should (= (mod-test-sum 1 #x1fffffff) (1+ #x1fffffff))) - (should (= (mod-test-sum -1 #x20000000) + (should (= (mod-test-sum -1 (1+ #x1fffffff)) #x1fffffff))) - (should-error (mod-test-sum 1 most-positive-fixnum) - :type 'overflow-error) - (should-error (mod-test-sum -1 most-negative-fixnum) - :type 'overflow-error)) + (should (= (mod-test-sum 1 most-positive-fixnum) + (1+ most-positive-fixnum))) + (should (= (mod-test-sum -1 most-negative-fixnum) + (1- most-negative-fixnum)))) (ert-deftest mod-test-sum-docstring () (should (string= (documentation 'mod-test-sum) "Return A + B\n\n(fn a b)"))) @@ -73,7 +82,9 @@ This test needs to be changed whenever the implementation changes." (let ((func (symbol-function #'mod-test-sum))) (should (module-function-p func)) + (should (functionp func)) (should (equal (type-of func) 'module-function)) + (should (eq (emacs-module-tests--generic func) 'module-function)) (should (string-match-p (rx bos "#<module function " (or "Fmod_test_sum" @@ -127,8 +138,9 @@ changes." (defun multiply-string (s n) (let ((res "")) - (dotimes (i n res) - (setq res (concat res s))))) + (dotimes (i n) + (setq res (concat res s))) + res)) (ert-deftest mod-test-globref-make-test () (let ((mod-str (mod-test-globref-make)) @@ -152,6 +164,7 @@ changes." (r (mod-test-userptr-get v))) (should (eq (type-of v) 'user-ptr)) + (should (eq (emacs-module-tests--generic v) 'user-ptr)) (should (integerp r)) (should (= r n)))) @@ -254,4 +267,26 @@ during garbage collection." (rx "Module function called during garbage collection\n") (mod-test-invalid-finalizer))) +(ert-deftest module/describe-function-1 () + "Check that Bug#30163 is fixed." + (with-temp-buffer + (let ((standard-output (current-buffer))) + (describe-function-1 #'mod-test-sum) + (should (equal + (buffer-substring-no-properties 1 (point-max)) + (format "a module function in `data/emacs-module/mod-test%s'. + +(mod-test-sum a b) + +Return A + B" + module-file-suffix)))))) + +(ert-deftest module/load-history () + "Check that Bug#30164 is fixed." + (load mod-test-file) + (cl-destructuring-bind (file &rest entries) (car load-history) + (should (equal (file-name-sans-extension file) mod-test-file)) + (should (member '(provide . mod-test) entries)) + (should (member '(defun . mod-test-sum) entries)))) + ;;; emacs-module-tests.el ends here diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index b7509aed58f..48295b81fa3 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -26,6 +26,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'cl-lib)) (ert-deftest eval-tests--bug24673 () "Check that Bug#24673 has been fixed." @@ -37,8 +38,7 @@ (ert-deftest eval-tests--bugs-24912-and-24913 () "Check that Emacs doesn't accept weird argument lists. Bug#24912 and Bug#24913." - (dolist (args '((&optional) (&rest) (&optional &rest) (&rest &optional) - (&optional &rest a) (&optional a &rest) + (dolist (args '((&rest &optional) (&rest a &optional) (&rest &optional a) (&optional &optional) (&optional &optional a) (&optional a &optional b) @@ -47,7 +47,22 @@ Bug#24912 and Bug#24913." (should-error (eval `(funcall (lambda ,args)) t) :type 'invalid-function) (should-error (byte-compile-check-lambda-list args)) (let ((byte-compile-debug t)) - (should-error (eval `(byte-compile (lambda ,args)) t))))) + (ert-info ((format "bytecomp: args = %S" args)) + (should-error (eval `(byte-compile (lambda ,args)) t)))))) + +(ert-deftest eval-tests-accept-empty-optional-rest () + "Check that Emacs accepts empty &optional and &rest arglists. +Bug#24912." + (dolist (args '((&optional) (&rest) (&optional &rest) + (&optional &rest a) (&optional a &rest))) + (let ((fun `(lambda ,args 'ok))) + (ert-info ("eval") + (should (eq (funcall (eval fun t)) 'ok))) + (ert-info ("byte comp check") + (byte-compile-check-lambda-list args)) + (ert-info ("bytecomp") + (let ((byte-compile-debug t)) + (should (eq (funcall (byte-compile fun)) 'ok))))))) (dolist (form '(let let*)) @@ -99,6 +114,31 @@ crash/abort/malloc assert failure on the next test." (signal-hook-function #'ignore)) (should-error (eval-tests--exceed-specbind-limit)))) +(ert-deftest defvar/bug31072 () + "Check that Bug#31072 is fixed." + (should-error (eval '(defvar 1) t) :type 'wrong-type-argument)) + +(ert-deftest defvaralias-overwrite-warning () + "Test for Bug#5950." + (defvar eval-tests--foo) + (setq eval-tests--foo 2) + (defvar eval-tests--foo-alias) + (setq eval-tests--foo-alias 1) + (cl-letf (((symbol-function 'display-warning) + (lambda (type &rest _) + (throw 'got-warning type)))) + ;; Warn if we lose a value through aliasing. + (should (equal + '(defvaralias losing-value eval-tests--foo-alias) + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo)))) + ;; Don't warn if we don't. + (makunbound 'eval-tests--foo-alias) + (should (eq 'no-warning + (catch 'got-warning + (defvaralias 'eval-tests--foo-alias 'eval-tests--foo) + 'no-warning))))) + (ert-deftest eval-tests-byte-code-being-evaluated-is-protected-from-gc () "Regression test for Bug#33014. Check that byte-compiled objects being executed by exec-byte-code diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index 8853a4e9f7b..6262d946df1 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -29,11 +29,7 @@ (defun fileio-tests--symlink-failure () (let* ((dir (make-temp-file "fileio" t)) - (link (expand-file-name "link" dir)) - (file-name-coding-system (if (and (eq system-type 'darwin) - (featurep 'ucs-normalize)) - 'utf-8-hfs-unix - file-name-coding-system))) + (link (expand-file-name "link" dir))) (unwind-protect (let (failure (char 0)) @@ -99,3 +95,15 @@ Also check that an encoding error can appear in a symlink." (should (equal (file-name-as-directory "d:/abc/") "d:/abc/")) (should (equal (file-name-as-directory "D:\\abc/") "d:/abc/")) (should (equal (file-name-as-directory "D:/abc//") "d:/abc//"))) + +(ert-deftest fileio-tests--relative-HOME () + "Test that expand-file-name works even when HOME is relative." + (let ((old-home (getenv "HOME"))) + (setenv "HOME" "a/b/c") + (should (equal (expand-file-name "~/foo") + (expand-file-name "a/b/c/foo"))) + (when (memq system-type '(ms-dos windows-nt)) + ;; Test expansion of drive-relative file names. + (setenv "HOME" "x:foo") + (should (equal (expand-file-name "~/bar") "x:/foo/bar"))) + (setenv "HOME" old-home))) diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index 6dfd01034eb..643866f1146 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -20,10 +20,10 @@ (require 'ert) (ert-deftest divide-extreme-sign () - (should-error (ceiling most-negative-fixnum -1.0)) - (should-error (floor most-negative-fixnum -1.0)) - (should-error (round most-negative-fixnum -1.0)) - (should-error (truncate most-negative-fixnum -1.0))) + (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (round most-negative-fixnum -1.0) (- most-negative-fixnum))) + (should (= (truncate most-negative-fixnum -1.0) (- most-negative-fixnum)))) (ert-deftest logb-extreme-fixnum () (should (= (logb most-negative-fixnum) (1+ (logb most-positive-fixnum))))) @@ -34,4 +34,89 @@ (should-error (ftruncate 0) :type 'wrong-type-argument) (should-error (fround 0) :type 'wrong-type-argument)) +(ert-deftest bignum-to-float () + ;; 122 because we want to go as big as possible to provoke a rounding error, + ;; but not too big: 2**122 < 10**37 < 2**123, and the C standard says + ;; 10**37 <= DBL_MAX so 2**122 cannot overflow as a double. + (let ((a (1- (ash 1 122)))) + (should (or (eql a (1- (floor (float a)))) + (eql a (floor (float a)))))) + (should (eql (float (+ most-positive-fixnum 1)) + (+ (float most-positive-fixnum) 1)))) + +(ert-deftest bignum-abs () + (should (= most-positive-fixnum + (- (abs most-negative-fixnum) 1)))) + +(ert-deftest bignum-expt () + (dolist (n (list most-positive-fixnum (1+ most-positive-fixnum) + most-negative-fixnum (1- most-negative-fixnum) + -2 -1 0 1 2)) + (should (= (expt n 0) 1)) + (should (= (expt n 1) n)) + (should (= (expt n 2) (* n n))) + (should (= (expt n 3) (* n n n))))) + +(ert-deftest bignum-logb () + (should (= (+ (logb most-positive-fixnum) 1) + (logb (+ most-positive-fixnum 1))))) + +(ert-deftest bignum-mod () + (should (= 0 (mod (1+ most-positive-fixnum) 2.0)))) + +(ert-deftest bignum-round () + (let ((ns (list (* most-positive-fixnum most-negative-fixnum) + (1- most-negative-fixnum) most-negative-fixnum + (1+ most-negative-fixnum) -2 1 1 2 + (1- most-positive-fixnum) most-positive-fixnum + (1+ most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum)))) + (dolist (n ns) + (should (= n (ceiling n))) + (should (= n (floor n))) + (should (= n (round n))) + (should (= n (truncate n))) + (let ((-n (- n)) + (f (float n)) + (-f (- (float n)))) + (should (= 1 (round n f) (round -n -f) (round f n) (round -f -n))) + (should (= -1 (round -n f) (round n -f) (round f -n) (round -f n)))) + (dolist (d ns) + (let ((q (/ n d)) + (r (% n d)) + (same-sign (eq (< n 0) (< d 0)))) + (should (= (ceiling n d) + (+ q (if (and same-sign (not (zerop r))) 1 0)))) + (should (= (floor n d) + (- q (if (and (not same-sign) (not (zerop r))) 1 0)))) + (should (= (truncate n d) q)) + (let ((cdelta (abs (- n (* d (ceiling n d))))) + (fdelta (abs (- n (* d (floor n d))))) + (rdelta (abs (- n (* d (round n d)))))) + (should (<= rdelta cdelta)) + (should (<= rdelta fdelta)) + (should (if (zerop r) + (= 0 cdelta fdelta rdelta) + (or (/= cdelta fdelta) + (zerop (% (round n d) 2))))))))))) + +(ert-deftest special-round () + (let ((ns '(-1e+INF 1e+INF -1 1 -1e+NaN 1e+NaN))) + (dolist (n ns) + (unless (<= (abs n) 1) + (should-error (ceiling n)) + (should-error (floor n)) + (should-error (round n)) + (should-error (truncate n))) + (dolist (d ns) + (unless (<= (abs (/ n d)) 1) + (should-error (ceiling n d)) + (should-error (floor n d)) + (should-error (round n d)) + (should-error (truncate n d))))))) + +(ert-deftest big-round () + (should (= (floor 54043195528445955 3) + (floor 54043195528445955 3.0)))) + (provide 'floatfns-tests) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 0d2a15e758b..3d1a8b37b4e 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -23,6 +23,17 @@ (require 'cl-lib) +;; Test that equality predicates work correctly on NaNs when combined +;; with hash tables based on those predicates. This was not the case +;; for eql in Emacs 26. +(ert-deftest fns-tests-equality-nan () + (dolist (test (list #'eq #'eql #'equal)) + (let* ((h (make-hash-table :test test)) + (nan 0.0e+NaN) + (-nan (- nan))) + (puthash nan t h) + (should (eq (funcall test nan -nan) (gethash -nan h)))))) + (ert-deftest fns-tests-reverse () (should-error (reverse)) (should-error (reverse 1)) @@ -575,4 +586,63 @@ :type 'wrong-type-argument) '(wrong-type-argument plistp (:foo 1 . :bar))))) +(ert-deftest test-string-distance () + "Test `string-distance' behavior." + ;; ASCII characters are always fine + (should (equal 1 (string-distance "heelo" "hello"))) + (should (equal 2 (string-distance "aeelo" "hello"))) + (should (equal 0 (string-distance "ab" "ab" t))) + (should (equal 1 (string-distance "ab" "abc" t))) + + ;; string containing hanzi character, compare by byte + (should (equal 6 (string-distance "ab" "ab我她" t))) + (should (equal 3 (string-distance "ab" "a我b" t))) + (should (equal 3 (string-distance "我" "她" t))) + + ;; string containing hanzi character, compare by character + (should (equal 2 (string-distance "ab" "ab我她"))) + (should (equal 1 (string-distance "ab" "a我b"))) + (should (equal 1 (string-distance "我" "她")))) + +(ert-deftest test-bignum-eql () + "Test that `eql' works for bignums." + (let ((x (+ most-positive-fixnum 1)) + (y (+ most-positive-fixnum 1))) + (should (eq x x)) + (should (eql x y)) + (should (equal x y)) + (should-not (eql x 0.0e+NaN)))) + +(ert-deftest test-bignum-hash () + "Test that hash tables work for bignums." + ;; Make two bignums that are eql but not eq. + (let ((b1 (1+ most-positive-fixnum)) + (b2 (1+ most-positive-fixnum))) + (dolist (test '(eq eql equal)) + (let ((hash (make-hash-table :test test))) + (puthash b1 t hash) + (should (eq (gethash b2 hash) + (funcall test b1 b2))))))) + +(ert-deftest test-nthcdr-simple () + (should (eq (nthcdr 0 'x) 'x)) + (should (eq (nthcdr 1 '(x . y)) 'y)) + (should (eq (nthcdr 2 '(x y . z)) 'z))) + +(ert-deftest test-nthcdr-circular () + (dolist (len '(1 2 5 37 120 997 1024)) + (let ((cycle (make-list len nil))) + (setcdr (last cycle) cycle) + (dolist (n (list (1- most-negative-fixnum) most-negative-fixnum + -1 0 1 + (1- len) len (1+ len) + most-positive-fixnum (1+ most-positive-fixnum) + (* 2 most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum) + (ash 1 12345))) + (let ((a (nthcdr n cycle)) + (b (if (<= n 0) cycle (nthcdr (mod n len) cycle)))) + (should (equal (list (eq a b) n len) + (list t n len)))))))) + (provide 'fns-tests) diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 00000000000..651b0a0bb7a --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,291 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2018 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: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(declare-function json-serialize "json.c" (object &rest args)) +(declare-function json-insert "json.c" (object &rest args)) +(declare-function json-parse-string "json.c" (string &rest args)) +(declare-function json-parse-buffer "json.c" (&rest args)) + +(define-error 'json-tests--error "JSON test error") + +(ert-deftest json-serialize/roundtrip () + (skip-unless (fboundp 'json-serialize)) + ;; The noncharacter U+FFFF should be passed through, + ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. + (let ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"]) + (json "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/object () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}"))) + (should (equal (json-serialize '((abc . [1 2 t]) (def . :null))) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize nil) "{}")) + (should (equal (json-serialize '((abc))) "{\"abc\":{}}")) + (should (equal (json-serialize '((a . 1) (b . 2) (a . 3))) + "{\"a\":1,\"b\":2}")) + (should-error (json-serialize '(abc)) :type 'wrong-type-argument) + (should-error (json-serialize '((a 1))) :type 'wrong-type-argument) + (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument) + (should-error (json-serialize '((a . 1) . b)) :type 'wrong-type-argument) + (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list) + (should-error (json-serialize '(#1=(a #1#)))) + + (should (equal (json-serialize '(:abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize '(abc [1 2 t] :def :null)) + "{\"abc\":[1,2,true],\"def\":null}")) + (should-error (json-serialize '#1=(:a 1 . #1#)) :type 'circular-list) + (should-error (json-serialize '#1=(:a 1 :b . #1#)) :type 'circular-list) + (should-error (json-serialize '(:foo "bar" (unexpected-alist-key . 1))) + :type 'wrong-type-argument) + (should-error (json-serialize '((abc . "abc") :unexpected-plist-key "key")) + :type 'wrong-type-argument) + (should-error (json-serialize '(:foo bar :odd-numbered)) + :type 'wrong-type-argument) + (should (equal + (json-serialize + (list :detect-hash-table #s(hash-table test equal data ("bla" "ble")) + :detect-alist '((bla . "ble")) + :detect-plist '(:bla "ble"))) + "\ +{\ +\"detect-hash-table\":{\"bla\":\"ble\"},\ +\"detect-alist\":{\"bla\":\"ble\"},\ +\"detect-plist\":{\"bla\":\"ble\"}\ +}"))) + +(ert-deftest json-serialize/object-with-duplicate-keys () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'eq))) + (puthash (copy-sequence "abc") [1 2 t] table) + (puthash (copy-sequence "abc") :null table) + (should (equal (hash-table-count table) 2)) + (should-error (json-serialize table) :type 'wrong-type-argument))) + +(ert-deftest json-parse-string/object () + (skip-unless (fboundp 'json-parse-string)) + (let ((input + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")) + (let ((actual (json-parse-string input))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null))))) + (should (equal (json-parse-string input :object-type 'alist) + '((abc . [9 :false]) (def . :null)))) + (should (equal (json-parse-string input :object-type 'plist) + '(:abc [9 :false] :def :null))))) + +(ert-deftest json-parse-string/string () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) + (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") + ["\nasdфывfgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) + (should-error (json-parse-string "foo") :type 'json-parse-error) + ;; FIXME: Is this the right behavior? + (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"]))) + +(ert-deftest json-serialize/string () + (skip-unless (fboundp 'json-serialize)) + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) + "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")) + (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]")) + ;; FIXME: Is this the right behavior? + (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]"))) + +(ert-deftest json-serialize/invalid-unicode () + (skip-unless (fboundp 'json-serialize)) + (should-error (json-serialize ["a\uDBBBb"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x110000v"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x3FFFFFv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\xCCv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\u00C4\xCCv"]) :type 'wrong-type-argument)) + +(ert-deftest json-parse-string/null () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "\x00") :type 'wrong-type-argument) + ;; FIXME: Reconsider whether this is the right behavior. + (should-error (json-parse-string "[a\\u0000b]") :type 'json-parse-error)) + +(ert-deftest json-parse-string/invalid-unicode () + "Some examples from +https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. +Test with both unibyte and multibyte strings." + (skip-unless (fboundp 'json-parse-string)) + ;; Invalid UTF-8 code unit sequences. + (should-error (json-parse-string "[\"\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xC0\xAF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\xAF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\x80\"]") + :type 'json-parse-error) + ;; Surrogates. + (should-error (json-parse-string "[\"\uDB7F\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\uDB7F\uDFFF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error)) + +(ert-deftest json-parse-string/incomplete () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) + +(ert-deftest json-parse-buffer/incomplete () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(ert-deftest json-parse-with-custom-null-and-false-objects () + (skip-unless (and (fboundp 'json-serialize) + (fboundp 'json-parse-string))) + (let* ((input + "{ \"abc\" : [9, false] , \"def\" : null }") + (output + (replace-regexp-in-string " " "" input))) + (should (equal (json-parse-string input + :object-type 'plist + :null-object :json-null + :false-object :json-false) + '(:abc [9 :json-false] :def :json-null))) + (should (equal (json-parse-string input + :object-type 'plist + :false-object :json-false) + '(:abc [9 :json-false] :def :null))) + (should (equal (json-parse-string input + :object-type 'alist + :null-object :zilch) + '((abc . [9 :false]) (def . :zilch)))) + (should (equal (json-parse-string input + :object-type 'alist + :false-object nil + :null-object nil) + '((abc . [9 nil]) (def)))) + (let* ((thingy '(1 2 3)) + (retval (json-parse-string input + :object-type 'alist + :false-object thingy + :null-object nil))) + (should (equal retval `((abc . [9 ,thingy]) (def)))) + (should (eq (elt (cdr (car retval)) 1) thingy))) + (should (equal output + (json-serialize '((abc . [9 :myfalse]) (def . :mynull)) + :false-object :myfalse + :null-object :mynull))) + ;; :object-type is not allowed in json-serialize + (should-error (json-serialize '() :object-type 'alist)))) + +(ert-deftest json-insert/signal () + (skip-unless (fboundp 'json-insert)) + (with-temp-buffer + (let ((calls 0)) + (add-hook 'after-change-functions + (lambda (_begin _end _length) + (cl-incf calls) + (signal 'json-tests--error + '("Error in `after-change-functions'"))) + :local) + (should-error + (json-insert '((a . "b") (c . 123) (d . [1 2 t :false]))) + :type 'json-tests--error) + (should (equal calls 1))))) + +(ert-deftest json-insert/throw () + (skip-unless (fboundp 'json-insert)) + (with-temp-buffer + (let ((calls 0)) + (add-hook 'after-change-functions + (lambda (_begin _end _length) + (cl-incf calls) + (throw 'test-tag 'throw-value)) + :local) + (should + (equal + (catch 'test-tag + (json-insert '((a . "b") (c . 123) (d . [1 2 t :false])))) + 'throw-value)) + (should (equal calls 1))))) + +(ert-deftest json-serialize/bignum () + (skip-unless (fboundp 'json-serialize)) + (should (equal (json-serialize (vector (1+ most-positive-fixnum) + (1- most-negative-fixnum))) + (format "[%d,%d]" + (1+ most-positive-fixnum) + (1- most-negative-fixnum))))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index b92dfc18c5c..ae918f03120 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -142,6 +142,23 @@ literals (Bug#20852)." "unescaped character literals " "`?\"', `?(', `?)', `?;', `?[', `?]' detected!"))))) +(ert-deftest lread-tests--funny-quote-symbols () + "Check that 'smart quotes' or similar trigger errors in symbol names." + (dolist (quote-char + '(#x2018 ;; LEFT SINGLE QUOTATION MARK + #x2019 ;; RIGHT SINGLE QUOTATION MARK + #x201B ;; SINGLE HIGH-REVERSED-9 QUOTATION MARK + #x201C ;; LEFT DOUBLE QUOTATION MARK + #x201D ;; RIGHT DOUBLE QUOTATION MARK + #x201F ;; DOUBLE HIGH-REVERSED-9 QUOTATION MARK + #x301E ;; DOUBLE PRIME QUOTATION MARK + #xFF02 ;; FULLWIDTH QUOTATION MARK + #xFF07 ;; FULLWIDTH APOSTROPHE + )) + (let ((str (format "%cfoo" quote-char))) + (should-error (read str) :type 'invalid-read-syntax) + (should (eq (read (concat "\\" str)) (intern str)))))) + (ert-deftest lread-test-bug26837 () "Test for https://debbugs.gnu.org/26837 ." (let ((load-path (cons @@ -156,13 +173,20 @@ literals (Bug#20852)." (should (string-suffix-p "/somelib.el" (caar load-history))))) (ert-deftest lread-tests--old-style-backquotes () - "Check that loading warns about old-style backquotes." + "Check that loading doesn't accept old-style backquotes." (lread-tests--with-temp-file file-name (write-region "(` (a b))" nil file-name) - (should (equal (load file-name nil :nomessage :nosuffix) t)) - (should (equal (lread-tests--last-message) - (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))) + (let ((data (should-error (load file-name nil :nomessage :nosuffix)))) + (should (equal (cdr data) + (list (concat (format-message "Loading `%s': " file-name) + "old-style backquotes detected!"))))))) + +(ert-deftest lread-tests--force-new-style-backquotes () + (let ((data (should-error (read "(` (a b))")))) + (should (equal (cdr data) '("Old-style backquotes detected!")))) + (should (equal (let ((force-new-style-backquotes t)) + (read "(` (a b))")) + '(`(a b))))) (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) @@ -170,6 +194,9 @@ literals (Bug#20852)." (lread--substitute-object-in-subtree x 1 t) (should (eq x (cdr x))))) +(ert-deftest lread-long-hex-integer () + (should (bignump (read "#xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff")))) + (ert-deftest lread-test-bug-31186 () (with-temp-buffer (insert ";; -*- -:*-") @@ -178,4 +205,17 @@ literals (Bug#20852)." ;; bug was fixed. (eval-buffer)))) +(ert-deftest lread-invalid-bytecodes () + (should-error + (let ((load-force-doc-strings t)) (read "#[0 \"\"]")))) + +(ert-deftest lread-string-to-number-trailing-dot () + (dolist (n (list (* most-negative-fixnum most-negative-fixnum) + (1- most-negative-fixnum) most-negative-fixnum + (1+ most-negative-fixnum) -1 0 1 + (1- most-positive-fixnum) most-positive-fixnum + (1+ most-positive-fixnum) + (* most-positive-fixnum most-positive-fixnum))) + (should (= n (string-to-number (format "%d." n)))))) + ;;; lread-tests.el ends here diff --git a/test/src/print-tests.el b/test/src/print-tests.el index bb98443bbe2..8e377d71808 100644 --- a/test/src/print-tests.el +++ b/test/src/print-tests.el @@ -27,6 +27,42 @@ (prin1-to-string "\u00A2\ff")) "\"\\x00a2\\ff\""))) +(defun print-tests--prints-with-charset-p (ch odd-charset) + "Return t if `prin1-to-string' prints CH with the `charset' property. +CH is propertized with a `charset' value according to +ODD-CHARSET: if nil, then use the one returned by `char-charset', +otherwise, use a different charset." + (integerp + (string-match + "charset" + (prin1-to-string + (propertize (string ch) + 'charset + (if odd-charset + (cl-find (char-charset ch) charset-list :test-not #'eq) + (char-charset ch))))))) + +(ert-deftest print-charset-text-property-nil () + (let ((print-charset-text-property nil)) + (should-not (print-tests--prints-with-charset-p ?\xf6 t)) ; Bug#31376. + (should-not (print-tests--prints-with-charset-p ?a t)) + (should-not (print-tests--prints-with-charset-p ?\xf6 nil)) + (should-not (print-tests--prints-with-charset-p ?a nil)))) + +(ert-deftest print-charset-text-property-default () + (let ((print-charset-text-property 'default)) + (should (print-tests--prints-with-charset-p ?\xf6 t)) + (should-not (print-tests--prints-with-charset-p ?a t)) + (should-not (print-tests--prints-with-charset-p ?\xf6 nil)) + (should-not (print-tests--prints-with-charset-p ?a nil)))) + +(ert-deftest print-charset-text-property-t () + (let ((print-charset-text-property t)) + (should (print-tests--prints-with-charset-p ?\xf6 t)) + (should (print-tests--prints-with-charset-p ?a t)) + (should (print-tests--prints-with-charset-p ?\xf6 nil)) + (should (print-tests--prints-with-charset-p ?a nil)))) + (ert-deftest terpri () (should (string= (with-output-to-string (princ 'abc) @@ -58,5 +94,27 @@ (buffer-string)) "--------\n")))) +(ert-deftest print-read-roundtrip () + (let ((syms (list '## '& '* '+ '- '/ '0E '0e '< '= '> 'E 'E0 'NaN '\" + '\# '\#x0 '\' '\'\' '\( '\) '\+00 '\, '\-0 '\. '\.0 + '\0 '\0.0 '\0E0 '\0e0 '\1E+ '\1E+NaN '\1e+ '\1e+NaN + '\; '\? '\[ '\\ '\] '\` '_ 'a 'e 'e0 'x + '{ '| '} '~ : '\’ '\’bar + (intern "\t") (intern "\n") (intern " ") + (intern "\N{NO-BREAK SPACE}") + (intern "\N{ZERO WIDTH SPACE}") + (intern "\0")))) + (dolist (sym syms) + (should (eq (read (prin1-to-string sym)) sym)) + (dolist (sym1 syms) + (let ((sym2 (intern (concat (symbol-name sym) (symbol-name sym1))))) + (should (eq (read (prin1-to-string sym2)) sym2))))))) + +(ert-deftest print-bignum () + (let* ((str "999999999999999999999999999999999") + (val (read str))) + (should (> val most-positive-fixnum)) + (should (equal (prin1-to-string val) str)))) + (provide 'print-tests) ;;; print-tests.el ends here diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 7cccc5a02cb..514bd04da4e 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -181,5 +181,88 @@ (should-not (process-query-on-exit-flag process)))) (kill-process process))))) +;; Return t if OUTPUT could have been generated by merging the INPUTS somehow. +(defun process-tests--mixable (output &rest inputs) + (while (and output (let ((ins inputs)) + (while (and ins (not (eq (car (car ins)) (car output)))) + (setq ins (cdr ins))) + (if ins + (setcar ins (cdr (car ins)))) + ins)) + (setq output (cdr output))) + (not (apply #'append output inputs))) + +(ert-deftest make-process/mix-stderr () + "Check that `make-process' mixes the output streams if STDERR is nil." + (skip-unless (executable-find "bash")) + ;; Frequent random (?) failures on hydra.nixos.org, with no process output. + ;; Maybe this test should be tagged unstable? See bug#31214. + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + (with-temp-buffer + (let ((process (make-process + :name "mix-stderr" + :command (list "bash" "-c" + "echo stdout && echo stderr >&2") + :buffer (current-buffer) + :sentinel #'ignore + :noquery t + :connection-type 'pipe))) + (while (process-live-p process) + (accept-process-output process)) + (should (eq (process-status process) 'exit)) + (should (eq (process-exit-status process) 0)) + (should (process-tests--mixable (string-to-list (buffer-string)) + (string-to-list "stdout\n") + (string-to-list "stderr\n")))))) + +(ert-deftest make-process/file-handler/found () + "Check that the ‘:file-handler’ argument of ‘make-process’ +works as expected if a file name handler is found." + (let ((file-handler-calls 0)) + (cl-flet ((file-handler + (&rest args) + (should (equal default-directory "test-handler:/dir/")) + (should (equal args '(make-process :name "name" + :command ("/some/binary") + :file-handler t))) + (cl-incf file-handler-calls) + 'fake-process)) + (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") + #'file-handler))) + (default-directory "test-handler:/dir/")) + (should (eq (make-process :name "name" + :command '("/some/binary") + :file-handler t) + 'fake-process)) + (should (= file-handler-calls 1)))))) + +(ert-deftest make-process/file-handler/not-found () + "Check that the ‘:file-handler’ argument of ‘make-process’ +works as expected if no file name handler is found." + (let ((file-name-handler-alist ()) + (default-directory invocation-directory) + (program (expand-file-name invocation-name invocation-directory))) + (should (processp (make-process :name "name" + :command (list program "--version") + :file-handler t))))) + +(ert-deftest make-process/file-handler/disable () + "Check ‘make-process’ works as expected if it shouldn’t use the +file name handler." + (let ((file-name-handler-alist (list (cons (rx bos "test-handler:") + #'process-tests--file-handler))) + (default-directory "test-handler:/dir/") + (program (expand-file-name invocation-name invocation-directory))) + (should (processp (make-process :name "name" + :command (list program "--version")))))) + +(defun process-tests--file-handler (operation &rest _args) + (cl-ecase operation + (unhandled-file-name-directory "/") + (make-process (ert-fail "file name handler called unexpectedly")))) + +(put #'process-tests--file-handler 'operations + '(unhandled-file-name-directory make-process)) + (provide 'process-tests) ;; process-tests.el ends here. diff --git a/test/src/regex-tests.el b/test/src/regex-emacs-tests.el index 26469c304db..e84af6b131b 100644 --- a/test/src/regex-tests.el +++ b/test/src/regex-emacs-tests.el @@ -1,4 +1,4 @@ -;;; regex-tests.el --- tests for regex.c functions -*- lexical-binding: t -*- +;;; regex-emacs-tests.el --- tests for regex-emacs.c -*- lexical-binding: t -*- ;; Copyright (C) 2015-2019 Free Software Foundation, Inc. @@ -24,7 +24,7 @@ (defvar regex-tests--resources-dir (concat (concat (file-name-directory (or load-file-name buffer-file-name)) "/regex-resources/")) - "Path to regex-resources directory next to the \"regex-tests.el\" file.") + "Path to regex-resources directory next to the \"regex-emacs-tests.el\" file.") (ert-deftest regex-word-cc-fallback-test () "Test that \"[[:cc:]]*x\" matches \"x\" (bug#24020). @@ -677,4 +677,10 @@ This evaluates the PTESTS test cases from glibc." This evaluates the TESTS test cases from glibc." (should-not (regex-tests-TESTS))) -;;; regex-tests.el ends here +(ert-deftest regex-repeat-limit () + "Test the #xFFFF repeat limit." + (should (string-match "\\`x\\{65535\\}" (make-string 65535 ?x))) + (should-not (string-match "\\`x\\{65535\\}" (make-string 65534 ?x))) + (should-error (string-match "\\`x\\{65536\\}" "X") :type 'invalid-regexp)) + +;;; regex-emacs-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index e8d66b87db3..5e5bfd155fb 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -19,6 +19,8 @@ ;;; Code: +(require 'thread) + ;; Declare the functions in case Emacs has been configured --without-threads. (declare-function all-threads "thread.c" ()) (declare-function condition-mutex "thread.c" (cond)) @@ -34,10 +36,11 @@ (declare-function thread--blocker "thread.c" (thread)) (declare-function thread-live-p "thread.c" (thread)) (declare-function thread-join "thread.c" (thread)) -(declare-function thread-last-error "thread.c" ()) +(declare-function thread-last-error "thread.c" (&optional cleanup)) (declare-function thread-name "thread.c" (thread)) (declare-function thread-signal "thread.c" (thread error-symbol data)) (declare-function thread-yield "thread.c" ()) +(defvar main-thread) (ert-deftest threads-is-one () "Test for existence of a thread." @@ -71,6 +74,11 @@ (skip-unless (featurep 'threads)) (should (listp (all-threads)))) +(ert-deftest threads-main-thread () + "Simple test for all-threads." + (skip-unless (featurep 'threads)) + (should (eq main-thread (car (all-threads))))) + (defvar threads-test-global nil) (defun threads-test-thread1 () @@ -94,15 +102,24 @@ (progn (setq threads-test-global nil) (let ((thread (make-thread #'threads-test-thread1))) - (thread-join thread) - (and threads-test-global - (not (thread-live-p thread))))))) + (and (= (thread-join thread) 23) + (= threads-test-global 23) + (not (thread-live-p thread))))))) (ert-deftest threads-join-self () "Cannot `thread-join' the current thread." (skip-unless (featurep 'threads)) (should-error (thread-join (current-thread)))) +(ert-deftest threads-join-error () + "Test of error signalling from `thread-join'." + :tags '(:unstable) + (skip-unless (featurep 'threads)) + (let ((thread (make-thread #'threads-call-error))) + (while (thread-live-p thread) + (thread-yield)) + (should-error (thread-join thread)))) + (defvar threads-test-binding nil) (defun threads-test-thread2 () @@ -191,7 +208,7 @@ (ert-deftest threads-mutex-signal () "Test signaling a blocked thread." (skip-unless (featurep 'threads)) - (should + (should-error (progn (setq threads-mutex (make-mutex)) (setq threads-mutex-key nil) @@ -200,8 +217,10 @@ (while (not threads-mutex-key) (thread-yield)) (thread-signal thr 'quit nil) - (thread-join thr)) - t))) + ;; `quit' is not catched by `should-error'. We must indicate it. + (condition-case nil + (thread-join thr) + (quit (signal 'error nil))))))) (defun threads-test-io-switch () (setq threads-test-global 23)) @@ -275,6 +294,9 @@ (thread-yield)) (should (equal (thread-last-error) '(error "Error is called"))) + (should (equal (thread-last-error 'cleanup) + '(error "Error is called"))) + (should-not (thread-last-error)) (setq th2 (make-thread #'threads-custom "threads-custom")) (should (threadp th2)))) @@ -300,6 +322,25 @@ (should-not (thread-live-p thread)) (should (equal (thread-last-error) '(error))))) +(ert-deftest threads-signal-main-thread () + "Test signaling the main thread." + (skip-unless (featurep 'threads)) + ;; We cannot use `ert-with-message-capture', because threads do not + ;; know let-bound variables. + (with-current-buffer "*Messages*" + (let (buffer-read-only) + (erase-buffer)) + (let ((thread + (make-thread #'(lambda () (thread-signal main-thread 'error nil))))) + (while (thread-live-p thread) + (thread-yield)) + (read-event nil nil 0.1) + ;; No error has been raised, which is part of the test. + (should + (string-match + (format-message "Error %s: (error nil)" thread) + (buffer-string )))))) + (defvar threads-condvar nil) (defun threads-test-condvar-wait () @@ -347,4 +388,8 @@ (should (= (length (all-threads)) 1)) (should (equal (thread-last-error) '(error "Die, die, die!"))))) +(ert-deftest threads-test-bug33073 () + (let ((th (make-thread 'ignore))) + (should-not (equal th main-thread)))) + ;;; threads.el ends here diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el new file mode 100644 index 00000000000..ebeb43de163 --- /dev/null +++ b/test/src/timefns-tests.el @@ -0,0 +1,144 @@ +;;; timefns-tests.el -- tests for timefns.c + +;; Copyright (C) 2016-2018 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; 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/>. + +(require 'ert) + +;;; Check format-time-string and decode-time with various TZ settings. +;;; Use only POSIX-compatible TZ values, since the tests should work +;;; even if tzdb is not in use. +(ert-deftest format-time-string-with-zone () + ;; Don’t use (0 0 0 0) as the test case, as there are too many bugs + ;; in MS-Windows (and presumably other) C libraries when formatting + ;; time stamps near the Epoch of 1970-01-01 00:00:00 UTC, and this + ;; test is for GNU Emacs, not for C runtimes. Instead, look before + ;; you leap: "look" is the timestamp just before the first leap + ;; second on 1972-06-30 23:59:60 UTC, so it should format to the + ;; same string regardless of whether the underlying C library + ;; ignores leap seconds, while avoiding circa-1970 glitches. + ;; + ;; Similarly, stick to the limited set of time zones that are + ;; supported by both POSIX and MS-Windows: exactly 3 ASCII letters + ;; in the abbreviation, and no DST. + (let ((format "%Y-%m-%d %H:%M:%S.%3N %z (%Z)")) + (dolist (look '((1202 22527 999999 999999) + (7879679999900 . 100000) + (78796799999999999999 . 1000000000000))) + ;; UTC. + (should (string-equal + (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" look t) + "1972-06-30 23:59:59.999 +0000")) + (should (equal (decode-time look t) + '(59 59 23 30 6 1972 5 nil 0))) + ;; "UTC0". + (should (string-equal + (format-time-string format look "UTC0") + "1972-06-30 23:59:59.999 +0000 (UTC)")) + (should (equal (decode-time look "UTC0") + '(59 59 23 30 6 1972 5 nil 0))) + ;; Negative UTC offset, as a Lisp list. + (should (string-equal + (format-time-string format look '(-28800 "PST")) + "1972-06-30 15:59:59.999 -0800 (PST)")) + (should (equal (decode-time look '(-28800 "PST")) + '(59 59 15 30 6 1972 5 nil -28800))) + ;; Negative UTC offset, as a Lisp integer. + (should (string-equal + (format-time-string format look -28800) + ;; MS-Windows build replaces unrecognizable TZ values, + ;; such as "-08", with "ZZZ". + (if (eq system-type 'windows-nt) + "1972-06-30 15:59:59.999 -0800 (ZZZ)" + "1972-06-30 15:59:59.999 -0800 (-08)"))) + (should (equal (decode-time look -28800) + '(59 59 15 30 6 1972 5 nil -28800))) + ;; Positive UTC offset that is not an hour multiple, as a string. + (should (string-equal + (format-time-string format look "IST-5:30") + "1972-07-01 05:29:59.999 +0530 (IST)")) + (should (equal (decode-time look "IST-5:30") + '(59 29 5 1 7 1972 6 nil 19800)))))) + +(ert-deftest decode-then-encode-time () + (let ((time-values (list 0 -2 1 0.0 -0.0 -2.0 1.0 + most-negative-fixnum most-positive-fixnum + (1- most-negative-fixnum) + (1+ most-positive-fixnum) + 1e+INF -1e+INF 1e+NaN -1e+NaN + '(0 1 0 0) '(1 0 0 0) '(-1 0 0 0) + '(123456789000000 . 1000000) + (cons (1+ most-positive-fixnum) 1000000000000) + (cons 1000000000000 (1+ most-positive-fixnum))))) + (dolist (a time-values) + (let* ((d (ignore-errors (decode-time a t))) + (e (encode-time d)) + (diff (float-time (time-subtract a e)))) + (should (or (not d) + (and (<= 0 diff) (< diff 1)))))))) + +;;; This should not dump core. +(ert-deftest format-time-string-with-outlandish-zone () + (should (stringp + (format-time-string "%Y-%m-%d %H:%M:%S.%3N %z" nil + (concat (make-string 2048 ?X) "0"))))) + +(defun timefns-tests--have-leap-seconds () + (string-equal (format-time-string "%Y-%m-%d %H:%M:%S" 78796800 t) + "1972-06-30 23:59:60")) + +(ert-deftest format-time-string-with-bignum-on-32-bit () + (should (or (string-equal + (format-time-string "%Y-%m-%d %H:%M:%S" (- (ash 1 31) 3600) t) + "2038-01-19 02:14:08") + (timefns-tests--have-leap-seconds)))) + +(ert-deftest time-equal-p-nil-nil () + (should (time-equal-p nil nil))) + +(ert-deftest time-arith-tests () + (let ((time-values (list 0 -1 1 0.0 -0.0 -1.0 1.0 + most-negative-fixnum most-positive-fixnum + (1- most-negative-fixnum) + (1+ most-positive-fixnum) + 1e+INF -1e+INF 1e+NaN -1e+NaN + '(0 0 0 1) '(0 0 1 0) '(0 1 0 0) '(1 0 0 0) + '(-1 0 0 0) '(1 2 3 4) '(-1 2 3 4) + '(-123456789 . 100000) '(123456789 . 1000000) + (cons (1+ most-positive-fixnum) 1000000000000) + (cons 1000000000000 (1+ most-positive-fixnum))))) + (dolist (a time-values) + (dolist (b time-values) + (let ((aa (time-subtract (time-add a b) b))) + (should (or (time-equal-p a aa) (and (floatp aa) (isnan aa))))) + (should (= 1 (+ (if (time-less-p a b) 1 0) + (if (time-equal-p a b) 1 0) + (if (time-less-p b a) 1 0) + (if (or (and (floatp a) (isnan a)) + (and (floatp b) (isnan b))) + 1 0)))) + (should (or (not (time-less-p 0 b)) + (time-less-p a (time-add a b)) + (time-equal-p a (time-add a b)) + (and (floatp (time-add a b)) (isnan (time-add a b))))) + (let ((x (float-time (time-add a b))) + (y (+ (float-time a) (float-time b)))) + (should (or (and (isnan x) (isnan y)) + (= x y) + (< 0.99 (/ x y) 1.01) + (< 0.99 (/ (- (float-time a)) (float-time b)) + 1.01)))))))) |