diff options
Diffstat (limited to 'test')
150 files changed, 11580 insertions, 1308 deletions
diff --git a/test/Makefile.in b/test/Makefile.in index 481c418787a..ce6ce04b8be 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))) @@ -231,16 +254,21 @@ else FPIC_CFLAGS = -fPIC endif +HYBRID_MALLOC = @HYBRID_MALLOC@ +LIBEGNU_ARCHIVE = ../lib/lib$(if $(HYBRID_MALLOC),e)gnu.a + # Note: emacs-module.h is generated from emacs-module.h.in, hence we # look in ../src, not $(srcdir)/../src. -MODULE_CFLAGS = -I../src $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \ +MODULE_CFLAGS = -I../src -I$(srcdir)/../lib \ + $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \ $(WARN_CFLAGS) $(WERROR_CFLAGS) $(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 +$(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h $(LIBEGNU_ARCHIVE) + $(AM_V_at)${MKDIR_P} $(dir $@) $(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ - -o $@ $< + -o $@ $< $(LIBEGNU_ARCHIVE) endif ## Check that there is no 'automated' subdirectory, which would @@ -283,14 +311,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 +333,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..cd6905d7ebf 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 @@ -69,6 +89,16 @@ value in order to overwrite the default value: env REMOTE_TEMPORARY_FILE_DIRECTORY=/ssh:host:/tmp make ... +There are also continuous integration tests on +<https://hydra.nixos.org/jobset/gnu/emacs-trunk> (see +admin/notes/hydra) and <https://emba.gnu.org/emacs/emacs>. Both +environments provide an environment variable, which could be used to +determine, whether the tests run in one of these test environments. + +$EMACS_HYDRA_CI indicates the hydra environment, and $EMACS_EMBA_CI +indicates the emba environment, respectively. + + (Also, see etc/compilation.txt for compilation mode font lock tests.) diff --git a/test/data/decompress/tg.tar.gz b/test/data/decompress/tg.tar.gz Binary files differnew file mode 100644 index 00000000000..3dc8185f56e --- /dev/null +++ b/test/data/decompress/tg.tar.gz diff --git a/test/data/decompress/zg.zip b/test/data/decompress/zg.zip Binary files differnew file mode 100644 index 00000000000..c4c998ee63d --- /dev/null +++ b/test/data/decompress/zg.zip diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index 30dc4fd9245..a39e41afee6 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -17,12 +17,20 @@ 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/>. */ +#include "config.h" + #include <assert.h> +#include <errno.h> +#include <limits.h> #include <stdio.h> #include <stdlib.h> -#include <limits.h> +#include <string.h> +#include <time.h> + #include <emacs-module.h> +#include "timespec.h" + int plugin_is_GPL_compatible; #if INTPTR_MAX <= 0 @@ -86,7 +94,7 @@ Fmod_test_signal (emacs_env *env, ptrdiff_t nargs, emacs_value args[], assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); env->non_local_exit_signal (env, env->intern (env, "error"), env->make_integer (env, 56)); - return env->intern (env, "nil"); + return NULL; } @@ -98,7 +106,7 @@ Fmod_test_throw (emacs_env *env, ptrdiff_t nargs, emacs_value args[], assert (env->non_local_exit_check (env) == emacs_funcall_exit_return); env->non_local_exit_throw (env, env->intern (env, "tag"), env->make_integer (env, 65)); - return env->intern (env, "nil"); + return NULL; } @@ -296,9 +304,67 @@ Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args, { current_env = env; env->make_user_ptr (env, invalid_finalizer, NULL); - return env->funcall (env, env->intern (env, "garbage-collect"), 0, NULL); + return env->intern (env, "nil"); +} + +static void +signal_wrong_type_argument (emacs_env *env, const char *predicate, + emacs_value arg) +{ + emacs_value symbol = env->intern (env, "wrong-type-argument"); + emacs_value elements[2] = {env->intern (env, predicate), arg}; + emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements); + env->non_local_exit_signal (env, symbol, data); } +static void +signal_errno (emacs_env *env, const char *function) +{ + const char *message = strerror (errno); + emacs_value message_value = env->make_string (env, message, strlen (message)); + emacs_value symbol = env->intern (env, "file-error"); + emacs_value elements[2] + = {env->make_string (env, function, strlen (function)), message_value}; + emacs_value data = env->funcall (env, env->intern (env, "list"), 2, elements); + env->non_local_exit_signal (env, symbol, data); +} + +/* A long-running operation that occasionally calls `should_quit' or + `process_input'. */ + +static emacs_value +Fmod_test_sleep_until (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 2); + const double until_seconds = env->extract_float (env, args[0]); + if (env->non_local_exit_check (env)) + return NULL; + if (until_seconds <= 0) + { + signal_wrong_type_argument (env, "cl-plusp", args[0]); + return NULL; + } + const bool process_input = env->is_not_nil (env, args[1]); + const struct timespec until = dtotimespec (until_seconds); + const struct timespec amount = make_timespec(0, 10000000); + while (true) + { + const struct timespec now = current_timespec (); + if (timespec_cmp (now, until) >= 0) + break; + if (nanosleep (&amount, NULL) && errno != EINTR) + { + signal_errno (env, "nanosleep"); + return NULL; + } + if ((process_input + && env->process_input (env) == emacs_process_input_quit) + || env->should_quit (env)) + return NULL; + } + return env->intern (env, "finished"); +} /* Lisp utilities for easier readability (simple wrappers). */ @@ -317,11 +383,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. */ @@ -367,6 +433,7 @@ emacs_module_init (struct emacs_runtime *ert) DEFUN ("mod-test-invalid-load", Fmod_test_invalid_load, 0, 0, NULL, NULL); DEFUN ("mod-test-invalid-finalizer", Fmod_test_invalid_finalizer, 0, 0, NULL, NULL); + DEFUN ("mod-test-sleep-until", Fmod_test_sleep_until, 2, 2, NULL, NULL); #undef DEFUN diff --git a/test/data/shr/ol.html b/test/data/shr/ol.html new file mode 100644 index 00000000000..f9a15f26409 --- /dev/null +++ b/test/data/shr/ol.html @@ -0,0 +1,29 @@ +<ol> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> + +<ol start="10"> + <li>ten</li> + <li>eleven</li> + <li>twelve</li> +</ol> + +<ol start="0"> + <li>zero</li> + <li>one</li> + <li>two</li> +</ol> + +<ol start="-5"> + <li>minus five</li> + <li>minus four</li> + <li>minus three</li> +</ol> + +<ol start="notanumber"> + <li>one</li> + <li>two</li> + <li>three</li> +</ol> diff --git a/test/data/shr/ol.txt b/test/data/shr/ol.txt new file mode 100644 index 00000000000..0d46e2a8ddb --- /dev/null +++ b/test/data/shr/ol.txt @@ -0,0 +1,19 @@ +1 one +2 two +3 three + +10 ten +11 eleven +12 twelve + +0 zero +1 one +2 two + +-5 minus five +-4 minus four +-3 minus three + +1 one +2 two +3 three diff --git a/test/data/vc/diff-mode/hello_emacs.c b/test/data/vc/diff-mode/hello_emacs.c new file mode 100644 index 00000000000..c7ed7538c3a --- /dev/null +++ b/test/data/vc/diff-mode/hello_emacs.c @@ -0,0 +1,6 @@ +#include <stdio.h> +int main() +{ + printf("Hello, Emacs!\n"); + return 0; +} diff --git a/test/data/vc/diff-mode/hello_emacs_1.c b/test/data/vc/diff-mode/hello_emacs_1.c new file mode 100644 index 00000000000..62145a6b44a --- /dev/null +++ b/test/data/vc/diff-mode/hello_emacs_1.c @@ -0,0 +1 @@ +int main() { printf("Hello, Emacs!\n"); return 0; }
\ No newline at end of file diff --git a/test/data/vc/diff-mode/hello_world.c b/test/data/vc/diff-mode/hello_world.c new file mode 100644 index 00000000000..dcbe06c6012 --- /dev/null +++ b/test/data/vc/diff-mode/hello_world.c @@ -0,0 +1,6 @@ +#include <stdio.h> +int main() +{ + printf("Hello, World!\n"); + return 0; +} diff --git a/test/data/vc/diff-mode/hello_world_1.c b/test/data/vc/diff-mode/hello_world_1.c new file mode 100644 index 00000000000..606afb371cb --- /dev/null +++ b/test/data/vc/diff-mode/hello_world_1.c @@ -0,0 +1 @@ +int main() { printf("Hello, World!\n"); return 0; }
\ No newline at end of file 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/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index e6857671393..79d3ac6365c 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -21,6 +21,8 @@ (require 'ert) (require 'arc-mode) +(defvar arc-mode-tests-data-directory + (expand-file-name "test/data/decompress" source-directory)) (ert-deftest arc-mode-test-archive-int-to-mode () (let ((alist (list (cons 448 "-rwx------") @@ -32,6 +34,18 @@ (dolist (x alist) (should (equal (cdr x) (archive-int-to-mode (car x))))))) +(ert-deftest arc-mode-test-zip-extract-gz () + (skip-unless (and archive-zip-extract (executable-find (car archive-zip-extract)))) + (skip-unless (executable-find "gzip")) + (let* ((zip-file (expand-file-name "zg.zip" arc-mode-tests-data-directory)) + zip-buffer gz-buffer) + (unwind-protect + (with-current-buffer (setq zip-buffer (find-file-noselect zip-file)) + (setq gz-buffer (archive-extract)) + (should (equal (char-after) ?\N{SNOWFLAKE}))) + (when (buffer-live-p zip-buffer) (kill-buffer zip-buffer)) + (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer))))) + (provide 'arc-mode-tests) ;; arc-mode-tests.el ends here diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 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/button-tests.el b/test/lisp/button-tests.el new file mode 100644 index 00000000000..d54a992ab89 --- /dev/null +++ b/test/lisp/button-tests.el @@ -0,0 +1,40 @@ +;;; button-tests.el --- tests for button.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) + +(ert-deftest button-at () + "Test `button-at' behavior." + (with-temp-buffer + (should-not (button-at (point))) + (let ((button (insert-text-button "text button")) + (marker (button-at (1- (point))))) + (should (markerp marker)) + (should (= (button-end button) (button-end marker) (point)))) + (let ((button (insert-button "overlay button")) + (overlay (button-at (1- (point))))) + (should (overlayp overlay)) + (should (eq button overlay))) + ;; Buttons and widgets are incompatible (bug#34506). + (widget-create 'link "link widget") + (should-not (button-at (1- (point)))))) + +;;; button-tests.el ends here 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-resources/custom--test-theme.el b/test/lisp/custom-resources/custom--test-theme.el new file mode 100644 index 00000000000..da9121e0a0a --- /dev/null +++ b/test/lisp/custom-resources/custom--test-theme.el @@ -0,0 +1,9 @@ +(deftheme custom--test + "A test theme.") + +(custom-theme-set-variables + 'custom--test + '(custom--test-user-option 'bar) + '(custom--test-variable 'bar)) + +(provide-theme 'custom--test) diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el new file mode 100644 index 00000000000..0c49db6c76d --- /dev/null +++ b/test/lisp/custom-tests.el @@ -0,0 +1,126 @@ +;;; custom-tests.el --- tests for custom.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2019 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))))) + +(defcustom custom--test-user-option 'foo + "User option for test." + :group 'emacs + :type 'symbol) + +(defvar custom--test-variable 'foo + "Variable for test.") + +;; This is demonstrating bug#34027. +(ert-deftest custom--test-theme-variables () + "Test variables setting with enabling / disabling a custom theme." + :expected-result :failed + ;; We load custom-resources/custom--test-theme.el. + (let ((custom-theme-load-path + `(,(expand-file-name "custom-resources" (file-name-directory #$))))) + (load-theme 'custom--test 'no-confirm 'no-enable) + ;; The variables have still their initial values. + (should (equal custom--test-user-option 'foo)) + (should (equal custom--test-variable 'foo)) + + (custom-set-variables + '(custom--test-user-option 'baz) + '(custom--test-variable 'baz)) + ;; The initial values have been changed. + (should (equal custom--test-user-option 'baz)) + (should (equal custom--test-variable 'baz)) + + (enable-theme 'custom--test) + ;; The variables have the theme values. + (should (equal custom--test-user-option 'bar)) + (should (equal custom--test-variable 'bar)) + + (disable-theme 'custom--test) + ;; The variables should have the changed values, by reverting. + ;; This doesn't work as expected. Instead, they have their + ;; initial values `foo'. + (should (equal custom--test-user-option 'baz)) + (should (equal custom--test-variable 'baz)))) + +;;; 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..4f1e5729be1 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 @@ -141,7 +157,7 @@ Should %s |%s| and point at %d" expected-string expected-point bindings - (modes '(quote (ruby-mode c++-mode))) + (modes '(quote (ruby-mode js-mode))) (test-in-comments t) (test-in-strings t) (test-in-code t) @@ -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,23 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-comments nil) +(ert-deftest electric-pair-whitespace-chomping-2-at-point-4-in-c++-mode-in-strings nil + "Check if whitespace chomping works in `c++' unterminated strings." + (electric-pair-test-for + "\" ( \n \n ) \"" 4 41 "\" () \"" 5 'c++-mode + '((electric-pair-skip-whitespace . chomp)) + (lambda () (electric-pair-mode 1)))) +;; A test failure introduced by: +;; +;; bb591f139f: Enhance CC Mode's fontification, etc., of unterminated strings. +;; +;; Hopefully CC mode will sort this out eventually. 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 @@ -481,6 +514,7 @@ baz\"\"" :fixture-fn #'(lambda () (electric-pair-mode 1))) + (define-electric-pair-test js-mode-braces-with-layout "" "{" :expected-string "{\n\n}" :expected-point 3 :modes '(js-mode) @@ -500,6 +534,16 @@ baz\"\"" (electric-indent-mode 1) (electric-layout-mode 1))) +(define-electric-pair-test js-mode-braces-with-layout-and-indent + "" "{" :expected-string "{\n \n}" :expected-point 7 + :modes '(js-mode) + :test-in-comments nil + :test-in-strings nil + :fixture-fn #'(lambda () + (electric-pair-mode 1) + (electric-indent-mode 1) + (electric-layout-mode 1))) + ;;; Backspacing ;;; TODO: better tests @@ -617,6 +661,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 +688,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 +709,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 +730,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 +751,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 +772,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 @@ -720,5 +830,127 @@ baz\"\"" :bindings '((comment-start . "<!--") (comment-use-syntax . t)) :test-in-comments nil :test-in-strings nil) + +;;; tests for `electric-layout-mode' + +(define-derived-mode plainer-c-mode c-mode "pC" + "A plainer/saner C-mode with no internal electric machinery." + (c-toggle-electric-state -1) + (setq-local electric-indent-local-mode-hook nil) + (setq-local electric-indent-mode-hook nil) + (electric-indent-local-mode 1) + (dolist (key '(?\" ?\' ?\{ ?\} ?\( ?\) ?\[ ?\])) + (local-set-key (vector key) 'self-insert-command))) + +(defun electric-layout-for-c-style-du-jour (inserted) + "A function to use in `electric-layout-rules'" + (when (memq inserted '(?{ ?})) + (save-excursion + (backward-char 2) (c-point-syntax) (forward-char) ; silly, but needed + (c-brace-newlines (c-point-syntax))))) + +(ert-deftest electric-layout-plainer-c-mode-use-c-style () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode 1) + (electric-pair-local-mode 1) + (electric-indent-local-mode 1) + (setq-local electric-layout-rules + '(electric-layout-for-c-style-du-jour)) + (insert "int main () ") + (let ((last-command-event ?\{)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main ()\n{\n \n}\n")))) + +(ert-deftest electric-layout-int-main-kernel-style () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode 1) + (electric-pair-local-mode 1) + (electric-indent-local-mode 1) + (setq-local electric-layout-rules + '((?\{ . (after)) + (?\} . (before)))) + (insert "int main () ") + (let ((last-command-event ?\{)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main () {\n \n}")))) + +(define-derived-mode plainer-c-mode c-mode "pC" + "A plainer/saner C-mode with no internal electric machinery." + (c-toggle-electric-state -1) + (setq-local electric-indent-local-mode-hook nil) + (setq-local electric-indent-mode-hook nil) + (electric-indent-local-mode 1) + (dolist (key '(?\" ?\' ?\{ ?\} ?\( ?\) ?\[ ?\])) + (local-set-key (vector key) 'self-insert-command))) + +(ert-deftest electric-modes-int-main-allman-style () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode 1) + (electric-pair-local-mode 1) + (electric-indent-local-mode 1) + (setq-local electric-layout-rules + '((?\{ . (before after)) + (?\} . (before)))) + (insert "int main () ") + (let ((last-command-event ?\{)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main ()\n{\n \n}")))) + +(ert-deftest electric-pair-mode-newline-between-parens () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode -1) ;; ensure e-l-m mode is off + (electric-pair-local-mode 1) + (insert-before-markers "int main () {}") + (backward-char 1) + (let ((last-command-event ?
)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main () {\n \n}")))) + +(ert-deftest electric-layout-mode-newline-between-parens-without-e-p-m () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode 1) + (electric-pair-local-mode -1) ;; ensure e-p-m mode is off + (electric-indent-local-mode 1) + (setq-local electric-layout-rules + '((?\n + . + (lambda () + (when (eq (save-excursion + (skip-chars-backward "\t\s") + (char-before (1- (point)))) + (matching-paren (char-after))) + '(after-stay)))))) + (insert "int main () {}") + (backward-char 1) + (let ((last-command-event ?
)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main () {\n \n}")))) + +(ert-deftest electric-layout-mode-newline-between-parens-without-e-p-m-2 () + (ert-with-test-buffer () + (plainer-c-mode) + (electric-layout-local-mode 1) + (electric-pair-local-mode -1) ;; ensure e-p-m mode is off + (electric-indent-local-mode 1) + (setq-local electric-layout-rules + '((lambda (char) + (when (and + (eq char ?\n) + (eq (save-excursion + (skip-chars-backward "\t\s") + (char-before (1- (point)))) + (matching-paren (char-after)))) + '(after-stay))))) + (insert "int main () {}") + (backward-char 1) + (let ((last-command-event ?
)) + (call-interactively (key-binding `[,last-command-event]))) + (should (equal (buffer-string) "int main () {\n \n}")))) + (provide 'electric-tests) ;;; electric-tests.el ends here diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el new file mode 100644 index 00000000000..ce827e0166f --- /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-2019 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..c218bd6382b --- /dev/null +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -0,0 +1,40 @@ +;;; cconv-tests.el -*- lexical-binding: t -*- + +;; Copyright (C) 2018-2019 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..3251b5ff0a2 --- /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-2019 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..406c528dce5 100644 --- a/test/lisp/emacs-lisp/cl-print-tests.el +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -34,7 +34,7 @@ (let ((print-circle t)) (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x))) "((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))"))) - (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^\)]*)\\'" + (should (string-match "\\`#f(compiled-function (x) \"[^\"]+\" [^)]*)\\'" (cl-prin1-to-string (symbol-function #'caar)))))) (ert-deftest cl-print-tests-2 () @@ -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..e940c5f5145 --- /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-2019 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..11c48de38eb --- /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-2019 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..c35188eb8b6 --- /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-2019 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..c8c3a1f5d8a --- /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-2019 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..c757bccf672 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. @@ -189,12 +190,33 @@ Must called from within a `tar-mode' buffer." "Return the package version as a string." (package-version-join (package-desc-version desc))) +(defun package-test--compatible-p (pkg-desc pkg-sample &optional kind) + (and (cl-every (lambda (f) + (equal (funcall f pkg-desc) + (funcall f pkg-sample))) + (cons (if kind #'package-desc-kind #'ignore) + '(package-desc-name + package-desc-version + package-desc-summary + package-desc-reqs + package-desc-archive + package-desc-dir + package-desc-signed))) + ;; The `extras' field should contain at least the specified elements. + (let ((extras (package-desc-extras pkg-desc)) + (extras-sample (package-desc-extras pkg-sample))) + (cl-every (lambda (sample-elem) + (member sample-elem extras)) + extras-sample)))) + (ert-deftest package-test-desc-from-buffer () "Parse an elisp buffer to get a `package-desc' object." (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") - (should (equal (package-buffer-info) simple-single-desc))) + (should (package-test--compatible-p + (package-buffer-info) simple-single-desc 'kind))) (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el") - (should (equal (package-buffer-info) simple-depend-desc))) + (should (package-test--compatible-p + (package-buffer-info) simple-depend-desc 'kind))) (with-package-test (:basedir "package-resources" :file "multi-file-0.2.3.tar") (tar-mode) @@ -222,15 +244,12 @@ Must called from within a `tar-mode' buffer." (with-temp-buffer (insert-file-contents (expand-file-name "simple-single-pkg.el" simple-pkg-dir)) - (should (string= (buffer-string) - (concat ";;; -*- no-byte-compile: t -*-\n" - "(define-package \"simple-single\" \"1.3\" " - "\"A single-file package " - "with no dependencies\" 'nil " - ":authors '((\"J. R. Hacker\" . \"jrh@example.com\")) " - ":maintainer '(\"J. R. Hacker\" . \"jrh@example.com\") " - ":url \"http://doodles.au\"" - ")\n")))) + (goto-char (point-min)) + (let ((sexp (read (current-buffer)))) + (should (eq (car-safe sexp) 'define-package)) + (should (package-test--compatible-p + (apply #'package-desc-from-define (cdr sexp)) + simple-single-desc)))) (should (file-exists-p autoloads-file)) (should-not (get-file-buffer autoloads-file))))) @@ -414,7 +433,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 +447,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 +499,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 +524,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 +546,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/['’]." @@ -556,8 +598,17 @@ Must called from within a `tar-mode' buffer." (setq archive-contents (package-read-from-string (buffer-substring (point-min) (point-max))))) - (should (equal archive-contents - (list 1 package-x-test--single-archive-entry-1-3)))))) + (should (equal 1 (car archive-contents))) + (should (equal 2 (length archive-contents))) + (let ((pac (cadr archive-contents)) + (pac-sample package-x-test--single-archive-entry-1-3)) + (should (equal (pop pac) (pop pac-sample))) + (dotimes (i 4) + (should (equal (aref pac i) (aref pac-sample i)))) + ;; The `extras' field should contain at least the specified elements. + (should (cl-every (lambda (sample-elem) + (member sample-elem (aref pac 4))) + (aref pac-sample 4))))))) (ert-deftest package-x-test-upload-new-version () "Test uploading a new version of a package" @@ -577,8 +628,17 @@ Must called from within a `tar-mode' buffer." (setq archive-contents (package-read-from-string (buffer-substring (point-min) (point-max))))) - (should (equal archive-contents - (list 1 package-x-test--single-archive-entry-1-4)))))) + (should (equal 1 (car archive-contents))) + (should (equal 2 (length archive-contents))) + (let ((pac (cadr archive-contents)) + (pac-sample package-x-test--single-archive-entry-1-4)) + (should (equal (pop pac) (pop pac-sample))) + (dotimes (i 4) + (should (equal (aref pac i) (aref pac-sample i)))) + ;; The `extras' field should contain at least the specified elements. + (should (cl-every (lambda (sample-elem) + (member sample-elem (aref pac 4))) + (aref pac-sample 4))))))) (ert-deftest package-test-get-deps () "Test `package--get-deps' with complex structures." diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index bc451a6212f..af8c9a3f3c3 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -51,11 +51,13 @@ (ert-deftest pcase-tests-member () (should (pcase-tests-grep - 'memq (macroexpand-all '(pcase x ((or 1 2 3) body))))) + 'memql (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))))) + (should-not (pcase-tests-grep + 'memql (macroexpand-all '(pcase x ((or "a" 2 3) body))))) (let ((exp (macroexpand-all '(pcase x ("a" body1) 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..4a5919edf02 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -25,7 +25,7 @@ ;;; Code: (ert-deftest rx-char-any () - "Test character alternatives with `\]' and `-' (Bug#25123)." + "Test character alternatives with `]' and `-' (Bug#25123)." (should (string-match (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:))) string-end) @@ -33,6 +33,36 @@ (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-range-bad () + (should-error (rx (any "0-9a-Z"))) + (should-error (rx (any (?0 . ?9) (?a . ?Z))))) + +(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)) + ;; Split range; \177-\377ÿ should not be optimised to \177-\377. + (should (equal (string-match-p (rx (any "\177-\377" ?ÿ)) + "ÿA\310B") + 0))) + (ert-deftest rx-pcase () (should (equal (pcase "a 1 2 3 1 1 b" ((rx (let u (+ digit)) space @@ -43,5 +73,41 @@ (list u v))) '("1" "3")))) +(ert-deftest rx-kleene () + "Test greedy and non-greedy repetition operators." + (should (equal (rx (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")) + "a*b+c?d?e*?f+?g??h??")) + (should (equal (rx (zero-or-more "a") (0+ "b") + (one-or-more "c") (1+ "d") + (zero-or-one "e") (optional "f") (opt "g")) + "a*b*c+d+e?f?g?")) + (should (equal (rx (minimal-match + (seq (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")))) + "a*b+c?d?e*?f+?g??h??")) + (should (equal (rx (minimal-match + (seq (zero-or-more "a") (0+ "b") + (one-or-more "c") (1+ "d") + (zero-or-one "e") (optional "f") (opt "g")))) + "a*?b*?c+?d+?e??f??g??")) + (should (equal (rx (maximal-match + (seq (* "a") (+ "b") (\? "c") (?\s "d") + (*? "e") (+? "f") (\?? "g") (?? "h")))) + "a*b+c?d?e*?f+?g??h??"))) + +(ert-deftest rx-or () + ;; Test or-pattern reordering (Bug#34641). + (let ((s "abc")) + (should (equal (and (string-match (rx (or "abc" "ab" "a")) s) + (match-string 0 s)) + "abc")) + (should (equal (and (string-match (rx (or "ab" "abc" "a")) s) + (match-string 0 s)) + "ab")) + (should (equal (and (string-match (rx (or "a" "ab" "abc")) s) + (match-string 0 s)) + "a")))) + (provide 'rx-tests) ;; rx-tests.el ends here. diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index deb2829db45..ef05e2b389d 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -185,6 +185,18 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(3 4 5 6)) (should (= 5 (seq-contains seq 5))))) +(ert-deftest test-seq-contains-p () + (with-test-sequences (seq '(3 4 5 6)) + (should (eq (seq-contains-p seq 3) t)) + (should-not (seq-contains-p seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains-p seq 3)) + (should-not (seq-contains-p seq nil)))) + +(ert-deftest test-seq-contains-p-with-nil () + (should (seq-contains-p [nil] nil)) + (should (seq-contains-p '(nil) nil))) + (ert-deftest test-seq-every-p () (with-test-sequences (seq '(43 54 22 1)) (should (seq-every-p (lambda (elt) t) seq)) @@ -424,5 +436,30 @@ 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])))) + +;; Regression tests for bug#34852 +(progn + (ert-deftest test-seq-intersection-with-nil () + (should (equal (seq-intersection '(1 2 nil) '(1 nil)) '(1 nil)))) + + (ert-deftest test-seq-set-equal-p-with-nil () + (should (seq-set-equal-p '("a" "b" nil) + '(nil "b" "a")))) + + (ert-deftest test-difference-with-nil () + (should (equal (seq-difference '(1 nil) '(2 nil)) + '(1))))) + (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..47db54a0512 --- /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-2019 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..39284c08a11 --- /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-2019 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/faces-tests.el b/test/lisp/faces-tests.el index 4447dd7b309..f00c93cedcb 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -60,5 +60,14 @@ (should (equal (background-color-at-point) "black")) (should (equal (foreground-color-at-point) "black")))) +(ert-deftest faces--test-face-id () + ;; Face ID of 0 is the 'default' face; no face should have the same ID. + (should (> (face-id 'faces--test1) 0)) + ;; 'tooltip' is the last face defined by preloaded packages, so any + ;; face we define in Emacs should have a face ID greater than that, + ;; since the ID of a face is just its index in the array that maps + ;; face IDs to faces. + (should (> (face-id 'faces--test1) (face-id 'tooltip)))) + (provide 'faces-tests) ;;; faces-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 4e1a46285c6..50036209b0f 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) @@ -425,36 +450,36 @@ This returns only for the local case and gfilenotify; otherwise it is nil. ;; harm. This fails on Cygwin because of timing issues unless a ;; long `sit-for' is added before the call to ;; `file-notify--test-read-event'. - (if (not (eq system-type 'cygwin)) - (let (results) - (cl-flet ((first-callback (event) - (when (eq (nth 1 event) 'deleted) (push 1 results))) - (second-callback (event) - (when (eq (nth 1 event) 'deleted) (push 2 results)))) - (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 - '(change) #'first-callback))) - (should - (setq file-notify--test-desc1 - (file-notify-add-watch - file-notify--test-tmpfile - '(change) #'second-callback))) - ;; Remove first watch. - (file-notify-rm-watch file-notify--test-desc) - ;; Only the second callback shall run. - (file-notify--test-read-event) - (delete-file file-notify--test-tmpfile) - (file-notify--wait-for-events - (file-notify--test-timeout) results) - (should (equal results (list 2))) + (unless (eq system-type 'cygwin) + (let (results) + (cl-flet ((first-callback (event) + (when (eq (nth 1 event) 'deleted) (push 1 results))) + (second-callback (event) + (when (eq (nth 1 event) 'deleted) (push 2 results)))) + (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 + '(change) #'first-callback))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'second-callback))) + ;; Remove first watch. + (file-notify-rm-watch file-notify--test-desc) + ;; Only the second callback shall run. + (file-notify--test-read-event) + (delete-file file-notify--test-tmpfile) + (file-notify--wait-for-events + (file-notify--test-timeout) results) + (should (equal results (list 2))) - ;; The environment shall be cleaned up. - (file-notify--test-cleanup-p)))) + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)))) ;; Cleanup. (file-notify--test-cleanup))) @@ -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,175 +651,203 @@ 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)) - ;; On emba, `deleted' and `stopped' events of the - ;; directory are not detected. - ((getenv "EMACS_EMBA_CI") - '(created changed deleted)) - (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)) - ;; 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)) - ;; On emba, `deleted' and `stopped' events of the - ;; directory are not detected. - ((getenv "EMACS_EMBA_CI") - '(created changed created changed deleted deleted)) - (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)) + ;; Cleanup. + (file-notify--test-cleanup)) - ;; 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)) - ;; On emba, `deleted' and `stopped' events of the - ;; directory are not detected. - ((getenv "EMACS_EMBA_CI") - '(created changed renamed deleted)) - (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)) + (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)) + ;; On emba, `deleted' and `stopped' events of the + ;; directory are not detected. + ((getenv "EMACS_EMBA_CI") + '(created changed deleted)) + (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 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 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)) + ;; On emba, `deleted' and `stopped' events of the + ;; directory are not detected. + ((getenv "EMACS_EMBA_CI") + '(created changed created changed deleted deleted)) + (t '(created changed created changed + deleted deleted deleted stopped))) (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) + (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)) + ;; On emba, `deleted' and `stopped' events of the + ;; directory are not detected. + ((getenv "EMACS_EMBA_CI") + '(created changed renamed deleted)) + (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) + (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)) @@ -861,15 +921,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) @@ -879,7 +939,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)) @@ -1029,7 +1092,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)) @@ -1051,7 +1114,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))) @@ -1108,14 +1171,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)) @@ -1137,8 +1202,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/files-x-tests.el b/test/lisp/files-x-tests.el index d678be409d1..568a8984479 100644 --- a/test/lisp/files-x-tests.el +++ b/test/lisp/files-x-tests.el @@ -35,6 +35,11 @@ '((remote-null-device . "/dev/null"))) (defconst files-x-test--variables4 '((remote-null-device . "null"))) +(put 'remote-shell-file-name 'safe-local-variable #'identity) +(put 'remote-shell-command-switch 'safe-local-variable #'identity) +(put 'remote-shell-interactive-switch 'safe-local-variable #'identity) +(put 'remote-shell-login-switch 'safe-local-variable #'identity) +(put 'remote-null-device 'safe-local-variable #'identity) (defconst files-x-test--application '(:application 'my-application)) (defconst files-x-test--another-application @@ -268,7 +273,9 @@ (should-not (local-variable-p 'remote-shell-file-name)) (should-not (boundp 'remote-shell-file-name)))))) -(ert-deftest files-x-test-with-connection-local-profiles () +(defvar tramp-connection-local-default-profile) + +(ert-deftest files-x-test-with-connection-local-variables () "Test setting connection-local variables." (let (connection-local-profile-alist connection-local-criteria-alist) @@ -303,46 +310,48 @@ (string-equal (symbol-value 'remote-null-device) "/dev/null")) ;; A candidate connection-local variable is not bound yet. - (should-not (local-variable-p 'remote-shell-command-switch)) - - ;; Use the macro. - (with-connection-local-profiles '(remote-bash remote-ksh) - ;; All connection-local variables are set. They apply in - ;; reverse order in `connection-local-variables-alist'. - ;; This variable keeps only the variables to be set inside - ;; the macro. - (should - (equal connection-local-variables-alist - (nreverse (copy-tree files-x-test--variables1)))) - ;; The variables exist also as local variables. - (should (local-variable-p 'remote-shell-file-name)) - (should (local-variable-p 'remote-shell-command-switch)) - ;; The proper variable values are set. The settings from - ;; `remote-bash' overwrite the same variables as in - ;; `remote-ksh'. - (should - (string-equal (symbol-value 'remote-shell-file-name) "/bin/bash")) - (should - (string-equal (symbol-value 'remote-shell-command-switch) "-c"))) - - ;; Everything is rewound. The old variable values are reset. - (should - (equal connection-local-variables-alist - (append - (nreverse (copy-tree files-x-test--variables3)) - (nreverse (copy-tree files-x-test--variables2))))) - ;; The variables exist also as local variables. - (should (local-variable-p 'remote-shell-file-name)) - (should (local-variable-p 'remote-null-device)) - ;; The proper variable values are set. The settings from - ;; `remote-ksh' are back. - (should - (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh")) - (should - (string-equal (symbol-value 'remote-null-device) "/dev/null")) + (should-not (local-variable-p 'remote-shell-command-switch)))) - ;; The variable set temporarily is not unbound, again. - (should-not (local-variable-p 'remote-shell-command-switch)))))) + (with-temp-buffer + ;; Use the macro. We need a remote `default-directory'. + (let ((enable-connection-local-variables t) + (default-directory "/method:host:") + (remote-null-device "null")) + (should-not connection-local-variables-alist) + (should-not (local-variable-p 'remote-shell-file-name)) + (should-not (local-variable-p 'remote-null-device)) + (should-not (boundp 'remote-shell-file-name)) + (should (string-equal (symbol-value 'remote-null-device) "null")) + + (with-connection-local-variables + ;; All connection-local variables are set. They apply in + ;; reverse order in `connection-local-variables-alist'. + ;; Since we ha a remote default directory, Tramp's settings + ;; are appended as well. + (should + (equal + connection-local-variables-alist + (append + (nreverse (copy-tree files-x-test--variables3)) + (nreverse (copy-tree files-x-test--variables2)) + (nreverse (copy-tree tramp-connection-local-default-profile))))) + ;; The variables exist also as local variables. + (should (local-variable-p 'remote-shell-file-name)) + (should (local-variable-p 'remote-null-device)) + ;; The proper variable values are set. + (should + (string-equal (symbol-value 'remote-shell-file-name) "/bin/ksh")) + (should + (string-equal (symbol-value 'remote-null-device) "/dev/null"))) + + ;; Everything is rewound. The old variable values are reset. + (should-not connection-local-variables-alist) + ;; The variables don't exist as local variables. + (should-not (local-variable-p 'remote-shell-file-name)) + (should-not (local-variable-p 'remote-null-device)) + ;; The variable values are reset. + (should-not (boundp 'remote-shell-file-name)) + (should (string-equal (symbol-value 'remote-null-device) "null")))))) (provide 'files-x-tests) ;;; files-x-tests.el ends here diff --git a/test/lisp/gnus/gnus-test-headers.el b/test/lisp/gnus/gnus-test-headers.el new file mode 100644 index 00000000000..abf3d4f2713 --- /dev/null +++ b/test/lisp/gnus/gnus-test-headers.el @@ -0,0 +1,178 @@ +;;; gnus-test-headers.el --- Tests for Gnus header-related functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2018-2019 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; The tests her are for + +;;; Code: + +(require 'ert) +(require 'gnus-sum) + +(defconst gnus-headers-test-data + '([2 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>" + "Thu, 14 Sep 2000 11:10:46 +0100" + "<200009141010.LAA26351@djlvig.dl.ac.uk>" + "<20000913175943.A26093@sparky.nisa.net>" + 1882 16 "nnmaildir mails:2" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [3 "Re: [Emacs-devel] Emacs move" "Sam Steingold <sds@gnu.org>" + "14 Sep 2000 10:21:56 -0400" "<upum7xddn.fsf@xchange.com>" + "<20000913175943.A26093@sparky.nisa.net>" + 2991 50 "nnmaildir mails:3" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [4 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Thu, 14 Sep 2000 09:14:47 -0700" + "<20000914091447.G4827@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <upum7xddn.fsf@xchange.com>" + 1780 15 "nnmaildir mails:4" + ((To . "sds@gnu.org, Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [5 "Re: [Emacs-devel] Emacs move" "Dave Love <d.love@dl.ac.uk>" + "Thu, 14 Sep 2000 18:24:36 +0100" + "<200009141724.SAA26807@djlvig.dl.ac.uk>" + "<20000913175943.A26093@sparky.nisa.net>" + 1343 9 "nnmaildir mails:5" + ((To . "Jeff Bailey <jbailey@nisa.net>") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [6 "Re: [Emacs-devel] Emacs move" "Karl Fogel <kfogel@galois.collab.net>" + "14 Sep 2000 10:37:35 -0500" "<87em2nyog0.fsf@galois.collab.net>" + "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk>" + 3740 124 "nnmaildir mails:6" + ((To . "Dave Love <d.love@dl.ac.uk>") + (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [7 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Thu, 14 Sep 2000 10:55:12 -0700" + "<20000914105512.A29291@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <200009141724.SAA26807@djlvig.dl.ac.uk> <87em2nyog0.fsf@galois.collab.net>" + 1687 16 "nnmaildir mails:7" + ((To . "kfogel@red-bean.com, Dave Love <d.love@dl.ac.uk>") + (Cc . "Jeff Bailey <jbailey@nisa.net>, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [8 "Re: [Emacs-devel] Emacs move" "John Wiegley <johnw@gnu.org>" + "Thu, 14 Sep 2000 12:19:01 -0700" + "<200009141919.MAA05085@localhost.localdomain>" + "<20000913175943.A26093@sparky.nisa.net>" + 1978 27 "nnmaildir mails:8" + ((To . "emacs-devel@gnu.org"))] + [9 "Re: [Emacs-devel] Emacs move" + "\"Robert J. Chassell\" <bob@rattlesnake.com>" + "Thu, 14 Sep 2000 07:33:15 -0400 (EDT)" + "<m13ZXGV-000BCgC@megalith.rattlesnake.com>" + "<20000913175943.A26093@sparky.nisa.net>" + 3046 72 "nnmaildir mails:9" + ((To . "jbailey@nisa.net") + (Cc . "emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [10 "Re: [Emacs-devel] Emacs move" + "wmperry@aventail.com (William M. Perry)" + "14 Sep 2000 09:10:25 -0500" + "<86g0n3f4j2.fsf@megalith.bp.aventail.com>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 3104 44 "nnmaildir mails:10" + ((To . "bob@rattlesnake.com") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [11 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>" + "Thu, 14 Sep 2000 21:51:05 +0200 (CEST)" + "<200009141951.VAA06005@gerd.segv.de>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <86g0n3f4j2.fsf@megalith.bp.aventail.com>" + 1884 6 "nnmaildir mails:11" + ((To . "wmvperry@aventail.com") + (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [12 "Re: [Emacs-devel] Emacs move" "Gerd Moellmann <gerd@gnu.org>" + "Thu, 14 Sep 2000 21:49:03 +0200 (CEST)" + "<200009141949.VAA05998@gerd.segv.de>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 2408 24 "nnmaildir mails:12" + ((To . "bob@rattlesnake.com") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [13 "Re: [Emacs-devel] Emacs move" + "\"Robert J. Chassell\" <bob@rattlesnake.com>" + "Thu, 14 Sep 2000 17:50:01 -0400 (EDT)" + "<m13ZgtN-000BD3C@megalith.rattlesnake.com>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de>" + 1968 23 "nnmaildir mails:13" + ((To . "gerd@gnu.org") + (Cc . "bob@rattlesnake.com, jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [14 "Re: [Emacs-devel] Emacs move" "Richard Stallman <rms@gnu.org>" + "Fri, 15 Sep 2000 16:28:12 -0600 (MDT)" + "<200009152228.QAA20526@wijiji.santafe.edu>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com>" + 1288 2 "nnmaildir mails:14" + ((To . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))] + [15 "[Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Wed, 13 Sep 2000 17:59:43 -0700" + "<20000913175943.A26093@sparky.nisa.net>" "" + 1661 26 "nnmaildir mails:15" + ((To . "emacs-devel@gnu.org") + (Cc . "cvs-hackers@gnu.org"))] + [16 "Re: [Emacs-devel] Emacs move" "Jeff Bailey <jbailey@nisa.net>" + "Fri, 15 Sep 2000 22:00:12 -0700" + "<20000915220012.A3923@sparky.nisa.net>" + "<20000913175943.A26093@sparky.nisa.net> <m13ZXGV-000BCgC@megalith.rattlesnake.com> <200009141949.VAA05998@gerd.segv.de> <m13ZgtN-000BD3C@megalith.rattlesnake.com>" + 2857 51 "nnmaildir mails:16" + ((To . "bob@rattlesnake.com, gerd@gnu.org") + (Cc . "jbailey@nisa.net, emacs-devel@gnu.org, cvs-hackers@gnu.org"))]) + "A pile of headers with potential interdependencies.") + +(ert-deftest gnus-headers-make-dependency-table () + (let ((table (gnus-make-hashtable 20)) + (data (copy-sequence gnus-headers-test-data)) + ret) + (dolist (h data) + ;; `gnus-dependencies-add-header' returns nil if it fails to add + ;; the header. + (should (gnus-dependencies-add-header h table nil))) + ;; Pick a value to test. + (setq ret (gethash "<m13ZXGV-000BCgC@megalith.rattlesnake.com>" + table)) + ;; The message has three children. + (should (= 3 (length (cdr ret)))) + ;; The first of those children has one child. + (should (= 1 (length (cdr (nth 1 ret))))))) + +(ert-deftest gnus-headers-loop-dependencies () + "Intentionally create a reference loop." + (let ((table (gnus-make-hashtable 20)) + (data (copy-sequence gnus-headers-test-data)) + (parent-id "<200009141724.SAA26807@djlvig.dl.ac.uk>") + (child-id "<87em2nyog0.fsf@galois.collab.net>") + parent) + (dolist (h data) + (gnus-dependencies-add-header h table nil)) + + (setq parent (gethash parent-id table)) + + ;; Put the parent header in the child references of one of its own + ;; children. `gnus-thread-loop-p' only checks if there's a loop + ;; between parent and immediate child, not parent and random + ;; descendant. At least, near as I can tell that's the case. + + (push (list (car parent)) (cdr (gethash child-id table))) + + (let ((gnus-newsgroup-dependencies table)) + (should + (= 1 ; 1 indicates an infloop. + (gnus-thread-loop-p (car parent) (cadr parent))))))) + +(provide 'gnus-test-headers) +;;; gnus-test-headers.el ends here 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..69e3930d42c --- /dev/null +++ b/test/lisp/international/ccl-tests.el @@ -0,0 +1,229 @@ +;; Copyright (C) 2018-2019 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/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index d31aa5b4a92..97d3eae41cc 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -182,25 +182,24 @@ implementations: (defconst ucs-normalize-tests--failing-lines-part1 (list 15131 15132 15133 15134 15135 15136 15137 15138 - 15139 - 16149 16150 16151 16152 16153 16154 16155 16156 - 16157 16158 16159 16160 16161 16162 16163 16164 - 16165 16166 16167 16168 16169 16170 16171 16172 - 16173 16174 16175 16176 16177 16178 16179 16180 - 16181 16182 16183 16184 16185 16186 16187 16188 - 16189 16190 16191 16192 16193 16194 16195 16196 - 16197 16198 16199 16200 16201 16202 16203 16204 - 16205 16206 16207 16208 16209 16210 16211 16212 - 16213 16214 16215 16216 16217 16218 16219 16220 - 16221 16222 16223 16224 16225 16226 16227 16228 - 16229 16230 16231 16232 16233 16234 16235 16236 - 16237 16238 16239 16240 16241 16242 16243 16244 - 16245 16246 16247 16248 16249 16250 16251 16252 - 16253 16254 16255 16256 16257 16258 16259 16260 - 16261 16262 16263 16264 16265 16266 16267 16268 - 16269 16270 16271 16272 16273 16274 16275 16276 - 16277 16278 16279 16280 16281 16282 16283 16284 - 16285 16286 16287 16288 16289)) + 15139 16149 16150 16151 16152 16153 16154 16155 + 16156 16157 16158 16159 16160 16161 16162 16163 + 16164 16165 16166 16167 16168 16169 16170 16171 + 16172 16173 16174 16175 16176 16177 16178 16179 + 16180 16181 16182 16183 16184 16185 16186 16187 + 16188 16189 16190 16191 16192 16193 16194 16195 + 16196 16197 16198 16199 16200 16201 16202 16203 + 16204 16205 16206 16207 16208 16209 16210 16211 + 16212 16213 16214 16215 16216 16217 16218 16219 + 16220 16221 16222 16223 16224 16225 16226 16227 + 16228 16229 16230 16231 16232 16233 16234 16235 + 16236 16237 16238 16239 16240 16241 16242 16243 + 16244 16245 16246 16247 16248 16249 16250 16251 + 16252 16253 16254 16255 16256 16257 16258 16259 + 16260 16261 16262 16263 16264 16265 16266 16267 + 16268 16269 16270 16271 16272 16273 16274 16275 + 16276 16277 16278 16279 16280 16281 16282 16283 + 16284 16285 16286 16287 16288 16289 16366)) ;; Keep a record of failures, for consulting afterwards (the ert ;; backtrace only shows a truncated version of these lists). @@ -258,23 +257,22 @@ implementations: ucs-normalize-tests--failing-lines-part1))) (defconst ucs-normalize-tests--failing-lines-part2 - (list 17482 17532 17636 18338 18340 18342 18344 18346 - 18348 18350 18352 18354 18356 18358 18360 18362 - 18364 18366 18376 18378 18380 18382 18384 18386 - 18388 18390 18392 18394 18396 18398 18400 18402 - 18404 18406 18408 18410 18412 18414 18416 18418 - 18420 18422 18424 18426 18428 18430 18432 18434 - 18436 18438 18440 18442 18444 18446 18448 18450 - 18452 18454 18456 18458 18460 18462 18464 18466 - 18468 18470 18472 18474 18476 18478 18480 18482 - 18484 18486 18488 18490 18492 18494 18496 18564 - 18566 18568 18570 18572 18574 18576 18578 18580 - 18582 18584 18586 18588 18590 18592 18594 18596 - 18598 18600 18602 18604 18606 18608 18610 18612 - 18614 18616 18618 18620 18622 18624 18626 18628 - 18630 18632 18634 18636 18638 18640 18642 18644 - 18646 18648 18650 18652 18654 18656 18658 18660 - 18662 18664 18666)) + (list 17689 18379 18381 18383 18385 18387 18389 18391 + 18393 18395 18397 18399 18401 18403 18405 18407 + 18409 18411 18413 18415 18417 18419 18421 18423 + 18425 18427 18429 18431 18433 18435 18437 18439 + 18441 18443 18445 18447 18449 18451 18453 18455 + 18457 18459 18461 18463 18465 18467 18469 18471 + 18473 18475 18477 18479 18481 18483 18485 18487 + 18489 18491 18493 18495 18497 18499 18501 18569 + 18571 18573 18575 18577 18579 18581 18583 18585 + 18587 18589 18591 18593 18595 18597 18599 18601 + 18603 18605 18607 18609 18611 18613 18615 18617 + 18619 18621 18623 18625 18627 18629 18631 18633 + 18635 18637 18639 18641 18643 18645 18647 18649 + 18651 18653 18655 18657 18659 18661 18663 18665 + 18667 18669 18671 18673 18675 18677 18679 18681 + 18683 18685 18687 18689 18691 18693)) (ert-deftest ucs-normalize-part2 () :tags '(:expensive-test) 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..52f709f14c1 --- /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-2019 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/mail/rmail-tests.el b/test/lisp/mail/rmail-tests.el index 00f4583335b..3a0fdbc2614 100644 --- a/test/lisp/mail/rmail-tests.el +++ b/test/lisp/mail/rmail-tests.el @@ -23,7 +23,7 @@ (ert-deftest rmail-autoload () - "Tests to see whether reftex-auc has been autoloaded" + "Test that `rmail-edit-current-message' has been autoloaded." (should (fboundp 'rmail-edit-current-message)) (should diff --git a/test/lisp/minibuffer-tests.el b/test/lisp/minibuffer-tests.el index 77bfea93716..35df7cc17f1 100644 --- a/test/lisp/minibuffer-tests.el +++ b/test/lisp/minibuffer-tests.el @@ -74,5 +74,11 @@ 'completion-table-with-predicate full-collection no-A nil)))))) +(ert-deftest completion-table-subvert-test () + (let* ((origtable '("A-hello" "A-there")) + (subvtable (completion-table-subvert origtable "B" "A"))) + (should (equal (try-completion "B-hel" subvtable) + "B-hello")))) + (provide 'completion-tests) ;;; completion-tests.el ends here 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/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 29b92da3de0..b85746a3123 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -25,6 +25,10 @@ ;;; Code: (require 'gnutls) +(require 'network-stream) +;; The require above is needed for 'open-network-stream' to work, but +;; it pulls in nsm, which then makes the :nowait t' tests fail unless +;; we disable the nsm, which we do by binding 'network-security-level' (ert-deftest make-local-unix-server () (skip-unless (featurep 'make-network-process '(:family local))) @@ -67,12 +71,45 @@ (= (aref (process-contact server :local) 4) 57869))) (delete-process server))) -(defun make-server (host) +(ert-deftest make-ipv6-tcp-server-with-unspecified-port () + (skip-unless (featurep 'make-network-process '(:family ipv6))) + (let ((server + (ignore-errors + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service t + :host 'local)))) + (skip-unless server) + (should (and (arrayp (process-contact server :local)) + (numberp (aref (process-contact server :local) 8)) + (> (aref (process-contact server :local) 8) 0))) + (delete-process server))) + +(ert-deftest make-ipv6-tcp-server-with-specified-port () + (skip-unless (featurep 'make-network-process '(:family ipv6))) + (let ((server + (ignore-errors + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv6 + :service 57870 + :host 'local)))) + (skip-unless server) + (should (and (arrayp (process-contact server :local)) + (= (aref (process-contact server :local) 8) 57870))) + (delete-process server))) + +(defun make-server (host &optional family) (make-network-process :name "server" :server t :noquery t - :family 'ipv4 + :family (or family 'ipv4) :coding 'raw-text-unix :buffer (get-buffer-create "*server*") :service t @@ -125,6 +162,36 @@ (should (equal (buffer-string) "foo\n"))) (delete-process server))) +(ert-deftest echo-server-with-local-ipv4 () + (let* ((server (make-server 'local 'ipv4)) + (port (aref (process-contact server :local) 4)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host 'local + :family 'ipv4 + :service port))) + (with-current-buffer (process-buffer proc) + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))) + (delete-process server))) + +(ert-deftest echo-server-with-local-ipv6 () + (skip-unless (featurep 'make-network-process '(:family ipv6))) + (let ((server (ignore-errors (make-server 'local 'ipv6)))) + (skip-unless server) + (let* ((port (aref (process-contact server :local) 8)) + (proc (make-network-process :name "foo" + :buffer (generate-new-buffer "*foo*") + :host 'local + :family 'ipv6 + :service port))) + (with-current-buffer (process-buffer proc) + (process-send-string proc "echo foo") + (sleep-for 0.1) + (should (equal (buffer-string) "foo\n"))) + (delete-process server)))) + (ert-deftest echo-server-with-ip () (let* ((server (make-server 'local)) (port (aref (process-contact server :local) 4)) @@ -214,6 +281,7 @@ (skip-unless (gnutls-available-p)) (let ((server (make-tls-server 44331)) (times 0) + (network-security-level 'low) proc status) (unwind-protect (progn @@ -257,6 +325,7 @@ (skip-unless (featurep 'make-network-process '(:family ipv6))) (let ((server (make-tls-server 44333)) (times 0) + (network-security-level 'low) proc status) (unwind-protect (progn @@ -294,4 +363,365 @@ (setq issuer (split-string issuer ",")) (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) +(ert-deftest open-network-stream-tls-wait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44334)) + (times 0) + (network-security-level 'low) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-network-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44334 + :type 'tls + :nowait nil)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-network-stream-tls-nowait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44335)) + (times 0) + (network-security-level 'low) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-network-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44335 + :type 'tls + :nowait t)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (setq times 0) + (while (and (eq (process-status proc) 'connect) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-network-stream-tls () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44336)) + (times 0) + (network-security-level 'low) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-network-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44336 + :type 'tls)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-network-stream-tls-nocert () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44337)) + (times 0) + (network-security-level 'low) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-network-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44337 + :type 'tls + :client-certificate nil)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-gnutls-stream-new-api-default () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44665)) + (times 0) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44665)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))) + +(ert-deftest open-gnutls-stream-new-api-wait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44666)) + (times 0) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44666 + (list :nowait nil))))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))) + +(ert-deftest open-gnutls-stream-old-api-wait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44667)) + (times 0) + nowait + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44667 + nowait)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + ;; This sleep-for is needed for the native MS-Windows build. If + ;; it is removed, the next test mysteriously fails because the + ;; initial part of the echo is not received. + (sleep-for 0.1) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC")))))) + +(ert-deftest open-gnutls-stream-new-api-nowait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44668)) + (times 0) + (network-security-level 'low) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44668 + (list :nowait t))))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (setq times 0) + (while (and (eq (process-status proc) 'connect) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-gnutls-stream-old-api-nowait () + (skip-unless (executable-find "gnutls-serv")) + (skip-unless (gnutls-available-p)) + (let ((server (make-tls-server 44669)) + (times 0) + (network-security-level 'low) + (nowait t) + proc status) + (unwind-protect + (progn + (sleep-for 1) + (with-current-buffer (process-buffer server) + (message "gnutls-serv: %s" (buffer-string))) + + ;; It takes a while for gnutls-serv to start. + (while (and (null (ignore-errors + (setq proc (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44669 + nowait)))) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (should proc) + (setq times 0) + (while (and (eq (process-status proc) 'connect) + (< (setq times (1+ times)) 10)) + (sit-for 0.1)) + (skip-unless (not (eq (process-status proc) 'connect)))) + (if (process-live-p server) (delete-process server))) + (setq status (gnutls-peer-status proc)) + (should (consp status)) + (delete-process proc) + (let ((issuer (plist-get (plist-get status :certificate) :issuer))) + (should (stringp issuer)) + (setq issuer (split-string issuer ",")) + (should (equal (nth 3 issuer) "O=Emacs Test Servicess LLC"))))) + +(ert-deftest open-gnutls-stream-new-api-errors () + (skip-unless (gnutls-available-p)) + (should-error + (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44777 + (list t))) + (should-error + (open-gnutls-stream + "bar" + (generate-new-buffer "*foo*") + "localhost" + 44777 + (vector :nowait t)))) + ;;; network-stream-tests.el ends here diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el new file mode 100644 index 00000000000..c565eba5679 --- /dev/null +++ b/test/lisp/net/secrets-tests.el @@ -0,0 +1,268 @@ +;;; secrets-tests.el --- Tests of Secret Service API + +;; Copyright (C) 2018-2019 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..454279e435e --- /dev/null +++ b/test/lisp/net/tramp-archive-tests.el @@ -0,0 +1,965 @@ +;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 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))))))) + + ;; Check error case. + (with-temp-buffer + (should-error + (insert-directory + (expand-file-name "baz" tramp-archive-test-archive) nil) + :type tramp-file-missing))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test18-file-attributes () + "Check `file-attributes'. +This tests also `access-file', `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)) + (tmp-name4 (expand-file-name "baz" 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)) + (should-not (access-file tmp-name1 "error")) + + ;; 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)) + (should-not (access-file tmp-name3 "error")) + + ;; Check error case. + (should-error + (access-file tmp-name4 "error") + :type tramp-file-missing)) + + ;; 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-test39-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-test42-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-test45-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-test45-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..5a9541db8fb 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,13 +136,20 @@ 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. If QUOTED is non-nil, the local part of the file name is quoted. The temporary file is not created." (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (make-temp-name "tramp-test") (if local temporary-file-directory tramp-test-temporary-file-directory)))) @@ -145,9 +161,9 @@ This shall used dynamically bound only.") (defmacro tramp--test-instrument-test-case (verbose &rest body) "Run BODY with `tramp-verbose' equal VERBOSE. -Print the content of the Tramp debug buffer, if BODY does not -eval properly in `should' or `should-not'. `should-error' is not -handled properly. BODY shall not contain a timeout." +Print the content of the Tramp connection and debug buffers, if +`tramp-verbose' is greater than 3. `should-error' is not handled +properly. BODY shall not contain a timeout." (declare (indent 1) (debug (natnump body))) `(let ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) (tramp-message-show-message t) @@ -169,7 +185,7 @@ handled properly. BODY shall not contain a timeout." "Emit a message into ERT *Messages*." (tramp--test-instrument-test-case 0 (apply - 'tramp-message + #'tramp-message (tramp-dissect-file-name tramp-test-temporary-file-directory) 0 fmt-string arguments))) @@ -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) @@ -211,6 +237,10 @@ handled properly. BODY shall not contain a timeout." (should (tramp-tramp-file-p "/method:[::1]:")) (should (tramp-tramp-file-p "/method:user@[::1]:")) + ;; Using an IPv4 mapped IPv6 address. + (should (tramp-tramp-file-p "/method:[::ffff:1.2.3.4]:")) + (should (tramp-tramp-file-p "/method:user@[::ffff:1.2.3.4]:")) + ;; Local file name part. (should (tramp-tramp-file-p "/method:::")) (should (tramp-tramp-file-p "/method::/:")) @@ -229,12 +259,16 @@ 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:")) (should-not (tramp-tramp-file-p "/1.2.3.4:")) (should-not (tramp-tramp-file-p "/[]:")) (should-not (tramp-tramp-file-p "/[::1]:")) + (should-not (tramp-tramp-file-p "/[::ffff:1.2.3.4]:")) (should-not (tramp-tramp-file-p "/host:/:")) (should-not (tramp-tramp-file-p "/host1|host2:")) (should-not (tramp-tramp-file-p "/user1@host1|user2@host2:")) @@ -242,6 +276,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)) @@ -277,6 +317,10 @@ handled properly. BODY shall not contain a timeout." (should (tramp-tramp-file-p "/[::1]:")) (should (tramp-tramp-file-p "/user@[::1]:")) + ;; Using an IPv4 mapped IPv6 address. + (should (tramp-tramp-file-p "/[::ffff:1.2.3.4]:")) + (should (tramp-tramp-file-p "/user@[::ffff:1.2.3.4]:")) + ;; Local file name part. (should (tramp-tramp-file-p "/host::")) (should (tramp-tramp-file-p "/host:/:")) @@ -327,6 +371,10 @@ handled properly. BODY shall not contain a timeout." (should (tramp-tramp-file-p "/[method/::1]")) (should (tramp-tramp-file-p "/[method/user@::1]")) + ;; Using an IPv4 mapped IPv6 address. + (should (tramp-tramp-file-p "/[method/::ffff:1.2.3.4]")) + (should (tramp-tramp-file-p "/[method/user@::ffff:1.2.3.4]")) + ;; Local file name part. (should (tramp-tramp-file-p "/[method/]")) (should (tramp-tramp-file-p "/[method/]/:")) @@ -365,7 +413,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 +769,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 +854,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 +1106,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 +1177,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 +1740,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)))) @@ -1551,57 +1830,126 @@ handled properly. BODY shall not contain a timeout." (should (string-equal (file-remote-p "/-:ftp.host:" 'method) "ftp")) (dolist (u '("ftp" "anonymous")) (should (string-equal (file-remote-p (format "/-:%s@:" u) 'method) "ftp"))) - ;; Default values in tramp-gvfs.el. - (when (and (load "tramp-gvfs" 'noerror 'nomessage) - (symbol-value 'tramp-gvfs-enabled)) - (should (string-equal (file-remote-p "/synce::" 'user) nil))) - ;; Default values in tramp-sh.el. + ;; Default values in tramp-sh.el and tramp-sudoedit.el. (dolist (h `("127.0.0.1" "[::1]" "localhost" "localhost6" ,(system-name))) (should (string-equal (file-remote-p (format "/-:root@%s:" h) 'method) "su"))) - (dolist (m '("su" "sudo" "ksu")) - (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root"))) - (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp")) + (dolist (m '("su" "sudo" "ksu" "doas" "sudoedit")) + (should (string-equal (file-remote-p (format "/%s::" m) 'user) "root")) + (should + (string-equal (file-remote-p (format "/%s::" m) 'host) (system-name)))) + (dolist (m '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp" "nc")) (should (string-equal (file-remote-p (format "/%s::" m) 'user) (user-login-name)))) ;; 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 @@ -1640,6 +1988,18 @@ handled properly. BODY shall not contain a timeout." (should (string-equal (expand-file-name "/method:host:/path/../file") "/method:host:/file")) + (should + (string-equal + (expand-file-name "/method:host:/path/.") "/method:host:/path")) + (should + (string-equal + (expand-file-name "/method:host:/path/..") "/method:host:/")) + (should + (string-equal + (expand-file-name "." "/method:host:/path/") "/method:host:/path")) + (should + (string-equal + (expand-file-name "" "/method:host:/path/") "/method:host:/path")) ;; Quoting local part. (should (string-equal @@ -1653,16 +2013,17 @@ handled properly. BODY shall not contain a timeout." (expand-file-name "/method:host:/:/~/path/./file") "/method:host:/:/~/path/file"))) -;; The following test is inspired by Bug#26911. It is rather a bug in -;; `expand-file-name', and it fails for all Emacs versions. Test -;; added for later, when it is fixed. +;; The following test is inspired by Bug#26911 and Bug#34834. They +;; are rather bugs in `expand-file-name', and it fails for all Emacs +;; versions. Test added for later, when they are fixed. (ert-deftest tramp-test05-expand-file-name-relative () "Check `expand-file-name'." ;; 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 +2070,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/") "")) @@ -1721,7 +2090,8 @@ This checks also `file-name-as-directory', `file-name-directory', ;; We must clear `tramp-default-method'. On hydra, it is "ftp", ;; which ruins the tests. (let ((non-essential n-e) - tramp-default-method) + (tramp-default-method + (file-remote-p tramp-test-temporary-file-directory 'method))) (dolist (file `(,(format @@ -1743,7 +2113,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 +2125,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 +2157,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 +2185,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 +2275,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 +2300,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 +2312,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 +2335,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 +2360,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 +2387,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 +2415,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 +2434,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 +2450,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 +2474,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 +2501,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 +2524,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 +2544,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 +2610,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 +2643,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 +2707,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)) @@ -2370,7 +2755,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (format "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" (regexp-opt (directory-files tmp-name1)) - (length (directory-files tmp-name1)))))))) + (length (directory-files tmp-name1))))))) + + ;; Check error case. We do not check for the error type, + ;; because ls-lisp returns `file-error', and native Tramp + ;; returns `file-missing'. + (delete-directory tmp-name1 'recursive) + (with-temp-buffer + (should-error (insert-directory tmp-name1 nil)))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -2383,7 +2775,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 @@ -2392,7 +2784,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (tmp-name4 (expand-file-name "bar" tmp-name2)) (tramp-test-temporary-file-directory (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) tramp-test-temporary-file-directory)) buffer) (unwind-protect @@ -2496,11 +2888,11 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test18-file-attributes () "Check `file-attributes'. -This tests also `file-readable-p', `file-regular-p' and -`file-ownership-preserved-p'." +This tests also `access-file', `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. @@ -2518,6 +2910,9 @@ This tests also `file-readable-p', `file-regular-p' and attr) (unwind-protect (progn + (should-error + (access-file tmp-name1 "error") + :type tramp-file-missing) ;; `file-ownership-preserved-p' should return t for ;; non-existing files. It is implemented only in tramp-sh.el. (when (tramp--test-sh-p) @@ -2526,6 +2921,7 @@ This tests also `file-readable-p', `file-regular-p' and (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should (file-regular-p tmp-name1)) + (should-not (access-file tmp-name1 "error")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name1 'group))) @@ -2550,18 +2946,22 @@ This tests also `file-readable-p', `file-regular-p' and (should (stringp (nth 3 attr))) ;; Gid. (tramp--test-ignore-make-symbolic-link-error + (should-error + (access-file tmp-name2 "error") + :type tramp-file-missing) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) (should (file-exists-p tmp-name2)) (should (file-symlink-p tmp-name2)) + (should-not (access-file tmp-name2 "error")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name2 'group))) (setq attr (file-attributes tmp-name2)) (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (car attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -2593,6 +2993,7 @@ This tests also `file-readable-p', `file-regular-p' and (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should-not (file-regular-p tmp-name1)) + (should-not (access-file tmp-name1 "")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) @@ -2603,11 +3004,18 @@ This tests also `file-readable-p', `file-regular-p' and (ignore-errors (delete-file tmp-name1)) (ignore-errors (delete-file tmp-name2)))))) +(defsubst tramp--test-file-attributes-equal-p (attr1 attr2) + "Check, whether file attributes ATTR1 and ATTR2 are equal. +They might differ only in access time." + (setcar (nthcdr 4 attr1) tramp-time-dont-know) + (setcar (nthcdr 4 attr2) tramp-time-dont-know) + (equal attr1 attr2)) + (ert-deftest tramp-test19-directory-files-and-attributes () "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,20 +3037,23 @@ 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))))) + (tramp--test-file-attributes-equal-p + (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))))) + (tramp--test-file-attributes-equal-p + (file-attributes (car elt)) (cdr elt))))) (setq attr (directory-files-and-attributes tmp-name2 nil "^b")) - (should (equal (mapcar 'car attr) '("bar" "boz")))) + (should (equal (mapcar #'car attr) '("bar" "boz")))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -2651,9 +3062,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 +3084,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. @@ -2702,30 +3125,32 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (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 (string-equal (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2)))) (make-symbolic-link tmp-name1 tmp-name2 'ok-if-already-exists) (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) ;; If we use the local part of `tmp-name1', it shall still work. @@ -2735,7 +3160,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) ;; `tmp-name3' is a local file name. Therefore, the link @@ -2747,14 +3172,15 @@ 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 (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name5))) ;; `smbclient' does not show symlinks in directories, so @@ -2771,38 +3197,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 @@ -2836,7 +3264,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (delete-file tmp-name2) (make-symbolic-link (funcall - (if quoted 'tramp-compat-file-name-unquote 'identity) + (if quoted #'tramp-compat-file-name-unquote #'identity) "/penguin:motd:") tmp-name2) (should (file-symlink-p tmp-name2)) @@ -2882,12 +3310,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 +3330,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 +3374,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 +3399,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 +3408,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 (= 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 (equal (visited-file-modtime) '(0 1 0 0))))) + (should (= 1 (float-time (visited-file-modtime)))))) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2982,7 +3430,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 +3508,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 +3649,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 +3657,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 +3712,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))) @@ -3280,12 +3733,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should-not (file-name-completion "a" tmp-name)) (should (equal - (file-name-completion "b" tmp-name 'file-directory-p) "boz/")) + (file-name-completion "b" tmp-name #'file-directory-p) "boz/")) (should (equal (file-name-all-completions "fo" tmp-name) '("foo"))) (should (equal - (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + (sort (file-name-all-completions "b" tmp-name) #'string-lessp) '("bold" "boz/"))) (should-not (file-name-all-completions "a" tmp-name)) ;; `completion-regexp-list' restricts the completion to @@ -3296,7 +3749,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (equal (file-name-completion "" tmp-name) "bo")) (should (equal - (sort (file-name-all-completions "" tmp-name) 'string-lessp) + (sort (file-name-all-completions "" tmp-name) #'string-lessp) '("bold" "boz/")))) ;; `file-name-completion' ignores file names that end in ;; any string in `completion-ignored-extensions'. @@ -3311,7 +3764,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `file-name-all-completions' is not affected. (should (equal - (sort (file-name-all-completions "" tmp-name) 'string-lessp) + (sort (file-name-all-completions "" tmp-name) #'string-lessp) '("../" "./" "bold" "boz/" "foo" "foo.ext"))))) ;; Cleanup. @@ -3321,7 +3774,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 +3799,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) @@ -3386,16 +3839,24 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) +;; Must be a command, because used as `sigusr' handler. +(defun tramp--test-timeout-handler (&rest _ignore) + "Timeout handler, reporting a failed test." + (interactive) + (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) + (ert-deftest tramp-test29-start-file-process () "Check `start-file-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (tramp--test-sh-p)) + (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 ((default-directory tramp-test-temporary-file-directory) (tmp-name (tramp--test-make-temp-name nil quoted)) kill-buffer-query-functions proc) + + ;; Simple process. (unwind-protect (with-temp-buffer (setq proc (start-file-process "test1" (current-buffer) "cat")) @@ -3404,14 +3865,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (process-send-string proc "foo") (process-send-eof proc) ;; Read output. - (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) - (accept-process-output proc 0.1))) - (should (string-equal (buffer-string) "foo"))) + (while (accept-process-output proc 0 nil t)))) + ;; We cannot use `string-equal', because tramp-adb.el + ;; echoes also the sent string. + (should (string-match "\\`foo" (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) + ;; Simple process using a file. (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) @@ -3422,9 +3886,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "cat" (file-name-nondirectory tmp-name))) (should (processp proc)) ;; Read output. - (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) - (accept-process-output proc 0.1))) + (while (accept-process-output proc 0 nil t)))) (should (string-equal (buffer-string) "foo"))) ;; Cleanup. @@ -3432,6 +3896,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (delete-process proc) (delete-file tmp-name))) + ;; Process filter. (unwind-protect (with-temp-buffer (setq proc (start-file-process "test3" (current-buffer) "cat")) @@ -3443,15 +3908,151 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (process-send-string proc "foo") (process-send-eof proc) ;; Read output. - (with-timeout (10 (ert-fail "`start-file-process' timed out")) + (with-timeout (10 (tramp--test-timeout-handler)) (while (< (- (point-max) (point-min)) (length "foo")) - (accept-process-output proc 0.1))) - (should (string-equal (buffer-string) "foo"))) + (while (accept-process-output proc 0 nil t)))) + ;; We cannot use `string-equal', because tramp-adb.el + ;; echoes also the sent string. + (should (string-match "\\`foo" (buffer-string)))) ;; 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 (or (tramp--test-adb-p) (tramp--test-sh-p))) + ;; `make-process' supports file name handlers since Emacs 27. + (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 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) (length "foo")) + (while (accept-process-output proc 0 nil t)))) + ;; We cannot use `string-equal', because tramp-adb.el + ;; echoes also the sent string. + (should (string-match "\\`foo" (buffer-string)))) + + ;; 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 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) (length "foo")) + (while (accept-process-output proc 0 nil t)))) + (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 (tramp--test-timeout-handler)) + (while (not (string-match "foo" (buffer-string))) + (while (accept-process-output proc 0 nil t)))) + ;; We cannot use `string-equal', because tramp-adb.el + ;; echoes also the sent string. + (should (string-match "\\`foo" (buffer-string)))) + + ;; 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 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + ;; We cannot use `string-equal', because tramp-adb.el + ;; echoes also the sent string. + (should (string-match "killed\n\\'" (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc))) + + ;; Process with stderr. tramp-adb.el doesn't support it (yet). + (unless (tramp--test-adb-p) + (let ((stderr + (generate-new-buffer (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 (tramp--test-timeout-handler)) + (while (= (point-min) (point-max)) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match "^cat:.* Is a directory" (buffer-string))))) + + ;; 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)) @@ -3470,7 +4071,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (numberp (process-get proc 'remote-pid))) (should (interrupt-process proc)) ;; Let the process accept the interrupt. - (accept-process-output proc 1 nil 0) + (while (accept-process-output proc nil nil 0)) (should-not (process-live-p proc)) ;; An interrupted process cannot be interrupted, again. (should-error (interrupt-process proc) :type 'error)) @@ -3478,13 +4079,16 @@ 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)) + ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for + ;; remote processes in Emacs. That doesn't work for tramp-adb.el. + (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) + (tramp--test-sh-p))) - (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. @@ -3518,11 +4122,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) ;; Read output. - (with-timeout (10 (ert-fail "`async-shell-command' timed out")) - (while (< (- (point-max) (point-min)) - (1+ (length (file-name-nondirectory tmp-name)))) - (accept-process-output - (get-buffer-process (current-buffer)) 0.1))) + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output + (get-buffer-process (current-buffer)) nil nil t))) ;; `ls' could produce colorized output. (goto-char (point-min)) (while @@ -3549,11 +4151,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (get-buffer-process (current-buffer)) (format "%s\n" (file-name-nondirectory tmp-name))) ;; Read output. - (with-timeout (10 (ert-fail "`async-shell-command' timed out")) - (while (< (- (point-max) (point-min)) - (1+ (length (file-name-nondirectory tmp-name)))) - (accept-process-output - (get-buffer-process (current-buffer)) 0.1))) + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output + (get-buffer-process (current-buffer)) nil nil t))) ;; `ls' could produce colorized output. (goto-char (point-min)) (while @@ -3575,14 +4175,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer (async-shell-command command (current-buffer)) - (with-timeout (10) - (while (get-buffer-process (current-buffer)) - (accept-process-output (get-buffer-process (current-buffer)) 0.1))) - (accept-process-output nil 0.1) + (with-timeout + ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) + (while (accept-process-output + (get-buffer-process (current-buffer)) nil nil t))) (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 +4260,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 @@ -3695,12 +4295,81 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (dolist (dir '("/mock:localhost#11111:" "/mock:localhost#22222:")) (tramp-cleanup-connection (tramp-dissect-file-name dir))))) +;; Connection-local variables are enabled per default since Emacs 27.1. +(ert-deftest tramp-test34-connection-local-variables () + "Check that connection-local variables are enabled." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'with-connection-local-variables)) + + ;; `connection-local-set-profile-variables' and + ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't + ;; want to see compiler warnings for older Emacsen. + (let* ((default-directory tramp-test-temporary-file-directory) + (tmp-name1 (tramp--test-make-temp-name)) + (tmp-name2 (expand-file-name "foo" tmp-name1)) + (enable-local-variables :all) + (enable-remote-dir-locals t) + kill-buffer-query-functions + connection-local-profile-alist connection-local-criteria-alist) + (unwind-protect + (progn + (make-directory tmp-name1) + (should (file-directory-p tmp-name1)) + + ;; `local-variable' is buffer-local due to explicit setting. + (with-no-warnings + (defvar-local local-variable 'buffer)) + (with-temp-buffer + (should (eq local-variable 'buffer))) + + ;; `local-variable' is connection-local due to Tramp. + (write-region "foo" nil tmp-name2) + (should (file-exists-p tmp-name2)) + (with-no-warnings + (connection-local-set-profile-variables + 'local-variable-profile + '((local-variable . connect))) + (connection-local-set-profiles + `(:application tramp + :protocol ,(file-remote-p default-directory 'method) + :user ,(file-remote-p default-directory 'user) + :machine ,(file-remote-p default-directory 'host)) + 'local-variable-profile)) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'connect)) + (kill-buffer (current-buffer))) + + ;; `local-variable' is dir-local due to existence of .dir-locals.el. + (write-region + "((nil . ((local-variable . dir))))" nil + (expand-file-name ".dir-locals.el" tmp-name1)) + (should (file-exists-p (expand-file-name ".dir-locals.el" tmp-name1))) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'dir)) + (kill-buffer (current-buffer))) + + ;; `local-variable' is file-local due to specifying as file variable. + (write-region + "-*- mode: comint; local-variable: file; -*-" nil tmp-name2) + (should (file-exists-p tmp-name2)) + (with-current-buffer (find-file-noselect tmp-name2) + (should (eq local-variable 'file)) + (kill-buffer (current-buffer)))) + + ;; Cleanup. + (ignore-errors (delete-directory tmp-name1 'recursive))))) + ;; 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)) - (skip-unless (tramp--test-sh-p)) + ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for + ;; remote processes in Emacs. That doesn't work for tramp-adb.el. + (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) + (tramp--test-sh-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -3709,44 +4378,162 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; `connection-local-set-profiles' exist since Emacs 26.1. We don't ;; want to see compiler warnings for older Emacsen. (let ((default-directory tramp-test-temporary-file-directory) - explicit-shell-file-name kill-buffer-query-functions) + explicit-shell-file-name kill-buffer-query-functions + connection-local-profile-alist connection-local-criteria-alist) (unwind-protect (progn ;; `shell-mode' would ruin our test, because it deletes all - ;; buffer local variables. + ;; buffer local variables. Not needed in Emacs 27.1. (put 'explicit-shell-file-name 'permanent-local t) - ;; Declare connection-local variable `explicit-shell-file-name'. + ;; Declare connection-local variables `explicit-shell-file-name' + ;; and `explicit-sh-args'. (with-no-warnings (connection-local-set-profile-variables 'remote-sh - '((explicit-shell-file-name . "/bin/sh") - (explicit-sh-args . ("-i")))) + `((explicit-shell-file-name + . ,(if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) + (explicit-sh-args . ("-c" "echo foo")))) (connection-local-set-profiles `(:application tramp :protocol ,(file-remote-p default-directory 'method) :user ,(file-remote-p default-directory 'user) :machine ,(file-remote-p default-directory 'host)) 'remote-sh)) + (put 'explicit-shell-file-name 'safe-local-variable #'identity) + (put 'explicit-sh-args 'safe-local-variable #'identity) - ;; Run interactive shell. Since the default directory is - ;; remote, `explicit-shell-file-name' shall be set in order - ;; to avoid a question. + ;; Run `shell' interactively. Since the default directory + ;; is remote, `explicit-shell-file-name' shall be set in + ;; order to avoid a question. `explicit-sh-args' echoes the + ;; test data. (with-current-buffer (get-buffer-create "*shell*") (ignore-errors (kill-process (current-buffer))) (should-not explicit-shell-file-name) - (call-interactively 'shell) - (should explicit-shell-file-name))) + (call-interactively #'shell) + (with-timeout (10) + (while (accept-process-output + (get-buffer-process (current-buffer)) nil nil t))) + (should (string-match "^foo$" (buffer-string))))) + ;; Cleanup. (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 (with-no-warnings (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 +4597,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))) @@ -3847,7 +4634,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (make-auto-save-file-name) (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (format "#%s#" (file-name-nondirectory tmp-name1)) tramp-test-temporary-file-directory)))))) @@ -3901,11 +4688,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. @@ -3921,7 +4708,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (find-backup-file-name tmp-name1) (list (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (format "%s~" (file-name-nondirectory tmp-name1)) tramp-test-temporary-file-directory))))))) @@ -3935,7 +4722,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (find-backup-file-name tmp-name1) (list (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (format "%s~" @@ -3963,7 +4750,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (find-backup-file-name tmp-name1) (list (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (format "%s~" @@ -3992,7 +4779,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (find-backup-file-name tmp-name1) (list (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (expand-file-name (format "%s~" @@ -4012,7 +4799,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 +4891,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 +4913,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 +4943,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 @@ -4187,7 +4988,7 @@ This requires restrictions of file name syntax." (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (car (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. @@ -4199,10 +5000,10 @@ This requires restrictions of file name syntax." ;; Check file names. (should (equal (directory-files tmp-name1 nil directory-files-no-dot-files-regexp) - (sort (copy-sequence files) 'string-lessp))) + (sort (copy-sequence files) #'string-lessp))) (should (equal (directory-files tmp-name2 nil directory-files-no-dot-files-regexp) - (sort (copy-sequence files) 'string-lessp))) + (sort (copy-sequence files) #'string-lessp))) ;; `substitute-in-file-name' could return different ;; values. For `adb', there could be strange file @@ -4262,7 +5063,7 @@ This requires restrictions of file name syntax." (should (string-equal (funcall - (if quoted 'tramp-compat-file-name-quote 'identity) + (if quoted #'tramp-compat-file-name-quote #'identity) (cadr (car (directory-files-and-attributes file1 nil (regexp-quote elt1))))) (file-remote-p (file-truename file2) 'localname))) @@ -4275,9 +5076,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 +5101,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 +5162,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 +5180,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 +5201,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 +5224,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 +5232,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 +5269,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 +5289,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 +5312,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 +5335,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. @@ -4520,29 +5352,38 @@ Use the `ls' command." (numberp (nth 1 fsi)) (numberp (nth 2 fsi)))))) -(defun tramp--test-timeout-handler () - (interactive) - (ert-fail (format "`%s' timed out" (ert-test-name (ert-running-test))))) +;; `tramp-test43-asynchronous-requests' could be blocked. So we set a +;; timeout of 300 seconds, and we send a SIGUSR1 signal after 300 +;; seconds. Similar check is performed in the timer function. +(defconst tramp--test-asynchronous-requests-timeout 300 + "Timeout for `tramp-test43-asynchronous-requests'.") ;; 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) + ;; The test fails from time to time, w/o a reproducible pattern. So + ;; we mark it as unstable. + :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. - (with-timeout (300 (tramp--test-timeout-handler)) - (define-key special-event-map [sigusr1] 'tramp--test-timeout-handler) + ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for + ;; remote processes in Emacs. That doesn't work for tramp-adb.el. + (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) + (tramp--test-sh-p))) + + (with-timeout + (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) + (define-key special-event-map [sigusr1] #'tramp--test-timeout-handler) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) + (shell-file-name (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh")) (watchdog - (start-process - "*watchdog*" nil shell-file-name shell-command-switch - (format "sleep 300; kill -USR1 %d" (emacs-pid)))) + (start-process-shell-command + "*watchdog*" nil + (format + "sleep %d; kill -USR1 %d" + tramp--test-asynchronous-requests-timeout (emacs-pid)))) (tmp-name (tramp--test-make-temp-name)) (default-directory tmp-name) ;; Do not cache Tramp properties. @@ -4555,10 +5396,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 @@ -4567,8 +5409,11 @@ process sentinels. They shall not disturb each other." ;; We must distinguish due to performance reasons. (timer-operation (cond - ((tramp--test-mock-p) 'vc-registered) - (t 'file-attributes))) + ((tramp--test-mock-p) #'vc-registered) + (t #'file-attributes))) + ;; This is when all timers start. We check inside the + ;; timer function, that we don't exceed timeout. + (timer-start (current-time)) timer buffers kill-buffer-query-functions) (unwind-protect @@ -4583,16 +5428,25 @@ process sentinels. They shall not disturb each other." (run-at-time 0 timer-repeat (lambda () + (when (> (- (time-to-seconds) (time-to-seconds timer-start)) + tramp--test-asynchronous-requests-timeout) + (tramp--test-timeout-handler)) (when buffers (let ((time (float-time)) (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. + (tramp--test-message + "Stop timer %s %s" file (current-time-string)) (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))))))) ;; Create temporary buffers. The number of buffers ;; corresponds to the number of processes; it could be @@ -4608,9 +5462,9 @@ process sentinels. They shall not disturb each other." (start-file-process-shell-command (buffer-name buf) buf (concat - "(read line && echo $line >$line);" - "(read line && cat $line);" - "(read line && rm $line)"))) + "(read line && echo $line >$line && echo $line);" + "(read line && cat $line);" + "(read line && rm -f $line)"))) (file (expand-file-name (buffer-name buf)))) ;; Remember the file name. Add counter. (process-put proc 'foo file) @@ -4619,20 +5473,23 @@ 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)) + (when (< (process-get proc 'bar) 2) (dired-uncache (process-get proc 'foo)) (should (file-attributes (process-get proc 'foo)))))) - ;; Add process sentinel. + ;; Add process sentinel. It shall not perform remote + ;; operations, triggering Tramp processes. This blocks. (set-process-sentinel proc (lambda (proc _state) - (dired-uncache (process-get proc 'foo)) - (should-not (file-attributes (process-get proc 'foo))))))) + (tramp--test-message + "Process sentinel %s %s" proc (current-time-string)))))) - ;; Send a string. Use a random order of the buffers. Mix - ;; with regular operation. + ;; Send a string to the processes. Use a random order of + ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers ;; Activate timer. @@ -4641,6 +5498,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) @@ -4648,14 +5507,18 @@ process sentinels. They shall not disturb each other." (should (file-attributes file))) ;; Send string to process. (process-send-string proc (format "%s\n" (buffer-name buf))) - (accept-process-output proc 0.1 nil 0) + (while (accept-process-output proc 0 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,15 +5526,22 @@ 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))))) + (should + (string-equal + ;; tramp-adb.el echoes, so we must add the three strings. + (if (tramp--test-adb-p) + (format "%s\n%s\n%s\n%s\n%s\n" buf buf buf buf buf) + (format "%s\n%s\n" buf buf)) + (buffer-string))))) (should-not (directory-files tmp-name nil directory-files-no-dot-files-regexp))) ;; Cleanup. - (define-key special-event-map [sigusr1] 'ignore) + (define-key special-event-map [sigusr1] #'ignore) (ignore-errors (quit-process watchdog)) (dolist (buf buffers) (ignore-errors (delete-process (get-buffer-process buf))) @@ -4680,8 +5550,10 @@ process sentinels. They shall not disturb each other." (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 @@ -4695,10 +5567,10 @@ process sentinels. They shall not disturb each other." "%s -batch -Q -L %s --eval %s" (shell-quote-argument (expand-file-name invocation-name invocation-directory)) - (mapconcat 'shell-quote-argument load-path " -L ") + (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. @@ -4728,10 +5600,10 @@ process sentinels. They shall not disturb each other." "%s -batch -Q -L %s --eval %s" (shell-quote-argument (expand-file-name invocation-name invocation-directory)) - (mapconcat 'shell-quote-argument load-path " -L ") + (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)) @@ -4752,10 +5624,10 @@ process sentinels. They shall not disturb each other." "%s -batch -Q -L %s --eval %s" (shell-quote-argument (expand-file-name invocation-name invocation-directory)) - (mapconcat 'shell-quote-argument load-path " -L ") + (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. @@ -4781,10 +5653,10 @@ process sentinels. They shall not disturb each other." "%s -batch -Q -L %s -l tramp-sh --eval %s" (shell-quote-argument (expand-file-name invocation-name invocation-directory)) - (mapconcat 'shell-quote-argument load-path " -L ") + (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,48 +5665,59 @@ 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]." (interactive "p") (funcall - (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^tramp")) + (if interactive + #'ert-run-tests-interactively #'ert-run-tests-batch) "^tramp")) ;; TODO: @@ -4843,13 +5726,19 @@ Since it unloads Tramp, it shall be the last test to run." ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p +;; * tramp-set-file-uid-gid ;; * 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'. -;; * 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'. +;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' +;; do not work properly for `nextcloud'. +;; * Fix `tramp-test29-start-file-process' and +;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). +;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. Looks +;; like it is resolved now. Remove `:unstable' tag? +;; * Implement `tramp-test31-interrupt-process' for `adb'. (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/f90-tests.el b/test/lisp/progmodes/f90-tests.el index 3cd7392bbc4..b1642388413 100644 --- a/test/lisp/progmodes/f90-tests.el +++ b/test/lisp/progmodes/f90-tests.el @@ -98,7 +98,7 @@ end subroutine test") (insert "(/ x /)") (f90-do-auto-fill) (beginning-of-line) - (skip-chars-forward "[ \t]") + (skip-chars-forward " \t") (should (equal "&(/" (buffer-substring (point) (+ 3 (point))))))) ;; TODO bug#5593 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..732193476dd 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,15 +130,20 @@ 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 () "Test GCC warning via function predicate." + ;; http://lists.gnu.org/archive/html/emacs-devel/2019-03/msg01043.html + :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) (skip-unless (and (executable-find "gcc") (version<= "5" (string-trim diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 3ce27a687da..999cf8dc7a3 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -1161,10 +1161,13 @@ def b() if do: something() else +outside " (python-tests-look-at "else") (goto-char (line-end-position)) (python-tests-self-insert ":") + (should (= (current-indentation) 0)) + (python-tests-look-at "outside") (should (= (current-indentation) 0)))) (ert-deftest python-indent-electric-colon-3 () @@ -2004,6 +2007,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 " @@ -5336,13 +5345,23 @@ class SomeClass: (ert-deftest python-tests--python-nav-end-of-statement--infloop () "Checks that `python-nav-end-of-statement' doesn't infloop in a buffer with overlapping strings." + ;; FIXME: The treatment of strings has changed in the mean time, and the + ;; test below now neither signals an error nor inf-loops. + ;; The description of the problem it's trying to catch is not clear enough + ;; to be able to see if the underlying problem is really fixed, sadly. + ;; E.g. I don't know what is meant by "overlap", really. + (skip-unless nil) (python-tests-with-temp-buffer "''' '\n''' ' '\n" (syntax-propertize (point-max)) ;; Create a situation where strings nominally overlap. This ;; shouldn't happen in practice, but apparently it can happen when ;; a package calls `syntax-ppss' in a narrowed buffer during JIT ;; lock. + ;; FIXME: 4-5 is the SPC right after the opening triple quotes: why + ;; put a string-fence syntax on it? (put-text-property 4 5 'syntax-table (string-to-syntax "|")) + ;; FIXME: 8-9 is the middle quote in the closing triple quotes: + ;; it shouldn't have any syntax-table property to remove anyway! (remove-text-properties 8 9 '(syntax-table nil)) (goto-char 4) (setq-local syntax-propertize-function nil) @@ -5352,6 +5371,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/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 604c02172ea..7a11f762eb0 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -53,5 +53,222 @@ (error "some error")))) (should-not (sql-postgres-list-databases)))) +;;; Check Connection Password Handling/Wallet + +(defvar sql-test-login-params nil) +(defmacro with-sql-test-connect-harness (id login-params connection expected) + "Set-up and tear-down SQL connect related test. + +Identify tests by ID. Set :sql-login dialect attribute to +LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED +string of values passed to the comint function for validation." + (declare (indent 2)) + `(cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet + (list + (make-temp-file + "sql-test-netrc" nil nil + (mapconcat #'identity + '("machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + ) "\n"))))) + + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)) + (delete-file (car sql-password-wallet))))) + +(ert-deftest sql-test-connect () + "Test of basic `sql-connect'." + (with-sql-test-connect-harness 1 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-password "test-1 aPassword") + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-password-func () + "Test of password function." + (with-sql-test-connect-harness 2 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s + ?a ?P ?a ?s ?s ?w ?o ?r ?d]))) + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-server-database () + "Test of password function." + (with-sql-test-connect-harness 3 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-database () + "Test of password function." + (with-sql-test-connect-harness 4 (user password database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-server () + "Test of password function." + (with-sql-test-connect-harness 5 (user password server) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-server "aServer")) + "(sqltest nil \"aUserName\" \"netrc-B aPassword\" \"aServer\" nil)\n")) + +;;; Set/Get Product Features + +(defvar sql-test-feature-value-a nil "Indirect value A.") +(defvar sql-test-feature-value-b nil "Indirect value B.") +(defvar sql-test-feature-value-c nil "Indirect value C.") +(defvar sql-test-feature-value-d nil "Indirect value D.") +(defmacro sql-test-product-feature-harness (&rest action) + "Set-up and tear-down of testing product/feature API. + +Perform ACTION and validate results" + (declare (indent 2)) + `(cl-letf + ((sql-product-alist + (list (list 'a :X 1 :Y 2 :Z 'sql-test-feature-value-a) + (list 'b :X 3 :Z 'sql-test-feature-value-b) + (list 'c :Y 6 :Z 'sql-test-feature-value-c) + (list 'd :X 7 :Y 8 ))) + (sql-indirect-features '(:Z :W)) + (sql-test-feature-value-a "original A") + (sql-test-feature-value-b "original B") + (sql-test-feature-value-c "original C") + (sql-test-feature-value-d "original D")) + ,@action)) + +(ert-deftest sql-test-add-product () + "Add a product" + + (sql-test-product-feature-harness + (sql-add-product 'xyz "XyzDb") + + (should (equal (pp-to-string (assoc 'xyz sql-product-alist)) + "(xyz :name \"XyzDb\")\n")))) + +(ert-deftest sql-test-add-existing-product () + "Add a product that already exists." + + (sql-test-product-feature-harness + (should-error (sql-add-feature 'a "Aaa")) + (should (equal (pp-to-string (assoc 'a sql-product-alist)) + "(a :X 1 :Y 2 :Z sql-test-feature-value-a)\n")))) + +(ert-deftest sql-test-set-feature () + "Add a feature" + + (sql-test-product-feature-harness + (sql-set-product-feature 'b :Y 4) + (should (equal (pp-to-string (assoc 'b sql-product-alist)) + "(b :Y 4 :X 3 :Z sql-test-feature-value-b)\n")))) + +(ert-deftest sql-test-set-indirect-feature () + "Set a new indirect feature" + + (sql-test-product-feature-harness + (sql-set-product-feature 'd :Z 'sql-test-feature-value-d) + (should (equal (pp-to-string (assoc 'd sql-product-alist)) + "(d :Z sql-test-feature-value-d :X 7 :Y 8)\n")))) + +(ert-deftest sql-test-set-existing-feature () + "Set an existing feature." + + (sql-test-product-feature-harness + (sql-set-product-feature 'b :X 33) + (should (equal (pp-to-string (assoc 'b sql-product-alist)) + "(b :X 33 :Z sql-test-feature-value-b)\n")))) + +(ert-deftest sql-test-set-existing-indirect-feature () + "Set an existing indirect feature." + + (sql-test-product-feature-harness + (should (equal sql-test-feature-value-b "original B")) + (sql-set-product-feature 'b :Z "Hurray!") + (should (equal (pp-to-string (assoc 'b sql-product-alist)) + "(b :X 3 :Z sql-test-feature-value-b)\n")) ;; unchanged + (should (equal sql-test-feature-value-b "Hurray!")))) + +(ert-deftest sql-test-set-missing-product () + "Add a feature to a missing product." + + (sql-test-product-feature-harness + (should-error (sql-set-product-feature 'x :Y 4)) + (should-not (assoc 'x sql-product-alist)))) + +(ert-deftest sql-test-get-feature () + "Get a feature value." + + (sql-test-product-feature-harness + (should (equal (sql-get-product-feature 'c :Y) 6)))) + +(ert-deftest sql-test-get-indirect-feature () + "Get a feature indirect value." + + (sql-test-product-feature-harness + (should (equal (sql-get-product-feature 'c :Z nil t) 'sql-test-feature-value-c)) + (should (equal sql-test-feature-value-c "original C")) + (should (equal (sql-get-product-feature 'c :Z) "original C")))) + +(ert-deftest sql-test-get-missing-product () + "Get a feature value from a missing product." + + (sql-test-product-feature-harness + (should-error (sql-get-product-feature 'x :Y)))) + +(ert-deftest sql-test-get-missing-feature () + "Get a missing feature value." + + (sql-test-product-feature-harness + (should-not (sql-get-product-feature 'c :X)))) + +(ert-deftest sql-test-get-missing-indirect-feature () + "Get a missing indirect feature value." + + (sql-test-product-feature-harness + (should-not (sql-get-product-feature 'd :Z)))) + (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el new file mode 100644 index 00000000000..50c3eba75d1 --- /dev/null +++ b/test/lisp/progmodes/tcl-tests.el @@ -0,0 +1,77 @@ +;;; tcl-tests.el --- Test suite for tcl-mode + +;; Copyright (C) 2018-2019 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..cc2feebbefa 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -22,6 +22,11 @@ (require 'ert) (eval-when-compile (require 'cl-lib)) +(defun simple-test--buffer-substrings () + "Return cons of buffer substrings before and after point." + (cons (buffer-substring (point-min) (point)) + (buffer-substring (point) (point-max)))) + (defmacro simple-test--dummy-buffer (&rest body) (declare (indent 0) (debug t)) @@ -31,10 +36,7 @@ (insert "(a b") (save-excursion (insert " c d)")) ,@body - (with-no-warnings - (cons (buffer-substring (point-min) (point)) - (buffer-substring (point) (point-max)))))) - + (with-no-warnings (simple-test--buffer-substrings)))) ;;; `transpose-sexps' @@ -46,8 +48,7 @@ (insert "(s1) (s2) (s3) (s4) (s5)") (backward-sexp 1) ,@body - (cons (buffer-substring (point-min) (point)) - (buffer-substring (point) (point-max))))) + (simple-test--buffer-substrings))) ;;; Transposition with negative args (bug#20698, bug#21885) (ert-deftest simple-transpose-subr () @@ -214,6 +215,147 @@ (remove-hook 'post-self-insert-hook inc)))) +;;; `delete-indentation' + +(ert-deftest simple-delete-indentation-no-region () + "Test `delete-indentation' when no mark is set; see bug#35021." + (with-temp-buffer + (insert " first \n second \n third \n fourth ") + (should-not (mark t)) + ;; Without prefix argument. + (should-not (call-interactively #'delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '(" first \n second \n third" . " fourth "))) + (should-not (call-interactively #'delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '(" first \n second" . " third fourth "))) + ;; With prefix argument. + (goto-char (point-min)) + (let ((current-prefix-arg '(4))) + (should-not (call-interactively #'delete-indentation))) + (should (equal (simple-test--buffer-substrings) + '(" first" . " second third fourth "))))) + +(ert-deftest simple-delete-indentation-inactive-region () + "Test `delete-indentation' with an inactive region." + (with-temp-buffer + (insert " first \n second \n third ") + (set-marker (mark-marker) (point-min)) + (should (mark t)) + (should-not (call-interactively #'delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '(" first \n second" . " third "))))) + +(ert-deftest simple-delete-indentation-blank-line () + "Test `delete-indentation' does not skip blank lines. +See bug#35036." + (with-temp-buffer + (insert "\n\n third \n \n \n sixth \n\n") + ;; Without prefix argument. + (should-not (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("\n\n third \n \n \n sixth \n" . ""))) + (should-not (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("\n\n third \n \n \n sixth" . ""))) + (should-not (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("\n\n third \n \n" . "sixth"))) + ;; With prefix argument. + (goto-char (point-min)) + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '("" . "\n third \n \nsixth"))) + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '("" . "third \n \nsixth"))) + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '("third" . "\nsixth"))) + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '("third" . " sixth"))))) + +(ert-deftest simple-delete-indentation-boundaries () + "Test `delete-indentation' motion at buffer boundaries." + (with-temp-buffer + (insert " first \n second \n third ") + ;; Stay at EOB. + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '(" first \n second \n third " . ""))) + ;; Stay at BOB. + (forward-line -1) + (save-restriction + (narrow-to-region (point) (line-end-position)) + (should-not (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("" . " second "))) + ;; Go to EOB. + (should-not (delete-indentation t)) + (should (equal (simple-test--buffer-substrings) + '(" second " . "")))) + ;; Go to BOB. + (end-of-line 0) + (should-not (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("" . " first \n second \n third "))))) + +(ert-deftest simple-delete-indentation-region () + "Test `delete-indentation' with an active region." + (with-temp-buffer + ;; Empty region. + (insert " first ") + (should-not (delete-indentation nil (point) (point))) + (should (equal (simple-test--buffer-substrings) + '(" first " . ""))) + ;; Single line. + (should-not (delete-indentation + nil (line-beginning-position) (1- (point)))) + (should (equal (simple-test--buffer-substrings) + '("" . " first "))) + (should-not (delete-indentation nil (1+ (point)) (line-end-position))) + (should (equal (simple-test--buffer-substrings) + '(" " . "first "))) + (should-not (delete-indentation + nil (line-beginning-position) (line-end-position))) + (should (equal (simple-test--buffer-substrings) + '("" . " first "))) + ;; Multiple lines. + (goto-char (point-max)) + (insert "\n second \n third \n fourth ") + (goto-char (point-min)) + (should-not (delete-indentation + nil (line-end-position) (line-beginning-position 2))) + (should (equal (simple-test--buffer-substrings) + '(" first" . " second \n third \n fourth "))) + (should-not (delete-indentation + nil (point) (1+ (line-beginning-position 2)))) + (should (equal (simple-test--buffer-substrings) + '(" first second" . " third \n fourth "))) + ;; Prefix argument overrides region. + (should-not (delete-indentation t (point-min) (point))) + (should (equal (simple-test--buffer-substrings) + '(" first second third" . " fourth "))))) + +(ert-deftest simple-delete-indentation-prefix () + "Test `delete-indentation' with a fill prefix." + (with-temp-buffer + (insert "> first \n> second \n> third \n> fourth ") + (let ((fill-prefix "")) + (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("> first \n> second \n> third" . " > fourth "))) + (let ((fill-prefix "<")) + (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("> first \n> second" . " > third > fourth "))) + (let ((fill-prefix ">")) + (delete-indentation)) + (should (equal (simple-test--buffer-substrings) + '("> first" . " second > third > fourth "))))) + + ;;; `delete-trailing-whitespace' (ert-deftest simple-delete-trailing-whitespace--bug-21766 () "Test bug#21766: delete-whitespace sometimes deletes non-whitespace." @@ -448,6 +590,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 +642,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 +663,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..c458eef2f93 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,25 @@ 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--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 +354,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/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 3ad0ced01d6..1fce200721b 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -21,6 +21,8 @@ (require 'ert) (require 'tar-mode) +(defvar tar-mode-tests-data-directory + (expand-file-name "test/data/decompress" source-directory)) (ert-deftest tar-mode-test-tar-grind-file-mode () (let ((alist (list (cons 448 "rwx------") @@ -31,6 +33,17 @@ (dolist (x alist) (should (equal (cdr x) (tar-grind-file-mode (car x))))))) +(ert-deftest tar-mode-test-tar-extract-gz () + (skip-unless (executable-find "gzip")) + (let* ((tar-file (expand-file-name "tg.tar.gz" tar-mode-tests-data-directory)) + tar-buffer gz-buffer) + (unwind-protect + (with-current-buffer (setq tar-buffer (find-file-noselect tar-file)) + (setq gz-buffer (tar-extract)) + (should (equal (char-after) ?\N{SNOWFLAKE}))) + (when (buffer-live-p tar-buffer) (kill-buffer tar-buffer)) + (when (buffer-live-p gz-buffer) (kill-buffer gz-buffer))))) + (provide 'tar-mode-tests) ;; tar-mode-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/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el new file mode 100644 index 00000000000..3eefc8f84f9 --- /dev/null +++ b/test/lisp/textmodes/conf-mode-tests.el @@ -0,0 +1,204 @@ +;;; conf-mode-tests.el --- Test suite for conf mode -*- lexical-binding: t; -*- + +;; Copyright (C) 2016-2019 Free Software Foundation, Inc. + +;; Author: J. Alexander Branham <alex.branham@gmail.com> +;; Keywords: internal + +;; 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/>. + +;;; Commentary: + +;;; Code: +(require 'conf-mode) +(require 'ert) + +(ert-deftest conf-test-align-assignments () + "Test for `conf-align-assignments'." + (with-temp-buffer + (insert "foo: bar\nbar: baz") + (conf-colon-mode) + (conf-align-assignments) + (should (equal (buffer-string) + "foo: bar\nbar: baz")))) + +(ert-deftest conf-test-font-lock () + (with-temp-buffer + (insert "foo: bar\nbar: baz") + (conf-colon-mode) + (font-lock-mode) + (font-lock-ensure) + (goto-char (point-min)) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "bar") + (should-not (face-at-point)))) + +(ert-deftest conf-test-windows-mode () + (with-temp-buffer + ;; from `conf-windows-mode' docstring: + (insert "[ExtShellFolderViews] +Default={5984FFE0-28D4-11CF-AE66-08002B2E1262} +{5984FFE0-28D4-11CF-AE66-08002B2E1262}={5984FFE0-28D4-11CF-AE66-08002B2E1262} + +[{5984FFE0-28D4-11CF-AE66-08002B2E1262}] +PersistMoniker=file://Folder.htt") + (goto-char (point-min)) + (conf-windows-mode) + (font-lock-mode) + (font-lock-ensure) + (search-forward "ExtShell") + (should (equal (face-at-point) 'font-lock-type-face)) + (search-forward "Defau") + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (forward-line) + (beginning-of-line) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (forward-line 2) + (should-not (face-at-point)) + (forward-char) + (should (equal (face-at-point) 'font-lock-type-face)))) + +(ert-deftest conf-test-javaprop-mode () + (with-temp-buffer + ;; From `conf-javaprop-mode' docstring + (insert "// another kind of comment +/* yet another */ + +name:value +name=value +name value +x.1 = +x.2.y.1.z.1 = +x.2.y.1.z.2.zz =") + (goto-char (point-min)) + (conf-javaprop-mode) + (font-lock-mode) + (font-lock-ensure) + (should (equal (face-at-point) 'font-lock-comment-delimiter-face)) + (forward-char 3) + (should (equal (face-at-point) 'font-lock-comment-face)) + (search-forward "*") + (should (equal (face-at-point) 'font-lock-comment-delimiter-face)) + (while (search-forward "nam" nil t) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "val") + (should-not (face-at-point))) + (while (re-search-forward "a-z" nil t) + (backward-char) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (re-search-forward "[0-0]" nil t) + (backward-char) + (should (equal (face-at-point) 'font-lock-constant-face))))) + +(ert-deftest conf-test-space-mode () + ;; From `conf-space-mode' docstring. + (with-temp-buffer + (insert "image/jpeg jpeg jpg jpe +image/png png +image/tiff tiff tif +") + (goto-char (point-min)) + (conf-space-mode) + (font-lock-mode) + (font-lock-ensure) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (forward-char 15) + (should-not (face-at-point)))) + +(ert-deftest conf-test-colon-mode () + ;; From `conf-colon-mode' docstring. + (with-temp-buffer + (insert "<Multi_key> <exclam> <exclam> : \"\\241\" exclamdown +<Multi_key> <c> <slash> : \"\\242\" cent") + (goto-char (point-min)) + (conf-colon-mode) + (font-lock-mode) + (font-lock-ensure) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "24") + (should (equal (face-at-point) 'font-lock-string-face)) + (forward-line) + (should (equal (face-at-point) 'font-lock-variable-name-face)))) + +(ert-deftest conf-test-ppd-mode () + ;; From `conf-ppd-mode' docstring. + (with-temp-buffer + (insert "*DefaultTransfer: Null +*Transfer Null.Inverse: \"{ 1 exch sub }\"") + (goto-char (point-min)) + (conf-ppd-mode) + (font-lock-mode) + (font-lock-ensure) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "Nul") + (should-not (face-at-point)))) + +(ert-deftest conf-test-xdefaults-mode () + ;; From `conf-xdefaults-mode' docstring. + (with-temp-buffer + (insert "*background: gray99 +*foreground: black") + (goto-char (point-min)) + (conf-xdefaults-mode) + (font-lock-mode) + (font-lock-ensure) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "gray") + (should-not (face-at-point)))) + +(ert-deftest conf-test-toml-mode () + ;; From `conf-toml-mode' docstring. + (with-temp-buffer + (insert "\[entry] +value = \"some string\"") + (goto-char (point-min)) + (conf-toml-mode) + (font-lock-mode) + (font-lock-ensure) + (should-not (face-at-point)) + (forward-char) + (should (equal (face-at-point) 'font-lock-type-face)) + (forward-line) + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (search-forward "som") + (should (equal (face-at-point) 'font-lock-string-face)))) + +(ert-deftest conf-test-desktop-mode () + ;; From `conf-desktop-mode' dostring. + (with-temp-buffer + (insert " [Desktop Entry] + Name=GNU Image Manipulation Program + Name[oc]=Editor d'imatge GIMP + Exec=gimp-2.8 %U + Terminal=false") + (goto-char (point-min)) + (conf-desktop-mode) + (font-lock-mode) + (font-lock-ensure) + (search-forward "Desk") + (should (equal (face-at-point) 'font-lock-type-face)) + (search-forward "Nam") + (should (equal (face-at-point) 'font-lock-variable-name-face)) + (forward-char 2) + (should-not (face-at-point)) + (search-forward "[") + (should (equal (face-at-point) 'font-lock-constant-face)))) + + + +(provide 'conf-mode-tests) + +;;; conf-mode-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..08728746629 --- /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-2019 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..3f7beed35a6 --- /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-2019 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..1613f87e707 --- /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-2019 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..676d461076b 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -21,7 +21,10 @@ ;;; Code: (require 'diff-mode) +(require 'diff) +(defconst diff-mode-tests--datadir + (expand-file-name "test/data/vc/diff-mode" source-directory)) (ert-deftest diff-mode-test-ignore-trailing-dashes () "Check to make sure we successfully ignore trailing -- made by @@ -182,7 +185,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)) @@ -199,5 +202,118 @@ youthfulness (kill-buffer buf2) (delete-directory temp-dir 'recursive)))))) +(ert-deftest diff-mode-test-font-lock () + "Check font-locking of diff hunks." + (skip-unless (executable-find shell-file-name)) + (skip-unless (executable-find diff-command)) + (let ((default-directory diff-mode-tests--datadir) + (old "hello_world.c") + (new "hello_emacs.c") + (diff-buffer (get-buffer-create "*Diff*")) + (diff-refine 'font-lock) + (diff-font-lock-syntax t) + diff-beg) + (diff-no-select old new '("-u") 'no-async diff-buffer) + (with-current-buffer diff-buffer + (font-lock-ensure) + (narrow-to-region (progn (diff-hunk-next) + (setq diff-beg (diff-beginning-of-hunk))) + (diff-end-of-hunk)) + + (should (equal-including-properties + (buffer-string) + #("@@ -1,6 +1,6 @@ + #include <stdio.h> + int main() + { +- printf(\"Hello, World!\\n\"); ++ printf(\"Hello, Emacs!\\n\"); + return 0; + } +" + 0 15 (face diff-hunk-header) + 16 36 (face diff-context) + 36 48 (face diff-context) + 48 51 (face diff-context) + 51 52 (face diff-indicator-removed) + 52 81 (face diff-removed) + 81 82 (face diff-indicator-added) + 82 111 (face diff-added) + 111 124 (face diff-context) + 124 127 (face diff-context)))) + + (should (equal (mapcar (lambda (o) + (list (- (overlay-start o) diff-beg) + (- (overlay-end o) diff-beg) + (append (and (overlay-get o 'diff-mode) + `(diff-mode ,(overlay-get o 'diff-mode))) + (and (overlay-get o 'face) + `(face ,(overlay-get o 'face)))))) + (sort (overlays-in (point-min) (point-max)) + (lambda (a b) (< (overlay-start a) (overlay-start b))))) + '((0 127 (diff-mode fine)) + (0 127 (diff-mode syntax)) + (17 25 (diff-mode syntax face font-lock-preprocessor-face)) + (26 35 (diff-mode syntax face font-lock-string-face)) + (37 40 (diff-mode syntax face font-lock-type-face)) + (41 45 (diff-mode syntax face font-lock-function-name-face)) + (61 78 (diff-mode syntax face font-lock-string-face)) + (69 74 (diff-mode fine face diff-refine-removed)) + (91 108 (diff-mode syntax face font-lock-string-face)) + (99 104 (diff-mode fine face diff-refine-added)) + (114 120 (diff-mode syntax face font-lock-keyword-face)))))))) + +(ert-deftest diff-mode-test-font-lock-syntax-one-line () + "Check diff syntax highlighting for one line with no newline at end." + (skip-unless (executable-find shell-file-name)) + (skip-unless (executable-find diff-command)) + (let ((default-directory diff-mode-tests--datadir) + (old "hello_world_1.c") + (new "hello_emacs_1.c") + (diff-buffer (get-buffer-create "*Diff*")) + (diff-refine nil) + (diff-font-lock-syntax t) + diff-beg) + (diff-no-select old new '("-u") 'no-async diff-buffer) + (with-current-buffer diff-buffer + (font-lock-ensure) + (narrow-to-region (progn (diff-hunk-next) + (setq diff-beg (diff-beginning-of-hunk))) + (diff-end-of-hunk)) + + (should (equal-including-properties + (buffer-string) + #("@@ -1 +1 @@ +-int main() { printf(\"Hello, World!\\n\"); return 0; } +\\ No newline at end of file ++int main() { printf(\"Hello, Emacs!\\n\"); return 0; } +\\ No newline at end of file +" + 0 11 (face diff-hunk-header) + 12 13 (face diff-indicator-removed) + 13 65 (face diff-removed) + 65 93 (face diff-context) + 93 94 (face diff-indicator-added) + 94 146 (face diff-added) + 146 174 (face diff-context)))) + + (should (equal (mapcar (lambda (o) + (list (- (overlay-start o) diff-beg) + (- (overlay-end o) diff-beg) + (append (and (overlay-get o 'diff-mode) + `(diff-mode ,(overlay-get o 'diff-mode))) + (and (overlay-get o 'face) + `(face ,(overlay-get o 'face)))))) + (sort (overlays-in (point-min) (point-max)) + (lambda (a b) (< (overlay-start a) (overlay-start b))))) + '((0 174 (diff-mode syntax)) + (13 16 (diff-mode syntax face font-lock-type-face)) + (17 21 (diff-mode syntax face font-lock-function-name-face)) + (33 50 (diff-mode syntax face font-lock-string-face)) + (53 59 (diff-mode syntax face font-lock-keyword-face)) + (94 97 (diff-mode syntax face font-lock-type-face)) + (98 102 (diff-mode syntax face font-lock-function-name-face)) + (114 131 (diff-mode syntax face font-lock-string-face)) + (134 140 (diff-mode syntax face font-lock-keyword-face)))))))) (provide 'diff-mode-tests) 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/wid-edit-tests.el b/test/lisp/wid-edit-tests.el new file mode 100644 index 00000000000..a4350e715ed --- /dev/null +++ b/test/lisp/wid-edit-tests.el @@ -0,0 +1,39 @@ +;;; wid-edit-tests.el --- tests for wid-edit.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019 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 'wid-edit) + +(ert-deftest widget-at () + "Test `widget-at' behavior." + (with-temp-buffer + (should-not (widget-at)) + (let ((marco (widget-create 'link "link widget")) + (polo (widget-at (1- (point))))) + (should (widgetp polo)) + (should (eq marco polo))) + ;; Buttons and widgets are incompatible (bug#34506). + (insert-text-button "text button") + (should-not (widget-at (1- (point)))) + (insert-button "overlay button") + (should-not (widget-at (1- (point)))))) + +;;; wid-edit-tests.el ends here 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/BidiCharacterTest.txt b/test/manual/BidiCharacterTest.txt index 6a0df6dfb6d..064594b98a2 100644 --- a/test/manual/BidiCharacterTest.txt +++ b/test/manual/BidiCharacterTest.txt @@ -1,5 +1,5 @@ -# BidiCharacterTest-11.0.0.txt -# Date: 2018-02-18, 05:50:00 GMT [LI] +# BidiCharacterTest-12.0.0.txt +# Date: 2018-11-02, 16:34:00 GMT [LI] # © 2018 Unicode®, Inc. # For terms of use, see http://www.unicode.org/terms_of_use.html # 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/manual/indent/js-jsx.js b/test/manual/indent/js-jsx.js deleted file mode 100644 index 7401939d282..00000000000 --- a/test/manual/indent/js-jsx.js +++ /dev/null @@ -1,85 +0,0 @@ -// -*- mode: js-jsx; -*- - -var foo = <div></div>; - -return ( - <div> - </div> - <div> - <div></div> - <div> - <div></div> - </div> - </div> -); - -React.render( - <div> - <div></div> - </div>, - { - a: 1 - }, - <div> - <div></div> - </div> -); - -return ( - // Sneaky! - <div></div> -); - -return ( - <div></div> - // Sneaky! -); - -React.render( - <input - />, - { - a: 1 - } -); - -return ( - <div> - {array.map(function () { - return { - a: 1 - }; - })} - </div> -); - -return ( - <div attribute={array.map(function () { - return { - a: 1 - }; - - return { - a: 1 - }; - - return { - a: 1 - }; - })}> - </div> -); - -// Local Variables: -// indent-tabs-mode: nil -// js-indent-level: 2 -// End: - -// The following test has intentionally unclosed elements and should -// be placed below all other tests to prevent awkward indentation. - -return ( - <div> - {array.map(function () { - return { - a: 1 diff --git a/test/manual/indent/js.js b/test/manual/indent/js.js index df790986947..9658c95701c 100644 --- a/test/manual/indent/js.js +++ b/test/manual/indent/js.js @@ -151,6 +151,20 @@ let b = { ` } +// bug#25904 +foo.bar.baz(very => // A comment + very +).biz(([baz={a: [123]}, boz]) => + baz +).snarf((snorf) => /* Another comment */ + snorf +); + +// Continuation of bug#25904; support broken arrow as N+1th arg +map(arr, (val) => + val +) + // Local Variables: // indent-tabs-mode: nil // js-indent-level: 2 diff --git a/test/manual/indent/jsx-align-gt-with-lt.jsx b/test/manual/indent/jsx-align-gt-with-lt.jsx new file mode 100644 index 00000000000..8eb1d6d718c --- /dev/null +++ b/test/manual/indent/jsx-align-gt-with-lt.jsx @@ -0,0 +1,12 @@ +<element + attr="" + > +</element> +<input + /> + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// js-jsx-align->-with-<: nil +// End: diff --git a/test/manual/indent/jsx-indent-level.jsx b/test/manual/indent/jsx-indent-level.jsx new file mode 100644 index 00000000000..0a84b9eb77a --- /dev/null +++ b/test/manual/indent/jsx-indent-level.jsx @@ -0,0 +1,13 @@ +return ( + <element> + <element> + Hello World! + </element> + </element> +) + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 4 +// js-jsx-indent-level: 2 +// End: diff --git a/test/manual/indent/jsx-quote.jsx b/test/manual/indent/jsx-quote.jsx new file mode 100644 index 00000000000..1b2c6528734 --- /dev/null +++ b/test/manual/indent/jsx-quote.jsx @@ -0,0 +1,16 @@ +// JSX text node values should be strings, but only JS string syntax +// is considered, so quote marks delimit strings like normal, with +// disastrous results (https://github.com/mooz/js2-mode/issues/409). +function Bug() { + return <div>C'est Montréal</div>; +} +function Test(foo = /'/, + bar = 123) {} + +// This test is in a separate file because it can break other tests +// when indenting the whole buffer (not sure why). + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: diff --git a/test/manual/indent/jsx-self-closing.jsx b/test/manual/indent/jsx-self-closing.jsx new file mode 100644 index 00000000000..f8ea7a138ad --- /dev/null +++ b/test/manual/indent/jsx-self-closing.jsx @@ -0,0 +1,13 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following test goes below any comments to avoid including +// misindented comments among the erroring lines. + +// Properly parse/indent code with a self-closing tag inside the +// attribute of another self-closing tag. +<div> + <div attr={() => <div attr="" />} /> +</div> diff --git a/test/manual/indent/jsx-unclosed-1.jsx b/test/manual/indent/jsx-unclosed-1.jsx new file mode 100644 index 00000000000..1f5c3fba8da --- /dev/null +++ b/test/manual/indent/jsx-unclosed-1.jsx @@ -0,0 +1,13 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following test goes below any comments to avoid including +// misindented comments among the erroring lines. + +return ( + <div> + {array.map(function () { + return { + a: 1 diff --git a/test/manual/indent/jsx-unclosed-2.jsx b/test/manual/indent/jsx-unclosed-2.jsx new file mode 100644 index 00000000000..fb665b96a43 --- /dev/null +++ b/test/manual/indent/jsx-unclosed-2.jsx @@ -0,0 +1,65 @@ +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: + +// The following tests go below any comments to avoid including +// misindented comments among the erroring lines. + +// Don’t misinterpret inequality operators as JSX. +for (; i < length;) void 0 +if (foo > bar) void 0 + +// Don’t misintrepet inequalities within JSX, either. +<div> + {foo < bar} +</div> + +// Don’t even misinterpret unary operators as JSX. +if (foo < await bar) void 0 +while (await foo > bar) void 0 + +<div> + {foo < await bar} +</div> + +// Allow unary keyword names as null-valued JSX attributes. +// (As if this will EVER happen…) +<Foo yield> + <Bar void> + <Baz + zorp + typeof> + <Please do_n0t delete this_stupidTest > + How would we ever live without unary support + </Please> + </Baz> + </Bar> +</Foo> + +// “-” is not allowed in a JSXBoundaryElement’s name. +<ABC /> + <A-B-C /> // Weirdly-indented “continued expression.” + +// “-” may be used in a JSXAttribute’s name. +<Foo a-b-c="" + x-y-z="" /> + +// Weird spaces should be tolerated. +< div > + < div > + < div + attr="" + / > + < div + attr="" + / > + < / div> +< / div > + +// Non-ASCII identifiers are acceptable. +<Über> + <Québec διακριτικός sueño=""> + Guten Tag! + </Québec> +</Über> diff --git a/test/manual/indent/jsx.jsx b/test/manual/indent/jsx.jsx new file mode 100644 index 00000000000..c200979df8c --- /dev/null +++ b/test/manual/indent/jsx.jsx @@ -0,0 +1,314 @@ +var foo = <div></div>; + +return ( + <div> + </div> + <div> + <div></div> + <div> + <div></div> + </div> + </div> +); + +React.render( + <div> + <div></div> + </div>, + { + a: 1 + }, + <div> + <div></div> + </div> +); + +return ( + // Sneaky! + <div></div> +); + +return ( + <div></div> + // Sneaky! +); + +React.render( + <input + />, + { + a: 1 + } +); + +return ( + <div> + {array.map(function () { + return { + a: 1 + }; + })} + </div> +); + +return ( + <div attribute={array.map(function () { + return { + a: 1 + }; + + return { + a: 1 + }; + + return { + a: 1 + }; + })}> + </div> +); + +return ( + <div attribute={{ + a: 1, // Indent relative to “attribute” column. + b: 2 + } && { // Dedent to “attribute” column. + a: 1, + b: 2 + }} /> // Also dedent. +); + +return ( + <div attribute= + { // Indent properly on another line, too. + { + a: 1, + b: 2, + } && ( + // Indent other forms, too. + a ? b : + c ? d : + e + ) + } /> +) + +// JSXMemberExpression names are parsed/indented: +<Foo.Bar> + <div> + <Foo.Bar> + Hello World! + </Foo.Bar> + <Foo.Bar> + <div> + </div> + </Foo.Bar> + </div> +</Foo.Bar> + +// JSXOpeningFragment and JSXClosingFragment are parsed/indented: +<> + <div> + <> + Hello World! + </> + <> + <div> + </div> + </> + </div> +</> + +// Indent void expressions (no need for contextual parens / commas) +// (https://github.com/mooz/js2-mode/issues/140#issuecomment-166250016). +<div className="class-name"> + <h2>Title</h2> + {array.map(() => { + return <Element />; + })} + {message} +</div> +// Another example of above issue +// (https://github.com/mooz/js2-mode/issues/490). +<App> + <div> + {variable1} + <Component/> + </div> +</App> + +// Comments and arrows can break indentation (Bug#24896 / +// https://github.com/mooz/js2-mode/issues/389). +const Component = props => ( + <FatArrow a={e => c} + b={123}> + </FatArrow> +); +const Component = props => ( + <NoFatArrow a={123} + b={123}> + </NoFatArrow> +); +const Component = props => ( // Parse this comment, please. + <FatArrow a={e => c} + b={123}> + </FatArrow> +); +const Component = props => ( // Parse this comment, please. + <NoFatArrow a={123} + b={123}> + </NoFatArrow> +); +// Another example of above issue (Bug#30225). +class { + render() { + return ( + <select style={{paddingRight: "10px"}} + onChange={e => this.setState({value: e.target.value})} + value={this.state.value}> + <option>Hi</option> + </select> + ); + } +} + +// JSX attributes of an arrow function’s expression body’s JSX +// expression should be indented with respect to the JSX opening +// element (Bug#26001 / +// https://github.com/mooz/js2-mode/issues/389#issuecomment-271869380). +class { + render() { + const messages = this.state.messages.map( + message => <Message key={message.id} + text={message.text} + mine={message.mine} /> + ); return messages; + } + render() { + const messages = this.state.messages.map(message => + <Message key={message.timestamp} + text={message.text} + mine={message.mine} /> + ); return messages; + } +} + +// Users expect tag closers to align with the tag’s start; this is the +// style used in the React docs, so it should be the default. +// - https://github.com/mooz/js2-mode/issues/389#issuecomment-390766873 +// - https://github.com/mooz/js2-mode/issues/482 +// - Bug#32158 +const foo = (props) => ( + <div> + <input + cat={i => i} + /> + <button + className="square" + > + {this.state.value} + </button> + </div> +); + +// Embedded JSX in parens breaks indentation +// (https://github.com/mooz/js2-mode/issues/411). +let a = ( + <div> + {condition && <Component/>} + {condition && <Component/>} + <div/> + </div> +) +let b = ( + <div> + {condition && (<Component/>)} + <div/> + </div> +) +let c = ( + <div> + {condition && (<Component/>)} + {condition && "something"} + </div> +) +let d = ( + <div> + {(<Component/>)} + {condition && "something"} + </div> +) +// Another example of the above issue (Bug#27000). +function testA() { + return ( + <div> + <div> { ( <div/> ) } </div> + </div> + ); +} +function testB() { + return ( + <div> + <div> { <div/> } </div> + </div> + ); +} +// Another example of the above issue +// (https://github.com/mooz/js2-mode/issues/451). +class Classy extends React.Component { + render () { + return ( + <div> + <ul className="tocListRoot"> + { this.state.list.map((item) => { + return (<div />) + })} + </ul> + </div> + ) + } +} + +// Self-closing tags should be indented properly +// (https://github.com/mooz/js2-mode/issues/459). +export default ({ stars }) => ( + <div className='overlay__container'> + <div className='overlay__header overlay--text'> + Congratulations! + </div> + <div className='overlay__reward'> + <Icon {...createIconProps(stars > 0)} size='large' /> + <div className='overlay__reward__bottom'> + <Icon {...createIconProps(stars > 1)} size='small' /> + <Icon {...createIconProps(stars > 2)} size='small' /> + </div> + </div> + <div className='overlay__description overlay--text'> + You have created <large>1</large> reminder + </div> + </div> +) + +// JS expressions should not break indentation +// (https://github.com/mooz/js2-mode/issues/462). +// +// In the referenced issue, the user actually wanted indentation which +// was simply different than Emacs’ SGML attribute indentation. +// Nevertheless, his issue highlighted our inability to properly +// indent code with JSX inside JSXExpressionContainers inside JSX. +return ( + <Router> + <Bar> + <Route exact path="/foo" + render={() => ( + <div>nothing</div> + )} /> + <Route exact path="/bar" /> + </Bar> + </Router> +) + +// Local Variables: +// indent-tabs-mode: nil +// js-indent-level: 2 +// End: 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..5c310b5c08d --- /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-2019 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/cmds-tests.el b/test/src/cmds-tests.el index 05c62858773..bab8b5f26ec 100644 --- a/test/src/cmds-tests.el +++ b/test/src/cmds-tests.el @@ -30,5 +30,13 @@ (let ((last-command-event ?a)) (should-error (self-insert-command -1)))) +(ert-deftest forward-line-with-bignum () + (with-temp-buffer + (insert "x\n") + (let ((shortage (forward-line (1- most-negative-fixnum)))) + (should (= shortage most-negative-fixnum))) + (let ((shortage (forward-line (+ 2 most-positive-fixnum)))) + (should (= shortage (1+ most-positive-fixnum)))))) + (provide 'cmds-tests) ;;; cmds-tests.el ends here diff --git a/test/src/data-tests.el b/test/src/data-tests.el index f3b4262de4b..a9d48e29a8a 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,6 +525,150 @@ 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))) + (ert-deftest data-tests-make-local-forwarded-var () ;bug#34318 ;; Boy, this bug is tricky to trigger. You need to: ;; - call make-local-variable on a forwarded var (i.e. one that diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index 041d21d9c16..1e8b7066d15 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -150,54 +150,58 @@ (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)) + (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 +327,61 @@ (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 () + ;; FIXME: Actually my GID in one of my systems has no associated entry + ;; in /etc/group so there's no name for it and `group-name' correctly + ;; returns nil! + (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))))))))) + +(ert-deftest test-translate-region-internal () + (with-temp-buffer + (let ((max-char #16r3FFFFF) + (tt (make-char-table 'translation-table))) + (aset tt max-char ?*) + (insert max-char) + (translate-region-internal (point-min) (point-max) tt) + (should (string-equal (buffer-string) "*"))))) + ;;; editfns-tests.el ends here diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 6f4490d9d12..35aaaa64b65 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)))) @@ -252,6 +265,49 @@ during garbage collection." (skip-unless (file-executable-p mod-test-emacs)) (module--test-assertion (rx "Module function called during garbage collection\n") - (mod-test-invalid-finalizer))) + (mod-test-invalid-finalizer) + (garbage-collect))) + +(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)))) + +(ert-deftest mod-test-sleep-until () + "Check that `mod-test-sleep-until' either returns normally or quits. +Interactively, you can try hitting \\[keyboard-quit] to quit." + (dolist (arg '(nil t)) + ;; Guard against some caller setting `inhibit-quit'. + (with-local-quit + (condition-case nil + (should (eq (with-local-quit + ;; Because `inhibit-quit' is nil here, the next + ;; form either quits or returns `finished'. + (mod-test-sleep-until + ;; Interactively, run for 5 seconds to give the + ;; user time to quit. In batch mode, run only + ;; briefly since the user can't quit. + (float-time (time-add nil (if noninteractive 0.1 5))) + ;; should_quit or process_input + arg)) + 'finished)) + (quit))))) ;;; 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..6ebab4287f7 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)) @@ -150,7 +161,10 @@ '(9 . "ppp") '(8 . "ttt") '(8 . "eee") '(9 . "fff")) (lambda (x y) (< (car x) (car y)))) [(8 . "xxx") (8 . "bbb") (8 . "ttt") (8 . "eee") - (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")]))) + (9 . "aaa") (9 . "zzz") (9 . "ppp") (9 . "fff")])) + ;; Bug#34104 + (should (equal (should-error (sort "cba" #'<) :type 'wrong-type-argument) + '(wrong-type-argument list-or-vector-p "cba")))) (ert-deftest fns-tests-collate-sort () (skip-unless (fns-tests--collate-enabled-p)) @@ -575,4 +589,81 @@ :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)))))))) + +(ert-deftest test-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"))))) + (provide 'fns-tests) diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 00000000000..04f91f4abbc --- /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-2019 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..5dbf441e8c2 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 (or (accept-process-output process) + (process-live-p 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..0ae50c94d4c 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). @@ -278,7 +278,7 @@ on success" (defconst regex-tests-re-even-escapes - "\\(?:^\\|[^\\\\]\\)\\(?:\\\\\\\\\\)*" + "\\(?:^\\|[^\\]\\)\\(?:\\\\\\\\\\)*" "Regex that matches an even number of \\ characters") (defconst regex-tests-re-odd-escapes @@ -555,11 +555,11 @@ differences in behavior.") (defconst regex-tests-PTESTS-whitelist [ - ;; emacs doesn't barf on weird ranges such as [b-a], but simply - ;; fails to match + ;; emacs doesn't see DEL (0x7f) as a [:cntrl:] character 138 - ;; emacs doesn't see DEL (0x78) as a [:cntrl:] character + ;; emacs doesn't barf on weird ranges such as [b-a], but simply + ;; fails to match 168 ] "Line numbers in the PTESTS test that should be skipped. These @@ -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..5c858ef3bd8 --- /dev/null +++ b/test/src/timefns-tests.el @@ -0,0 +1,144 @@ +;;; timefns-tests.el -- tests for timefns.c + +;; Copyright (C) 2016-2019 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)))))))) |