diff options
Diffstat (limited to 'test')
173 files changed, 8615 insertions, 4290 deletions
diff --git a/test/Makefile.in b/test/Makefile.in index 1d247f3300b..d6ab7b244d2 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -31,7 +31,7 @@ SHELL = @SHELL@ srcdir = @srcdir@ -abs_top_srcdir=@abs_top_srcdir@ +abs_top_srcdir = @abs_top_srcdir@ top_builddir = @top_builddir@ VPATH = $(srcdir) @@ -67,7 +67,7 @@ elpa_opts = $(foreach el,$(elpa_els),$(and $(wildcard $(el)),-L $(dir $(el)) -l # directory, we can use emacs --chdir. EMACS = ../src/emacs -EMACS_EXTRAOPT= +EMACS_EXTRAOPT = # Command line flags for Emacs. # Apparently MSYS bash would convert "-L :" to "-L ;" anyway, @@ -77,9 +77,14 @@ EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" # Prevent any settings in the user environment causing problems. unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS XDG_CONFIG_HOME -## To run tests under a debugger, set this to eg: "gdb --args". +# To run tests under a debugger, set this to eg: "gdb --args". GDB = +# Whether a timeout shall be given, writing possibly a core dump. +ifneq (${EMACS_TEST_TIMEOUT},) +TEST_TIMEOUT = timeout -s ABRT ${EMACS_TEST_TIMEOUT} +endif + # Set this to 'yes' to run the tests in an interactive instance. TEST_INTERACTIVE ?= no @@ -117,7 +122,7 @@ endif # and prevent locals to influence the text of the errors we expect to receive. emacs = LANG=C EMACSLOADPATH= \ EMACS_TEST_DIRECTORY=$(abspath $(srcdir)) \ - $(GDB) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT) + $(GDB) $(TEST_TIMEOUT) "$(EMACS)" $(MODULES_EMACSOPT) $(EMACSOPT) # Set HOME to a nonexistent directory to prevent tests from accessing # it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg @@ -167,7 +172,7 @@ lisp/net/tramp-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif ifdef EMACS_EMBA_CI -lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.el \ +lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif @@ -178,8 +183,8 @@ testloadfile = $* endif %.log: %.elc - $(AM_V_at)${MKDIR_P} $(dir $@) - $(AM_V_GEN)HOME=$(TEST_HOME) $(emacs) \ + $(AM_V_GEN)${MKDIR_P} $(dir $@) + $(AM_V_at)HOME=$(TEST_HOME) $(emacs) \ -l ert ${ert_opts} -l $(testloadfile) \ $(TEST_RUN_ERT) @@ -247,9 +252,12 @@ endef $(foreach test,${TESTS},$(eval $(call test_template,${test}))) ## Get the tests for only a specific directory. -SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d ! -path "*resources*" -print)) +SUBDIRS = $(sort $(shell cd ${srcdir} && find lib-src lisp misc src -type d \ + ! \( -path "*resources*" -o -path "*auto-save-list" \) -print)) +SUBDIR_TARGETS = define subdir_template + SUBDIR_TARGETS += check-$(subst /,-,$(1)) .PHONY: check-$(subst /,-,$(1)) check-$(subst /,-,$(1)): @${MAKE} check LOGFILES="$(patsubst %.el,%.log, \ @@ -283,8 +291,8 @@ FREE_SOURCE_1 = $(srcdir)/../lib/free.c # as source because those are not compiled with -fPIC. Therefore we # use only source files. $(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h - $(AM_V_at)${MKDIR_P} $(dir $@) - $(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ + $(AM_V_CCLD)${MKDIR_P} $(dir $@) + $(AM_V_at)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ -o $@ $< $(LIBGMP) \ $(and $(GMP_H),$(srcdir)/../lib/mini-gmp-gnulib.c) \ $(FREE_SOURCE_$(REPLACE_FREE)) \ @@ -345,6 +353,7 @@ mostlyclean: clean: find . '(' -name '*.log' -o -name '*.log~' ')' $(FIND_DELETE) + find . '(' -name '*.xml' -a ! -path '*resources*' ')' $(FIND_DELETE) rm -f ${srcdir}/lisp/gnus/mml-sec-resources/random_seed rm -f $(test_module_dir)/*.o $(test_module_dir)/*.so \ $(test_module_dir)/*.dll @@ -362,3 +371,14 @@ maintainer-clean: distclean bootstrap-clean check-declare: $(emacs) --batch -l check-declare \ --eval '(check-declare-directory "$(srcdir)")' + +.PHONY: subdirs subdir-targets generate-test-jobs + +subdirs: + @: $(info $(SUBDIRS)) + +subdir-targets: + @: $(info $(SUBDIR_TARGETS)) + +generate-test-jobs: + @$(MAKE) -C infra generate-test-jobs SUBDIRS="$(SUBDIRS)" diff --git a/test/README b/test/README index 0c153e7ef3c..e44c4a43eeb 100644 --- a/test/README +++ b/test/README @@ -114,6 +114,9 @@ mode--only the names of the failed tests are listed. If the $EMACS_TEST_VERBOSE environment variable is set, the failure summaries will also include the data from the failing test. +If the $EMACS_TEST_JUNIT_REPORT environment variable is set to a file +name, a JUnit test report is generated under this name. + Some of the tests require a remote temporary directory (autorevert-tests.el, filenotify-tests.el, shadowfile-tests.el and tramp-tests.el). Per default, a mock-up connection method is used @@ -140,6 +143,11 @@ these test environments. $EMACS_HYDRA_CI indicates the hydra environment, and $EMACS_EMBA_CI indicates the emba environment, respectively. +If tests on these premises take too long, and it is needed to create a +core dump for further analysis, the environment variable +$EMACS_TEST_TIMEOUT could set a limit (in seconds) when this shall +happen. + (Also, see etc/compilation.txt for compilation mode font lock tests and etc/grep.txt for grep mode font lock tests.) diff --git a/test/data/image/black.gif b/test/data/image/black.gif Binary files differnew file mode 100644 index 00000000000..6ab623e367e --- /dev/null +++ b/test/data/image/black.gif diff --git a/test/data/image/black.webp b/test/data/image/black.webp Binary files differnew file mode 100644 index 00000000000..5dbe716415b --- /dev/null +++ b/test/data/image/black.webp diff --git a/test/infra/Dockerfile.emba b/test/infra/Dockerfile.emba index f8fe13d2469..d9d963bcfd5 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -29,7 +29,7 @@ FROM debian:stretch as emacs-base RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ - libdbus-1-dev libacl1-dev acl git texinfo \ + libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* FROM emacs-base as emacs-inotify @@ -72,14 +72,14 @@ RUN ./autogen.sh autoconf RUN ./configure --with-ns RUN make bootstrap -FROM emacs-base as emacs-native-comp-speed0 +FROM emacs-base as emacs-native-comp RUN apt-get update && \ apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ libgccjit-6-dev \ && rm -rf /var/lib/apt/lists/* -ARG make_bootstrap_params="" +FROM emacs-native-comp as emacs-native-comp-speed0 COPY . /checkout WORKDIR /checkout @@ -87,3 +87,19 @@ RUN ./autogen.sh autoconf RUN ./configure --with-native-compilation RUN make bootstrap -j2 \ NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' + +FROM emacs-native-comp as emacs-native-comp-speed1 + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --with-native-compilation +RUN make bootstrap -j2 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' + +FROM emacs-native-comp as emacs-native-comp-speed2 + +COPY . /checkout +WORKDIR /checkout +RUN ./autogen.sh autoconf +RUN ./configure --with-native-compilation +RUN make bootstrap -j2 diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in new file mode 100644 index 00000000000..368be7392b2 --- /dev/null +++ b/test/infra/Makefile.in @@ -0,0 +1,100 @@ +### @configure_input@ + +# Copyright (C) 2021 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +### Commentary: + +## Generate the test-jobs.yml file for emba. + +### Code: + +SHELL = @SHELL@ + +top_builddir = @top_builddir@ + +-include ${top_builddir}/src/verbose.mk + +## Get the tests for only a specific directory. +SUBDIRS ?= $(shell make -s -C .. subdirs) +SUBDIR_TARGETS = +FILE = test-jobs.yml +tn = $$$${test_name} +cps = $$$$CI_PIPELINE_SOURCE + +define subdir_template + $(eval target = check-$(subst /,-,$(1))) + SUBDIR_TARGETS += $(target) + + $(eval + ifeq ($(findstring src, $(1)), src) + define changes + @echo ' - $(1)/*.{h,c}' >>$(FILE) + endef + else ifeq ($(findstring eieio, $(1)), eieio) + define changes + @echo ' - lisp/emacs-lisp/eieio*.el' >>$(FILE) + endef + else ifeq ($(findstring faceup, $(1)), faceup) + define changes + @echo ' - lisp/emacs-lisp/faceup*.el' >>$(FILE) + endef + else ifeq ($(findstring so-long, $(1)), so-long) + define changes + @echo ' - lisp/so-long*.el' >>$(FILE) + endef + else ifeq ($(findstring misc, $(1)), misc) + define changes + @echo ' - admin/*.el' >>$(FILE) + endef + else + define changes + @echo ' - $(1)/*.el' >>$(FILE) + endef + endif) + + $(target): + @echo >>$(FILE) + @echo 'test-$(subst /,-,$(1))-inotify:' >>$(FILE) + @echo ' stage: normal' >>$(FILE) + @echo ' extends: [.job-template, .test-template]' >>$(FILE) + @echo ' needs:' >>$(FILE) + @echo ' - job: build-image-inotify' >>$(FILE) + @echo ' optional: true' >>$(FILE) + @echo ' rules:' >>$(FILE) + @echo " - if: '"'${cps} == "schedule"'"'" >>$(FILE) + @echo ' when: never' >>$(FILE) + @echo ' - changes:' >>$(FILE) + $(changes) + @echo ' - test/$(1)/*.el' >>$(FILE) + @echo ' - test/$(1)/*resources/**' >>$(FILE) + @echo ' variables:' >>$(FILE) + @echo ' target: emacs-inotify' >>$(FILE) + @echo ' make_params: "-k -C test $(target)"' >>$(FILE) +endef + +$(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) + +all: generate-test-jobs + +.PHONY: generate-test-jobs $(FILE) $(SUBDIR_TARGETS) + +generate-test-jobs: $(FILE) $(SUBDIR_TARGETS) + +$(FILE): + $(AM_V_GEN) + @echo "# Generated by \"make generate-test-jobs\", don't edit." >$(FILE) diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 00f4917dd3a..e034430edce 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -15,7 +15,7 @@ # You should have received a copy of the GNU General Public License # along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -# GNU Emacs support for the GitLab protocol for CI +# GNU Emacs support for the GitLab protocol for CI. # The presence of this file does not imply any FSF/GNU endorsement of # any particular service that uses that protocol. Also, it is intended for @@ -44,8 +44,10 @@ workflow: variables: GIT_STRATEGY: fetch EMACS_EMBA_CI: 1 + EMACS_TEST_JUNIT_REPORT: junit-test-report.xml + EMACS_TEST_TIMEOUT: 3600 EMACS_TEST_VERBOSE: 1 - # # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled + # Use TLS https://docs.gitlab.com/ee/ci/docker/using_docker_build.html#tls-enabled # DOCKER_HOST: tcp://docker:2376 # DOCKER_TLS_CERTDIR: "/certs" # Put the configuration for each run in a separate directory to @@ -55,6 +57,8 @@ variables: # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap # across multiple builds. BUILD_TAG: ${CI_COMMIT_REF_SLUG} + # Disable if you don't need it, it can be a security risk. + # CI_DEBUG_TRACE: "true" default: image: docker:19.03.12 @@ -67,31 +71,6 @@ default: .job-template: variables: test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} - rules: - - changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - aclocal.m4 - - autogen.sh - - configure.ac - - lib/*.{h,c} - - lisp/**/*.el - - src/*.{h,c} - - test/infra/* - - test/lib-src/*.el - - test/lisp/**/*.el - - test/src/*.el - - changes: - # gfilemonitor, kqueue - - src/gfilenotify.c - - src/kqueue.c - # MS Windows - - "**/w32*" - # GNUstep - - lisp/term/ns-win.el - - src/ns*.{h,m} - - src/macfont.{h,m} - when: never # These will be cached across builds. cache: key: ${CI_COMMIT_SHA} @@ -107,25 +86,31 @@ default: # TODO: with make -j4 several of the tests were failing, for # example shadowfile-tests, but passed without it. - 'export PWD=$(pwd)' - - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' + - 'docker run -i -e EMACS_EMBA_CI=${EMACS_EMBA_CI} -e EMACS_TEST_JUNIT_REPORT=${EMACS_TEST_JUNIT_REPORT} -e EMACS_TEST_TIMEOUT=${EMACS_TEST_TIMEOUT} -e EMACS_TEST_VERBOSE=${EMACS_TEST_VERBOSE} --volumes-from $(docker ps -q -f "label=com.gitlab.gitlab-runner.job.id=${CI_JOB_ID}"):ro --name ${test_name} ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} /bin/bash -c "git fetch ${PWD} HEAD && echo checking out these updated files && git diff --name-only FETCH_HEAD && ( git diff --name-only FETCH_HEAD | xargs git checkout -f FETCH_HEAD ) && make -j4 && make ${make_params}"' after_script: # - docker ps -a # - printenv # - test -n "$(docker ps -aq -f name=${test_name})" && ( docker export ${test_name} | tar -tvf - ) + # Prepare test artifacts. - test -n "$(docker ps -aq -f name=${test_name})" && docker cp ${test_name}:checkout/test ${test_name} - test -n "$(docker ps -aq -f name=${test_name})" && docker rm ${test_name} + - find ${test_name} ! \( -name "*.log" -o -name ${EMACS_TEST_JUNIT_REPORT} \) -type f -delete + # BusyBox find does not know -empty. + - find ${test_name} -type d -depth -exec rmdir {} + 2>/dev/null .build-template: + needs: [] rules: - if: '$CI_PIPELINE_SOURCE == "web"' when: always - changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" + - GNUmakefile - aclocal.m4 - autogen.sh - configure.ac - lib/*.{h,c} + - lib/malloc/*.{h,c} - lisp/emacs-lisp/*.el - src/*.{h,c} - test/infra/* @@ -134,7 +119,7 @@ default: - src/gfilenotify.c - src/kqueue.c # MS Windows - - "**/w32*" + - "**w32*" # GNUstep - lisp/term/ns-win.el - src/ns*.{h,m} @@ -145,32 +130,26 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - # Do not block later stages. - allow_failure: true - # Do not run fast and normal test jobs when scheduled. - rules: - - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' - when: never - - when: always artifacts: name: ${test_name} public: true expire_in: 1 week + when: always paths: - - "${test_name}/**/*.log" + - ${test_name}/ + reports: + junit: ${test_name}/${EMACS_TEST_JUNIT_REPORT} .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml - - configure.ac + - "**.in" - src/ns*.{h,m} - src/macfont.{h,m} - lisp/term/ns-win.el - - nextstep/**/* + - nextstep/** - test/infra/* .filenotify-gio-template: @@ -178,8 +157,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" - lisp/autorevert.el - lisp/filenotify.el - lisp/net/tramp-sh.el @@ -193,8 +171,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" - - .gitlab-ci.yml + - "**.in" - lisp/emacs-lisp/comp.el - lisp/emacs-lisp/comp-cstr.el - src/comp.{h,m} @@ -205,13 +182,11 @@ default: stages: - build-images -# - fast - normal - platform-images - platforms - native-comp-images - native-comp - - slow build-image-inotify: stage: build-images @@ -219,26 +194,22 @@ build-image-inotify: variables: target: emacs-inotify -# test-fast-inotify: -# stage: fast -# extends: [.job-template, .test-template] -# variables: -# target: emacs-inotify -# make_params: "-C test check" - -test-lisp-inotify: - stage: normal - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check-lisp" +include: '/test/infra/test-jobs.yml' -test-lisp-net-inotify: +test-all-inotify: + # This tests also file monitor libraries inotify and inotifywatch. stage: normal extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + # Note there's no "changes" section, so this always runs on a schedule. + - if: '$CI_PIPELINE_SOURCE == "web"' + - if: '$CI_PIPELINE_SOURCE == "schedule"' variables: target: emacs-inotify - make_params: "-C test check-lisp-net" + make_params: check-expensive build-image-filenotify-gio: stage: platform-images @@ -246,80 +217,62 @@ build-image-filenotify-gio: variables: target: emacs-filenotify-gio -build-image-gnustep: - stage: platform-images - extends: [.job-template, .build-template, .gnustep-template] - variables: - target: emacs-gnustep - test-filenotify-gio: # This tests file monitor libraries gfilemonitor and gio. stage: platforms - needs: [build-image-filenotify-gio] extends: [.job-template, .test-template, .filenotify-gio-template] + needs: + - job: build-image-filenotify-gio + optional: true variables: target: emacs-filenotify-gio - make_params: "-k -C test autorevert-tests.log filenotify-tests.log" + # This is needed in order to get a JUnit test report. + make_params: '-k -C test check-expensive LOGFILES="lisp/autorevert-tests.log lisp/filenotify-tests.log"' + +build-image-gnustep: + stage: platform-images + extends: [.job-template, .build-template, .gnustep-template] + variables: + target: emacs-gnustep test-gnustep: # This tests the GNUstep build process. stage: platforms - needs: [build-image-gnustep] extends: [.job-template, .gnustep-template] + needs: + - job: build-image-gnustep + optional: true variables: target: emacs-gnustep make_params: install -build-native-bootstrap-speed0: +build-native-comp-speed0: stage: native-comp-images extends: [.job-template, .build-template, .native-comp-template] variables: target: emacs-native-comp-speed0 -# build-native-bootstrap-speed0: -# # Test a full native bootstrap -# # Run for now only speed 0 to limit memory usage and compilation time. -# stage: native-comp-images -# # Uncomment the following to run it only when scheduled. -# # only: -# # - schedules -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 -# timeout: 8 hours - -# build-native-bootstrap-speed1: -# stage: native-comp-images -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' -# timeout: 8 hours +build-native-comp-speed1: + stage: native-comp-images + extends: [.job-template, .build-template, .native-comp-template] + variables: + target: emacs-native-comp-speed1 -# build-native-bootstrap-speed2: -# stage: native-comp-images -# script: -# - DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev -# - ./autogen.sh autoconf -# - ./configure --with-native-compilation -# - make bootstrap -# timeout: 8 hours +build-native-comp-speed2: + stage: native-comp-images + extends: [.job-template, .build-template, .native-comp-template] + variables: + target: emacs-native-comp-speed2 -test-all-inotify: - # This tests also file monitor libraries inotify and inotifywatch. - stage: slow - needs: [build-image-inotify] - extends: [.job-template, .test-template] - rules: - # Note there's no "changes" section, so this always runs on a schedule. - - if: '$CI_PIPELINE_SOURCE == "web"' - - if: '$CI_PIPELINE_SOURCE == "schedule"' +test-native-comp-speed0: + stage: native-comp + extends: [.job-template, .test-template, .native-comp-template] + needs: + - job: build-native-comp-speed0 + optional: true variables: - target: emacs-inotify - make_params: check-expensive + target: emacs-native-comp-speed0 + make_params: "-k -C test check SELECTOR='(not (tag :unstable))'" # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml new file mode 100644 index 00000000000..51707c181b1 --- /dev/null +++ b/test/infra/test-jobs.yml @@ -0,0 +1,545 @@ +# Generated by "make generate-test-jobs", don't edit. + +test-lib-src-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lib-src/*.{h,c} + - test/lib-src/*.el + - test/lib-src/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lib-src" + +test-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/*.el + - test/lisp/*.el + - test/lisp/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp" + +test-lisp-calc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/calc/*.el + - test/lisp/calc/*.el + - test/lisp/calc/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-calc" + +test-lisp-calendar-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/calendar/*.el + - test/lisp/calendar/*.el + - test/lisp/calendar/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-calendar" + +test-lisp-cedet-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/*.el + - test/lisp/cedet/*.el + - test/lisp/cedet/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-cedet" + +test-lisp-cedet-semantic-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/semantic/*.el + - test/lisp/cedet/semantic/*.el + - test/lisp/cedet/semantic/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-cedet-semantic" + +test-lisp-cedet-semantic-bovine-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/semantic/bovine/*.el + - test/lisp/cedet/semantic/bovine/*.el + - test/lisp/cedet/semantic/bovine/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-cedet-semantic-bovine" + +test-lisp-cedet-srecode-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/cedet/srecode/*.el + - test/lisp/cedet/srecode/*.el + - test/lisp/cedet/srecode/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-cedet-srecode" + +test-lisp-emacs-lisp-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*.el + - test/lisp/emacs-lisp/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-emacs-lisp" + +test-lisp-emacs-lisp-eieio-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/eieio*.el + - test/lisp/emacs-lisp/eieio-tests/*.el + - test/lisp/emacs-lisp/eieio-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-emacs-lisp-eieio-tests" + +test-lisp-emacs-lisp-faceup-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emacs-lisp/faceup*.el + - test/lisp/emacs-lisp/faceup-tests/*.el + - test/lisp/emacs-lisp/faceup-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-emacs-lisp-faceup-tests" + +test-lisp-emulation-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/emulation/*.el + - test/lisp/emulation/*.el + - test/lisp/emulation/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-emulation" + +test-lisp-erc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/erc/*.el + - test/lisp/erc/*.el + - test/lisp/erc/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-erc" + +test-lisp-eshell-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/eshell/*.el + - test/lisp/eshell/*.el + - test/lisp/eshell/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-eshell" + +test-lisp-gnus-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/gnus/*.el + - test/lisp/gnus/*.el + - test/lisp/gnus/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-gnus" + +test-lisp-image-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/image/*.el + - test/lisp/image/*.el + - test/lisp/image/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-image" + +test-lisp-international-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/international/*.el + - test/lisp/international/*.el + - test/lisp/international/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-international" + +test-lisp-mail-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/mail/*.el + - test/lisp/mail/*.el + - test/lisp/mail/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-mail" + +test-lisp-mh-e-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/mh-e/*.el + - test/lisp/mh-e/*.el + - test/lisp/mh-e/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-mh-e" + +test-lisp-net-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/net/*.el + - test/lisp/net/*.el + - test/lisp/net/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-net" + +test-lisp-nxml-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/nxml/*.el + - test/lisp/nxml/*.el + - test/lisp/nxml/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-nxml" + +test-lisp-obsolete-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/obsolete/*.el + - test/lisp/obsolete/*.el + - test/lisp/obsolete/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-obsolete" + +test-lisp-org-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/org/*.el + - test/lisp/org/*.el + - test/lisp/org/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-org" + +test-lisp-play-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/play/*.el + - test/lisp/play/*.el + - test/lisp/play/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-play" + +test-lisp-progmodes-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/progmodes/*.el + - test/lisp/progmodes/*.el + - test/lisp/progmodes/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-progmodes" + +test-lisp-so-long-tests-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/so-long*.el + - test/lisp/so-long-tests/*.el + - test/lisp/so-long-tests/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-so-long-tests" + +test-lisp-term-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/term/*.el + - test/lisp/term/*.el + - test/lisp/term/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-term" + +test-lisp-textmodes-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/textmodes/*.el + - test/lisp/textmodes/*.el + - test/lisp/textmodes/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-textmodes" + +test-lisp-url-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/url/*.el + - test/lisp/url/*.el + - test/lisp/url/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-url" + +test-lisp-vc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - lisp/vc/*.el + - test/lisp/vc/*.el + - test/lisp/vc/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-lisp-vc" + +test-misc-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - admin/*.el + - test/misc/*.el + - test/misc/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-misc" + +test-src-inotify: + stage: normal + extends: [.job-template, .test-template] + needs: + - job: build-image-inotify + optional: true + rules: + - if: '$CI_PIPELINE_SOURCE == "schedule"' + when: never + - changes: + - src/*.{h,c} + - test/src/*.el + - test/src/*resources/** + variables: + target: emacs-inotify + make_params: "-k -C test check-src" diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 95ffb4d2b04..394eae48ee3 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -28,6 +28,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'abbrev) (require 'seq) @@ -236,44 +237,41 @@ (ert-deftest read-write-abbrev-file-test () "Test reading and writing abbrevs from file." - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) - (delete-file temp-test-file))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))))) (ert-deftest read-write-abbrev-file-test-with-props () "Test reading and writing abbrevs from file." - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table-with-props))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))) - (delete-file temp-test-file))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table-with-props))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))))) (ert-deftest abbrev-edit-save-to-file-test () "Test saving abbrev definitions in buffer to file." (defvar ert-save-test-table nil) - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (with-temp-buffer - (goto-char (point-min)) - (insert "(ert-save-test-table)\n") - (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") - (should (equal "abbrev-ert-test" - (abbrev-expansion "a-e-t" ert-test-abbrevs))) - ;; clears abbrev tables - (abbrev-edit-save-to-file temp-test-file) - (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "save-abbrevs-test" - (abbrev-expansion "s-a-t" ert-save-test-table))) - (delete-file temp-test-file)))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (with-temp-buffer + (goto-char (point-min)) + (insert "(ert-save-test-table)\n") + (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") + (should (equal "abbrev-ert-test" + (abbrev-expansion "a-e-t" ert-test-abbrevs))) + ;; clears abbrev tables + (abbrev-edit-save-to-file temp-test-file) + (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "save-abbrevs-test" + (abbrev-expansion "s-a-t" ert-save-test-table))))))) (ert-deftest inverse-add-abbrev-skips-trailing-nonword () "Test that adding an inverse abbrev skips trailing nonword characters." diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index fe97c27f032..71b706c763f 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -24,10 +24,12 @@ ;;; Code: (require 'ansi-color) +(eval-when-compile (require 'cl-lib)) (defvar ansi-color-tests--strings (let ((bright-yellow (face-foreground 'ansi-color-bright-yellow nil 'default)) - (yellow (face-foreground 'ansi-color-yellow nil 'default))) + (yellow (face-foreground 'ansi-color-yellow nil 'default)) + (custom-color "#87FFFF")) `(("Hello World" "Hello World") ("\e[33mHello World\e[0m" "Hello World" (:foreground ,yellow)) @@ -51,7 +53,25 @@ (ansi-color-bold (:foreground ,bright-yellow))) ("\e[1m\e[3m\e[5mbold italics blink\e[0m" "bold italics blink" (ansi-color-bold ansi-color-italic ansi-color-slow-blink)) - ("\e[10munrecognized\e[0m" "unrecognized")))) + ("\e[10munrecognized\e[0m" "unrecognized") + ("\e[38;5;3;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[48;5;123;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color))) + ("\e[48;2;135;255;255;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color)))))) + +(defun ansi-color-tests-equal-props (o1 o2) + "Return t if two Lisp objects have similar structure and contents. +While `equal-including-properties' compares text properties of +strings with `eq', this function compares them with `equal'." + (or (equal-including-properties o1 o2) + (and (stringp o1) + (equal o1 o2) + (cl-loop for i below (length o1) + always (equal (text-properties-at i o1) + (text-properties-at i o2)))))) (ert-deftest ansi-color-apply-on-region-test () (pcase-dolist (`(,input ,text ,face) ansi-color-tests--strings) @@ -83,6 +103,76 @@ (ansi-color-apply-on-region (point-min) (point-max) t) (should (equal (buffer-string) (car pair)))))) +(ert-deftest ansi-color-incomplete-sequences-test () + (let* ((strs (list "\e[" "2;31m Hello World " + "\e" "[108;5;12" "3m" "Greetings" + "\e[0m\e[35;6m" "Hello")) + (complete-str (apply #'concat strs)) + (filtered-str) + (propertized-str) + (ansi-color-apply-face-function + #'ansi-color-apply-text-property-face) + (ansi-filt (lambda (str) (ansi-color-filter-apply + (copy-sequence str)))) + (ansi-app (lambda (str) (ansi-color-apply + (copy-sequence str))))) + + (with-temp-buffer + (setq filtered-str + (replace-regexp-in-string "\e\\[.*?m" "" complete-str)) + (setq propertized-str (funcall ansi-app complete-str)) + + (should-not (ansi-color-tests-equal-props + filtered-str propertized-str)) + (should (equal filtered-str propertized-str))) + + ;; Tests for `ansi-color-filter-apply' + (with-temp-buffer + (should (equal-including-properties + filtered-str + (funcall ansi-filt complete-str)))) + + (with-temp-buffer + (should (equal-including-properties + filtered-str + (mapconcat ansi-filt strs "")))) + + ;; Tests for `ansi-color-filter-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-filter-region (point-min) (point-max)) + (should (equal-including-properties + filtered-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-filter-region opoint (point)))) + (should (equal-including-properties + filtered-str (buffer-string)))) + + ;; Test for `ansi-color-apply' + (with-temp-buffer + (should (ansi-color-tests-equal-props + propertized-str + (mapconcat ansi-app strs "")))) + + ;; Tests for `ansi-color-apply-on-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-apply-on-region opoint (point)))) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))))) + (provide 'ansi-color-tests) ;;; ansi-color-tests.el ends here diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 900c99ccc61..7060d9570eb 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'cl-lib) (require 'auth-source) (require 'secrets) @@ -277,34 +278,33 @@ "((:host \"a1\" :port \"a2\" :user \"a3\" :secret \"a4\") (:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\") (:host \"c1\" :port \"c2\" :user \"c3\" :secret \"c4\"))" :host t :max 4) ("host b1, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1") ("host b1, port b2, user b3, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1" :port "b2" :user "b3") - )) - - (netrc-file (make-temp-file "auth-source-test" nil nil - (mapconcat 'identity entries "\n"))) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - found found-as-string) - - (dolist (test tests) - (cl-destructuring-bind (testname needed &rest parameters) test - (setq found (apply #'auth-source-search parameters)) - (when (listp found) - (dolist (f found) - (setf f (plist-put f :secret - (let ((secret (plist-get f :secret))) - (if (functionp secret) - (funcall secret) - secret)))))) - - (setq found-as-string (format "%s: %S" testname found)) - ;; (message "With parameters %S found: [%s] needed: [%s]" parameters found-as-string needed) - (should (equal found-as-string (concat testname ": " needed))))) - (delete-file netrc-file))) + ))) + (ert-with-temp-file netrc-file + :text (mapconcat 'identity entries "\n") + (let ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + found found-as-string) + + (dolist (test tests) + (cl-destructuring-bind (testname needed &rest parameters) test + (setq found (apply #'auth-source-search parameters)) + (when (listp found) + (dolist (f found) + (setf f (plist-put f :secret + (let ((secret (plist-get f :secret))) + (if (functionp secret) + (funcall secret) + secret)))))) + + (setq found-as-string (format "%s: %S" testname found)) + ;; (message "With parameters %S found: [%s] needed: [%s]" + ;; parameters found-as-string needed) + (should (equal found-as-string (concat testname ": " needed))))))))) (ert-deftest auth-source-test-secrets-create-secret () (skip-unless secrets-enabled) @@ -360,77 +360,73 @@ (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))) (ert-deftest auth-source-test-netrc-create-secret () - (let* ((netrc-file (make-temp-file "auth-source-test")) - (auth-sources (list netrc-file)) - (auth-source-save-behavior t) - host auth-info auth-passwd) - (unwind-protect - (dolist (passwd '("foo" "" nil)) - ;; Redefine `read-*' in order to avoid interactive input. - (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) - ((symbol-function 'read-string) - (lambda (_prompt &optional _initial _history default - _inherit-input-method) - default))) - (setq host - (md5 (concat (prin1-to-string process-environment) passwd)) - auth-info - (car (auth-source-search - :max 1 :host host :require '(:user :secret) :create t)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (should (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (equal auth-passwd passwd)) - (when (functionp (plist-get auth-info :save-function)) - (funcall (plist-get auth-info :save-function))) - - ;; Check, that the item has been created indeed. - (auth-source-forget+ :host t) - (setq auth-source-netrc-cache nil) - (setq auth-info (car (auth-source-search :host host)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (with-temp-buffer - (insert-file-contents netrc-file) - (if (zerop (length passwd)) - (progn - (should-not (plist-get auth-info :user)) - (should-not (plist-get auth-info :host)) - (should-not auth-passwd) - (should-not (search-forward host nil 'noerror))) - (should - (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (string-equal auth-passwd passwd)) - (should (search-forward host nil 'noerror)))))) - - ;; Cleanup. - (delete-file netrc-file)))) + (ert-with-temp-file netrc-file + :suffix "auth-source-test" + (let* ((auth-sources (list netrc-file)) + (auth-source-save-behavior t) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-source-netrc-cache nil) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (with-temp-buffer + (insert-file-contents netrc-file) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd) + (should-not (search-forward host nil 'noerror))) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd)) + (should (search-forward host nil 'noerror))))))))) (ert-deftest auth-source-delete () - (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ + (ert-with-temp-file netrc-file + :suffix "auth-source-test" :text "\ machine a1 port a2 user a3 password a4 machine b1 port b2 user b3 password b4 -machine c1 port c2 user c3 password c4\n")) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) - (parameters '(:max 1 :host t))) - (unwind-protect - (let ((found (apply #'auth-source-delete parameters))) - (dolist (f found) - (let ((s (plist-get f :secret))) - (setf f (plist-put f :secret - (if (functionp s) (funcall s) s))))) - ;; Note: The netrc backend doesn't delete anything, so - ;; this is actually the same as `auth-source-search'. - (should (equal found expected))) - (delete-file netrc-file)))) +machine c1 port c2 user c3 password c4\n" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) + (parameters '(:max 1 :host t)) + (found (apply #'auth-source-delete parameters))) + (dolist (f found) + (let ((s (plist-get f :secret))) + (setf f (plist-put f :secret + (if (functionp s) (funcall s) s))))) + ;; Note: The netrc backend doesn't delete anything, so + ;; this is actually the same as `auth-source-search'. + (should (equal found expected))))) (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 3f7ff0d000c..722215cb7e4 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -28,6 +28,7 @@ (require 'autoinsert) (require 'ert) +(require 'ert-x) (ert-deftest autoinsert-tests-auto-insert-skeleton () (let ((auto-insert-alist '((text-mode nil "f" _ "oo"))) @@ -39,16 +40,14 @@ (should (equal (point) (+ (point-min) 1)))))) (ert-deftest autoinsert-tests-auto-insert-file () - (let ((temp-file (make-temp-file "autoinsert-tests" nil nil "foo"))) - (unwind-protect - (let ((auto-insert-alist `((text-mode . ,temp-file))) - (auto-insert-query nil)) - (with-temp-buffer - (text-mode) - (auto-insert) - (should (equal (buffer-string) "foo")))) - (when (file-exists-p temp-file) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + :text "foo" + (let ((auto-insert-alist `((text-mode . ,temp-file))) + (auto-insert-query nil)) + (with-temp-buffer + (text-mode) + (auto-insert) + (should (equal (buffer-string) "foo")))))) (ert-deftest autoinsert-tests-auto-insert-function () (let ((auto-insert-alist '((text-mode . (lambda () (insert "foo"))))) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index b058f19a26c..d26e0f5a159 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -127,7 +127,7 @@ This expects `auto-revert--messages' to be bound by `ert-with-message-capture' before calling." ;; Remote files do not cooperate well with timers. So we count ourselves. (let ((ct (current-time))) - (while (and (< (float-time (time-subtract (current-time) ct)) + (while (and (< (float-time (time-subtract nil ct)) (auto-revert--timeout)) (null (string-match (format-message @@ -167,49 +167,48 @@ This expects `auto-revert--messages' to be bound by (defun auto-revert-tests--write-file (text file time-delta &optional append) (write-region text nil file append 'no-message) - (set-file-times file (time-subtract (current-time) time-delta))) + (set-file-times file (time-subtract nil time-delta))) (ert-deftest auto-revert-test00-auto-revert-mode () "Check autorevert for a file." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(60 30 15)) - buf) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (ert-with-message-capture auto-revert--messages - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf)) - (should (string-match "another text" (buffer-string))) - - ;; When the buffer is modified, it shall not be reverted. - (ert-with-message-capture auto-revert--messages - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - ;; Check, that the buffer hasn't been reverted. - (auto-revert--wait-for-revert buf)) - (should-not (string-match "any text" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let ((times '(60 30 15)) + buf) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (ert-with-message-capture auto-revert--messages + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf)) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (ert-with-message-capture auto-revert--messages + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf)) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test00-auto-revert-mode "Check autorevert for a remote file.") @@ -219,63 +218,61 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for several files at once." (skip-unless (executable-find "cp" (file-remote-p temporary-file-directory))) - (with-auto-revert-test - (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) - (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) - (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) - (tmpfile1 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (tmpfile2 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (times '(120 60 30 15)) - buf1 buf2) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) - (setq buf1 (find-file-noselect tmpfile1)) - (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) - (setq buf2 (find-file-noselect tmpfile2)) - - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode))) - - ;; Modify files. We wait for a second, in order to have - ;; another timestamp. - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) - (pop times)) - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) - (pop times)) - ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) - ;; Strange, that `copy-directory' does not work as expected. - ;; The following shell command is not portable on all - ;; platforms, unfortunately. - (shell-command - (format "%s -f %s/* %s" - cp (file-local-name tmpdir2) (file-local-name tmpdir1))) - - ;; Check, that the buffers have been reverted. - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (auto-revert--wait-for-revert buf) - (should (string-match "another text" (buffer-string)))))) - - ;; Exit. - (ignore-errors - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-directory tmpdir1 'recursive)) - (ignore-errors (delete-directory tmpdir2 'recursive)))))) + (ert-with-temp-directory tmpdir1 + (ert-with-temp-directory tmpdir2 + (ert-with-temp-file tmpfile1 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (ert-with-temp-file tmpfile2 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (with-auto-revert-test + (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) + (times '(120 60 30 15)) + buf1 buf2) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) + (setq buf1 (find-file-noselect tmpfile1)) + (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + (pop times)) + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + (pop times)) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command + (format "%s -f %s/* %s" + cp (file-local-name tmpdir2) (file-local-name tmpdir1))) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))))))) (auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files "Check autorevert for several remote files at once.") @@ -284,80 +281,79 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test02-auto-revert-deleted-file () "Check autorevert for a deleted file." ;; Repeated unpredictable failures, bug#32645. - ;; Unlikely to be hydra-specific? -; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) :tags '(:unstable) + ;; Unlikely to be hydra-specific? + ;; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - ;; Try to catch bug#32645. - (auto-revert-debug (getenv "EMACS_HYDRA_CI")) - (file-notify-debug (getenv "EMACS_HYDRA_CI")) - (times '(120 60 30 15)) - buf desc) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor)) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (setq desc auto-revert-notify-watch-descriptor) - - ;; Remove file while reverting. We simulate this by - ;; modifying `before-revert-hook'. - (add-hook - 'before-revert-hook - (lambda () - (when auto-revert-debug - (message "%s deleted" buffer-file-name)) - (delete-file buffer-file-name)) - nil t) - - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer hasn't been reverted. File - ;; notification should be disabled, falling back to - ;; polling. - (should (string-match "any text" (buffer-string))) - ;; With w32notify, and on emba, the `stopped' events are not sent. - (or (eq file-notify--library 'w32notify) - (getenv "EMACS_EMBA_CI") - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor))) - - ;; Once the file has been recreated, the buffer shall be - ;; reverted. - (kill-local-variable 'before-revert-hook) - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-match "another text" (buffer-string))) - ;; When file notification is used, it must be reenabled - ;; after recreation of the file. We cannot expect that - ;; the descriptor is the same, so we just check the - ;; existence. - (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) - - ;; An empty file shall still be reverted. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-equal "" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let (;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) + (times '(120 60 30 15)) + buf desc) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () + (when auto-revert-debug + (message "%s deleted" buffer-file-name)) + (delete-file buffer-file-name)) + nil t) + + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (should (string-match "any text" (buffer-string))) + ;; With w32notify, and on emba, the `stopped' events are not sent. + (or (eq file-notify--library 'w32notify) + (getenv "EMACS_EMBA_CI") + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) + + ;; An empty file shall still be reverted. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file "Check autorevert for a deleted remote file.") @@ -366,34 +362,33 @@ This expects `auto-revert--messages' to be bound by "Check autorevert tail mode." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(30 15)) - buf) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-tail-mode 1) - (should auto-revert-tail-mode) - (erase-buffer) - (insert "modified text\n") - (set-buffer-modified-p nil) - - ;; Modify file. - (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf) - (should - (string-match "modified text\nanother text" (buffer-string))))) - - ;; Exit. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (let ((times '(30 15)) + buf) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. + (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (ignore-errors (kill-buffer buf)))))) (auto-revert--deftest-remote auto-revert-test03-auto-revert-tail-mode "Check remote autorevert tail mode.") @@ -403,46 +398,45 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let* ((tmpfile (make-temp-file "auto-revert-test")) - (name (file-name-nondirectory tmpfile)) - (times '(30)) - buf) - (unwind-protect - (progn - (setq buf (dired-noselect temporary-file-directory)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (should - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Delete file. - (delete-file tmpfile) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should-not - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Make dired buffer modified. Check, that the buffer has - ;; been still reverted. - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should - (string-match name (substring-no-properties (buffer-string)))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let* ((name (file-name-nondirectory tmpfile)) + (times '(30)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Delete file. + (delete-file tmpfile) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired "Check remote autorevert for dired.") @@ -459,7 +453,7 @@ This expects `auto-revert--messages' to be bound by (defun auto-revert-test--wait-for (pred max-wait) "Wait until PRED is true, or MAX-WAIT seconds elapsed." (let ((ct (current-time))) - (while (and (< (float-time (time-subtract (current-time) ct)) max-wait) + (while (and (< (float-time (time-subtract nil ct)) max-wait) (not (funcall pred))) (read-event nil nil 0.1)))) @@ -485,99 +479,84 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (auto-revert-avoid-polling t) - (auto-revert-debug (getenv "EMACS_EMBA_CI")) - (file-notify-debug (getenv "EMACS_EMBA_CI")) - (was-in-global-auto-revert-mode global-auto-revert-mode) - (file-1 (make-temp-file "global-auto-revert-test-1")) - (file-2 (make-temp-file "global-auto-revert-test-2")) - (file-3 (make-temp-file "global-auto-revert-test-3")) - (file-2b (concat file-2 "-b")) - require-final-newline buf-1 buf-2 buf-3) - (unwind-protect - (progn - (setq buf-1 (find-file-noselect file-1)) - (auto-revert-test--instrument-kill-buffer-hook buf-1) - (setq buf-2 (find-file-noselect file-2)) - (auto-revert-test--instrument-kill-buffer-hook buf-2) - (auto-revert-test--write-file "1-a" file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "")) - - (global-auto-revert-mode 1) ; Turn it on. - - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2)) - - ;; buf-1 should have been reverted immediately when the mode - ;; was enabled. - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - - ;; Alter a file. - (auto-revert-test--write-file "2-a" file-2) - ;; Allow for some time to handle notification events. - (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - - ;; Visit a file, and modify it on disk. - (setq buf-3 (find-file-noselect file-3)) - (auto-revert-test--instrument-kill-buffer-hook buf-3) - ;; Newly opened buffers won't be use notification until the - ;; first poll cycle; wait for it. - (auto-revert-test--wait-for - (lambda () (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert-test--write-file "3-a" file-3) - (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) - (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) - - ;; Delete a visited file, and re-create it with new contents. - (when auto-revert-debug (message "Hallo0")) - (delete-file file-1) - (when auto-revert-debug (message "Hallo1")) - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - (when auto-revert-debug (message "Hallo2")) - (auto-revert-test--write-file "1-b" file-1) - (when auto-revert-debug (message "Hallo3")) - (auto-revert-test--wait-for-buffer-text - buf-1 "1-b" (auto-revert--timeout)) - ;; On emba, `buf-1' is a killed buffer. - (when auto-revert-debug - (message - "Hallo4 %s %s %s %s %s %s %s" - buf-1 (buffer-name buf-1) (buffer-live-p buf-1) - file-1 (get-file-buffer file-1) - (buffer-name (get-file-buffer file-1)) - (buffer-live-p (get-file-buffer file-1))) - (with-current-buffer buf-1 - (message "Hallo5\n%s" (buffer-local-variables)))) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (when auto-revert-debug (message "Hallo6")) - - ;; Write a buffer to a new file, then modify the new file on disk. - (with-current-buffer buf-2 - (write-file file-2b)) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - (auto-revert-test--write-file "2-b" file-2b) - (auto-revert-test--wait-for-buffer-text - buf-2 "2-b" (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2))) - - ;; Clean up. - (unless was-in-global-auto-revert-mode - (global-auto-revert-mode 0)) ; Turn it off. - (dolist (buf (list buf-1 buf-2 buf-3)) - (with-current-buffer buf (setq-local kill-buffer-hook nil)) - (ignore-errors (kill-buffer buf))) - (dolist (file (list file-1 file-2 file-2b file-3)) - (ignore-errors (delete-file file))))))) + (ert-with-temp-file file-1 + (ert-with-temp-file file-2 + (ert-with-temp-file file-3 + (let* ((auto-revert-use-notify t) + (auto-revert-avoid-polling t) + (was-in-global-auto-revert-mode global-auto-revert-mode) + (file-2b (concat file-2 "-b")) + require-final-newline buf-1 buf-2 buf-3) + (unwind-protect + (progn + (setq buf-1 (find-file-noselect file-1)) + (auto-revert-test--instrument-kill-buffer-hook buf-1) + (setq buf-2 (find-file-noselect file-2)) + (auto-revert-test--instrument-kill-buffer-hook buf-2) + (auto-revert-test--write-file "1-a" file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "")) + + (global-auto-revert-mode 1) ; Turn it on. + + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2)) + + ;; buf-1 should have been reverted immediately when the mode + ;; was enabled. + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + + ;; Alter a file. + (auto-revert-test--write-file "2-a" file-2) + ;; Allow for some time to handle notification events. + (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + + ;; Visit a file, and modify it on disk. + (setq buf-3 (find-file-noselect file-3)) + (auto-revert-test--instrument-kill-buffer-hook buf-3) + ;; Newly opened buffers won't be use notification until the + ;; first poll cycle; wait for it. + (auto-revert-test--wait-for + (lambda () (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert-test--write-file "3-a" file-3) + (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) + (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) + + ;; Delete a visited file, and re-create it with new contents. + (delete-file file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + (auto-revert-test--write-file "1-b" file-1) + ;; Since the file is deleted, it needs at least + ;; `autorevert-interval' to recognize the new file, + ;; while polling. So increase the timeout. + (auto-revert-test--wait-for-buffer-text + buf-1 "1-b" (* 2 (auto-revert--timeout))) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + + ;; Write a buffer to a new file, then modify the new file on disk. + (with-current-buffer buf-2 + (write-file file-2b)) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + (auto-revert-test--write-file "2-b" file-2b) + (auto-revert-test--wait-for-buffer-text + buf-2 "2-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2))) + + ;; Clean up. + (unless was-in-global-auto-revert-mode + (global-auto-revert-mode 0)) ; Turn it off. + (dolist (buf (list buf-1 buf-2 buf-3)) + (with-current-buffer buf (setq-local kill-buffer-hook nil)) + (ignore-errors (kill-buffer buf))) + (ignore-errors (delete-file file-2b))))))))) (auto-revert--deftest-remote auto-revert-test05-global-notify "Test `global-auto-revert-mode' without polling for remote buffers.") @@ -587,31 +566,30 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (file-1 (make-temp-file "auto-revert-test")) - (file-2 (concat file-1 "-2")) - require-final-newline buf) - (unwind-protect - (progn - (setq buf (find-file-noselect file-1)) - (with-current-buffer buf - (insert "A") - (save-buffer) + (ert-with-temp-file file-1 + (let* ((auto-revert-use-notify t) + (file-2 (concat file-1 "-2")) + require-final-newline buf) + (unwind-protect + (progn + (setq buf (find-file-noselect file-1)) + (with-current-buffer buf + (insert "A") + (save-buffer) - (auto-revert-mode 1) + (auto-revert-mode 1) - (insert "B") - (write-file file-2) + (insert "B") + (write-file file-2) - (auto-revert-test--write-file "C" file-2) - (auto-revert-test--wait-for-buffer-text - buf "C" (auto-revert--timeout)) - (should (equal (buffer-string) "C")))) + (auto-revert-test--write-file "C" file-2) + (auto-revert-test--wait-for-buffer-text + buf "C" (auto-revert--timeout)) + (should (equal (buffer-string) "C")))) - ;; Clean up. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file file-1)) - (ignore-errors (delete-file file-2)))))) + ;; Clean up. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-2))))))) (auto-revert--deftest-remote auto-revert-test06-write-file "Test `write-file' in `auto-revert-mode' for remote buffers.") @@ -620,82 +598,81 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test07-auto-revert-several-buffers () "Check autorevert for several buffers visiting the same file." ;; (with-auto-revert-test - (let ((auto-revert-use-notify t) - (tmpfile (make-temp-file "auto-revert-test")) - (times '(120 60 30 15)) - (num-buffers 10) - require-final-newline buffers) - - (unwind-protect - ;; Check indirect buffers. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (push (find-file-noselect tmpfile) buffers) - (with-current-buffer (car buffers) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode)) - - (dotimes (i num-buffers) - (push (make-indirect-buffer - (car buffers) - (format "%s-%d" (buffer-file-name (car buffers)) i) - 'clone) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert (car buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (setq buffers nil) - (ignore-errors (delete-file tmpfile))) - - ;; Check direct buffers. - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (dotimes (i num-buffers) - (push (generate-new-buffer - (format "%s-%d" (file-name-nondirectory tmpfile) i)) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (insert-file-contents tmpfile 'visit) - (should (string-equal (buffer-string) "any text")) - (auto-revert-mode 1) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffers have been reverted. - (dolist (buf buffers) - (auto-revert--wait-for-revert buf) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-file tmpfile)))));) + (ert-with-temp-file tmpfile + (let ((auto-revert-use-notify t) + (times '(120 60 30 15)) + (num-buffers 10) + require-final-newline buffers) + + (unwind-protect + ;; Check indirect buffers. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (push (find-file-noselect tmpfile) buffers) + (with-current-buffer (car buffers) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode)) + + (dotimes (i num-buffers) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert (car buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (setq buffers nil) + (ignore-errors (delete-file tmpfile))) + + ;; Check direct buffers. + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (dotimes (i num-buffers) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (insert-file-contents tmpfile 'visit) + (should (string-equal (buffer-string) "any text")) + (auto-revert-mode 1) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffers have been reverted. + (dolist (buf buffers) + (auto-revert--wait-for-revert buf) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)))))));) (auto-revert--deftest-remote auto-revert-test07-auto-revert-several-buffers "Check autorevert for several buffers visiting the same remote file.") diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 0dd8ba4492f..ae7331fcc2b 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -371,16 +371,14 @@ Same as `with-bookmark-test' but also sets a temporary `bookmark-default-file', evaluates BODY, and then runs the test that saves and then loads the bookmark file." `(with-bookmark-test - (let ((file (make-temp-file "bookmark-tests-"))) - (unwind-protect - (let ((bookmark-default-file file) - (old-alist bookmark-alist)) - ,@body - (bookmark-save nil file t) - (setq bookmark-alist nil) - (bookmark-load file nil t) - (should (equal bookmark-alist old-alist))) - (delete-file file))))) + (ert-with-temp-file file + (let ((bookmark-default-file file) + (old-alist bookmark-alist)) + ,@body + (bookmark-save nil file t) + (setq bookmark-alist nil) + (bookmark-load file nil t) + (should (equal bookmark-alist old-alist)))))) (defvar bookmark-tests-non-ascii-data (concat "Здра́вствуйте!" "中文,普通话,汉语" "åäöøñ" diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el index 9957b36b1e4..8e7981e6999 100644 --- a/test/lisp/buff-menu-tests.el +++ b/test/lisp/buff-menu-tests.el @@ -24,19 +24,20 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (ert-deftest buff-menu-24962 () "Test for https://debbugs.gnu.org/24962 ." - (let* ((file (make-temp-file "foo")) - (buf (find-file file))) - (unwind-protect - (progn - (rename-buffer " foo") - (list-buffers) - (with-current-buffer "*Buffer List*" - (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) - (and (buffer-live-p buf) (kill-buffer buf)) - (and (file-exists-p file) (delete-file file))))) + (ert-with-temp-file file + :suffix "foo" + (let ((buf (find-file file))) + (unwind-protect + (progn + (rename-buffer " foo") + (list-buffers) + (with-current-buffer "*Buffer List*" + (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) + (and (buffer-live-p buf) (kill-buffer buf)))))) (provide 'buff-menu-tests) diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el index 870ec29b70c..99d1ee3de46 100644 --- a/test/lisp/button-tests.el +++ b/test/lisp/button-tests.el @@ -21,11 +21,9 @@ (require 'ert) -(defvar button-tests--map - (let ((map (make-sparse-keymap))) - (define-key map "x" #'ignore) - map) - "Keymap for testing command substitution.") +(defvar-keymap button-tests--map + :doc "Keymap for testing command substitution." + "x" #'ignore) (ert-deftest button-at () "Test `button-at' behavior." diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 5f9e02f774d..892fd278df8 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -810,6 +810,12 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1)))) (should (equal (calcFunc-test7 3) (* 3 2)))) +(ert-deftest calc-nth-root () + ;; bug#51209 + (let* ((calc-display-working-message nil) + (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6))))) + (should (< (abs (- x (sqrt 2.0))) 1.0e-10)))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index fa741b087b8..c918b0f63fa 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -698,17 +698,18 @@ and ISO style input data must use english month names." "Actually perform export test. Argument INPUT input diary string. Argument EXPECTED-OUTPUT expected iCalendar result string." - (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (ert-with-temp-file temp-file + :suffix "icalendar-tests-ics" (unwind-protect - (progn - (with-temp-buffer - (insert input) - (icalendar-export-region (point-min) (point-max) temp-file)) - (save-excursion - (find-file temp-file) - (goto-char (point-min)) - (cond (expected-output - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 BEGIN:VEVENT @@ -717,23 +718,22 @@ UID:emacs[0-9]+ END:VEVENT END:VCALENDAR \\s-*$" - nil t)) - (should (string-match - (concat "^\\s-*" - (regexp-quote (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - "\\s-*$") - expected-output))) - (t - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 END:VCALENDAR \\s-*$" - nil t)))))) + nil t)))))) ;; cleanup!! - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-export-ordinary-no-time () "Perform export test." @@ -1031,7 +1031,8 @@ During import test the timezone is set to Central European Time." (defun icalendar-tests--do-test-import (expected-output) "Actually perform import test. Argument EXPECTED-OUTPUT file containing expected diary string." - (let ((temp-file (make-temp-file "icalendar-test-diary"))) + (ert-with-temp-file temp-file + :suffix "icalendar-test-diary" ;; Test the Catch-the-mysterious-coding-header logic below. ;; Ruby-mode adds an after-save-hook which inserts the header! ;; (save-excursion @@ -1061,8 +1062,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." (let ((result (buffer-substring-no-properties (point-min) (point-max)))) (should (string= expected-output result))) - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-import-non-recurring () "Perform standard import tests." @@ -1240,35 +1240,33 @@ Argument INPUT icalendar event string." (defun icalendar-tests--do-test-cycle () "Actually perform import/export cycle test." - (let ((temp-diary (make-temp-file "icalendar-test-diary")) - (temp-ics (make-temp-file "icalendar-test-ics")) - (org-input (buffer-substring-no-properties (point-min) (point-max)))) - - (unwind-protect - (progn - ;; step 1: import - (icalendar-import-buffer temp-diary t t) - - ;; step 2: export what was just imported - (save-excursion - (find-file temp-diary) - (icalendar-export-region (point-min) (point-max) temp-ics)) - - ;; compare the output of step 2 with the input of step 1 - (save-excursion - (find-file temp-ics) - (goto-char (point-min)) - ;;(when (re-search-forward "\nUID:.*\n" nil t) - ;;(replace-match "\n")) - (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= org-input cycled))))) - ;; clean up - (kill-buffer (find-buffer-visiting temp-diary)) - (with-current-buffer (find-buffer-visiting temp-ics) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (delete-file temp-diary) - (delete-file temp-ics)))) + (ert-with-temp-file temp-diary + (ert-with-temp-file temp-ics + (let ((org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)))))))) (ert-deftest icalendar-cycle () "Perform cycling tests. @@ -1635,28 +1633,32 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(defun icalendar-tests--decode-isodatetime (_ical-string) +(ert-deftest icalendar-tests--decode-isodatetime () "Test `icalendar--decode-isodatetime'." - (should (equal (icalendar-test--format "20040917T050910-0200") - "2004-09-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910") + (should (equal (icalendar-test--format "20040917T050910-02:00") "2004-09-17T03:09:10+0000")) + (let ((orig (icalendar-test--format "20040917T050910"))) + (unwind-protect + (progn + (set-time-zone-rule "UTC-02:00") + (should (equal (icalendar-test--format "20040917T050910") + "2004-09-17T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T0509") + "2004-09-17T03:09:00+0000")) + (should (equal (icalendar-test--format "20040917") + "2004-09-16T22:00:00+0000")) + (should (equal (icalendar-test--format "20040917T050910" 1) + "2004-09-18T03:09:10+0000")) + (should (equal (icalendar-test--format "20040917T050910" 30) + "2004-10-17T03:09:10+0000"))) + (set-time-zone-rule 'wall) ;; (set-time-zone-rule nil) is broken + (should (equal orig (icalendar-test--format "20040917T050910"))))) (should (equal (icalendar-test--format "20040917T050910Z") "2004-09-17T05:09:10+0000")) - (should (equal (icalendar-test--format "20040917T0509") - "2004-09-17T03:09:00+0000")) - (should (equal (icalendar-test--format "20040917") - "2004-09-16T22:00:00+0000")) - (should (equal (icalendar-test--format "20040917T050910" 1) - "2004-09-18T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" 30) - "2004-10-17T03:09:10+0000")) - (should (equal (icalendar-test--format "20040917T050910" -1) - "2004-09-16T03:09:10+0000")) - + (should (equal (icalendar-test--format "20040917T050910" -1 0) + "2004-09-16T05:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910" nil -3600) "2004-09-17T06:09:10+0000"))) - (provide 'icalendar-tests) ;;; icalendar-tests.el ends here diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 19088e8a368..5a37c914931 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -41,6 +41,13 @@ (encode-time-value 1 2 3 4 3)) '(1 2 3 4)))) +(ert-deftest test-date-to-time () + (should (equal (format-time-string "%F %T" (date-to-time "2021-12-04")) + "2021-12-04 00:00:00"))) + +(ert-deftest test-days-between () + (should (equal (days-between "2021-10-22" "2020-09-29") 388))) + (ert-deftest test-leap-year () (should-not (date-leap-year-p 1999)) (should-not (date-leap-year-p 1900)) @@ -48,13 +55,13 @@ (should (date-leap-year-p 2004))) (ert-deftest test-days-to-time () - (should (equal (days-to-time 0) '(0 0))) - (should (equal (days-to-time 1) '(1 20864))) - (should (equal (days-to-time 999) '(1317 2688))) - (should (equal (days-to-time 0.0) '(0 0 0 0))) - (should (equal (days-to-time 0.5) '(0 43200 0 0))) - (should (equal (days-to-time 1.0) '(1 20864 0 0))) - (should (equal (days-to-time 999.0) '(1317 2688 0 0)))) + (should (time-equal-p (days-to-time 0) '(0 0))) + (should (time-equal-p (days-to-time 1) '(1 20864))) + (should (time-equal-p (days-to-time 999) '(1317 2688))) + (should (time-equal-p (days-to-time 0.0) '(0 0 0 0))) + (should (time-equal-p (days-to-time 0.5) '(0 43200 0 0))) + (should (time-equal-p (days-to-time 1.0) '(1 20864 0 0))) + (should (time-equal-p (days-to-time 999.0) '(1317 2688 0 0)))) (ert-deftest test-seconds-to-string () (should (equal (seconds-to-string 0) "0s")) @@ -163,7 +170,8 @@ (ert-deftest test-time-since () (should (time-equal-p 0 (time-since nil))) - (should (= (cadr (time-since (time-subtract (current-time) 1))) 1))) + (should (time-equal-p 1 (time-convert (time-since (time-subtract nil 1)) + 'integer)))) (ert-deftest test-time-decoded-period () (should (equal (decoded-time-period '(nil nil 1 nil nil nil nil nil nil)) diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 8172a39865f..0102b62c10f 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -37,25 +37,24 @@ (defmacro with-todo-test (&rest body) "Set up an isolated `todo-mode' test environment." (declare (debug (body))) - `(let* ((todo-test-home (make-temp-file "todo-test-home-" t)) - ;; Since we change HOME, clear this to avoid a conflict - ;; e.g. if Emacs runs within the user's home directory. - (abbreviated-home-dir nil) - (process-environment (cons (format "HOME=%s" todo-test-home) - process-environment)) - (todo-directory (ert-resource-directory)) - (todo-default-todo-file (todo-short-file-name - (car (funcall todo-files-function))))) - (unwind-protect - (progn ,@body) - ;; Restore pre-test-run state of test files. - (dolist (f (directory-files todo-directory)) - (let ((buf (get-file-buffer f))) - (when buf - (with-current-buffer buf - (restore-buffer-modified-p nil) - (kill-buffer))))) - (delete-directory todo-test-home t)))) + `(ert-with-temp-directory todo-test-home + (let* (;; Since we change HOME, clear this to avoid a conflict + ;; e.g. if Emacs runs within the user's home directory. + (abbreviated-home-dir nil) + (process-environment (cons (format "HOME=%s" todo-test-home) + process-environment)) + (todo-directory (ert-resource-directory)) + (todo-default-todo-file (todo-short-file-name + (car (funcall todo-files-function))))) + (unwind-protect + (progn ,@body) + ;; Restore pre-test-run state of test files. + (dolist (f (directory-files todo-directory)) + (let ((buf (get-file-buffer f))) + (when buf + (with-current-buffer buf + (restore-buffer-modified-p nil) + (kill-buffer))))))))) (defun todo-test--show (num &optional archive) "Display category NUM of test todo file. diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index 2ebd991679a..2e61f91e58c 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -127,8 +127,9 @@ gcc version 2.95.2 19991024 (release)" ;; Some macOS machines run llvm when you type gcc. (!) ;; We can't even check if it's a symlink; it's a binary placed in ;; "/usr/bin/gcc". So check the output and just skip this test if - ;; it says "Apple LLVM". - (unless (string-match "Apple LLVM" (car semantic-gcc-test-strings)) + ;; it looks like that's the case. + (unless (string-match "Apple \\(LLVM\\|clang\\)\\|Xcode\\.app" + (car semantic-gcc-test-strings)) (semantic-gcc-test-output-parser)))) ;;; gcc-tests.el ends here diff --git a/test/lisp/cedet/srecode/fields-tests.el b/test/lisp/cedet/srecode/fields-tests.el index 5e41010f3cd..292ac4e3b5e 100644 --- a/test/lisp/cedet/srecode/fields-tests.el +++ b/test/lisp/cedet/srecode/fields-tests.el @@ -57,8 +57,7 @@ It is filled with some text." (end-of-line) (forward-word -1) - (setq f (srecode-field "Test" - :name "TEST" + (setq f (srecode-field :name "TEST" :start 6 :end 8)) @@ -99,19 +98,17 @@ It is filled with some text." (reg nil) (fields (list - (srecode-field "Test1" :name "TEST-1" :start 5 :end 10) - (srecode-field "Test2" :name "TEST-2" :start 15 :end 20) - (srecode-field "Test3" :name "TEST-3" :start 25 :end 30) + (srecode-field :name "TEST-1" :start 5 :end 10) + (srecode-field :name "TEST-2" :start 15 :end 20) + (srecode-field :name "TEST-3" :start 25 :end 30) - (srecode-field "Test4" :name "TEST-4" :start 35 :end 35)) - )) + (srecode-field :name "TEST-4" :start 35 :end 35)))) (when (not (= (length srecode-field-archive) 4)) (error "Region Test: Found %d fields. Expected 4" (length srecode-field-archive))) - (setq reg (srecode-template-inserted-region "REG" - :start 4 + (setq reg (srecode-template-inserted-region :start 4 :end 40)) (srecode-overlaid-activate reg) @@ -183,10 +180,10 @@ It is filled with some text." ;; Test variable linkage. (let* ((srecode-field-archive nil) - (f1 (srecode-field "Test1" :name "TEST" :start 6 :end 8)) - (f2 (srecode-field "Test2" :name "TEST" :start 28 :end 30)) - (f3 (srecode-field "Test3" :name "NOTTEST" :start 35 :end 40)) - (reg (srecode-template-inserted-region "REG" :start 4 :end 40))) + (f1 (srecode-field :name "TEST" :start 6 :end 8)) + (f2 (srecode-field :name "TEST" :start 28 :end 30)) + (f3 (srecode-field :name "NOTTEST" :start 35 :end 40)) + (reg (srecode-template-inserted-region :start 4 :end 40))) (srecode-overlaid-activate reg) (when (not (string= (srecode-overlaid-text f1) diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index b284aa871ef..2885aaa9146 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -43,6 +43,7 @@ "PIN for user:" ; Bug#35523 "Password (again):" "Enter password:" + "(user@host) Password: " ; openssh-8.6p1 "Current password:" ; "passwd" (to change password) in Debian. "Enter encryption key: " ; ccrypt "Enter decryption key: " ; ccrypt diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index 2a0b0fc012c..77bb337d6aa 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -25,20 +25,9 @@ (require 'wid-edit) (require 'cus-edit) -(defmacro custom-tests--with-temp-dir (&rest body) - "Eval BODY with `temporary-file-directory' bound to a fresh directory. -Ensure the directory is recursively deleted after the fact." - (declare (debug t) (indent 0)) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t)))) - (unwind-protect - (let ((temporary-file-directory ,dir)) - ,@body) - (delete-directory ,dir t))))) - (ert-deftest custom-theme--load-path () "Test `custom-theme--load-path' behavior." - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory ;; Path is empty. (let ((custom-theme-load-path ())) (should (null (custom-theme--load-path)))) @@ -50,28 +39,28 @@ Ensure the directory is recursively deleted after the fact." (should (null (custom-theme--load-path)))) ;; Path comprises existing file. - (let* ((file (make-temp-file "file")) - (custom-theme-load-path (list file))) - (should (file-exists-p file)) - (should (not (file-directory-p file))) - (should (null (custom-theme--load-path)))) + (ert-with-temp-file file + (let* ((custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path))))) ;; Path comprises existing directory. - (let* ((dir (make-temp-file "dir" t)) - (custom-theme-load-path (list dir))) - (should (file-directory-p dir)) - (should (equal (custom-theme--load-path) custom-theme-load-path))) + (ert-with-temp-directory dir + (let* ((custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path)))) ;; Expand `custom-theme-directory' path element. (let ((custom-theme-load-path '(custom-theme-directory))) (let ((custom-theme-directory (make-temp-name temporary-file-directory))) (should (not (file-exists-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "file"))) + (ert-with-temp-file custom-theme-directory (should (file-exists-p custom-theme-directory)) (should (not (file-directory-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "dir" t))) + (ert-with-temp-directory custom-theme-directory (should (file-directory-p custom-theme-directory)) (should (equal (custom-theme--load-path) (list custom-theme-directory))))) @@ -97,7 +86,7 @@ Ensure the directory is recursively deleted after the fact." (ert-deftest custom-tests-require-theme () "Test `require-theme'." (require 'warnings) - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory (let* ((default-directory temporary-file-directory) (custom-theme-load-path (list default-directory)) (load-path ())) diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 3ffcd529cae..694deaae4c2 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -19,26 +19,25 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-aux) (eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." (skip-unless (executable-find shell-file-name)) - (let* ((foo (make-temp-file "foo")) - (files (list foo))) - (unwind-protect - (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) - (dired temporary-file-directory) - (dired-goto-file foo) - ;; `dired-do-shell-command' returns nil on success. - (should-error (dired-do-shell-command "ls ? ./?" nil files)) - (should-error (dired-do-shell-command "ls ./? ?" nil files)) - (should-not (dired-do-shell-command "ls ? ?" nil files)) - (should-error (dired-do-shell-command "ls * ./*" nil files)) - (should-not (dired-do-shell-command "ls * *" nil files)) - (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) - (delete-file foo)))) + (ert-with-temp-file foo + (let* ((files (list foo))) + (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) + (dired temporary-file-directory) + (dired-goto-file foo) + ;; `dired-do-shell-command' returns nil on success. + (should-error (dired-do-shell-command "ls ? ./?" nil files)) + (should-error (dired-do-shell-command "ls ./? ?" nil files)) + (should-not (dired-do-shell-command "ls ? ?" nil files)) + (should-error (dired-do-shell-command "ls * ./*" nil files)) + (should-not (dired-do-shell-command "ls * *" nil files)) + (should-not (dired-do-shell-command "ls ? ./`?`" nil files)))))) ;; Auxiliary macro for `dired-test-bug28834': it binds ;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. @@ -47,28 +46,25 @@ (defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) (declare (debug (form symbolp body))) (let ((foo (make-symbol "foo"))) - `(let* ((,foo (make-temp-file "foo" 'dir)) - (dired-create-destination-dirs ,create-dirs)) - (setq from (make-temp-file "from")) - (setq to-cp - (expand-file-name - "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) - (setq to-mv - (expand-file-name - "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) - (unwind-protect - (if ,yes-or-no - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (_prompt) (eq ,yes-or-no 'yes)))) - ,@body) - ,@body) - ;; clean up - (delete-directory ,foo 'recursive) - (delete-file from))))) + `(ert-with-temp-directory ,foo + (ert-with-temp-file from + (let* ((dired-create-destination-dirs ,create-dirs)) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body))))))) (ert-deftest dired-test-bug28834 () "test for https://debbugs.gnu.org/28834 ." - (let (from to-cp to-mv) + (let (to-cp to-mv) ;; `dired-create-destination-dirs' set to 'always. (with-dired-bug28834-test 'always nil diff --git a/test/lisp/dired-resources/insert-directory/test_dir/bar b/test/lisp/dired-resources/insert-directory/test_dir/bar new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir/bar diff --git a/test/lisp/dired-resources/insert-directory/test_dir/foo b/test/lisp/dired-resources/insert-directory/test_dir/foo new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir/foo diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/bar b/test/lisp/dired-resources/insert-directory/test_dir_other/bar new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir_other/bar diff --git a/test/lisp/dired-resources/insert-directory/test_dir_other/foo b/test/lisp/dired-resources/insert-directory/test_dir_other/foo new file mode 100644 index 00000000000..e69de29bb2d --- /dev/null +++ b/test/lisp/dired-resources/insert-directory/test_dir_other/foo diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 62aa5af573d..0e893259077 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (ert-deftest dired-autoload () @@ -141,116 +142,113 @@ (ert-deftest dired-test-bug27243-01 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ." - (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t))) - (save-pos (lambda () - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (dired-save-positions)))) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; dired-buffers-for-dir. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (should-not (dired-buffers-for-dir test-dir)) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (message "Saved pos: %S" (funcall save-pos)) - ;; Point must be at end-of-buffer. - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (should (eobp))) - (push (dired test-dir) buffers) - (message "Saved pos: %S" (funcall save-pos)) - ;; Previous dired call shouldn't create a new buffer: must visit the one - ;; created by `find-file-noselect' above. - (should (eq 1 (length (dired-buffers-for-dir test-dir)))) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (message "Saved pos: %S" (funcall save-pos)) - (write-region "Test" nil test-file nil 'silent nil 'excl) - (message "Saved pos: %S" (funcall save-pos)) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat test-dir (file-name-as-directory "test-subdir")))) - (message "Saved pos: %S" (funcall save-pos)) - (push (dired-find-file) buffers) - (let ((pt2 (point))) ; Point is on test-file. - (pop-to-buffer-same-window buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) + (ert-with-temp-directory test-dir + (let* ((save-pos (lambda () + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (dired-save-positions)))) + (dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; dired-buffers-for-dir. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (should-not (dired-buffers-for-dir test-dir)) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (message "Saved pos: %S" (funcall save-pos)) + ;; Point must be at end-of-buffer. + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (should (eobp))) + (push (dired test-dir) buffers) + (message "Saved pos: %S" (funcall save-pos)) + ;; Previous dired call shouldn't create a new buffer: must visit the one + ;; created by `find-file-noselect' above. + (should (eq 1 (length (dired-buffers-for-dir test-dir)))) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (message "Saved pos: %S" (funcall save-pos)) + (write-region "Test" nil test-file nil 'silent nil 'excl) + (message "Saved pos: %S" (funcall save-pos)) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat test-dir (file-name-as-directory "test-subdir")))) + (message "Saved pos: %S" (funcall save-pos)) (push (dired-find-file) buffers) - (should (eq (point) pt2)))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (let ((pt2 (point))) ; Point is on test-file. + (pop-to-buffer-same-window buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired-find-file) buffers) + (should (eq (point) pt2)))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-02 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; string comparisons below. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (push (dired test-dir) buffers) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (write-region "Test" nil test-file nil 'silent nil 'excl) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat (file-name-as-directory test-dir) - (file-name-as-directory "test-subdir")))) - (push (dired-find-file) buffers) - ;; Point is on test-file. - (switch-to-buffer buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) - (push (dired test-dir) buffers) - (should (eq (point) pt1))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; string comparisons below. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (push (dired test-dir) buffers) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (write-region "Test" nil test-file nil 'silent nil 'excl) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat (file-name-as-directory test-dir) + (file-name-as-directory "test-subdir")))) + (push (dired-find-file) buffers) + ;; Point is on test-file. + (switch-to-buffer buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired test-dir) buffers) + (should (eq (point) pt1))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-03 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) - allbufs) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect test-dir) - (push (current-buffer) allbufs) - (make-directory "test-subdir1") - (make-directory "test-subdir2") - (let ((test-file1 "test-file1") - (test-file2 "test-file2")) - (with-current-buffer (find-file-noselect "test-subdir1") - (push (current-buffer) allbufs) - (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) - (with-current-buffer (find-file-noselect "test-subdir2") - (push (current-buffer) allbufs) - (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) - ;; Call find-file with a wild card and test point in each file. - (let ((buffers (find-file (concat (file-name-as-directory test-dir) - "*") - t))) - (dolist (buf buffers) - (let ((pt (with-current-buffer buf (point)))) - (switch-to-buffer (find-file-noselect test-dir)) - (find-file (buffer-name buf)) - (should (equal (point) pt)))) - (append buffers allbufs))) - (dolist (buf allbufs) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) + allbufs) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect test-dir) + (push (current-buffer) allbufs) + (make-directory "test-subdir1") + (make-directory "test-subdir2") + (let ((test-file1 "test-file1") + (test-file2 "test-file2")) + (with-current-buffer (find-file-noselect "test-subdir1") + (push (current-buffer) allbufs) + (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) + (with-current-buffer (find-file-noselect "test-subdir2") + (push (current-buffer) allbufs) + (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) + ;; Call find-file with a wild card and test point in each file. + (let ((buffers (find-file (concat (file-name-as-directory test-dir) + "*") + t))) + (dolist (buf buffers) + (let ((pt (with-current-buffer buf (point)))) + (switch-to-buffer (find-file-noselect test-dir)) + (find-file (buffer-name buf)) + (should (equal (point) pt)))) + (append buffers allbufs))) + (dolist (buf allbufs) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug7131 () "Test for https://debbugs.gnu.org/7131 ." @@ -274,22 +272,21 @@ ;; ls-lisp-tests.el and em-ls-tests.el. (skip-unless (and (not (featurep 'ls-lisp)) (not (featurep 'eshell)))) - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." @@ -310,72 +307,69 @@ (ert-deftest dired-test-bug27968 () "Test for https://debbugs.gnu.org/27968 ." - (let* ((top-dir (make-temp-file "top-dir" t)) - (subdir (expand-file-name "subdir" top-dir)) - (header-len-fn (lambda () - (save-excursion - (goto-char 1) - (forward-line 1) - (- (point-at-eol) (point))))) - orig-len len diff pos line-nb) - (make-directory subdir 'parents) - (unwind-protect - (with-current-buffer (dired-noselect subdir) - (setq orig-len (funcall header-len-fn) - pos (point) - line-nb (line-number-at-pos)) - ;; Bug arises when the header line changes its length; this may - ;; happen if the used space has changed: for instance, with the - ;; creation of additional files. - (make-directory "subdir" t) - (dired-revert) - ;; Change the header line. - (save-excursion - (goto-char 1) - (forward-line 1) - (let ((inhibit-read-only t) - (new-header " test-bug27968")) - (delete-region (point) (point-at-eol)) - (when (= orig-len (length new-header)) - ;; Wow lucky guy! I must buy lottery today. - (setq new-header (concat new-header " :-)"))) - (insert new-header))) - (setq len (funcall header-len-fn) - diff (- len orig-len)) - (should-not (zerop diff)) ; Header length has changed. - ;; If diff > 0, then the point moves back. - ;; If diff < 0, then the point moves forward. - ;; If diff = 0, then the point doesn't move. - ;; Sometimes this point movement causes - ;; line-nb != (line-number-at-pos pos), so that we get - ;; an unexpected file at point if we store buffer points. - ;; Note that the line number before/after revert - ;; doesn't change. - (should (= line-nb - (line-number-at-pos) - (line-number-at-pos (+ pos diff)))) - ;; After revert, the point must be in 'subdir' line. - (should (equal "subdir" (dired-get-filename 'local t)))) - (delete-directory top-dir t)))) + (ert-with-temp-directory top-dir + (let* ((subdir (expand-file-name "subdir" top-dir)) + (header-len-fn (lambda () + (save-excursion + (goto-char 1) + (forward-line 1) + (- (point-at-eol) (point))))) + orig-len len diff pos line-nb) + (make-directory subdir 'parents) + (with-current-buffer (dired-noselect subdir) + (setq orig-len (funcall header-len-fn) + pos (point) + line-nb (line-number-at-pos)) + ;; Bug arises when the header line changes its length; this may + ;; happen if the used space has changed: for instance, with the + ;; creation of additional files. + (make-directory "subdir" t) + (dired-revert) + ;; Change the header line. + (save-excursion + (goto-char 1) + (forward-line 1) + (let ((inhibit-read-only t) + (new-header " test-bug27968")) + (delete-region (point) (point-at-eol)) + (when (= orig-len (length new-header)) + ;; Wow lucky guy! I must buy lottery today. + (setq new-header (concat new-header " :-)"))) + (insert new-header))) + (setq len (funcall header-len-fn) + diff (- len orig-len)) + (should-not (zerop diff)) ; Header length has changed. + ;; If diff > 0, then the point moves back. + ;; If diff < 0, then the point moves forward. + ;; If diff = 0, then the point doesn't move. + ;; Sometimes this point movement causes + ;; line-nb != (line-number-at-pos pos), so that we get + ;; an unexpected file at point if we store buffer points. + ;; Note that the line number before/after revert + ;; doesn't change. + (should (= line-nb + (line-number-at-pos) + (line-number-at-pos (+ pos diff)))) + ;; After revert, the point must be in 'subdir' line. + (should (equal "subdir" (dired-get-filename 'local t))))))) (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body) "Helper macro for Bug#27940 test." (declare (indent 1) (debug body)) (let ((dir (make-symbol "dir"))) - `(let* ((,dir (make-temp-file "bug27940" t)) - (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. - (inhibit-message t) - (default-directory ,dir)) - (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) - (unless ,just-empty-dirs - (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) - (make-directory "zeta-empty-dir") - (unwind-protect - (progn - ,@body) - (delete-directory ,dir t) - (kill-buffer (current-buffer)))))) + `(ert-with-temp-directory ,dir + (let* ((dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. + (inhibit-message t) + (default-directory ,dir)) + (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) + (unless ,just-empty-dirs + (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) + (make-directory "zeta-empty-dir") + (unwind-protect + (progn + ,@body) + (kill-buffer (current-buffer))))))) (ert-deftest dired-test-bug27940 () "Test for https://debbugs.gnu.org/27940 ." @@ -517,5 +511,92 @@ (when (file-directory-p testdir) (delete-directory testdir t))))) +;; `dired-insert-directory' output tests. +(let* ((data-dir "insert-directory") + (test-dir (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir")))) + (test-dir-other (file-name-as-directory + (ert-resource-file + (concat data-dir "/test_dir_other")))) + (test-files `(,test-dir "foo" "bar")) ;expected files to be found + ;; Free space test data for `insert-directory'. + ;; Meaning: (path free-space-bytes-to-stub expected-free-space-string) + (free-data `((,test-dir 10 "available 10 B") + (,test-dir-other 100 "available 100 B") + (:default 999 "available 999 B")))) + + (defun files-tests--look-up-free-data (path) + "Look up free space test data, with a default for unspecified paths." + (let ((path (file-name-as-directory path))) + (cdr (or (assoc path free-data) + (assoc :default free-data))))) + + (defun files-tests--make-file-system-info-stub (&optional static-path) + "Return a stub for `file-system-info' using dynamic or static test data. +If that data should be static, pass STATIC-PATH to choose which +path's data to use." + (lambda (path) + (let* ((path (cond (static-path) + ;; file-system-info knows how to handle ".", so we + ;; do the same thing + ((equal "." path) default-directory) + (path))) + (return-size + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--look-up-free-data) + (car (files-tests--look-up-free-data path))))) + (list return-size return-size return-size)))) + + (defun files-tests--insert-directory-output (dir &optional _verbose) + "Run `insert-directory' and return its output." + (with-current-buffer-window "files-tests--insert-directory" nil nil + (let ((dired-free-space 'separate)) + (dired-insert-directory dir "-l" nil nil t)) + (buffer-substring-no-properties (point-min) (point-max)))) + + (ert-deftest files-tests-insert-directory-shows-files () + "Verify `insert-directory' reports the files in the directory." + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--insert-directory-output) + (let* ((test-dir (car test-files)) + (files (cdr test-files)) + (output (files-tests--insert-directory-output test-dir))) + (dolist (file files) + (should (string-match-p file output)))))) + + (defun files-tests--insert-directory-shows-given-free (dir &optional + info-func) + "Run `insert-directory' and verify it reports the correct available space. +Stub `file-system-info' to ensure the available space is consistent, +either with the given stub function or a default one using test data." + ;; It is always defined but this silences the byte-compiler: + (when (and (fboundp 'files-tests--make-file-system-info-stub) + (fboundp 'files-tests--look-up-free-data) + (fboundp 'files-tests--insert-directory-output)) + (cl-letf (((symbol-function 'file-system-info) + (or info-func + (files-tests--make-file-system-info-stub)))) + (should (string-match-p (cadr + (files-tests--look-up-free-data dir)) + (files-tests--insert-directory-output dir t)))))) + + (ert-deftest files-tests-insert-directory-shows-free () + "Test that verbose `insert-directory' shows the correct available space." + ;; It is always defined but this silences the byte-compiler: + (when (and (fboundp 'files-tests--insert-directory-shows-given-free) + (fboundp 'files-tests--make-file-system-info-stub)) + (files-tests--insert-directory-shows-given-free + test-dir + (files-tests--make-file-system-info-stub test-dir)))) + + (ert-deftest files-tests-bug-50630 () + "Verify verbose `insert-directory' shows free space of the target directory. +The current directory at call time should not affect the result (Bug#50630)." + ;; It is always defined but this silences the byte-compiler: + (when (fboundp 'files-tests--insert-directory-shows-given-free) + (let ((default-directory test-dir-other)) + (files-tests--insert-directory-shows-given-free test-dir))))) + (provide 'dired-tests) ;;; dired-tests.el ends here diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el index e6228f065d0..cec266b0ef9 100644 --- a/test/lisp/dired-x-tests.el +++ b/test/lisp/dired-x-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-x) @@ -31,23 +32,20 @@ (append (copy-sequence dirs) (delete "c" (copy-sequence files))) #'string<)) - (dir (make-temp-file "Bug25942" 'dir)) (extension "c")) - (unwind-protect - (progn - (dolist (d dirs) - (make-directory (expand-file-name d dir))) - (dolist (f files) - (write-region nil nil (expand-file-name f dir))) - (dired dir) - (dired-mark-extension extension) - (should (equal '("bar.c" "foo.c") - (sort (dired-get-marked-files 'local) #'string<))) - (dired-unmark-all-marks) - (dired-mark-suffix extension) - (should (equal all-but-c - (sort (dired-get-marked-files 'local) #'string<)))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (dolist (d dirs) + (make-directory (expand-file-name d dir))) + (dolist (f files) + (write-region nil nil (expand-file-name f dir))) + (dired dir) + (dired-mark-extension extension) + (should (equal '("bar.c" "foo.c") + (sort (dired-get-marked-files 'local) #'string<))) + (dired-unmark-all-marks) + (dired-mark-suffix extension) + (should (equal all-but-c + (sort (dired-get-marked-files 'local) #'string<)))))) (ert-deftest dired-guess-default () (let ((dired-guess-shell-alist-user nil) @@ -62,5 +60,15 @@ (should (equal (dired-guess-default '("/tmp/foo.png" "/tmp/foo.txt")) nil)))) +(ert-deftest dired-x--string-to-number () + (should (= (dired-x--string-to-number "2.4K") 2457.6)) + (should (= (dired-x--string-to-number "2400") 2400)) + (should (= (dired-x--string-to-number "123.4M") 129394278.4)) + (should (= (dired-x--string-to-number "123.40000M") 129394278.4)) + (should (= (dired-x--string-to-number "4.134") 4134)) + (should (= (dired-x--string-to-number "4,134") 4134)) + (should (= (dired-x--string-to-number "4 134") 4134)) + (should (= (dired-x--string-to-number "41,52,134") 4152134))) + (provide 'dired-x-tests) ;;; dired-x-tests.el ends here diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el new file mode 100644 index 00000000000..974f506a367 --- /dev/null +++ b/test/lisp/edmacro-tests.el @@ -0,0 +1,47 @@ +;;; edmacro-tests.el --- Tests for edmacro.el -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'edmacro) + +(ert-deftest edmacro-test-edmacro-parse-keys () + (should (equal (edmacro-parse-keys "") "")) + (should (equal (edmacro-parse-keys "x") "x")) + (should (equal (edmacro-parse-keys "C-a") "\C-a")) + + ;; comments + (should (equal (edmacro-parse-keys ";; foobar") "")) + (should (equal (edmacro-parse-keys ";;;") "")) + (should (equal (edmacro-parse-keys "; ; ;") ";;;")) + (should (equal (edmacro-parse-keys "REM foobar") "")) + (should (equal (edmacro-parse-keys "x ;; foobar") "x")) + (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys "<<goto-line>>") + [134217848 103 111 116 111 45 108 105 110 101 13])) + + ;; repetitions + (should (equal (edmacro-parse-keys "3*x") "xxx")) + (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) + (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + +;;; edmacro-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 1263767476e..e10ed04f9d3 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -97,8 +97,8 @@ (with-temp-buffer (cl-progv ;; FIXME: avoid `eval' - (mapcar #'car (eval bindings)) - (mapcar #'cdr (eval bindings)) + (mapcar #'car (eval bindings t)) + (mapcar #'cdr (eval bindings t)) (dlet ((python-indent-guess-indent-offset-verbose nil)) (funcall mode) (insert fixture) @@ -176,7 +176,7 @@ The buffer's contents should %s: expected-string expected-point bindings - (modes '(quote (ruby-mode js-mode python-mode))) + (modes '(quote (ruby-mode js-mode python-mode c-mode))) (test-in-comments t) (test-in-strings t) (test-in-code t) @@ -187,7 +187,7 @@ The buffer's contents should %s: (fixture-fn '#'electric-pair-mode)) `(progn ,@(cl-loop - for mode in (eval modes) ;FIXME: avoid `eval' + for mode in (eval modes t) ;FIXME: avoid `eval' append (cl-loop for (prefix suffix extra-desc) in @@ -428,7 +428,9 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-strings nil :test-in-code nil - :test-in-comments t) + :test-in-comments t + :fixture-fn (lambda () (when (eq major-mode 'c-mode) + (c-toggle-comment-style -1)))) (define-electric-pair-test whitespace-skipping-for-quotes-not-outside " \" \"" "\"-----" :expected-string "\"\" \" \"" @@ -548,16 +550,6 @@ 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 diff --git a/test/lisp/emacs-lisp/backtrace-tests.el b/test/lisp/emacs-lisp/backtrace-tests.el index 6f099fff173..b08695a22bb 100644 --- a/test/lisp/emacs-lisp/backtrace-tests.el +++ b/test/lisp/emacs-lisp/backtrace-tests.el @@ -49,7 +49,7 @@ (setq backtrace-frames (seq-subseq backtrace-frames 0 (1+ this-index)))) (backtrace-print)))) - (eval backtrace-tests--uncompiled-functions)) + (eval backtrace-tests--uncompiled-functions t)) (defun backtrace-tests--backtrace-lines () (if debugger-stack-frame-as-list diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el new file mode 100644 index 00000000000..37cfe463bfe --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-substitutions.el @@ -0,0 +1,17 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "None of this should be considered too wide. + +; this should be treated as 60 characters - no warning +\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window]\\[quit-window] + +; 64 * 'x' does not warn +\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x'\\`x' + +; keymaps are just ignored +\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map>\\<foo-bar-map> + +\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map}\\{foo-bar-map} + +bar baz foo bar baz foo bar baz foo bar baz foo bar baz foo bar +") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 8a09c545914..abd33ab8e5a 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -640,6 +640,58 @@ inner loops respectively." (f (list (lambda (x) (setq a x))))) (funcall (car f) 3) (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) + + ;; These expressions give different results in lexbind and dynbind modes, + ;; but in each the compiler and interpreter should agree! + ;; (They look much the same but come in pairs exercising both the + ;; `let' and `let*' paths.) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (lambda () + (let ((g (lambda () x))) + (setq x (list x x)) + (let* ((x 'a)) + (list x (funcall g)))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + (let ((f (lambda (x) + (let ((g (lambda () x)) + (h (lambda () (setq x (list x x))))) + (let* ((x 'a)) + (list x (funcall g) (funcall h))))))) + (funcall (funcall f 'b))) + + ;; Test constant-propagation of access to captured variables. + (let* ((x 2) + (f (lambda () + (let ((y x)) (list y 3 y))))) + (funcall f)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -690,24 +742,19 @@ byte-compiled. Run with dynamic binding." (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile))) - (load elfile nil 'nomessage)) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) + (ert-with-temp-file elfile + :suffix ".el" + (ert-with-temp-file elcfile + :suffix ".elc" + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -810,8 +857,7 @@ byte-compiled. Run with dynamic binding." (byte-compile-file ,(ert-resource-file file)) (ert-info ((buffer-string) :prefix "buffer: ") (,(if reverse 'should-not 'should) - (re-search-forward ,(string-replace " " "[ \n]+" re-warning) - nil t)))))) + (re-search-forward ,re-warning nil t)))))) (bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" "add-hook.*lexical var") @@ -939,7 +985,7 @@ byte-compiled. Run with dynamic binding." (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than .* characters") + "Warning: docstring wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" @@ -958,6 +1004,10 @@ byte-compiled. Run with dynamic binding." "defvar .foo-bar. docstring wider than .* characters" 'reverse) (bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-substitutions.el" + "defvar .foo-bar. docstring wider than .* characters" 'reverse) + +(bytecomp--define-warning-file-test "warn-wide-docstring-ignore.el" "defvar .foo-bar. docstring wider than .* characters" 'reverse) @@ -1013,10 +1063,9 @@ byte-compiled. Run with dynamic binding." (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -1243,25 +1292,25 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't writable (Bug#44631)." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (should (byte-compile-file input-file)) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) (ert-deftest bytecomp-tests--dest-mountpoint () "Test that byte compilation works if the destination file is a @@ -1273,56 +1322,53 @@ mountpoint (Bug#44631)." (skip-unless (not (file-remote-p bwrap))) (skip-unless (file-executable-p emacs)) (skip-unless (not (file-remote-p emacs))) - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (unquoted-file (file-name-unquote output-file)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (should-not (file-remote-p input-file)) - (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (with-temp-buffer - (let ((status (call-process - bwrap nil t nil - "--ro-bind" "/" "/" - "--bind" unquoted-file unquoted-file - emacs "--quick" "--batch" "--load=bytecomp" - (format "--eval=%S" - `(setq byte-compile-dest-file-function - (lambda (_) ,output-file) - byte-compile-error-on-warn t)) - "--funcall=batch-byte-compile" input-file))) - (unless (eql status 0) - (ert-fail `((status . ,status) - (output . ,(buffer-string))))))) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive)))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) (ert-deftest bytecomp-tests--target-file-no-directory () "Check that Bug#45287 is fixed." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((default-directory directory) - (byte-compile-dest-file-function (lambda (_) "test.elc")) - (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) - (should (byte-compile-file "test.el")) - (should (file-regular-p "test.elc")) - (should (cl-plusp (file-attribute-size - (file-attributes "test.elc"))))) - (with-demoted-errors "Error cleaning up directory: %s" - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) (defun bytecomp-tests--get-vars () (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index edb746cdecf..0668e44ba51 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -23,6 +23,7 @@ (require 'ert) (require 'cl-lib) +(require 'generator) (ert-deftest cconv-tests-lambda-:documentation () "Docstring for lambda can be specified with :documentation." @@ -83,9 +84,6 @@ (iter-yield 'cl-iter-defun-result)) (ert-deftest cconv-tests-cl-iter-defun-:documentation () "Docstring for cl-iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-cl-iter-defun) "cl-iter-defun documentation")) (should (eq (iter-next (cconv-tests-cl-iter-defun)) @@ -96,17 +94,12 @@ (iter-yield 'iter-defun-result)) (ert-deftest cconv-tests-iter-defun-:documentation () "Docstring for iter-defun can be specified with :documentation." - ;; FIXME: See Bug#28557. - :tags '(:unstable) - :expected-result :failed (should (string= (documentation 'cconv-tests-iter-defun) "iter-defun documentation")) (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) (ert-deftest cconv-tests-iter-lambda-:documentation () "Docstring for iter-lambda can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((iter-fun (iter-lambda () (:documentation (concat "iter-lambda" " documentation")) @@ -116,13 +109,11 @@ (ert-deftest cconv-tests-cl-function-:documentation () "Docstring for cl-function can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((fun (cl-function (lambda (&key arg) (:documentation (concat "cl-function" " documentation")) (list arg 'cl-function-result))))) - (should (string= (documentation fun) "cl-function documentation")) + (should (string-match "\\`cl-function documentation$" (documentation fun))) (should (equal (funcall fun :arg t) '(t cl-function-result))))) (ert-deftest cconv-tests-function-:documentation () @@ -142,8 +133,6 @@ (+ 1 n)) (ert-deftest cconv-tests-cl-defgeneric-:documentation () "Docstring for cl-defgeneric can be specified with :documentation." - ;; FIXME: See Bug#28557. - :expected-result :failed (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) (set-text-properties 0 (length descr) nil descr) (should (string-match-p "cl-defgeneric documentation" descr)) @@ -205,5 +194,157 @@ nil 99) 42))) +(defun cconv-tests--intern-all (x) + "Intern all symbols in X." + (cond ((symbolp x) (intern (symbol-name x))) + ((consp x) (cons (cconv-tests--intern-all (car x)) + (cconv-tests--intern-all (cdr x)))) + ;; Assume we don't need to deal with vectors etc. + (t x))) + +(ert-deftest cconv-closure-convert-remap-var () + ;; Verify that we correctly remap shadowed lambda-lifted variables. + + ;; We intern all symbols for ease of comparison; this works because + ;; the `cconv-closure-convert' result should contain no pair of + ;; distinct symbols having the same name. + + ;; Sanity check: captured variable, no lambda-lifting or shadowing: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () x)))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (internal-get-closed-var 0))))) + + ;; Basic case: + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let ((x 'b) + (closed-x x)) + (list x (funcall f closed-x))))))) + (should (equal (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((f #'(lambda () x))) + (let* ((x 'b)) + (list x (funcall f))))))) + '#'(lambda (x) + (let ((f #'(lambda (x) x))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall f closed-x))))))) + + ;; With the lambda-lifted shadowed variable also being captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) x))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x)))))))) + ;; With lambda-lifted shadowed variable also being mutably captured: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let ((x 'a) + (closed-x (internal-get-closed-var 0))) + (list x (funcall f closed-x))))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + #'(lambda () + (let ((f #'(lambda () x))) + (setq x x) + (let* ((x 'a)) + (list x (funcall f)))))))) + '#'(lambda (x) + (let ((x (list x))) + (internal-make-closure + nil (x) nil + (let ((f #'(lambda (x) (car-safe x)))) + (setcar (internal-get-closed-var 0) + (car-safe (internal-get-closed-var 0))) + (let* ((closed-x (internal-get-closed-var 0)) + (x 'a)) + (list x (funcall f closed-x))))))))) + ;; Lambda-lifted variable that isn't actually captured where it is shadowed: + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let ((x 'b) + (closed-x x)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + (should (equal + (cconv-tests--intern-all + (cconv-closure-convert + '#'(lambda (x) + (let ((g #'(lambda () x)) + (h #'(lambda () (setq x x)))) + (let* ((x 'b)) + (list x (funcall g) (funcall h))))))) + '#'(lambda (x) + (let ((x (list x))) + (let ((g #'(lambda (x) (car-safe x))) + (h #'(lambda (x) (setcar x (car-safe x))))) + (let* ((closed-x x) + (x 'b)) + (list x (funcall g closed-x) (funcall h closed-x)))))))) + ) + (provide 'cconv-tests) ;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 42b6a4ccab6..59dfc10163d 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -28,6 +28,7 @@ (require 'check-declare) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'subr-x)) (ert-deftest check-declare-tests-locate () @@ -36,62 +37,53 @@ (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) (ert-deftest check-declare-tests-scan () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(declare-function ring-insert \"ring\" (ring item))" - "(let ((foo 'code)) foo)") - "\n"))) - (let ((res (check-declare-scan file))) - (should (= (length res) 1)) - (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) - (should (string-match-p "ring" fnfile)) - (should (equal "ring-insert" fn)) - (should (equal '(ring item) arglist)) - (should-not fileonly)))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) (ert-deftest check-declare-tests-verify () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring item)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should-not - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) (ert-deftest check-declare-tests-verify-mismatch () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should - (equal - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))) - '(("foo.el" "ring-insert" "arglist mismatch"))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) (ert-deftest check-declare-tests-sort () (should-not (check-declare-sort '())) diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index b906e8485cd..2ec01b2b5d7 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -200,9 +200,14 @@ (fmakunbound 'cl--generic-1) (cl-defgeneric cl--generic-1 (x y)) (cl-defmethod cl--generic-1 ((x t) y) - (list x y (cl-next-method-p))) + (list x y + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)))) (cl-defmethod cl--generic-1 ((_x (eql 4)) _y) - (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) + (cl-list* "quatre" + (with-suppressed-warnings ((obsolete cl-next-method-p)) + (cl-next-method-p)) + (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) (ert-deftest cl-generic-test-12-context () diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 03b5371f1bf..b19494af746 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -353,13 +353,6 @@ (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) (should-error (cl-fifth "12345") :type 'wrong-type-argument)) -(ert-deftest cl-lib-test-fifth () - (should (null (cl-fifth '()))) - (should (null (cl-fifth '(1 2 3 4)))) - (should (= 5 (cl-fifth '(1 2 3 4 5)))) - (should (= 5 (cl-fifth '(1 2 3 4 5 6)))) - (should-error (cl-fifth "12345") :type 'wrong-type-argument)) - (ert-deftest cl-lib-test-sixth () (should (null (cl-sixth '()))) (should (null (cl-sixth '(1 2 3 4 5)))) @@ -558,4 +551,9 @@ (should cl-old-struct-compat-mode) (cl-old-struct-compat-mode (if saved 1 -1)))) +(ert-deftest cl-constantly () + (should (equal (mapcar (cl-constantly 3) '(a b c d)) + '(3 3 3 3)))) + + ;;; cl-lib-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 17a84d2067a..008ec0de4a6 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -529,7 +529,7 @@ collection clause." (should-error ;; Use `eval' so the error is signaled when running the test rather than ;; when macroexpanding it. - (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))))) + (eval '(let ((l (list 1))) (cl-symbol-macrolet ((x 1)) (setq (car l) 0))) t)) ;; Make sure `gv-synthetic-place' isn't macro-expanded before `setf' gets to ;; see its `gv-expander'. (should (equal (let ((l '(0))) @@ -637,17 +637,26 @@ collection clause." (/ 1 (logand n 1)) (arith-error (len3 (cdr xs) (1+ n))) (:success (len3 (cdr xs) (+ n k)))) - n))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) (should (equal (len list-42 0) 42)) (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) - (should (equal (len3 list-42k 0) 42000)))) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) @@ -657,11 +666,32 @@ collection clause." (should (pcase (macroexpand '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) #'len)) - (`(function (lambda (,_ ,_) . ,_)) t)))) + (`(function (lambda (,_ ,_) . ,_)) t))) + + ;; Verify that there is no tail position inside dynamic variable bindings. + (defvar dyn-var) + (let ((dyn-var 'a)) + (cl-labels ((f (x) (if x + dyn-var + (let ((dyn-var 'b)) + (f dyn-var))))) + (should (equal (f nil) 'b)))) + + ;; Control: same as above but with lexical binding. + (let ((lex-var 'a)) + (cl-labels ((f (x) (if x + lex-var + (let ((lex-var 'b)) + (f lex-var))))) + (should (equal (f nil) 'a))))) (ert-deftest cl-macs--progv () - (should (= (cl-progv '(test test) '(1 2) test) 2)) - (should (equal (cl-progv '(test1 test2) '(1 2) (list test1 test2)) + (defvar cl-macs--test) + (defvar cl-macs--test1) + (defvar cl-macs--test2) + (should (= (cl-progv '(cl-macs--test cl-macs--test) '(1 2) cl-macs--test) 2)) + (should (equal (cl-progv '(cl-macs--test1 cl-macs--test2) '(1 2) + (list cl-macs--test1 cl-macs--test2)) '(1 2)))) ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/derived-tests.el b/test/lisp/emacs-lisp/derived-tests.el index dba8f904c78..d867a181832 100644 --- a/test/lisp/emacs-lisp/derived-tests.el +++ b/test/lisp/emacs-lisp/derived-tests.el @@ -24,13 +24,13 @@ (define-derived-mode derived-tests--parent-mode prog-mode "P" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFP=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFP=%s " (let ((x "D")) x (funcall f))))) (insert "PB ")) (define-derived-mode derived-tests--child-mode derived-tests--parent-mode "C" :after-hook (let ((f (let ((x "S")) (lambda () x)))) - (insert (format "AFC=%s " (let ((x "D")) (funcall f))))) + (insert (format "AFC=%s " (let ((x "D")) x (funcall f))))) (insert "CB ")) (ert-deftest derived-tests-after-hook-lexical () diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 92f63ec7880..d238bffdaa1 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -53,22 +53,20 @@ Since `should' failures which happen inside `post-command-hook' will be trapped by the command loop, this preserves them until we get back to the top level.") -(defvar edebug-tests-keymap - (let ((map (make-sparse-keymap))) - (define-key map "@" 'edebug-tests-call-instrumented-func) - (define-key map "C-u" 'universal-argument) - (define-key map "C-p" 'previous-line) - (define-key map "C-n" 'next-line) - (define-key map "C-b" 'backward-char) - (define-key map "C-a" 'move-beginning-of-line) - (define-key map "C-e" 'move-end-of-line) - (define-key map "C-k" 'kill-line) - (define-key map "M-x" 'execute-extended-command) - (define-key map "C-M-x" 'eval-defun) - (define-key map "C-x X b" 'edebug-set-breakpoint) - (define-key map "C-x X w" 'edebug-where) - map) - "Keys used by the keyboard macros in Edebug's tests.") +(defvar-keymap edebug-tests-keymap + :doc "Keys used by the keyboard macros in Edebug's tests." + "@" 'edebug-tests-call-instrumented-func + "C-u" 'universal-argument + "C-p" 'previous-line + "C-n" 'next-line + "C-b" 'backward-char + "C-a" 'move-beginning-of-line + "C-e" 'move-end-of-line + "C-k" 'kill-line + "M-x" 'execute-extended-command + "C-M-x" 'eval-defun + "C-x X b" 'edebug-set-breakpoint + "C-x X w" 'edebug-where) ;;; Macros for defining tests: @@ -107,27 +105,27 @@ back to the top level.") "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -860,7 +858,8 @@ test and possibly others should be updated." (let ((inhibit-read-only t)) (delete-region (point-min) (point-max)) (insert "`1")) - (edebug-eval-defun nil) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun nil)) ;; `eval-defun' outputs its message to the echo area in a rather ;; funny way, so the "1" and the " (#o1, #x1, ?\C-a)" end up placed ;; there in separate pieces (via `print' rather than via `message'). @@ -870,7 +869,8 @@ test and possibly others should be updated." (setq edebug-initial-mode 'go) ;; In Bug#23651 Edebug would hang reading `1. - (edebug-eval-defun t))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (edebug-eval-defun t)))) (ert-deftest edebug-tests-trivial-comma () "Edebug can read a trivial comma expression (Bug#23651)." @@ -879,7 +879,8 @@ test and possibly others should be updated." (delete-region (point-min) (point-max)) (insert ",1") (read-only-mode) - (should-error (edebug-eval-defun t)))) + (with-suppressed-warnings ((obsolete edebug-eval-defun)) + (should-error (edebug-eval-defun t))))) (ert-deftest edebug-tests-circular-read-syntax () "Edebug can instrument code using circular read object syntax (Bug#23660)." 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 be627b01012..3b6d8ca5dd6 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -55,6 +55,7 @@ ;;; Code: (require 'eieio) +(require 'eieio-compat) (require 'ert) (defvar eieio-test-method-order-list nil @@ -85,37 +86,40 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) - (eieio-test-method-store :BEFORE 'eitest-B-base1)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base1)) + (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) - (eieio-test-method-store :BEFORE 'eitest-B-base2)) + (defmethod eitest-F :BEFORE ((_p eitest-B-base2)) + (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((_p eitest-B)) - (eieio-test-method-store :BEFORE 'eitest-B)) + (defmethod eitest-F :BEFORE ((_p eitest-B)) + (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((_p eitest-B)) - (eieio-test-method-store :PRIMARY 'eitest-B) - (call-next-method)) - -(defmethod eitest-F ((_p eitest-B-base1)) - (eieio-test-method-store :PRIMARY 'eitest-B-base1) - (call-next-method)) + (defmethod eitest-F ((_p eitest-B)) + (eieio-test-method-store :PRIMARY 'eitest-B) + (call-next-method)) -(defmethod eitest-F ((_p eitest-B-base2)) - (eieio-test-method-store :PRIMARY 'eitest-B-base2) - (when (next-method-p) + (defmethod eitest-F ((_p eitest-B-base1)) + (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) - ) -(defmethod eitest-F :AFTER ((_p eitest-B-base1)) - (eieio-test-method-store :AFTER 'eitest-B-base1)) + (defmethod eitest-F ((_p eitest-B-base2)) + (eieio-test-method-store :PRIMARY 'eitest-B-base2) + (when (next-method-p) + (call-next-method))) -(defmethod eitest-F :AFTER ((_p eitest-B-base2)) - (eieio-test-method-store :AFTER 'eitest-B-base2)) + (defmethod eitest-F :AFTER ((_p eitest-B-base1)) + (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((_p eitest-B)) - (eieio-test-method-store :AFTER 'eitest-B)) + (defmethod eitest-F :AFTER ((_p eitest-B-base2)) + (eieio-test-method-store :AFTER 'eitest-B-base2)) + + (defmethod eitest-F :AFTER ((_p eitest-B)) + (eieio-test-method-store :AFTER 'eitest-B))) (ert-deftest eieio-test-method-order-list-3 () (let ((eieio-test-method-order-list nil) @@ -138,9 +142,11 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((_class eitest-A)) - "No need to do work in here." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-H :STATIC ((_class eitest-A)) + "No need to do work in here." + 'moose)) (ert-deftest eieio-test-method-order-list-4 () ;; Both of these situations should succeed. @@ -149,17 +155,19 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((_a eitest-A)) - (eieio-test-method-store :BEFORE 'eitest-A) - ":before") +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod eitest-I :BEFORE ((_a eitest-A)) + (eieio-test-method-store :BEFORE 'eitest-A) + ":before") -(defmethod eitest-I :PRIMARY ((_a eitest-A)) - (eieio-test-method-store :PRIMARY 'eitest-A) - ":primary") + (defmethod eitest-I :PRIMARY ((_a eitest-A)) + (eieio-test-method-store :PRIMARY 'eitest-A) + ":primary") -(defmethod eitest-I :AFTER ((_a eitest-A)) - (eieio-test-method-store :AFTER 'eitest-A) - ":after") + (defmethod eitest-I :AFTER ((_a eitest-A)) + (eieio-test-method-store :AFTER 'eitest-A) + ":after")) (ert-deftest eieio-test-method-order-list-5 () (let ((eieio-test-method-order-list nil) @@ -175,16 +183,18 @@ (defclass C-base2 () ()) (defclass C (C-base1 C-base2) ()) -;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((_p C-base1) &rest _args) - (eieio-test-method-store :STATIC 'C-base1) - (if (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + ;; Just use the obsolete name once, to make sure it also works. + (defmethod constructor :STATIC ((_p C-base1) &rest _args) + (eieio-test-method-store :STATIC 'C-base1) + (if (next-method-p) (call-next-method))) -(defmethod make-instance :STATIC ((_p C-base2) &rest _args) - (eieio-test-method-store :STATIC 'C-base2) - (if (next-method-p) (call-next-method)) - ) + (defmethod make-instance :STATIC ((_p C-base2) &rest _args) + (eieio-test-method-store :STATIC 'C-base2) + (if (next-method-p) (call-next-method)))) (cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) @@ -215,29 +225,32 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((_p D)) - "D" - (eieio-test-method-store :PRIMARY 'D) - (call-next-method)) - -(defmethod eitest-F ((_p D-base0)) - "D-base0" - (eieio-test-method-store :PRIMARY 'D-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method) + (obsolete next-method-p)) + (defmethod eitest-F ((_p D)) + "D" + (eieio-test-method-store :PRIMARY 'D) + (call-next-method)) -(defmethod eitest-F ((_p D-base1)) - "D-base1" - (eieio-test-method-store :PRIMARY 'D-base1) - (call-next-method)) + (defmethod eitest-F ((_p D-base0)) + "D-base0" + (eieio-test-method-store :PRIMARY 'D-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p D-base2)) - "D-base2" - (eieio-test-method-store :PRIMARY 'D-base2) - (when (next-method-p) + (defmethod eitest-F ((_p D-base1)) + "D-base1" + (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p D-base2)) + "D-base2" + (eieio-test-method-store :PRIMARY 'D-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-7 () (let ((eieio-test-method-order-list nil) @@ -258,25 +271,28 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((_p E)) - (eieio-test-method-store :PRIMARY 'E) - (call-next-method)) - -(defmethod eitest-F ((_p E-base0)) - (eieio-test-method-store :PRIMARY 'E-base0) - ;; This should have no next - ;; (when (next-method-p) (call-next-method)) - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod eitest-F ((_p E)) + (eieio-test-method-store :PRIMARY 'E) + (call-next-method)) -(defmethod eitest-F ((_p E-base1)) - (eieio-test-method-store :PRIMARY 'E-base1) - (call-next-method)) + (defmethod eitest-F ((_p E-base0)) + (eieio-test-method-store :PRIMARY 'E-base0) + ;; This should have no next + ;; (when (next-method-p) (call-next-method)) + ) -(defmethod eitest-F ((_p E-base2)) - (eieio-test-method-store :PRIMARY 'E-base2) - (when (next-method-p) + (defmethod eitest-F ((_p E-base1)) + (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) - ) + + (defmethod eitest-F ((_p E-base2)) + (eieio-test-method-store :PRIMARY 'E-base2) + (when (next-method-p) + (call-next-method)))) (ert-deftest eieio-test-method-order-list-8 () (let ((eieio-test-method-order-list nil) @@ -295,24 +311,32 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) - ;(message "+Ja") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Ja") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) + ;;(message "+Ja") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Ja") + )) (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) - ;(message "+Jb") - ;; FIXME: Using next-method-p in an after-method is invalid! - (when (next-method-p) - (call-next-method)) - ;(message "-Jb") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) + ;;(message "+Jb") + ;; FIXME: Using next-method-p in an after-method is invalid! + (when (next-method-p) + (call-next-method)) + ;;(message "-Jb") + )) (defclass eitest-Jc (eitest-Jb) ()) @@ -320,12 +344,16 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) - ;(message "+Jd") - (when (next-method-p) - (call-next-method)) - ;(message "-Jd") - ) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod initialize-instance ((_this eitest-Jd) &rest _slots) + ;;(message "+Jd") + (when (next-method-p) + (call-next-method)) + ;;(message "-Jd") + )) (ert-deftest eieio-test-method-order-list-9 () (should (eitest-Jd))) @@ -345,32 +373,36 @@ (defclass CNM-2 (CNM-1-1 CNM-1-2) ()) -(defmethod CNM-M ((this CNM-0) args) - (push (cons 'CNM-0 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-0 args)))) - -(defmethod CNM-M ((this CNM-1-1) args) - (push (cons 'CNM-1-1 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-1-1 args)))) - -(defmethod CNM-M ((_this CNM-1-2) args) - (push (cons 'CNM-1-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method))) - -(defmethod CNM-M ((this CNM-2) args) - (push (cons 'CNM-2 (copy-sequence args)) - eieio-test-call-next-method-arguments) - (when (next-method-p) - (call-next-method - this (cons 'CNM-2 args)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete next-method-p) + (obsolete call-next-method)) + (defmethod CNM-M ((this CNM-0) args) + (push (cons 'CNM-0 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-0 args)))) + + (defmethod CNM-M ((this CNM-1-1) args) + (push (cons 'CNM-1-1 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-1-1 args)))) + + (defmethod CNM-M ((_this CNM-1-2) args) + (push (cons 'CNM-1-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method))) + + (defmethod CNM-M ((this CNM-2) args) + (push (cons 'CNM-2 (copy-sequence args)) + eieio-test-call-next-method-arguments) + (when (next-method-p) + (call-next-method + this (cons 'CNM-2 args))))) (ert-deftest eieio-test-method-order-list-10 () (let ((eieio-test-call-next-method-arguments nil)) 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 fcd2f2f45a6..e839e1262fa 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -99,7 +99,7 @@ This is usually a symbol that starts with `:'." (defclass persist-simple (eieio-persistent) ((slot1 :initarg :slot1 :type symbol - :initform moose) + :initform 'moose) (slot2 :initarg :slot2 :initform "foo") (slot3 :initform 2)) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index c03b3854e49..cbcb5215565 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -27,18 +27,24 @@ (require 'ert) (require 'eieio) (require 'eieio-base) +(require 'eieio-compat) (require 'eieio-opt) (eval-when-compile (require 'cl-lib)) +;; Silence byte-compiler. +(eval-when-compile + (dolist (slot '(:a :b ooga-booga :derived-value missing-slot)) + (cl-pushnew slot eieio--known-slot-names))) + ;;; Code: ;; Set up some test classes (defclass class-a () ((water :initarg :water - :initform h20 + :initform 'h20 :type symbol :documentation "Detail about water.") - (classslot :initform penguin + (classslot :initform 'penguin :type symbol :documentation "A class allocated slot." :allocation :class) @@ -50,6 +56,9 @@ ) "Class A.") +;; Silence compiler warning about `water' not being a class-allocated slot. +(defclass eieio-tests--dummy () ((water :allocation :class))) + (defclass class-b () ((land :initform "Sc" :type string @@ -61,40 +70,41 @@ :documentation "Detail about amphibian on land and water.")) "Class A and B combined.") -(defclass class-c () - ((slot-1 :initarg :moose - :initform moose - :type symbol - :allocation :instance - :documentation "First slot testing slot arguments." - :custom symbol - :label "Wild Animal" - :group borg - :protection :public) - (slot-2 :initarg :penguin - :initform "penguin" - :type string - :allocation :instance - :documentation "Second slot testing slot arguments." - :custom string - :label "Wild bird" - :group vorlon - :accessor get-slot-2 - :protection :private) - (slot-3 :initarg :emu - :initform emu - :type symbol - :allocation :class - :documentation "Third slot test class allocated accessor" - :custom symbol - :label "Fuzz" - :group tokra - :accessor get-slot-3 - :protection :private) - ) - (:custom-groups (foo)) - "A class for testing slot arguments." - ) +(with-no-warnings ; FIXME: Make more specific. + (defclass class-c () + ((slot-1 :initarg :moose + :initform 'moose + :type symbol + :allocation :instance + :documentation "First slot testing slot arguments." + :custom symbol + :label "Wild Animal" + :group borg + :protection :public) + (slot-2 :initarg :penguin + :initform "penguin" + :type string + :allocation :instance + :documentation "Second slot testing slot arguments." + :custom string + :label "Wild bird" + :group vorlon + :accessor get-slot-2 + :protection :private) + (slot-3 :initarg :emu + :initform 'emu + :type symbol + :allocation :class + :documentation "Third slot test class allocated accessor" + :custom symbol + :label "Fuzz" + :group tokra + :accessor get-slot-3 + :protection :private) + ) + (:custom-groups (foo)) + "A class for testing slot arguments." + )) (defclass class-subc (class-c) ((slot-1 ;; :initform moose - don't override this @@ -132,21 +142,25 @@ ;; (error "invalid-slot-type thrown when eieio-error-unsupported-class-tags is nil") ;; ))) +;; Silence byte-compiler. +(declare-function eitest-subordinate--eieio-childp nil) +(declare-function class-alloc-initarg--eieio-childp nil) (ert-deftest eieio-test-01-mix-alloc-initarg () ;; Only run this test if the message framework thingy works. - (when (and (message "foo") (string= "foo" (current-message))) + (skip-unless (and (message "foo") (string= "foo" (current-message)))) - ;; Defining this class should generate a warning(!) message that - ;; you should not mix :initarg with class allocated slots. + ;; Defining this class should generate a warning(!) message that + ;; you should not mix :initarg with class allocated slots. + (with-no-warnings ; FIXME: Make more specific. (defclass class-alloc-initarg () ((throwwarning :initarg :throwwarning - :allocation :class)) - "Throw a warning mixing allocation class and an initarg.") + :allocation :class)) + "Throw a warning mixing allocation class and an initarg.")) - ;; Check that message is there - (should (current-message)) - (should (string-match "Class allocated slots do not need :initarg" - (current-message))))) + ;; Check that message is there + (should (current-message)) + (should (string-match "Class allocated slots do not need :initarg" + (current-message)))) (defclass abstract-class () ((some-slot :initarg :some-slot @@ -160,30 +174,33 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function.") +(with-suppressed-warnings ((obsolete defgeneric)) + (defgeneric generic1 () "First generic function.")) (ert-deftest eieio-test-03-generics () - (defun anormalfunction () "A plain function for error testing." nil) - (should-error - (progn - (defgeneric anormalfunction () - "Attempt to turn it into a generic."))) - - ;; Check that generic-p works - (should (generic-p 'generic1)) - - (defmethod generic1 ((c class-a)) - "Method on generic1." - 'monkey) - - (defmethod generic1 (not-an-object) - "Method generic1 that can take a non-object." - not-an-object) - - (let ((ans-obj (generic1 (class-a))) - (ans-num (generic1 666))) - (should (eq ans-obj 'monkey)) - (should (eq ans-num 666)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defun anormalfunction () "A plain function for error testing." nil) + (should-error + (progn + (defgeneric anormalfunction () + "Attempt to turn it into a generic."))) + + ;; Check that generic-p works + (should (generic-p 'generic1)) + + (defmethod generic1 ((_c class-a)) + "Method on generic1." + 'monkey) + + (defmethod generic1 (not-an-object) + "Method generic1 that can take a non-object." + not-an-object) + + (let ((ans-obj (generic1 (class-a))) + (ans-num (generic1 666))) + (should (eq ans-obj 'monkey)) + (should (eq ans-num 666))))) (defclass static-method-class () ((some-slot :initform nil @@ -191,12 +208,17 @@ :documentation "A slot.")) :documentation "A class used for testing static methods.") -(defmethod static-method-class-method :STATIC ((c static-method-class) value) - "Test static methods. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot value)) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot value))) +;; Silence byte-compiler. +(declare-function static-method-class-2 nil) +(declare-function static-method-class-2--eieio-childp nil) (ert-deftest eieio-test-04-static-method () ;; Call static method on a class and see if it worked (static-method-class-method 'static-method-class 'class) @@ -209,11 +231,13 @@ Argument C is the class bound to this static method." () "A second class after the previous for static methods.") - (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) - "Test static methods. + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod static-method-class-method :STATIC ((c static-method-class-2) value) + "Test static methods. Argument C is the class bound to this static method." - (if (eieio-object-p c) (setq c (eieio-object-class c))) - (oset-default c some-slot (intern (concat "moose-" (symbol-name value))))) + (if (eieio-object-p c) (setq c (eieio-object-class c))) + (oset-default c some-slot (intern (concat "moose-" (symbol-name value)))))) (static-method-class-method 'static-method-class-2 'class) (should (eq (oref-default 'static-method-class-2 some-slot) 'moose-class)) @@ -240,64 +264,71 @@ Argument C is the class bound to this static method." (should (make-instance 'class-a :water 'cho)) (should (make-instance 'class-b))) -(defmethod class-cn ((a class-a)) - "Try calling `call-next-method' when there isn't one. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-cn ((_a class-a)) + "Try calling `call-next-method' when there isn't one. Argument A is object of type symbol `class-a'." - (call-next-method)) + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -(defmethod no-next-method ((a class-a) &rest args) - "Override signal throwing for variable `class-a'. + (defmethod no-next-method ((_a class-a) &rest _args) + "Override signal throwing for variable `class-a'. Argument A is the object of class variable `class-a'." - 'moose) + 'moose)) (ert-deftest eieio-test-08-call-next-method () ;; Play with call-next-method (should (eq (class-cn eitest-ab) 'moose))) -(defmethod no-applicable-method ((b class-b) method &rest args) - "No need. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod no-applicable-method ((_b class-b) _method &rest _args) + "No need. Argument B is for booger. METHOD is the method that was attempting to be called." - 'moose) + 'moose)) (ert-deftest eieio-test-09-no-applicable-method () ;; Non-existing methods. (should (eq (class-cn eitest-b) 'moose))) -(defmethod class-fun ((a class-a)) - "Fun with class A." - 'moose) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun ((_a class-a)) + "Fun with class A." + 'moose) -(defmethod class-fun ((b class-b)) - "Fun with class B." - (error "Class B fun should not be called") - ) + (defmethod class-fun ((_b class-b)) + "Fun with class B." + (error "Class B fun should not be called")) -(defmethod class-fun-foo ((b class-b)) - "Foo Fun with class B." - 'moose) + (defmethod class-fun-foo ((_b class-b)) + "Foo Fun with class B." + 'moose) -(defmethod class-fun2 ((a class-a)) - "More fun with class A." - 'moose) + (defmethod class-fun2 ((_a class-a)) + "More fun with class A." + 'moose) -(defmethod class-fun2 ((b class-b)) - "More fun with class B." - (error "Class B fun2 should not be called") - ) + (defmethod class-fun2 ((_b class-b)) + "More fun with class B." + (error "Class B fun2 should not be called")) -(defmethod class-fun2 ((ab class-ab)) - "More fun with class AB." - (call-next-method)) + (defmethod class-fun2 ((_ab class-ab)) + "More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))) -;; How about if B is the only slot? -(defmethod class-fun3 ((b class-b)) - "Even More fun with class B." - 'moose) + ;; How about if B is the only slot? + (defmethod class-fun3 ((_b class-b)) + "Even More fun with class B." + 'moose) -(defmethod class-fun3 ((ab class-ab)) - "Even More fun with class AB." - (call-next-method)) + (defmethod class-fun3 ((_ab class-ab)) + "Even More fun with class AB." + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))) (ert-deftest eieio-test-10-multiple-inheritance () ;; play with methods and mi @@ -314,20 +345,22 @@ METHOD is the method that was attempting to be called." (defvar class-fun-value-seq '()) -(defmethod class-fun-value :BEFORE ((a class-a)) - "Return `before', and push `before' in `class-fun-value-seq'." - (push 'before class-fun-value-seq) - 'before) - -(defmethod class-fun-value :PRIMARY ((a class-a)) - "Return `primary', and push `primary' in `class-fun-value-seq'." - (push 'primary class-fun-value-seq) - 'primary) - -(defmethod class-fun-value :AFTER ((a class-a)) - "Return `after', and push `after' in `class-fun-value-seq'." - (push 'after class-fun-value-seq) - 'after) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod class-fun-value :BEFORE ((_a class-a)) + "Return `before', and push `before' in `class-fun-value-seq'." + (push 'before class-fun-value-seq) + 'before) + + (defmethod class-fun-value :PRIMARY ((_a class-a)) + "Return `primary', and push `primary' in `class-fun-value-seq'." + (push 'primary class-fun-value-seq) + 'primary) + + (defmethod class-fun-value :AFTER ((_a class-a)) + "Return `after', and push `after' in `class-fun-value-seq'." + (push 'after class-fun-value-seq) + 'after)) (ert-deftest eieio-test-12-generic-function-call () ;; Test value of a generic function call @@ -343,20 +376,23 @@ METHOD is the method that was attempting to be called." ;; (ert-deftest eieio-test-13-init-methods () - (defmethod initialize-instance ((a class-a) &rest slots) - "Initialize the slots of class-a." - (call-next-method) - (if (/= (oref a test-tag) 1) - (error "shared-initialize test failed.")) - (oset a test-tag 2)) - - (defmethod shared-initialize ((a class-a) &rest slots) - "Shared initialize method for class-a." - (call-next-method) - (oset a test-tag 1)) - - (let ((ca (class-a))) - (should (= (oref ca test-tag) 2)))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric) + (obsolete call-next-method)) + (defmethod initialize-instance ((a class-a) &rest _slots) + "Initialize the slots of class-a." + (call-next-method) + (if (/= (oref a test-tag) 1) + (error "shared-initialize test failed.")) + (oset a test-tag 2)) + + (defmethod shared-initialize ((a class-a) &rest _slots) + "Shared initialize method for class-a." + (call-next-method) + (oset a test-tag 1)) + + (let ((ca (class-a))) + (should (= (oref ca test-tag) 2))))) ;;; Perform slot testing @@ -368,10 +404,11 @@ METHOD is the method that was attempting to be called." (should (oref eitest-ab amphibian))) (ert-deftest eieio-test-15-slot-missing () - - (defmethod slot-missing ((ab class-ab) &rest foo) - "If a slot in AB is unbound, return something cool. FOO." - 'moose) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((_ab class-ab) &rest _foo) + "If a slot in AB is unbound, return something cool. FOO." + 'moose)) (should (eq (oref eitest-ab ooga-booga) 'moose)) (should-error (oref eitest-a ooga-booga) :type 'invalid-slot-name)) @@ -391,17 +428,20 @@ METHOD is the method that was attempting to be called." (defclass virtual-slot-class () ((base-value :initarg :base-value)) "Class has real slot :base-value and simulated slot :derived-value.") -(defmethod slot-missing ((vsc virtual-slot-class) - slot-name operation &optional new-value) - "Simulate virtual slot derived-value." - (cond - ((or (eq slot-name :derived-value) - (eq slot-name 'derived-value)) - (with-slots (base-value) vsc - (if (eq operation 'oref) - (+ base-value 1) - (setq base-value (- new-value 1))))) - (t (call-next-method)))) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-missing ((vsc virtual-slot-class) + slot-name operation &optional new-value) + "Simulate virtual slot derived-value." + (cond + ((or (eq slot-name :derived-value) + (eq slot-name 'derived-value)) + (with-slots (base-value) vsc + (if (eq operation 'oref) + (+ base-value 1) + (setq base-value (- new-value 1))))) + (t (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method)))))) (ert-deftest eieio-test-17-virtual-slot () (setq eitest-vsca (virtual-slot-class :base-value 1)) @@ -424,35 +464,37 @@ METHOD is the method that was attempting to be called." (should (= (oref eitest-vscb :derived-value) 5))) (ert-deftest eieio-test-18-slot-unbound () - - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - 'moose) - - (should (eq (oref eitest-a water) 'moose)) - - ;; Check if oset of unbound works - (oset eitest-a water 'moose) - (should (eq (oref eitest-a water) 'moose)) - - ;; oref/oref-default comparison - (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; oset-default -> oref/oref-default comparison - (oset-default (eieio-object-class eitest-a) water 'moose) - (should (eq (oref eitest-a water) (oref-default eitest-a water))) - - ;; After setting 'water to 'moose, make sure a new object has - ;; the right stuff. - (oset-default (eieio-object-class eitest-a) water 'penguin) - (should (eq (oref (class-a) water) 'penguin)) - - ;; Revert the above - (defmethod slot-unbound ((a class-a) &rest foo) - "If a slot in A is unbound, ignore FOO." - ;; Disable the old slot-unbound so we can run this test - ;; more than once - (call-next-method))) + (with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + 'moose) + + (should (eq (oref eitest-a water) 'moose)) + + ;; Check if oset of unbound works + (oset eitest-a water 'moose) + (should (eq (oref eitest-a water) 'moose)) + + ;; oref/oref-default comparison + (should-not (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; oset-default -> oref/oref-default comparison + (oset-default (eieio-object-class eitest-a) water 'moose) + (should (eq (oref eitest-a water) (oref-default eitest-a water))) + + ;; After setting 'water to 'moose, make sure a new object has + ;; the right stuff. + (oset-default (eieio-object-class eitest-a) water 'penguin) + (should (eq (oref (class-a) water) 'penguin)) + + ;; Revert the above + (defmethod slot-unbound ((_a class-a) &rest _foo) + "If a slot in A is unbound, ignore FOO." + ;; Disable the old slot-unbound so we can run this test + ;; more than once + (with-suppressed-warnings ((obsolete call-next-method)) + (call-next-method))))) (ert-deftest eieio-test-19-slot-type-checking () ;; Slot type checking @@ -489,7 +531,7 @@ METHOD is the method that was attempting to be called." (defclass inittest nil ((staticval :initform 1) - (symval :initform eieio-test-permuting-value) + (symval :initform 'eieio-test-permuting-value) (evalval :initform (symbol-value 'eieio-test-permuting-value)) (evalnow :initform (symbol-value 'eieio-test-permuting-value) :allocation :class) @@ -506,8 +548,10 @@ METHOD is the method that was attempting to be called." (should (eq (oref eitest-pvinit evalval) 2)) (should (eq (oref eitest-pvinit evalnow) 1))) +;; Silence byte-compiler. (defvar eitest-tests nil) - +(declare-function eitest-superior nil) +(declare-function eitest-superior--eieio-childp nil) (ert-deftest eieio-test-22-init-forms-dont-match-runnable () ;; Init forms with types that don't match the runnable. (defclass eitest-subordinate nil @@ -515,7 +559,7 @@ METHOD is the method that was attempting to be called." "Test class that will be a calculated value.") (defclass eitest-superior nil - ((sub :initform (eitest-subordinate) + ((sub :initform (funcall #'eitest-subordinate) :type eitest-subordinate)) "A class with an initform that creates a class.") @@ -555,7 +599,10 @@ METHOD is the method that was attempting to be called." (should-not (cl-typep listooa '(list-of class-b))) (should-not (cl-typep listoob '(list-of class-a))))) +;; Silence byte-compiler. (defvar eitest-t1 nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present nil) +(declare-function eieio-tests-initform-not-evaluated-when-initarg-is-present--eieio-childp nil) (ert-deftest eieio-test-25-slot-tests () (setq eitest-t1 (class-c)) ;; Slot initialization @@ -617,12 +664,14 @@ METHOD is the method that was attempting to be called." () "Protection testing baseclass.") -(defmethod prot0-slot-2 ((s2 prot-0)) - "Try to access slot-2 from this class which doesn't have it. +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot0-slot-2 ((s2 prot-0)) + "Try to access slot-2 from this class which doesn't have it. The object S2 passed in will be of class prot-1, which does have the slot. This could be allowed, and currently is in EIEIO. Needed by the eieio persistent base class." - (oref s2 slot-2)) + (oref s2 slot-2))) (defclass prot-1 (prot-0) ((slot-1 :initarg :slot-1 @@ -640,26 +689,28 @@ Needed by the eieio persistent base class." nil "A class for testing the :protection option.") -(defmethod prot1-slot-2 ((s2 prot-1)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod prot1-slot-2 ((s2 prot-1)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-2 ((s2 prot-2)) - "Try to access slot-2 in S2." - (oref s2 slot-2)) + (defmethod prot1-slot-2 ((s2 prot-2)) + "Try to access slot-2 in S2." + (oref s2 slot-2)) -(defmethod prot1-slot-3-only ((s2 prot-1)) - "Try to access slot-3 in S2. + (defmethod prot1-slot-3-only ((s2 prot-1)) + "Try to access slot-3 in S2. Do not override for `prot-2'." - (oref s2 slot-3)) + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-1)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-1)) + "Try to access slot-3 in S2." + (oref s2 slot-3)) -(defmethod prot1-slot-3 ((s2 prot-2)) - "Try to access slot-3 in S2." - (oref s2 slot-3)) + (defmethod prot1-slot-3 ((s2 prot-2)) + "Try to access slot-3 in S2." + (oref s2 slot-3))) (defvar eitest-p1 nil) (defvar eitest-p2 nil) @@ -729,7 +780,7 @@ Do not override for `prot-2'." (should (eq (oref eitest-II3 slot3) 'penguin))) (defclass slotattr-base () - ((initform :initform init) + ((initform :initform 'init) (type :type list) (initarg :initarg :initarg) (protection :protection :private) @@ -744,7 +795,7 @@ Do not override for `prot-2'." Subclasses to override slot attributes.") (defclass slotattr-ok (slotattr-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -778,28 +829,29 @@ Subclasses to override slot attributes.") (let ((obj (slotattr-ok))) (should (eq (oref obj initform) 'no-init)))) -(defclass slotattr-class-base () - ((initform :allocation :class - :initform init) - (type :allocation :class - :type list) - (initarg :allocation :class - :initarg :initarg) - (protection :allocation :class - :protection :private) - (custom :allocation :class - :custom (repeat string) - :label "Custom Strings" - :group moose) - (docstring :allocation :class - :documentation - "Replace the doc-string for this property.") - ) - "Baseclass we will attempt to subclass. -Subclasses to override slot attributes.") +(with-no-warnings ; FIXME: Make more specific. + (defclass slotattr-class-base () + ((initform :allocation :class + :initform 'init) + (type :allocation :class + :type list) + (initarg :allocation :class + :initarg :initarg) + (protection :allocation :class + :protection :private) + (custom :allocation :class + :custom (repeat string) + :label "Custom Strings" + :group moose) + (docstring :allocation :class + :documentation + "Replace the doc-string for this property.") + ) + "Baseclass we will attempt to subclass. +Subclasses to override slot attributes.")) (defclass slotattr-class-ok (slotattr-class-base) - ((initform :initform no-init) + ((initform :initform 'no-init) (initarg :initarg :initblarg) (custom :custom string :label "One String" @@ -861,7 +913,7 @@ Subclasses to override slot attributes.") (should (setq eitest-CLONETEST2 (clone eitest-CLONETEST1)))) (defclass IT (eieio-instance-tracker) - ((tracking-symbol :initform IT-list) + ((tracking-symbol :initform 'IT-list) (slot1 :initform 'die)) "Instance Tracker test object.") @@ -914,13 +966,20 @@ Subclasses to override slot attributes.") (defclass eieio--testing () ()) -(defmethod constructor :static ((_x eieio--testing) newname &rest _args) - (list newname 2)) +(with-suppressed-warnings ((obsolete defmethod) + (obsolete defgeneric)) + (defmethod constructor :static ((_x eieio--testing) newname &rest _args) + (list newname 2))) (ert-deftest eieio-test-37-obsolete-name-in-constructor () ;; FIXME repeated intermittent failures on hydra and elsewhere (bug#24503). :tags '(:unstable) - (should (equal (eieio--testing "toto") '("toto" 2)))) + ;; Disable byte-compiler "Warning: Obsolete name arg "toto" to + ;; constructor eieio--testing". This could be made more specific + ;; with changes to `with-suppressed-warnings', but it's not worth + ;; the hassle for just this one test. + (with-no-warnings + (should (equal (eieio--testing "toto") '("toto" 2))))) (ert-deftest eieio-autoload () "Tests to see whether reftex-auc has been autoloaded" @@ -969,6 +1028,21 @@ Subclasses to override slot attributes.") (should (eieio-instance-inheritor-slot-boundp C :b)) (should-not (eieio-instance-inheritor-slot-boundp C :c)))) +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b (c nil :read-only t)) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))) + (setf (slot-value x 'a) 1) + (should (eq (eieio-test--struct-a x) 1)) + (should-error (setf (slot-value x 'c) 3) :type 'eieio-read-only))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index e93ec18406c..ac130644743 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -39,10 +39,11 @@ (defun ert-self-test () "Run ERT's self-tests and make sure they actually ran." (let ((window-configuration (current-window-configuration))) - (let ((ert--test-body-was-run nil)) + (let ((ert--test-body-was-run nil) + (ert--output-buffer-name " *ert self-tests*")) ;; The buffer name chosen here should not compete with the default ;; results buffer name for completion in `switch-to-buffer'. - (let ((stats (ert-run-tests-interactively "^ert-" " *ert self-tests*"))) + (let ((stats (ert-run-tests-interactively "^ert-"))) (cl-assert ert--test-body-was-run) (if (zerop (ert-stats-completed-unexpected stats)) ;; Hide results window only when everything went well. @@ -494,6 +495,12 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-select-tests '(tag b) (list test)) (list test))) (should (equal (ert-select-tests '(tag c) (list test)) '())))) +(ert-deftest ert-test-select-undefined () + (let* ((symbol (make-symbol "ert-not-a-test")) + (data (should-error (ert-select-tests symbol t) + :type 'ert-test-unbound))) + (should (eq (cadr data) symbol)))) + ;;; Tests for utility functions. (ert-deftest ert-test-parse-keys-and-body () @@ -519,17 +526,18 @@ This macro is used to test if macroexpansion in `should' works." :body (lambda () (ert-skip "skip message"))))) (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name " *ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((buffer-name (generate-new-buffer-name + " *ert-test-run-tests*")) + (ert--output-buffer-name buffer-name) + (messages nil) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test, skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test, skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " @@ -551,6 +559,68 @@ This macro is used to test if macroexpansion in `should' works." (when (get-buffer buffer-name) (kill-buffer buffer-name)))))))) +(ert-deftest ert-test-run-tests-batch () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (long-list (make-list 11 1)) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1))))) + (failing-test-2 + (make-ert-test :name 'failing-test-2 + :body (lambda () (should (equal long-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-print-level 10) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1 ,failing-test-2)))))) + (let ((long-text "(different-types[ \t\n]+(1 1 1 1 1 1 1 1 1 1 1)[ \t\n]+1)))[ \t\n]*$") + (complex-text "(different-types[ \t\n]+((:1[ \t\n]+(:2[ \t\n]+(:3[ \t\n]+(:4[ \t\n]+(:5[ \t\n]+(:6[ \t\n]+\"abc\")))))))[ \t\n]+1)))[ \t\n]*$") + found-long + found-complex) + (cl-loop for msg in (reverse messages) + do + (unless found-long + (setq found-long (string-match long-text msg))) + (unless found-complex + (setq found-complex (string-match complex-text msg)))) + (should found-long) + (should found-complex))))) + +(ert-deftest ert-test-run-tests-batch-expensive () + (let* ((complex-list '((:1 (:2 (:3 (:4 (:5 (:6 "abc")))))))) + (failing-test-1 + (make-ert-test :name 'failing-test-1 + :body (lambda () (should (equal complex-list 1)))))) + (let ((ert-debug-on-error nil) + messages) + (cl-letf* (((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil) + (ert-batch-backtrace-right-margin nil) + (ert-batch-backtrace-line-length nil) + (ert-batch-print-level 6) + (ert-batch-print-length 11)) + (ert-run-tests-batch + `(member ,failing-test-1)))))) + (let ((frame "ert-fail(((should (equal complex-list 1)) :form (equal ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1) :value nil :explanation (different-types ((:1 (:2 (:3 (:4 (:5 (:6 \"abc\"))))))) 1)))") + found-frame) + (cl-loop for msg in (reverse messages) + do + (unless found-frame + (setq found-frame (cl-search frame msg :test 'equal)))) + (should found-frame))))) + (ert-deftest ert-test-special-operator-p () (should (ert--special-operator-p 'if)) (should-not (ert--special-operator-p 'car)) @@ -695,49 +765,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - - (should (equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index afa2105c48d..38698041102 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -90,10 +90,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -103,23 +103,27 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let* ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message"))))) - (skipped-test (make-ert-test :name 'skipped-test - :body (lambda () (ert-skip - "skip message")))) - (ert-debug-on-error nil) - (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) + (cl-letf* ((passing-test (make-ert-test + :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test + :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (skipped-test (make-ert-test + :name 'skipped-test + :body (lambda () (ert-skip + "skip message")))) + (ert-debug-on-error nil) + (messages nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + ((symbol-function 'message) + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages))) + (ert--output-buffer-name buffer-name)) (cl-flet ((expected-string (with-font-lock-p) (ert-propertized-string "Selector: (member <passing-test> <failing-test> " @@ -152,21 +156,19 @@ "failing-test" nil "\n Info: " '(a b) "foo\n" nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) + nil "\n (ert-test-failed \"failure message\")\n\n\n"))) (save-window-excursion (unwind-protect (let ((case-fold-search nil)) (ert-run-tests-interactively - `(member ,passing-test ,failing-test ,skipped-test) buffer-name - mock-message-fn) + `(member ,passing-test ,failing-test ,skipped-test)) (should (equal messages `(,(concat "Ran 3 tests, 1 results were " "as expected, 1 unexpected, " "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +177,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -271,6 +273,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 298e7c8d415..b7a21d49b2f 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -74,7 +74,7 @@ identical output." (cps-testcase cps-prog1-b (prog1 1)) (cps-testcase cps-prog1-c (prog2 1 2 3)) (cps-testcase cps-quote (progn 'hello)) -(cps-testcase cps-function (progn #'hello)) +(cps-testcase cps-function (progn #'message)) (cps-testcase cps-and-fail (and 1 nil 2)) (cps-testcase cps-and-succeed (and 1 2 3)) @@ -85,9 +85,9 @@ identical output." (cps-testcase cps-or-empty (or)) (cps-testcase cps-let* (let* ((i 10)) i)) -(cps-testcase cps-let*-shadow-empty (let* ((i 10)) (let (i) i))) +(cps-testcase cps-let*-shadow-empty (let* ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let (let ((i 10)) i)) -(cps-testcase cps-let-shadow-empty (let ((i 10)) (let (i) i))) +(cps-testcase cps-let-shadow-empty (let ((i 10)) i (let ((i nil)) i))) (cps-testcase cps-let-novars (let nil 42)) (cps-testcase cps-let*-novars (let* nil 42)) @@ -95,7 +95,7 @@ identical output." (let ((a 5) (b 6)) (let ((a b) (b a)) (list a b)))) (cps-testcase cps-let*-parallel - (let* ((a 5) (b 6)) (let* ((a b) (b a)) (list a b)))) + (let* ((a 5) (b 6)) a (let* ((a b) (b a)) (list a b)))) (cps-testcase cps-while-dynamic (setq *cps-test-i* 0) @@ -219,7 +219,7 @@ identical output." (should (eql (iter-next it -1) 42)) (should (eql (iter-next it -1) -1)))) -(ert-deftest cps-loop () +(ert-deftest cps-loop-2 () (should (equal (cl-loop for x iter-by (mygenerator 42) collect x) @@ -307,6 +307,7 @@ identical output." (1+ it))))))) -2))) +(defun generator-tests-edebug ()) ; silence byte-compiler (ert-deftest generator-tests-edebug () "Check that Bug#40434 is fixed." (with-temp-buffer diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 0b1f9d0cf01..0757e3c7aa5 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -21,22 +21,21 @@ (require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index 042e57e92f9..c4e4feaad30 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -82,7 +82,7 @@ (ert-deftest let-alist-list-to-sexp () "Check that multiple dots are handled correctly." - (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1))))))))) + (should (= 1 (eval (let-alist--list-to-sexp '(a b c d) ''((d (c (b (a . 1)))))) t))) (should (equal (let-alist--access-sexp '.foo.bar.baz 'var) '(cdr (assq 'baz (cdr (assq 'bar (cdr (assq 'foo var)))))))) (should (equal (let-alist--access-sexp '..foo.bar.baz 'var) '.foo.bar.baz))) diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 7d14f5545be..901447ecd27 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -213,6 +213,7 @@ (should-error (forward-sexp)))) ;; FIXME: Shouldn't be an error. ;; Test some core Elisp rules. +(defvar c-e-x) (ert-deftest core-elisp-tests-1-defvar-in-let () "Test some core Elisp rules." (with-temp-buffer @@ -235,7 +236,7 @@ (should (or (not mark-active) (mark))))) (ert-deftest core-elisp-tests-3-backquote () - (should (eq 3 (eval ``,,'(+ 1 2))))) + (should (eq 3 (eval ``,,'(+ 1 2) t)))) ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) @@ -324,7 +325,7 @@ start." (declare (indent 1) (debug (def-form body))) (let* ((var-pos nil) (text (with-temp-buffer - (insert (eval contents)) + (insert (eval contents t)) (goto-char (point-min)) (while (re-search-forward elisp-test-point-position-regex nil t) (push (list (intern (match-string-no-properties 1)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/m1.el b/test/lisp/emacs-lisp/macroexp-resources/m1.el index acffe6b8b61..88c51e75261 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m1.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m1.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m1-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/m2.el b/test/lisp/emacs-lisp/macroexp-resources/m2.el index 0bb8d02a135..cebe4cac125 100644 --- a/test/lisp/emacs-lisp/macroexp-resources/m2.el +++ b/test/lisp/emacs-lisp/macroexp-resources/m2.el @@ -5,23 +5,23 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: (defconst macroexp--m2-tests-filename (macroexp-file-name)) diff --git a/test/lisp/emacs-lisp/macroexp-resources/vk.el b/test/lisp/emacs-lisp/macroexp-resources/vk.el new file mode 100644 index 00000000000..2dee1306a2d --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-resources/vk.el @@ -0,0 +1,130 @@ +;;; vk.el --- test code for macroexp-tests -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'macroexp) + +(defmacro vk-variable-kind (var) + (if (macroexp--dynamic-variable-p var) ''dyn ''lex)) + +(defvar vk-a 1) +(defconst vk-b 2) +(defvar vk-c) + +(defun vk-f1 (x) + (defvar vk-u1) + (let ((vk-a 10) + (vk-b 20) + (vk-c 30) + (vk-u1 40) + (y 50)) + (ignore vk-a vk-b vk-c vk-u1 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-c) ; dyn + (vk-variable-kind vk-u1) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y)))) ; lex + +(eval-and-compile + (defvar vk-u2) + (defun vk-f2 (x) + (defvar vk-v2) + (let ((vk-u2 11) + (vk-v2 12) + (y 13)) + (ignore vk-u2 vk-v2 x y) + (list + (vk-variable-kind vk-u2) ; dyn + (vk-variable-kind vk-v2) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(eval-when-compile + (defvar vk-u3) + (defun vk-f3 (x) + (defvar vk-v3) + (let ((vk-a 23) + (vk-b 24) + (vk-u3 25) + (vk-v3 26) + (y 27)) + (ignore vk-a vk-b vk-u3 vk-v3 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-u3) ; dyn + (vk-variable-kind vk-v3) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defconst vk-val3 (eval-when-compile (vk-f3 0))) + +(defconst vk-f4 '(lambda (x) + (defvar vk-v4) + (let ((vk-v4 31) + (y 32)) + (ignore vk-v4 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v4) ; dyn + (vk-variable-kind x) ; dyn + (vk-variable-kind y))))) ; dyn + +(defconst vk-f5 '(closure (t) (x) + (defvar vk-v5) + (let ((vk-v5 41) + (y 42)) + (ignore vk-v5 x y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v5) ; dyn + (vk-variable-kind x) ; lex + (vk-variable-kind y))))) ; lex + +(defun vk-f6 () + (eval '(progn + (defvar vk-v6) + (let ((vk-v6 51) + (y 52)) + (ignore vk-v6 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v6) ; dyn + (vk-variable-kind vk-y)))))) ; dyn + +(defun vk-f7 () + (eval '(progn + (defvar vk-v7) + (let ((vk-v7 51) + (y 52)) + (ignore vk-v7 y) + (list + (vk-variable-kind vk-a) ; dyn + (vk-variable-kind vk-b) ; dyn + (vk-variable-kind vk-v7) ; dyn + (vk-variable-kind vk-y)))) ; lex + t)) + +(provide 'vk) diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el index ee400626a26..4e6bd8b8fcd 100644 --- a/test/lisp/emacs-lisp/macroexp-tests.el +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -5,25 +5,28 @@ ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; 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. -;; This program is distributed in the hope that it will be useful, +;; 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/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: -;; - ;;; Code: +(require 'macroexp) +(require 'ert-x) + (ert-deftest macroexp--tests-fgrep () (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) '((x)))) @@ -67,6 +70,58 @@ (should (equal "m1.el" (file-name-nondirectory macroexp--m1-tests-comp-filename))))) +(defun macroexp-tests--run-emacs (&rest args) + "Run Emacs in batch mode with ARGS, return output." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (with-temp-buffer + (let ((res (apply #'call-process emacs nil t nil + "-Q" "--batch" args)) + (output (buffer-string))) + (unless (equal res 0) + (message "%s" output) + (error "Inferior Emacs exited with status %S" res)) + output)))) + +(defun macroexp-tests--eval-in-subprocess (file expr) + (let ((output (macroexp-tests--run-emacs + "-l" file (format "--eval=(print %S)" expr)))) + (car (read-from-string output)))) + +(defun macroexp-tests--byte-compile-in-subprocess (file) + "Byte-compile FILE using a subprocess to avoid contaminating the lisp state." + (let ((output (macroexp-tests--run-emacs "-f" "batch-byte-compile" file))) + (when output + (message "%s" output)))) + +(ert-deftest macroexp--tests-dynamic-variable-p () + "Test `macroexp--dynamic-variable-p'." + (let* ((vk-el (ert-resource-file "vk.el")) + (vk-elc (concat vk-el "c")) + (expr '(list (vk-f1 0) + (vk-f2 0) + vk-val3 + (funcall vk-f4 0) + (funcall vk-f5 0) + (vk-f6) + (vk-f7)))) + ;; We compile and run the test in separate processes for complete + ;; isolation between test cases. + (should (equal (macroexp-tests--eval-in-subprocess vk-el expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))) + (macroexp-tests--byte-compile-in-subprocess vk-el) + (should (equal (macroexp-tests--eval-in-subprocess vk-elc expr) + '((dyn dyn dyn dyn lex lex) + (dyn dyn lex lex) + (dyn dyn dyn dyn lex lex) + (dyn dyn dyn dyn dyn) + (dyn dyn dyn lex lex) + (dyn dyn dyn dyn) + (dyn dyn dyn lex)))))) -(provide 'macroexp-tests) ;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/multisession-tests.el b/test/lisp/emacs-lisp/multisession-tests.el new file mode 100644 index 00000000000..17457d9be2f --- /dev/null +++ b/test/lisp/emacs-lisp/multisession-tests.el @@ -0,0 +1,207 @@ +;;; multisession-tests.el --- Tests for multisession.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'multisession) +(require 'ert) +(require 'ert-x) +(require 'cl-lib) + +(declare-function sqlite-close "sqlite.c") + +(ert-deftest multi-test-sqlite-simple () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'sqlite) + (multisession-directory dir)) + (unwind-protect + (progn + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--foo) 0)) + (cl-incf (multisession-value multisession--foo)) + (should (= (multisession-value multisession--foo) 1)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/foo.el")) + (define-multisession-variable multisession--foo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--foo)))))) + (should (= (multisession-value multisession--foo) 2))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-sqlite-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-directory dir) + (multisession-storage 'sqlite) + proc) + (unwind-protect + (progn + (define-multisession-variable multisession--bar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--bar) 0)) + (cl-incf (multisession-value multisession--bar)) + (should (= (multisession-value multisession--bar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'sqlite) + (user-init-file "/tmp/bar.el")) + (define-multisession-variable multisession--bar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--bar)))))))) + (while (process-live-p proc) + (ignore-error 'sqlite-locked-error + (message "multisession--bar %s" (multisession-value multisession--bar)) + ;;(cl-incf (multisession-value multisession--bar)) + ) + (sleep-for 0.1)) + (message "multisession--bar ends up as %s" (multisession-value multisession--bar)) + (should (< (multisession-value multisession--bar) 1003))) + (sqlite-close multisession--db) + (setq multisession--db nil))))) + +(ert-deftest multi-test-files-simple () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sfoo) 0)) + (cl-incf (multisession-value multisession--sfoo)) + (should (= (multisession-value multisession--sfoo) 1)) + ;; On Windows and Haiku, we don't have sub-second resolution, so + ;; let some time pass to make the "later" logic work. + (when (memq system-type '(windows-nt haiku)) + (sleep-for 0.6)) + (call-process + (concat invocation-directory invocation-name) + nil t nil + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sfoo.el")) + (define-multisession-variable multisession--sfoo 0 + "" + :synchronized t) + (cl-incf (multisession-value multisession--sfoo)))))) + (should (= (multisession-value multisession--sfoo) 2))))) + +(ert-deftest multi-test-files-busy () + (skip-unless (sqlite-available-p)) + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/foo.el") + (multisession-storage 'files) + (multisession-directory dir) + proc) + (define-multisession-variable multisession--sbar 0 + "" + :synchronized t) + (should (= (multisession-value multisession--sbar) 0)) + (cl-incf (multisession-value multisession--sbar)) + (should (= (multisession-value multisession--sbar) 1)) + (setq proc + (start-process + "other-emacs" + nil + (concat invocation-directory invocation-name) + "-Q" "-batch" + "--eval" (prin1-to-string + `(progn + (require 'multisession) + (let ((multisession-directory ,dir) + (multisession-storage 'files) + (user-init-file "/tmp/sbar.el")) + (define-multisession-variable multisession--sbar 0 + "" :synchronized t) + (dotimes (i 100) + (cl-incf (multisession-value multisession--sbar)))))))) + (while (process-live-p proc) + (message "multisession--sbar %s" (multisession-value multisession--sbar)) + ;;(cl-incf (multisession-value multisession--sbar)) + (sleep-for 0.1)) + (message "multisession--sbar ends up as %s" (multisession-value multisession--sbar)) + (should (< (multisession-value multisession--sbar) 200))))) + +(ert-deftest multi-test-files-some-values () + (ert-with-temp-file dir + :directory t + (let ((user-init-file "/tmp/sfoo.el") + (multisession-storage 'files) + (multisession-directory dir)) + (define-multisession-variable multisession--foo1 nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) nil) + (should (eq (multisession-value multisession--foo1) nil)) + (setf (multisession-value multisession--foo1) t) + (should (eq (multisession-value multisession--foo1) t)) + + (define-multisession-variable multisession--foo2 t) + (setf (multisession-value multisession--foo2) nil) + (should (eq (multisession-value multisession--foo2) nil)) + (setf (multisession-value multisession--foo2) t) + (should (eq (multisession-value multisession--foo2) t)) + + (define-multisession-variable multisession--foo3 t) + (should-error (setf (multisession-value multisession--foo3) (make-marker))) + + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (define-multisession-variable multisession--foo4 nil) + (setf (multisession-value multisession--foo4) string) + (should (equal (multisession-value multisession--foo4) string)))))) + +;;; multisession-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 69c14050b96..d7a55998c20 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -115,57 +115,55 @@ &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (([&rest form]) body))) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when ,upload-base - (dolist (f '("archive-contents" - "simple-single-1.3.el" - "simple-single-1.4.el" - "simple-single-readme.txt")) - (ignore-errors - (delete-file - (expand-file-name f package-test-archive-upload-base)))) - (delete-directory package-test-archive-upload-base)) - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." @@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)." (declare-function macro-problem-func "macro-problem" ()) (declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) @@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -685,25 +713,23 @@ but with a different end of line convention (bug#48137)." (defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (concat "HOME=" homedir) - process-environment))) - (require 'epg-config) - (defvar epg-config--program-alist) - (epg-find-configuration - 'OpenPGP nil - ;; By default we require gpg2 2.1+ due to some - ;; practical problems with pinentry. But this - ;; test works fine with 2.0 as well. - (let ((prog-alist (copy-tree epg-config--program-alist))) - (setf (alist-get "gpg2" - (alist-get 'OpenPGP prog-alist) - nil nil #'equal) - "2.0") - prog-alist))) - (delete-directory homedir t)))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index ea4119bf9a3..80607990808 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -107,8 +107,11 @@ (should (equal (pcase 1 ((cl-type (integer 0 2)) 'integer-0<=n<=2)) 'integer-0<=n<=2)) - (should-error (pcase 1 - ((cl-type notatype) 'integer)))) + (should-error + ;; Avoid error at compile time due to compiler macro. + (eval '(pcase 1 + ((cl-type notatype) 'integer)) + t))) (ert-deftest pcase-tests-setq () (should (equal (let (a b) diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..2b2001d0964 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,124 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index d74ef32f9f4..01ac572c537 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/ring-tests.el b/test/lisp/emacs-lisp/ring-tests.el index 5331af9ca7f..6bbcd94f201 100644 --- a/test/lisp/emacs-lisp/ring-tests.el +++ b/test/lisp/emacs-lisp/ring-tests.el @@ -199,7 +199,7 @@ (should (= (ring-size ring) 3)) (should (equal (ring-elements ring) '(5 4 3))))) -(ert-deftest ring-tests-insert () +(ert-deftest ring-tests-insert-2 () (let ((ring (make-ring 2))) (ring-insert+extend ring :a) (ring-insert+extend ring :b) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 11499b6b0e7..c1c46d6400e 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -22,14 +22,42 @@ ;;; Commentary: -;; - ;;; Code: (require 'ert) (require 'rmc) +(require 'cl-lib) (eval-when-compile (require 'cl-lib)) +(ert-deftest test-rmc--add-key-description () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal (rmc--add-key-description '(?y "yes")) + '(?y . "yes"))) + (should (equal (rmc--add-key-description '(?n "foo")) + '(?n . "n foo"))) + (should (equal (rmc--add-key-description '(?\s "foo bar")) + `(?\s . "SPC foo bar"))))) + +(ert-deftest test-rmc--add-key-description/with-attributes () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) t))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + `(?y . ,(concat (propertize "y" 'face 'read-multiple-choice-face) "es")))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'read-multiple-choice-face) " foo")))) + (should (equal-including-properties + (rmc--add-key-description '(?\s "foo bar")) + `(?\s . ,(concat (propertize "SPC" 'face 'read-multiple-choice-face) " foo bar")))))) + +(ert-deftest test-rmc--add-key-description/non-graphical-display () + (cl-letf (((symbol-function 'display-supports-face-attributes-p) (lambda (_ _) nil))) + (should (equal-including-properties + (rmc--add-key-description '(?y "yes")) + '(?y . "[Y]es"))) + (should (equal-including-properties + (rmc--add-key-description '(?n "foo")) + `(?n . ,(concat (propertize "n" 'face 'help-key-binding) " foo")))))) (ert-deftest test-read-multiple-choice () (dolist (char '(?y ?n)) @@ -38,6 +66,5 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) - (provide 'rmc-tests) ;;; rmc-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 228c5c1991e..9e5d59163f9 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -173,16 +173,18 @@ Evaluate BODY for each created sequence. (should (seq-find #'null '(1 2 3) 'sentinel))) (ert-deftest test-seq-contains () - (with-test-sequences (seq '(3 4 5 6)) - (should (seq-contains seq 3)) - (should-not (seq-contains seq 7))) - (with-test-sequences (seq '()) - (should-not (seq-contains seq 3)) - (should-not (seq-contains seq nil)))) + (with-suppressed-warnings ((obsolete seq-contains)) + (with-test-sequences (seq '(3 4 5 6)) + (should (seq-contains seq 3)) + (should-not (seq-contains seq 7))) + (with-test-sequences (seq '()) + (should-not (seq-contains seq 3)) + (should-not (seq-contains seq nil))))) (ert-deftest test-seq-contains-should-return-the-elt () - (with-test-sequences (seq '(3 4 5 6)) - (should (= 5 (seq-contains seq 5))))) + (with-suppressed-warnings ((obsolete seq-contains)) + (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)) @@ -404,7 +406,7 @@ Evaluate BODY for each created sequence. (let ((seq '(1 (2 (3 (4)))))) (seq-let (_ (_ (_ (a)))) seq (should (= a 4)))) - (let (seq) + (let ((seq nil)) (seq-let (a b c) seq (should (null a)) (should (null b)) @@ -428,7 +430,7 @@ Evaluate BODY for each created sequence. (seq '(1 (2 (3 (4)))))) (seq-setq (_ (_ (_ (a)))) seq) (should (= a 4))) - (let (seq a b c) + (let ((seq nil) a b c) (seq-setq (a b c) seq) (should (null a)) (should (null b)) diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 7d5aca7ba4a..d38a8e2352b 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -169,13 +169,13 @@ "no") "no")) (should (equal - (let (z) + (let ((z nil)) (if-let* (z (a 1) (b 2) (c 3)) "yes" "no")) "no")) (should (equal - (let (d) + (let ((d nil)) (if-let* ((a 1) (b 2) (c 3) d) "yes" "no")) @@ -191,7 +191,7 @@ (ert-deftest subr-x-test-if-let*-and-laziness-is-preserved () "Test `if-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a nil) (b (setq b-called t)) @@ -199,7 +199,7 @@ "yes" (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) (b nil) @@ -207,12 +207,12 @@ "yes" (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) c-called) (should (equal (if-let* ((a (setq a-called t)) - (b (setq b-called t)) - (c nil) - (d (setq c-called t))) + (b (setq b-called t)) + (c nil) + (d (setq c-called t))) "yes" (list a-called b-called c-called)) (list t t nil))))) @@ -329,12 +329,12 @@ "no") nil)) (should (equal - (let (z) + (let ((z nil)) (when-let* (z (a 1) (b 2) (c 3)) "no")) nil)) (should (equal - (let (d) + (let ((d nil)) (when-let* ((a 1) (b 2) (c 3) d) "no")) nil))) @@ -348,7 +348,7 @@ (ert-deftest subr-x-test-when-let*-and-laziness-is-preserved () "Test `when-let' respects `and' laziness." - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a nil) @@ -357,7 +357,7 @@ "yes") (list a-called b-called c-called)) (list nil nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -366,7 +366,7 @@ "yes") (list a-called b-called c-called)) (list t nil nil)))) - (let (a-called b-called c-called) + (let ((a-called nil) (b-called nil) (c-called nil)) (should (equal (progn (when-let* ((a (setq a-called t)) @@ -638,5 +638,79 @@ (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + +(ert-deftest subr-x-test-add-display-text-property () + (with-temp-buffer + (insert "Foo bar zot gazonk") + (add-display-text-property 4 8 'height 2.0) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + '((raise 0.5) (height 2.0)))) + (should (equal (get-text-property 9 'display) '(raise 0.5)))) + (with-temp-buffer + (insert "Foo bar zot gazonk") + (put-text-property 4 8 'display [(height 2.0)]) + (add-display-text-property 2 12 'raise 0.5) + (should (equal (get-text-property 2 'display) '(raise 0.5))) + (should (equal (get-text-property 5 'display) + [(raise 0.5) (height 2.0)])) + (should (equal (get-text-property 9 'display) '(raise 0.5))))) + +(ert-deftest subr-x-named-let () + (let ((funs ())) + (named-let loop + ((rest '(1 42 3)) + (sum 0)) + (when rest + ;; Here, we make sure that the variables are distinct in every + ;; iteration, since a naive tail-call optimization would tend to end up + ;; with a single `sum' variable being shared by all the closures. + (push (lambda () sum) funs) + ;; Here we add a dummy `sum' variable which shadows the `sum' iteration + ;; variable since a naive tail-call optimization could also trip here + ;; thinking it can `(setq sum ...)' to set the iteration + ;; variable's value. + (let ((sum sum)) + (loop (cdr rest) (+ sum (car rest)))))) + (should (equal (mapcar #'funcall funs) '(43 1 0))))) + (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 1d5821146c8..46040be1a6c 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -424,7 +424,7 @@ (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) (debug (form (vector &rest form)))) - `(eval (aref ,vec%%% ,arg%%%))%%%) + `(eval (aref ,vec%%% ,arg%%%) t)%%%) (defun testcover-testcase-use-nth-case (choice val) (testcover-testcase-nth-case choice diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 8bb6b6f0150..39cd3175c26 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -99,32 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; which can happen if Testcover fails to attach itself - ;; correctly. Note that this will prevent debugging - ;; these tests using Edebug. - (cl-letf (((symbol-function #'edebug-default-enter) - (lambda (&rest _args) - (ert-fail "Debugger invoked during test run")))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) + (lambda (&rest _args) + (ert-fail "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 1123596113e..4d974cfd9d7 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -37,7 +37,8 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. (skip-unless (fboundp 'debug-timer-check)) - (should (debug-timer-check))) + (when (fboundp 'debug-timer-check) ; silence byte-compiler + (should (debug-timer-check)))) (ert-deftest timer-test-multiple-of-time () (should (time-equal-p diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index d2f5988442d..1d2bf46b199 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -21,7 +21,8 @@ ;;; Code: - +(require 'ert) +(require 'ert-x) (require 'viper) (defun viper-test-undo-kmacro (kmacro) @@ -30,47 +31,42 @@ This function makes as many attempts as possible to clean up after itself, although it will leave a buffer called *viper-test-buffer* if it fails (this is deliberate!)." - (let ( - ;; Viper just turns itself off during batch use. - (noninteractive nil) - ;; Switch off start up message or it will chew the key presses. - (viper-inhibit-startup-message 't) - ;; Select an expert-level for the same reason. - (viper-expert-level 5) - ;; viper loads this even with -q so make sure it's empty! - (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc")) - (before-buffer (current-buffer))) - (unwind-protect - (progn - ;; viper-mode is essentially global, so set it here. - (viper-mode) - ;; We must switch to buffer because we are using a keyboard macro - ;; which appears to not go to the current-buffer but what ever is - ;; currently taking keyboard events. We use a named buffer because - ;; then we can see what it in it if it all goes wrong. - (switch-to-buffer - (get-buffer-create - "*viper-test-buffer*")) - (erase-buffer) - ;; The new buffer fails to enter vi state so set it. - (viper-change-state-to-vi) - ;; Run the macro. - (execute-kbd-macro kmacro) - (let ((rtn - (buffer-substring-no-properties - (point-min) - (point-max)))) - ;; Kill the buffer iff the macro succeeds. - (kill-buffer) - rtn)) - ;; Switch everything off and restore the buffer. - (toggle-viper-mode) - (delete-file viper-custom-file-name) - (switch-to-buffer before-buffer)))) - -(ert-deftest viper-test-go () - "Test that this file is running." - (should t)) + (ert-with-temp-file viper-custom-file-name + ;; viper loads this even with -q so make sure it's empty! + :prefix "emacs-viper-tests" :suffix ".elc" + (let (;; Viper just turns itself off during batch use. + (noninteractive nil) + ;; Switch off start up message or it will chew the key presses. + (viper-inhibit-startup-message 't) + ;; Select an expert-level for the same reason. + (viper-expert-level 5) + (before-buffer (current-buffer))) + (unwind-protect + (progn + ;; viper-mode is essentially global, so set it here. + (viper-mode) + ;; We must switch to buffer because we are using a keyboard macro + ;; which appears to not go to the current-buffer but what ever is + ;; currently taking keyboard events. We use a named buffer because + ;; then we can see what it in it if it all goes wrong. + (switch-to-buffer + (get-buffer-create + "*viper-test-buffer*")) + (erase-buffer) + ;; The new buffer fails to enter vi state so set it. + (viper-change-state-to-vi) + ;; Run the macro. + (execute-kbd-macro kmacro) + (let ((rtn + (buffer-substring-no-properties + (point-min) + (point-max)))) + ;; Kill the buffer iff the macro succeeds. + (kill-buffer) + rtn)) + ;; Switch everything off and restore the buffer. + (toggle-viper-mode) + (switch-to-buffer before-buffer))))) (ert-deftest viper-test-fix () "Test that the viper kmacro fixture is working." diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 6354f926912..65aaafd9f18 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -58,48 +58,45 @@ (cl-defmacro with-epg-tests ((&optional &key require-passphrase require-public-key require-secret-key) - &rest body) + &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (sexp body))) - `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t)) - (process-environment - (append - (list "GPG_AGENT_INFO" - (format "GNUPGHOME=%s" epg-tests-home-directory)) - process-environment))) - (unwind-protect - ;; GNUPGHOME is needed to find a usable gpg, so we can't - ;; check whether to skip any earlier (Bug#23561). - (let ((epg-config (or (epg-tests-find-usable-gpg-configuration - ,require-passphrase ,require-public-key) - (ert-skip "No usable gpg config"))) - (context (epg-make-context 'OpenPGP))) - (setf (epg-context-program context) - (alist-get 'program epg-config)) - (setf (epg-context-home-directory context) - epg-tests-home-directory) - ,(if require-passphrase - '(with-temp-file (expand-file-name - "gpg-agent.conf" epg-tests-home-directory) - (insert "pinentry-program " - (ert-resource-file "dummy-pinentry") - "\n") - (epg-context-set-passphrase-callback - context - #'epg-tests-passphrase-callback))) - ,(if require-public-key - '(epg-import-keys-from-file - context - (ert-resource-file "pubkey.asc"))) - ,(if require-secret-key - '(epg-import-keys-from-file - context - (ert-resource-file "seckey.asc"))) - (with-temp-buffer - (setq-local epg-tests-context context) - ,@body)) - (when (file-directory-p epg-tests-home-directory) - (delete-directory epg-tests-home-directory t))))) + `(ert-with-temp-directory epg-tests-home-directory + (let* ((process-environment + (append + (list "GPG_AGENT_INFO" + (format "GNUPGHOME=%s" epg-tests-home-directory)) + process-environment))) + ;; GNUPGHOME is needed to find a usable gpg, so we can't + ;; check whether to skip any earlier (Bug#23561). + (let ((epg-config (or (epg-tests-find-usable-gpg-configuration + ,require-passphrase ,require-public-key) + (ert-skip "No usable gpg config"))) + (context (epg-make-context 'OpenPGP))) + (setf (epg-context-program context) + (alist-get 'program epg-config)) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + ,(if require-passphrase + '(with-temp-file (expand-file-name + "gpg-agent.conf" epg-tests-home-directory) + (insert "pinentry-program " + (ert-resource-file "dummy-pinentry") + "\n") + (epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback))) + ,(if require-public-key + '(epg-import-keys-from-file + context + (ert-resource-file "pubkey.asc"))) + ,(if require-secret-key + '(epg-import-keys-from-file + context + (ert-resource-file "seckey.asc"))) + (with-temp-buffer + (setq-local epg-tests-context context) + ,@body))))) (ert-deftest epg-decrypt-1 () :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 60b3da2317f..5603e764547 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -228,4 +228,75 @@ (kill-buffer "*erc-protocol*") (should-not erc-debug-irc-protocol))) + +;; The point of this test is to ensure output is handled identically +;; regardless of whether a command handler is summoned. + +(ert-deftest erc-process-input-line () + (let (erc-server-last-sent-time + erc-server-flood-queue + (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) + (erc-default-recipients '("#chan")) + calls) + (with-temp-buffer + (cl-letf (((symbol-function 'erc-cmd-MSG) + (lambda (line) + (push line calls) + (funcall orig-erc-cmd-MSG line))) + ((symbol-function 'erc-server-buffer) + (lambda () (current-buffer))) + ((symbol-function 'erc-server-process-alive) + (lambda () t)) + ((symbol-function 'erc-server-send-queue) + #'ignore)) + + (ert-info ("Dispatch to user command handler") + + (ert-info ("Baseline") + (erc-process-input-line "/msg #chan hi\n") + (should (equal (pop calls) " #chan hi")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Quote preserves line intact") + (erc-process-input-line "/QUOTE FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Unknown command respected") + (erc-process-input-line "/FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "/msg #chan hi you\n") + (should (equal (pop calls) " #chan hi you")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line honored") + (erc-process-input-line "/msg #chan\n") + (should (equal (pop calls) " #chan")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8))))) + + (ert-info ("Implicit cmd via `erc-send-input-line-function'") + + (ert-info ("Baseline") + (erc-process-input-line "hi") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "hi you") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line transmitted without injected-space kludge") + (erc-process-input-line "") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8)))) + + (should-not calls)))))) + ;;; erc-tests.el ends here diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index c598ce7d4f0..634e9819839 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -20,19 +20,18 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-hist) (ert-deftest eshell-write-readonly-history () "Test that having read-only strings in history is okay." - (let ((histfile (make-temp-file "eshell-history")) - (eshell-history-ring (make-ring 2))) - (ring-insert eshell-history-ring - (propertize "echo foo" 'read-only t)) - (ring-insert eshell-history-ring - (propertize "echo bar" 'read-only t)) - (unwind-protect - (eshell-write-history histfile) - (delete-file histfile)))) + (ert-with-temp-file histfile + (let ((eshell-history-ring (make-ring 2))) + (ring-insert eshell-history-ring + (propertize "echo foo" 'read-only t)) + (ring-insert eshell-history-ring + (propertize "echo bar" 'read-only t)) + (eshell-write-history histfile)))) (provide 'em-hist-test) diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index 2f739979169..272280e81c7 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -25,30 +25,30 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-ls) (require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - (orig eshell-ls-use-in-dired) - buf) - (unwind-protect - (progn - (customize-set-value 'eshell-ls-use-in-dired t) - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (customize-set-variable 'eshell-ls-use-in-dired orig) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + (orig eshell-ls-use-in-dired) + buf) + (unwind-protect + (progn + (customize-set-value 'eshell-ls-use-in-dired t) + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (customize-set-variable 'eshell-ls-use-in-dired orig) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest em-ls-test-bug27817 () "Test for https://debbugs.gnu.org/27817 ." diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index a9b1e2ab4e8..aef14479078 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -26,23 +26,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'esh-mode) (require 'eshell) (defmacro with-temp-eshell (&rest body) "Evaluate BODY in a temporary Eshell buffer." - `(let* ((eshell-directory-name (make-temp-file "eshell" t)) - ;; We want no history file, so prevent Eshell from falling - ;; back on $HISTFILE. - (process-environment (cons "HISTFILE" process-environment)) - (eshell-history-file-name nil) - (eshell-buffer (eshell t))) - (unwind-protect - (with-current-buffer eshell-buffer - ,@body) - (let (kill-buffer-query-functions) - (kill-buffer eshell-buffer) - (delete-directory eshell-directory-name t))))) + `(ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer)))))) (defun eshell-insert-command (text &optional func) "Insert a command at the end of the buffer." @@ -65,11 +65,9 @@ (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." - (let ((eshell-directory-name (make-temp-file "eshell" t)) - (eshell-history-file-name nil)) - (unwind-protect - (eshell-command-result command) - (delete-directory eshell-directory-name t)))) + (ert-with-temp-directory eshell-directory-name + (let ((eshell-history-file-name nil)) + (eshell-command-result command)))) ;;; Tests: diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 7c6b708f0a3..aebc9b6dbb9 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -25,30 +25,29 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'ffap) (ert-deftest ffap-tests-25243 () "Test for https://debbugs.gnu.org/25243 ." - (let ((file (make-temp-file "test-Bug#25243"))) - (unwind-protect - (with-temp-file file - (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el + (ert-with-temp-file file + :suffix "-bug25243" + (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el index 3d7cebadcf..ad4b70d737 100644 --- b/lisp/ffap.el +++ a/lisp/ffap.el @@ -203,6 +203,9 @@ ffap-foo-at-bar-prefix ")) - (transient-mark-mode 1) - (when (natnump ffap-max-region-length) - (insert - (concat - str - (make-string ffap-max-region-length #xa) - (format "%s ENDS HERE" file))) - (call-interactively 'mark-whole-buffer) - (should (equal "" (ffap-string-at-point))) - (should (equal '(1 1) ffap-string-at-point-region))))) - (and (file-exists-p file) (delete-file file))))) + (transient-mark-mode 1) + (when (natnump ffap-max-region-length) + (insert + (concat + str + (make-string ffap-max-region-length #xa) + (format "%s ENDS HERE" file))) + (call-interactively 'mark-whole-buffer) + (should (equal "" (ffap-string-at-point))) + (should (equal '(1 1) ffap-string-at-point-region)))))) (ert-deftest ffap-gopher-at-point () (with-temp-buffer @@ -133,7 +132,7 @@ left alone when opening a URL in an external browser." ;; Macros in BODY are expanded when the test is defined, not when it ;; is run. If a macro (possibly with side effects) is to be tested, ;; it has to be wrapped in `(eval (quote ...))'. - (eval (quote (ido-everywhere))) + (eval (quote (ido-everywhere)) t) (let ((read-file-name-function (lambda (&rest args) (expand-file-name (nth 4 args) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index eabcbd51427..13bb2cd3452 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -162,9 +162,7 @@ Return nil when any other file notification watch is still active." (defun file-notify--test-cleanup () "Cleanup after a test." - (file-notify-rm-watch file-notify--test-desc) - (file-notify-rm-watch file-notify--test-desc1) - (file-notify-rm-watch file-notify--test-desc2) + (file-notify-rm-all-watches) (ignore-errors (delete-file (file-newest-backup file-notify--test-tmpfile))) @@ -421,7 +419,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; This test is inspired by Bug#26126 and Bug#26127. (ert-deftest file-notify-test02-rm-watch () - "Check `file-notify-rm-watch'." + "Check `file-notify-rm-watch' and `file-notify-rm-all-watches'." (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -517,6 +515,31 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (file-notify--test-cleanup-p)))) ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check `file-notify-rm-all-watches'. + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile1 '(change) #'ignore))) + (file-notify-rm-all-watches) + (delete-file file-notify--test-tmpfile) + (delete-file file-notify--test-tmpfile1) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test02-rm-watch diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 57597762afd..a3c67bc3d64 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -136,7 +136,7 @@ form.") ;; Prevent any dir-locals file interfering with the tests. (enable-dir-local-variables nil)) (hack-local-variables) - (eval (nth 2 test-settings))))) + (eval (nth 2 test-settings) t)))) (ert-deftest files-tests-local-variables () "Test the file-local variables implementation." @@ -176,15 +176,14 @@ form.") ;; If called interactively, environment variable ;; $EMACS_TEST_DIRECTORY does not exist. (skip-unless (file-exists-p files-test-bug-18141-file)) - (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) - (unwind-protect - (progn - (copy-file files-test-bug-18141-file tempfile t) - (with-current-buffer (find-file-noselect tempfile) - (set-buffer-modified-p t) - (save-buffer) - (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + :prefix "emacs-test-files-bug-18141" + :suffix ".gz" + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix))))) (ert-deftest files-tests-make-temp-file-empty-prefix () "Test make-temp-file with an empty prefix." @@ -283,22 +282,20 @@ If we are in a directory named `~', the default value should not be $HOME." (cl-letf (((symbol-function 'completing-read) (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (or def init)))) + (ert-with-temp-directory dir + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir)))))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. @@ -341,14 +338,6 @@ be $HOME." (progn ,@body) (advice-remove #',symbol ,function))))) -(defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1) (debug (symbolp body))) - (cl-check-type name symbol) - `(let ((,name (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,name)))) - (ert-deftest files-tests-file-name-non-special--buffers () "Check that Bug#25951 is fixed. We call `verify-visited-file-modtime' on a buffer visiting a file @@ -357,7 +346,7 @@ the buffer current and a nil argument, second passing the buffer object explicitly. In both cases no error should be raised and the `file-name-non-special' handler for quoted file names should be invoked with the right arguments." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) @@ -476,6 +465,15 @@ unquoted file names." (let (file-name-handler-alist) (concat (file-name-sans-extension name) part (file-name-extension name t)))) +(ert-deftest files-tests-file-name-non-special-abbreviate-file-name () + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + ;; Check that abbreviation doesn't occur for quoted file names. + (should (equal (concat "/:" homedir "foo/bar") + (abbreviate-file-name (concat "/:" homedir "foo/bar")))))) + (ert-deftest files-tests-file-name-non-special-access-file () (files-tests--with-temp-non-special (tmpfile nospecial) ;; Both versions of the file name work. @@ -1239,26 +1237,26 @@ works as expected if the default directory is quoted." (insert-directory-wildcard-in-dir-p (car path-res))))))) (ert-deftest files-tests-make-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (file (concat dirname "file")) - (subdir1 (concat dirname "subdir1")) - (subdir2 (concat dirname "subdir2")) - (a/b (concat dirname "a/b"))) - (write-region "" nil file) - (should-error (make-directory "/")) - (should-not (make-directory "/" t)) - (should-error (make-directory dir)) - (should-not (make-directory dir t)) - (should-error (make-directory dirname)) - (should-not (make-directory dirname t)) - (should-error (make-directory file)) - (should-error (make-directory file t)) - (should-not (make-directory subdir1)) - (should-not (make-directory subdir2 t)) - (should-error (make-directory a/b)) - (should-not (make-directory a/b t)) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (file (concat dirname "file")) + (subdir1 (concat dirname "subdir1")) + (subdir2 (concat dirname "subdir2")) + (a/b (concat dirname "a/b"))) + (write-region "" nil file) + (should-error (make-directory "/")) + (should-not (make-directory "/" t)) + (should-error (make-directory dir)) + (should-not (make-directory dir t)) + (should-error (make-directory dirname)) + (should-not (make-directory dirname t)) + (should-error (make-directory file)) + (should-error (make-directory file t)) + (should-not (make-directory subdir1)) + (should-not (make-directory subdir2 t)) + (should-error (make-directory a/b)) + (should-not (make-directory a/b t)) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-modes-symbolic-to-number () (let ((alist (list (cons "a=rwx" #o777) @@ -1318,7 +1316,7 @@ name (Bug#28412)." (set-buffer-modified-p t) (should-error (save-buffer) :type 'error)) ;; Then a buffer visiting a file: should save normally. - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-current-buffer (find-file-noselect temp-file-name) (setq write-contents-functions nil) (insert "p") @@ -1326,21 +1324,21 @@ name (Bug#28412)." (should (eq (buffer-size) 1)))))) (ert-deftest files-tests-copy-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (source (concat dirname "source")) - (dest (concat dirname "dest/new/directory/")) - (file (concat (file-name-as-directory source) "file")) - (source2 (concat dirname "source2")) - (dest2 (concat dirname "dest/new2"))) - (make-directory source) - (write-region "" nil file) - (copy-directory source dest t t t) - (should (file-exists-p (concat dest "file"))) - (make-directory (concat (file-name-as-directory source2) "a") t) - (copy-directory source2 dest2) - (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (source (concat dirname "source")) + (dest (concat dirname "dest/new/directory/")) + (file (concat (file-name-as-directory source) "file")) + (source2 (concat dirname "source2")) + (dest2 (concat dirname "dest/new2"))) + (make-directory source) + (write-region "" nil file) + (copy-directory source dest t t t) + (should (file-exists-p (concat dest "file"))) + (make-directory (concat (file-name-as-directory source2) "a") t) + (copy-directory source2 dest2) + (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-abbreviate-file-name-homedir () ;; Check homedir abbreviation. @@ -1392,43 +1390,40 @@ See <https://debbugs.gnu.org/19657#20>." (ert-deftest files-tests-executable-find () "Test that `executable-find' works also with a relative or remote PATH. See <https://debbugs.gnu.org/35241>." - (let ((tmpfile (make-temp-file "files-test" nil (car exec-suffixes)))) - (unwind-protect - (progn - (set-file-modes tmpfile #o777) - (let ((exec-path `(,temporary-file-directory))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; An empty element of `exec-path' means `default-directory'. - (let ((default-directory temporary-file-directory) - (exec-path nil)) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; The remote file name shall be quoted, and handled like a - ;; non-existing directory. - (let ((default-directory "/ssh::") - (exec-path (append exec-path `("." ,temporary-file-directory)))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile)))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix (car exec-suffixes) + (set-file-modes tmpfile #o755) + (let ((exec-path `(,temporary-file-directory))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; An empty element of `exec-path' means `default-directory'. + (let ((default-directory temporary-file-directory) + (exec-path nil)) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; The remote file name shall be quoted, and handled like a + ;; non-existing directory. + (let ((default-directory "/ssh::") + (exec-path (append exec-path `("." ,temporary-file-directory)))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))))) (ert-deftest files-tests-dont-rewrite-precious-files () "Test that `file-precious-flag' forces files to be saved by renaming only, rather than modified in-place." - (let* ((temp-file-name (make-temp-file "files-tests")) - (advice (lambda (_start _end filename &rest _r) - (should-not (string= filename temp-file-name))))) - (unwind-protect - (with-current-buffer (find-file-noselect temp-file-name) - (advice-add #'write-region :before advice) - (setq-local file-precious-flag t) - (insert "foobar") - (should (null (save-buffer)))) - (ignore-errors (advice-remove #'write-region advice)) - (ignore-errors (delete-file temp-file-name))))) + (ert-with-temp-file temp-file-name + (let* ((advice (lambda (_start _end filename &rest _r) + (should-not (string= filename temp-file-name))))) + (unwind-protect + (with-current-buffer (find-file-noselect temp-file-name) + (advice-add #'write-region :before advice) + (setq-local file-precious-flag t) + (insert "foobar") + (should (null (save-buffer)))) + (ignore-errors (advice-remove #'write-region advice)))))) (ert-deftest files-test-file-size-human-readable () (should (equal (file-size-human-readable 13) "13")) @@ -1542,26 +1537,32 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer () "Test that revert-buffer is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (revert-buffer t t t) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (revert-buffer t t t)) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) (ert-deftest files-tests-revert-buffer-with-fine-grain () "Test that revert-buffer-with-fine-grain is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) - (write-file temp-file-name) - (erase-buffer) - (insert files-tests-tzu) - (should (revert-buffer-with-fine-grain t t)) + ;; Disable lock files, since that barfs in + ;; userlock--check-content-unchanged on MS-Windows. + (let (create-lockfiles) + (write-file temp-file-name) + (erase-buffer) + (insert files-tests-tzu) + (should (revert-buffer-with-fine-grain t t))) (should (compare-strings files-tests-lao nil nil (buffer-substring (point-min) (point-max)) nil nil))))) @@ -1584,6 +1585,14 @@ The door of all subtleties! (should-error (file-name-with-extension "Jack" ".")) (should-error (file-name-with-extension "/is/a/directory/" "css"))) +(ert-deftest files-tests-file-name-base () + (should (equal (file-name-base "") "")) + (should (equal (file-name-base "/foo/") "")) + (should (equal (file-name-base "/foo") "foo")) + (should (equal (file-name-base "/foo/bar") "bar")) + (should (equal (file-name-base "foo") "foo")) + (should (equal (file-name-base "foo/bar") "bar"))) + (ert-deftest files-test-dir-locals-auto-mode-alist () "Test an `auto-mode-alist' entry in `.dir-locals.el'" (find-file (ert-resource-file "whatever.quux")) @@ -1611,40 +1620,39 @@ on BUF-1 and BUF-2 after the `save-some-buffers' call. The test is repeated with `save-some-buffers-default-predicate' let-bound to PRED and passing nil as second arg of `save-some-buffers'." - (let* ((dir (make-temp-file "testdir" 'dir)) - (file-1 (expand-file-name "subdir-1/file.foo" dir)) - (file-2 (expand-file-name "subdir-2/file.bar" dir)) - (inhibit-message t) - buf-1 buf-2) - (unwind-protect - (progn - (make-empty-file file-1 'parens) - (make-empty-file file-2 'parens) - (setq buf-1 (find-file file-1) - buf-2 (find-file file-2)) - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf (insert "foobar\n"))) - ;; Run the test. - (with-current-buffer buf-1 - (let ((save-some-buffers-default-predicate def-pred-bind)) - (save-some-buffers t pred)) - (should (eq exp-1 (buffer-modified-p buf-1))) - (should (eq exp-2 (buffer-modified-p buf-2)))) - ;; Set both buffers as modified to run another test. - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf (set-buffer-modified-p t))) - ;; The result of this test must be identical as the previous one. - (with-current-buffer buf-1 - (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) - (save-some-buffers t nil)) - (should (eq exp-1 (buffer-modified-p buf-1))) - (should (eq exp-2 (buffer-modified-p buf-2))))) - ;; Clean up. - (dolist (buf (list buf-1 buf-2)) - (with-current-buffer buf - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (let* ((file-1 (expand-file-name "subdir-1/file.foo" dir)) + (file-2 (expand-file-name "subdir-2/file.bar" dir)) + (inhibit-message t) + buf-1 buf-2) + (unwind-protect + (progn + (make-empty-file file-1 'parens) + (make-empty-file file-2 'parens) + (setq buf-1 (find-file file-1) + buf-2 (find-file file-2)) + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (insert "foobar\n"))) + ;; Run the test. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate def-pred-bind)) + (save-some-buffers t pred)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2)))) + ;; Set both buffers as modified to run another test. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (set-buffer-modified-p t))) + ;; The result of this test must be identical as the previous one. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) + (save-some-buffers t nil)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2))))) + ;; Clean up. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))))))) (ert-deftest files-tests-save-some-buffers () "Test `save-some-buffers'. @@ -1807,6 +1815,12 @@ Prompt users for any modified buffer with `buffer-offer-save' non-nil." ;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored. (nil save-some-buffers-root ,nb-might-save)))))) +(ert-deftest test-file-name-split () + (should (equal (file-name-split "foo/bar") '("foo" "bar"))) + (should (equal (file-name-split "/foo/bar") '("" "foo" "bar"))) + (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))) + (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) + (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el index 0062a7d4cb6..4a3cc74c334 100644 --- a/test/lisp/format-spec-tests.el +++ b/test/lisp/format-spec-tests.el @@ -56,7 +56,7 @@ (ert-deftest format-spec-do-flags-truncate () "Test `format-spec--do-flags' truncation." - (let (flags) + (let ((flags nil)) (should (equal (format-spec--do-flags "" flags nil 0) "")) (should (equal (format-spec--do-flags "" flags nil 1) "")) (should (equal (format-spec--do-flags "a" flags nil 0) "")) @@ -75,7 +75,7 @@ (ert-deftest format-spec-do-flags-pad () "Test `format-spec--do-flags' padding." - (let (flags) + (let ((flags nil)) (should (equal (format-spec--do-flags "" flags 0 nil) "")) (should (equal (format-spec--do-flags "" flags 1 nil) " ")) (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el new file mode 100644 index 00000000000..ee1e01be4b2 --- /dev/null +++ b/test/lisp/gnus/gnus-group-tests.el @@ -0,0 +1,52 @@ +;;; gnus-group-tests.el --- Tests for gnus-group.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'gnus-group) +(require 'ert) + +(ert-deftest gnus-short-group-name () + (map-apply + (lambda (input expected) + (should (string-equal (gnus-short-group-name input) expected))) + '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03") + ("nndiary+diary:birthdays" . "diary:birthdays") + ("nnimap+email@example.com:test" . "email@example:test") + ("nnimap+email@example.com:234" . "email@example:234") + + ;; This is a very aggressive shortening of the left hand side. + ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234") + ("nntp+some.where.edu:soc.motss" . "some:s.motss") + ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general") + ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps") + + ;; nnimap groups. + ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas") + ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas" + . "email@banana:I/Bananas") + + ;; The "n" from "nnspool" is perhaps not optimal. + ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture")))) + +;;; gnus-group-tests.el ends here diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el index 0118bc354c4..348ddf9f056 100644 --- a/test/lisp/gnus/gnus-icalendar-tests.el +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -216,7 +216,7 @@ RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE DTSTAMP:20200915T120627Z ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com -ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE +ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com CREATED:20200325T095723Z DESCRIPTION:Coffee talk diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 4002501ddee..6ee7b4f3eb1 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -148,7 +148,7 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-describe-keymap/value () (describe-keymap minibuffer-local-must-match-map) (with-current-buffer "*Help*" - (should (looking-at "^key")))) + (should (looking-at "\nKey")))) (ert-deftest help-fns-test-describe-keymap/not-keymap () (should-error (describe-keymap nil)) @@ -158,7 +158,7 @@ Return first line of the output of (describe-function-1 FUNC)." (let ((foobar minibuffer-local-must-match-map)) (describe-keymap foobar) (with-current-buffer "*Help*" - (should (looking-at "^key"))))) + (should (looking-at "\nKey"))))) (ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 3d4293cd380..d27e3d7cd4d 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -65,7 +65,7 @@ result)))) (test-re (lambda (orig regexp) - (should (string-match (concat "^" regexp "$") + (should (string-match (concat "\\`" regexp "\\'") (substitute-command-keys orig)))))) ,@body)) @@ -88,41 +88,77 @@ (test "\\[emacs-version]\\[next-line]" "M-x emacs-versionC-n") (test-re "\\[emacs-version]`foo'" "M-x emacs-version[`'‘]foo['’]"))) -(ert-deftest help-tests-substitute-command-keys/keymaps () +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence () + "Literal replacement." (with-substitute-command-keys-test - (test "\\{minibuffer-local-must-match-map}" - "\ -key binding ---- ------- + (test "\\`C-m'" "C-m") + (test "\\`C-m'\\`C-j'" "C-mC-j") + (test "foo\\`C-m'bar\\`C-j'baz" "fooC-mbarC-jbaz"))) + +(ert-deftest help-tests-substitute-command-keys/literal-key-sequence-errors () + (should-error (substitute-command-keys "\\`'")) + (should-error (substitute-command-keys "\\`c-c'")) + (should-error (substitute-command-keys "\\`<foo bar baz>'"))) + +(ert-deftest help-tests-substitute-key-bindings/face-help-key-binding () + (should (eq (get-text-property 0 'face (substitute-command-keys "\\[next-line]")) + 'help-key-binding)) + (should (eq (get-text-property 0 'face (substitute-command-keys "\\`f'")) + 'help-key-binding))) + +(defvar-keymap help-tests--test-keymap + :doc "Just some keymap for testing." + "C-g" #'abort-minibuffers + "TAB" #'minibuffer-complete + "C-j" #'minibuffer-complete-and-exit + "RET" #'minibuffer-complete-and-exit + "SPC" #'minibuffer-complete-word + "?" #'minibuffer-completion-help + "C-<tab>" #'file-cache-minibuffer-complete + "<XF86Back>" #'previous-history-element + "<XF86Forward>" #'next-history-element + "<backtab>" #'minibuffer-complete + "<down>" #'next-line-or-history-element + "<next>" #'next-history-element + "<prior>" #'switch-to-completions + "<up>" #'previous-line-or-history-element + "M-v" #'switch-to-completions + "M-<" #'minibuffer-beginning-of-buffer + "M-n" #'next-history-element + "M-p" #'previous-history-element + "M-r" #'previous-matching-history-element + "M-s" #'next-matching-history-element + "M-g M-c" #'switch-to-completions) +(ert-deftest help-tests-substitute-command-keys/keymaps () + (with-substitute-command-keys-test + (test-re "\\{help-tests--test-keymap}" + " +Key Binding +-+ C-g abort-minibuffers TAB minibuffer-complete C-j minibuffer-complete-and-exit RET minibuffer-complete-and-exit -ESC Prefix Command SPC minibuffer-complete-word -? minibuffer-completion-help +\\? minibuffer-completion-help C-<tab> file-cache-minibuffer-complete <XF86Back> previous-history-element <XF86Forward> next-history-element +<backtab> minibuffer-complete <down> next-line-or-history-element <next> next-history-element <prior> switch-to-completions <up> previous-line-or-history-element -M-g Prefix Command -M-v switch-to-completions - -M-g ESC Prefix Command - M-< minibuffer-beginning-of-buffer M-n next-history-element M-p previous-history-element M-r previous-matching-history-element M-s next-matching-history-element +M-v switch-to-completions M-g M-c switch-to-completions - "))) (ert-deftest help-tests-substitute-command-keys/keymap-change () @@ -130,12 +166,11 @@ M-g M-c switch-to-completions (test "\\<minibuffer-local-must-match-map>\\[abort-recursive-edit]" "C-]") (test "\\<emacs-lisp-mode-map>\\[eval-defun]" "C-M-x"))) -(defvar help-tests-remap-map - (let ((map (make-keymap))) - (define-key map (kbd "x") 'foo) - (define-key map (kbd "y") 'bar) - (define-key map [remap foo] 'bar) - map)) +(defvar-keymap help-tests-remap-map + :full t + "x" 'foo + "y" 'bar + "<remap> <foo>" 'bar) (ert-deftest help-tests-substitute-command-keys/remap () (should (equal (substitute-command-keys "\\<help-tests-remap-map>\\[foo]") "y")) @@ -180,7 +215,7 @@ M-g M-c switch-to-completions (let ((text-quoting-style 'grave)) (test "\\=`x\\='" "`x'")))) -(ert-deftest help-tests-substitute-command-keys/no-change () +(ert-deftest help-tests-substitute-command-keys/no-change-2 () (with-substitute-command-keys-test (test "\\[foobar" "\\[foobar") (test "\\=" "\\="))) @@ -199,30 +234,28 @@ M-g M-c switch-to-completions (goto-char (point-min)) (should (looking-at "Type RET on")))) -(defvar help-tests-major-mode-map - (let ((map (make-keymap))) - (define-key map "x" 'foo-original) - (define-key map "1" 'foo-range) - (define-key map "2" 'foo-range) - (define-key map "3" 'foo-range) - (define-key map "4" 'foo-range) - (define-key map (kbd "C-e") 'foo-something) - (define-key map '[F1] 'foo-function-key1) - (define-key map "(" 'short-range) - (define-key map ")" 'short-range) - (define-key map "a" 'foo-other-range) - (define-key map "b" 'foo-other-range) - (define-key map "c" 'foo-other-range) - map)) +(defvar-keymap help-tests-major-mode-map + :full t + "x" 'foo-original + "1" 'foo-range + "2" 'foo-range + "3" 'foo-range + "4" 'foo-range + "C-e" 'foo-something + "<f1>" 'foo-function-key1 + "(" 'short-range + ")" 'short-range + "a" 'foo-other-range + "b" 'foo-other-range + "c" 'foo-other-range) (define-derived-mode help-tests-major-mode nil "Major mode for testing shadowing.") -(defvar help-tests-minor-mode-map - (let ((map (make-keymap))) - (define-key map "x" 'foo-shadow) - (define-key map (kbd "C-e") 'foo-shadow) - map)) +(defvar-keymap help-tests-minor-mode-map + :full t + "x" 'foo-shadow + "C-e" 'foo-shadow) (define-minor-mode help-tests-minor-mode "Minor mode for testing shadowing.") @@ -249,11 +282,10 @@ M-g M-c switch-to-completions (with-substitute-command-keys-test (with-temp-buffer (help-tests-major-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -261,7 +293,6 @@ a .. c foo-other-range C-e foo-something x foo-original <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/shadow () @@ -269,11 +300,10 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (help-tests-minor-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -283,7 +313,6 @@ C-e foo-something x foo-original (this binding is currently shadowed) <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/command-remap () @@ -292,15 +321,11 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (define-key help-tests-major-mode-map [remap foo] 'bar) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - -<remap> Prefix Command - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ <remap> <foo> bar - "))))) (ert-deftest help-tests-describe-map-tree/no-menu-t () @@ -312,12 +337,11 @@ key binding :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/no-menu-nil () (with-temp-buffer @@ -328,15 +352,13 @@ C-a foo :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -<menu-bar> Prefix Command -<menu-bar> <foo> foo - -"))))) +<menu-bar> <foo> foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-t () (with-temp-buffer @@ -345,14 +367,13 @@ C-a foo (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil t) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo (this binding is currently shadowed) -C-b bar - -"))))) +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-nil () (with-temp-buffer @@ -361,12 +382,11 @@ C-b bar (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-b bar - -"))))) + (should (string-match " +Key Binding +-+ +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-t () (with-temp-buffer @@ -374,12 +394,11 @@ C-b bar (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map t nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-nil () (with-temp-buffer @@ -387,13 +406,12 @@ C-a foo (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -C-b undefined - -"))))) +C-b undefined\n" + (buffer-string)))))) (defvar help-tests--was-in-buffer nil) diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image-dired-tests.el new file mode 100644 index 00000000000..3f0304ee405 --- /dev/null +++ b/test/lisp/image-dired-tests.el @@ -0,0 +1,37 @@ +;;; image-dired-tests.el --- Tests for image-dired.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'image-dired) + +(defun image-dired-test-image-file (name) + (expand-file-name + name (expand-file-name "data/image" + (or (getenv "EMACS_TEST_DIRECTORY") + "../")))) + +(ert-deftest image-dired-tests-get-exif-file-name () + (skip-unless (image-type-available-p 'jpeg)) + (let ((img (image-dired-test-image-file "black.jpg"))) + (should (equal (image-dired-get-exif-file-name img) + "2019_09_21_16_22_13_black.jpg")))) + +;;; image-dired-tests.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index d1ce890d795..6abfcfedcf4 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -28,6 +28,27 @@ (expand-file-name "images" data-directory) "Directory containing Emacs images.") +(defconst image-tests--files + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(expand-file-name "splash.pbm" + image-tests--emacs-images-directory)) + (png . ,(expand-file-name "splash.png" + image-tests--emacs-images-directory)) + (svg . ,(expand-file-name "splash.svg" + image-tests--emacs-images-directory)) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(expand-file-name "gnus/gnus.xbm" + image-tests--emacs-images-directory)) + (xpm . ,(expand-file-name "splash.xpm" + image-tests--emacs-images-directory)))) + (ert-deftest image--set-property () "Test `image--set-property' behavior." (let ((image (list 'image))) @@ -49,25 +70,53 @@ (should (equal image '(image))))) (ert-deftest image-find-image () - (find-image '((:type xpm :file "undo.xpm"))) - (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))) + (should (listp (find-image '((:type xpm :file "undo.xpm"))))) + (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))) + (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) (ert-deftest image-type-from-file-name () (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png))) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. (skip-unless (and (bound-and-true-p image-types) - (bound-and-true-p image-load-path))) + (bound-and-true-p image-load-path) + (image-type-available-p 'jpeg))) (should (eq (image-type "foo.jpg") 'jpeg))) -(ert-deftest image-type-from-file-header-test () +(defun image-tests--type-from-file-header (type) "Test image-type-from-file-header." - (should (eq (if (image-type-available-p 'svg) 'svg) - (image-type-from-file-header - (expand-file-name "splash.svg" - image-tests--emacs-images-directory))))) + (should (eq (if (image-type-available-p type) type) + (image-type-from-file-header (cdr (assq type image-tests--files)))))) + +(ert-deftest image-type-from-file-header-test/gif () + (image-tests--type-from-file-header 'gif)) + +(ert-deftest image-type-from-file-header-test/jpeg () + (image-tests--type-from-file-header 'jpeg)) + +(ert-deftest image-type-from-file-header-test/pbm () + (image-tests--type-from-file-header 'pbm)) + +(ert-deftest image-type-from-file-header-test/png () + (image-tests--type-from-file-header 'png)) + +(ert-deftest image-type-from-file-header-test/svg () + (image-tests--type-from-file-header 'svg)) + +(ert-deftest image-type-from-file-header-test/tiff () + (image-tests--type-from-file-header 'tiff)) + +(ert-deftest image-type-from-file-header-test/webp () + (image-tests--type-from-file-header 'webp)) + +(ert-deftest image-type-from-file-header-test/xbm () + (image-tests--type-from-file-header 'xbm)) + +(ert-deftest image-type-from-file-header-test/xpm () + (image-tests--type-from-file-header 'xpm)) (ert-deftest image-rotate () "Test `image-rotate'." diff --git a/test/lisp/image/exif-tests.el b/test/lisp/image/exif-tests.el index 18a9b5a3de0..d62eef4798d 100644 --- a/test/lisp/image/exif-tests.el +++ b/test/lisp/image/exif-tests.el @@ -28,24 +28,19 @@ (or (getenv "EMACS_TEST_DIRECTORY") "../../")))) -(defun exif-elem (exif elem) - (plist-get (seq-find (lambda (e) - (eq elem (plist-get e :tag-name))) - exif) - :value)) - (ert-deftest test-exif-parse () (let ((exif (exif-parse-file (test-image-file "black.jpg")))) - (should (equal (exif-elem exif 'make) "Panasonic")) - (should (equal (exif-elem exif 'orientation) 1)) - (should (equal (exif-elem exif 'x-resolution) '(180 . 1))))) + (should (equal (exif-field 'make exif) "Panasonic")) + (should (equal (exif-field 'orientation exif) 1)) + (should (equal (exif-field 'x-resolution exif) '(180 . 1))) + (should (equal (exif-field 'date-time exif) "2019:09:21 16:22:13")))) (ert-deftest test-exif-parse-short () (let ((exif (exif-parse-file (test-image-file "black-short.jpg")))) - (should (equal (exif-elem exif 'make) "thr")) - (should (equal (exif-elem exif 'model) "four")) - (should (equal (exif-elem exif 'software) "em")) - (should (equal (exif-elem exif 'artist) "z")))) + (should (equal (exif-field 'make exif) "thr")) + (should (equal (exif-field 'model exif) "four")) + (should (equal (exif-field 'software exif) "em")) + (should (equal (exif-field 'artist exif) "z")))) (ert-deftest test-exit-direct-ascii-value () (should (equal (exif--direct-ascii-value 28005 2 t) (string ?e ?m 0))) diff --git a/test/lisp/info-tests.el b/test/lisp/info-tests.el new file mode 100644 index 00000000000..3e2aa3e089d --- /dev/null +++ b/test/lisp/info-tests.el @@ -0,0 +1,39 @@ +;;; info-tests.el --- Tests for info.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'info) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-info-urls () + (should (equal (Info-url-for-node "(emacs)Minibuffer") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer.html")) + (should (equal (Info-url-for-node "(emacs)Minibuffer File") + "https://www.gnu.org/software/emacs/manual/html_node/emacs/Minibuffer-File.html")) + (should (equal (Info-url-for-node "(elisp)Backups and Auto-Saving") + "https://www.gnu.org/software/emacs/manual/html_node/elisp/Backups-and-Auto_002dSaving.html")) + (should-error (Info-url-for-node "(gnus)Minibuffer File"))) + +;;; info-tests.el ends here diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index ba1ebac5dc7..acfd6e82f16 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'info-xref) (defun info-xref-test-internal (body result) @@ -96,15 +97,17 @@ text. (ert-deftest info-xref-test-makeinfo () "Test that info-xref can parse basic makeinfo output." (skip-unless (executable-find "makeinfo")) - (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) - (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) - (errflag t)) - (unwind-protect - (progn - ;; tempfile contains xrefs to various things, including tempfile2. - (info-xref-test-write-file - tempfile - (concat "\ + (ert-with-temp-file tempfile + :suffix ".texi" + (ert-with-temp-file tempfile2 + :suffix ".texi" + (let ((errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ @xref{nodename,,,missing,Missing Manual}. @xref{nodename,crossref,title,missing,Missing Manual}. @@ -114,35 +117,36 @@ text. @xref{Chapter One,Something}. " - (format "@xref{Chapter One,,,%s,Present Manual}.\n" - (file-name-sans-extension (file-name-nondirectory - tempfile2))))) - ;; Something for tempfile to xref to. - (info-xref-test-write-file tempfile2 "") - (require 'info) - (save-window-excursion - (let ((Info-directory-list - (list - (or (file-name-directory tempfile) "."))) - Info-additional-directory-list) - (info-xref-check (format "%s.info" (file-name-sans-extension - tempfile)))) - (should (equal (list info-xref-bad info-xref-good - info-xref-unavail) - '(0 1 2))) - (setq errflag nil) - ;; If there was an error, we can leave this around. - (kill-buffer info-xref-output-buffer))) - ;; Useful diagnostic in case of problems. - (if errflag - (with-temp-buffer - (call-process "makeinfo" nil t nil "--version") - (message "%s" (buffer-string)))) - (mapc 'delete-file (list tempfile tempfile2 - (format "%s.info" (file-name-sans-extension - tempfile)) - (format "%s.info" (file-name-sans-extension - tempfile2))))))) + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile2))))))))) (ert-deftest info-xref-test-emacs-manuals () "Test that all internal links in the Emacs manuals work." diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index e1eabeb9591..c62a2a501ba 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -91,33 +91,30 @@ body in KEYS-AND-BODY." ,docstring ,@keys (kmacro-tests-with-kmacro-clean-slate ,@body)))) -(defvar kmacro-tests-keymap - (let ((map (make-sparse-keymap))) - (dotimes (i 26) - (define-key map (string (+ ?a i)) 'self-insert-command)) - (dotimes (i 10) - (define-key map (string (+ ?0 i)) 'self-insert-command)) - ;; Define a few key sequences of different lengths. - (dolist (item '(("\C-a" . beginning-of-line) - ("\C-b" . backward-char) - ("\C-e" . end-of-line) - ("\C-f" . forward-char) - ("\C-r" . isearch-backward) - ("\C-u" . universal-argument) - ("\C-w" . kill-region) - ("\C-SPC" . set-mark-command) - ("\M-w" . kill-ring-save) - ("\M-x" . execute-extended-command) - ("\C-cd" . downcase-word) - ("\C-cxu" . upcase-word) - ("\C-cxq" . quoted-insert) - ("\C-cxi" . kmacro-insert-counter) - ("\C-x\C-k" . kmacro-keymap))) - (define-key map (car item) (cdr item))) - map) - "Keymap to use for testing keyboard macros. +(defvar-keymap kmacro-tests-keymap + :doc "Keymap to use for testing keyboard macros. This is used to obtain consistent results even if tests are run -in an environment with rebound keys.") +in an environment with rebound keys." + ;; Define a few key sequences of different lengths. + "C-a" 'beginning-of-line + "C-b" 'backward-char + "C-e" 'end-of-line + "C-f" 'forward-char + "C-r" 'isearch-backward + "C-u" 'universal-argument + "C-w" 'kill-region + "C-SPC" 'set-mark-command + "M-w" 'kill-ring-save + "M-x" 'execute-extended-command + "C-c d" 'downcase-word + "C-c x u" 'upcase-word + "C-c x q" 'quoted-insert + "C-c x i" 'kmacro-insert-counter + "C-x C-k" 'kmacro-keymap) +(dotimes (i 26) + (keymap-set kmacro-tests-keymap (string (+ ?a i)) 'self-insert-command)) +(dotimes (i 10) + (keymap-set kmacro-tests-keymap (string (+ ?0 i)) 'self-insert-command)) (defvar kmacro-tests-events nil "Input events used by the kmacro test in progress.") diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index 2cfd3576a94..3e23fc74540 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ls-lisp) (require 'dired) @@ -53,28 +54,29 @@ (kill-buffer buf) (setq buf (dired (nconc (list dir) files))) (should (looking-at "src")) - (next-line) ; File names must be aligned. + (with-suppressed-warnings ((interactive-only next-line)) + (next-line)) ; File names must be aligned. (should (looking-at "src"))) (when (buffer-live-p buf) (kill-buffer buf))))) (ert-deftest ls-lisp-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - ls-lisp-use-insert-directory-program buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + :suffix "bug27631" + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + ls-lisp-use-insert-directory-program buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest ls-lisp-test-bug27693 () "Test for https://debbugs.gnu.org/27693 ." diff --git a/test/lisp/mail/mail-utils-tests.el b/test/lisp/mail/mail-utils-tests.el index 4b2d2d7e005..29a9b9eeb96 100644 --- a/test/lisp/mail/mail-utils-tests.el +++ b/test/lisp/mail/mail-utils-tests.el @@ -85,7 +85,8 @@ "foo@example.org\\|bar@example.org\\|baz@example.org"))) (ert-deftest mail-utils-tests-mail-rfc822-time-zone () - (should (stringp (mail-rfc822-time-zone (current-time))))) + (with-suppressed-warnings ((obsolete mail-rfc822-time-zone)) + (should (stringp (mail-rfc822-time-zone (current-time)))))) (ert-deftest mail-utils-test-mail-rfc822-date/contains-year () (should (string-match (rx " 20" digit digit " ") diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el index a58a4d9e6f6..7946e99dbc9 100644 --- a/test/lisp/mail/uudecode-tests.el +++ b/test/lisp/mail/uudecode-tests.el @@ -50,14 +50,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-internal (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-internal (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str))))) (ert-deftest uudecode-tests-decode-region-external () ;; Write to buffer @@ -68,14 +65,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-external (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-external (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str)))))) (provide 'uudecode-tests) ;;; uudecode-tests.el ends here diff --git a/test/lisp/mh-e/mh-thread-tests.el b/test/lisp/mh-e/mh-thread-tests.el new file mode 100644 index 00000000000..4f09677e53f --- /dev/null +++ b/test/lisp/mh-e/mh-thread-tests.el @@ -0,0 +1,131 @@ +;;; mh-thread-tests.el --- tests for mh-thread.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'mh-thread) +(eval-when-compile (require 'cl-lib)) + +(defun mh-thread-tests-before-from () + "Generate the fields of a scan line up to where the 'From' field would start. +The exact contents are not important, but the number of characters is." + (concat (make-string mh-cmd-note ?9) + (make-string mh-scan-cmd-note-width ?A) + (make-string mh-scan-destination-width ?t) + (make-string mh-scan-date-width ?/) + (make-string mh-scan-date-flag-width ?*))) + +;;; Tests of support routines + +(ert-deftest mh-thread-current-indentation-level () + "Test that `mh-thread-current-indentation-level' identifies the level." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] Subject of msg 1\n") + (insert (mh-thread-tests-before-from) " [Sender Two] Subject of msg 2\n") + (goto-char (point-min)) + (should (equal 0 (mh-thread-current-indentation-level))) + (forward-line) + (should (equal 2 (mh-thread-current-indentation-level))))) + +(ert-deftest mh-thread-find-children () + "Test `mh-thread-find-children'." + (let (expected-start expected-end) + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender One] line 1\n") + (setq expected-start (point)) + (insert (mh-thread-tests-before-from) " [Sender Two] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 4\n") + (setq expected-end (1- (point))) + (insert (mh-thread-tests-before-from) " [Sender Five] line 5\n") + (goto-char (1+ expected-start)) + (should (equal (list expected-start expected-end) + (mh-thread-find-children)))))) + +(ert-deftest mh-thread-immediate-ancestor () + "Test that `mh-thread-immediate-ancestor' moves to the correct message." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 3)) ;goes up only one level at a time + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)) + (mh-thread-immediate-ancestor) + (should (equal (line-number-at-pos) 2)))) ;no further motion at thread root + +;;; Tests of MH-Folder Commands + +(ert-deftest mh-thread-sibling-and-ancestor () + "Test motion by `mh-thread-ancestor' and `mh-thread-next-sibling'." + (with-temp-buffer + (insert (mh-thread-tests-before-from) "[Sender Other] line 1\n") + (insert (mh-thread-tests-before-from) "[Sender One] line 2\n") + (insert (mh-thread-tests-before-from) " [Sender Two] line 3\n") + (insert (mh-thread-tests-before-from) " [Sender Three] line 4\n") + (insert (mh-thread-tests-before-from) " [Sender Four] line 5\n") + (insert (mh-thread-tests-before-from) " [Sender Five] line 6\n") + (forward-line -1) + (let ((mh-view-ops '(unthread)) + (show-count 0)) + (cl-letf (((symbol-function 'mh-maybe-show) + (lambda () + (setq show-count (1+ show-count))))) + (should (equal (line-number-at-pos) 6)) + ;; test mh-thread-ancestor + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 4)) ;skips over sibling + (should (equal show-count 1)) + (mh-thread-ancestor t) + (should (equal (line-number-at-pos) 2)) ;root flag skips to root + (should (equal show-count 2)) + (mh-thread-ancestor) + (should (equal (line-number-at-pos) 2)) ;do not move from root + (should (equal show-count 2)) ;do not re-show at root + ;; test mh-thread-sibling + (mh-thread-next-sibling) + (should (equal (line-number-at-pos) 2)) ;no next sibling, no motion + (should (equal show-count 2)) ;no sibling, no show + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) + (should (equal show-count 3)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 1)) ;no previous sibling + (should (equal show-count 3)) + (goto-char (point-max)) + (forward-line -1) + (should (equal (line-number-at-pos) 6)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) + (should (equal show-count 4)) + (mh-thread-next-sibling t) + (should (equal (line-number-at-pos) 5)) ;no previous sibling + (should (equal show-count 4)) + )))) + +;;; mh-thread-tests.el ends here diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el index b1a892b8530..07086172595 100644 --- a/test/lisp/mh-e/mh-utils-tests.el +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -80,6 +80,54 @@ (mh-normalize-folder-name "+inbox////../news/" nil t))) (should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news")))) +(ert-deftest mh-sub-folders-parse-no-folder () + "Test `mh-sub-folders-parse' with no starting folder." + (let (others-position) + (with-temp-buffer + (insert "lines without has-string are ignored\n") + (insert "onespace has no messages.\n") + (insert "twospace has no messages.\n") + (insert " precedingblanks has no messages.\n") + (insert ".leadingdot has no messages.\n") + (insert "#leadinghash has no messages.\n") + (insert ",leadingcomma has no messages.\n") + (insert "withothers has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (insert "curf has no messages.\n") + (insert "curf+ has 123 messages.\n") + (insert "curf2+ has 17 messages.\n") + (insert "\ntotal after blank line is ignored has no messages.\n") + (should (equal + (mh-sub-folders-parse nil "curf+") + (list '("onespace") '("twospace") '("precedingblanks") + (cons "withothers" others-position) + '("curf") '("curf") '("curf2+"))))))) + +(ert-deftest mh-sub-folders-parse-relative-folder () + "Test `mh-sub-folders-parse' with folder." + (let (others-position) + (with-temp-buffer + (insert "testf+ has no messages.\n") + (insert "testf/sub1 has no messages.\n") + (insert "testf/sub2 has no messages ; (others)") + (setq others-position (point)) + (insert ".\n") + (should (equal + (mh-sub-folders-parse "+testf" "testf+") + (list '("sub1") (cons "sub2" others-position))))))) + +(ert-deftest mh-sub-folders-parse-root-folder () + "Test `mh-sub-folders-parse' with root folder." + (with-temp-buffer + (insert "/+ has no messages.\n") + (insert "/ has no messages.\n") + (insert "//nmh-style has no messages.\n") + (insert "/mu-style has no messages.\n") + (should (equal + (mh-sub-folders-parse "+/" "inbox+") + '(("") ("nmh-style") ("mu-style")))))) + ;; Folder names that are used by the following tests. (defvar mh-test-rel-folder "rela-folder") @@ -211,6 +259,10 @@ The tests use this method if no configured MH variant is found." "/abso-folder/bar has no messages." "/abso-folder/foo has no messages." "/abso-folder/food has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+/") . + ("/+ has no messages ; (others)." + "/abso-folder has no messages ; (others)." + "/tmp has no messages ; (others).")) )) (arglist (cons (file-name-base program) args))) (let ((response-list-cons (assoc arglist argument-responses))) @@ -303,6 +355,15 @@ if `mh-test-utils-debug-mocks' is non-nil." (message "file-directory-p: %S -> %s" filename result)) result)) +(defun mh-test-variant-handles-plus-slash (variant) + "Returns non-nil if this MH variant handles \"folders +/\". +Mailutils 3.5, 3.7, and 3.13 are known not to." + (cond ((not (stringp variant))) ;our mock handles it + ((string-search "GNU Mailutils" variant) + (let ((mu-version (string-remove-prefix "GNU Mailutils " variant))) + (version<= "3.13.91" mu-version))) + (t))) ;no other known failures + (ert-deftest mh-sub-folders-actual () "Test `mh-sub-folders-actual'." @@ -310,14 +371,15 @@ if `mh-test-utils-debug-mocks' is non-nil." ;; already been normalized with ;; (mh-normalize-folder-name folder nil nil t) (with-mh-test-env - (should (equal + (should (member mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil))))) + (mapcar (lambda (x) (car x)) (mh-sub-folders-actual nil)))) ;; Empty string and "+" not tested since mh-normalize-folder-name ;; would change them to nil. - (should (equal "foo" - (car (assoc "foo" (mh-sub-folders-actual - (format "+%s" mh-test-rel-folder)))))) + (should (member "foo" + (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual + (format "+%s" mh-test-rel-folder))))) ;; Folder with trailing slash not tested since ;; mh-normalize-folder-name would strip it. (should (equal @@ -328,6 +390,10 @@ if `mh-test-utils-debug-mocks' is non-nil." (list (list "bar") (list "foo") (list "food")) (mh-sub-folders-actual (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" (mapcar (lambda (x) (car x)) + (mh-sub-folders-actual "+/"))))) + ;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a ;; nonexistent folder. ;; (should (equal nil @@ -339,13 +405,12 @@ if `mh-test-utils-debug-mocks' is non-nil." (ert-deftest mh-sub-folders () "Test `mh-sub-folders'." (with-mh-test-env - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders nil))))) - (should (equal mh-test-rel-folder - (car (assoc mh-test-rel-folder (mh-sub-folders ""))))) - (should (equal nil - (car (assoc mh-test-no-such-folder (mh-sub-folders - "+"))))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders nil)))) + (should (member mh-test-rel-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "")))) + (should-not (member mh-test-no-such-folder + (mapcar (lambda (x) (car x)) (mh-sub-folders "+")))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) @@ -356,6 +421,9 @@ if `mh-test-utils-debug-mocks' is non-nil." (mh-sub-folders (format "+%s/foo" mh-test-rel-folder)))) (should (equal (list (list "bar") (list "foo") (list "food")) (mh-sub-folders (format "+%s" mh-test-abs-folder)))) + (when (mh-test-variant-handles-plus-slash mh-variant-in-use) + (should (member "tmp" + (mapcar (lambda (x) (car x)) (mh-sub-folders "+/"))))) ;; FIXME: mh-sub-folders doesn't (yet) expect to be given a ;; nonexistent folder. @@ -437,18 +505,20 @@ and the `should' macro requires idempotent evaluation anyway." (ert-deftest mh-folder-completion-function-08-plus-slash () "Test `mh-folder-completion-function' with `+/'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil) - ;; case "bb" - (with-mh-test-env - (should (equal nil - (member (format "+%s/" mh-test-rel-folder) - (mh-folder-completion-function "+/" nil t)))))) + (with-mh-test-env + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) + (mh-test-folder-completion-1 "+/" "+/" "tmp/" t) + ;; case "bb" + (with-mh-test-env + (should (equal nil + (member (format "+%s/" mh-test-rel-folder) + (mh-folder-completion-function "+/" nil t)))))) (ert-deftest mh-folder-completion-function-09-plus-slash-tmp () "Test `mh-folder-completion-function' with `+/tmp'." - :expected-result :failed ;to be fixed in a patch by mkupfer - (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t)) + (with-mh-test-env + (skip-unless (mh-test-variant-handles-plus-slash mh-variant-in-use))) + (mh-test-folder-completion-1 "+/tmp" "+/tmp/" "tmp/" t)) (ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () "Test `mh-folder-completion-function' with `+/abso-folder'." diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh index 6693a8a3e97..3789a5fdedc 100755 --- a/test/lisp/mh-e/test-all-mh-variants.sh +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -79,12 +79,10 @@ for path in "${mh_sys_path[@]}"; do continue fi fi - echo "Testing with PATH $path" + echo "** Testing with PATH $path" ((++tests_total)) - # The LD_LIBRARY_PATH setting is needed - # to run locally installed Mailutils. TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ - LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ + HOME=/nonexistent \ "${emacs[@]}" -l ert \ --eval "(setq load-prefer-newer t)" \ --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el index e0a0fec0fb9..8f180f3d6bb 100644 --- a/test/lisp/net/browse-url-tests.el +++ b/test/lisp/net/browse-url-tests.el @@ -28,6 +28,7 @@ (require 'browse-url) (require 'ert) +(require 'ert-x) (ert-deftest browse-url-tests-browser-kind () (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") @@ -87,11 +88,10 @@ "ftp://foo/"))) (ert-deftest browse-url-tests-delete-temp-file () - (let ((browse-url-temp-file-name - (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file browse-url-temp-file-name (browse-url-delete-temp-file) (should-not (file-exists-p browse-url-temp-file-name))) - (let ((file (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file file (browse-url-delete-temp-file file) (should-not (file-exists-p file)))) diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index f5280092c69..f14ee20a302 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -30,6 +30,14 @@ (require 'gnutls) (require 'hex-util) +(declare-function gnutls-symmetric-decrypt "gnutls.c") +(declare-function gnutls-symmetric-encrypt "gnutls.c") +(declare-function gnutls-hash-mac "gnutls.c") +(declare-function gnutls-hash-digest "gnutls.c") +(declare-function gnutls-ciphers "gnutls.c") +(declare-function gnutls-digests "gnutls.c") +(declare-function gnutls-macs "gnutls.c") + (defvar gnutls-tests-message-prefix "") (defsubst gnutls-tests-message (format-string &rest args) diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index 22c353928c3..8e83f405bcc 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,7 +48,7 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) -(ert-deftest test-netrc-credentials () +(ert-deftest test-netrc-credentials-2 () (let ((netrc-file (ert-resource-file "netrc-folding"))) (should (equal (netrc-parse netrc-file) diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index e10d81a756a..1bdc35da195 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -32,6 +32,8 @@ ;; 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' +(declare-function gnutls-peer-status "gnutls.c") + (ert-deftest make-local-unix-server () (skip-unless (featurep 'make-network-process '(:family local))) (let* ((file (make-temp-name "/tmp/server-test")) diff --git a/test/lisp/net/ntlm-tests.el b/test/lisp/net/ntlm-tests.el index b96228426bd..f7407032323 100644 --- a/test/lisp/net/ntlm-tests.el +++ b/test/lisp/net/ntlm-tests.el @@ -227,6 +227,8 @@ This string will be returned from the NTLM server to the NTLM client." ;; Silence some byte-compiler warnings that occur when ;; web-server/web-server.el is not found. +(eval-when-compile (cl-pushnew 'headers eieio--known-slot-names) + (cl-pushnew 'process eieio--known-slot-names)) (declare-function ws-send nil) (declare-function ws-parse-request nil) (declare-function ws-start nil) diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 8689bbf2a85..c6f9474f65a 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -61,4 +61,11 @@ ;; Only allowed in unrestricted. (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) +(ert-deftest puny-normalize () + (should (equal (puny-encode-string (string-glyph-compose "Bä.com")) + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") + "xn--b.com-gra")) + (should (equal (puny-encode-string "Bä.com") "xn--b.com-gra"))) + ;;; puny-tests.el ends here diff --git a/test/lisp/net/secrets-tests.el b/test/lisp/net/secrets-tests.el index a02e926a79a..7e66774701c 100644 --- a/test/lisp/net/secrets-tests.el +++ b/test/lisp/net/secrets-tests.el @@ -57,8 +57,11 @@ (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))) + ;; If the "session" collection does not exist, a `dbus-error' is + ;; fired, which we ignore. + (dbus-ignore-errors + (dolist (item (secrets-list-items "session")) + (secrets-delete-item "session" item)))) (ert-deftest secrets-test01-sessions () "Test opening / closing a secrets session." @@ -93,7 +96,7 @@ (unwind-protect (progn (should (secrets-open-session)) - (should (member "session" (secrets-list-collections))) + (skip-unless (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 @@ -153,6 +156,7 @@ (unwind-protect (let (item-path) (should (secrets-open-session)) + (skip-unless (member "session" (secrets-list-collections))) ;; Cleanup. There could be items in the "session" collection. (secrets--test-delete-all-session-items) @@ -214,6 +218,7 @@ (unwind-protect (progn (should (secrets-open-session)) + (skip-unless (member "session" (secrets-list-collections))) ;; Cleanup. There could be items in the "session" collection. (secrets--test-delete-all-session-items) diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index e71bd025de9..821ca5ca636 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -27,6 +27,8 @@ (require 'ert-x) (require 'shr) +(declare-function libxml-parse-html-region "xml.c") + (defun shr-test (name) (with-temp-buffer (insert-file-contents (format (concat (ert-resource-directory) "/%s.html") name)) diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 5bdae2a760a..254595d1b4f 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -122,12 +122,6 @@ the origin of the temporary TMPFILE, have no write permissions." (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 @@ -433,7 +427,7 @@ This checks also `file-name-as-directory', `file-name-directory', (setq tmp-name (file-local-copy (expand-file-name "what" tramp-archive-test-archive))) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (tramp-archive--test-delete tmp-name)) @@ -461,7 +455,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-file-contents (expand-file-name "what" tramp-archive-test-archive)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -552,11 +546,9 @@ This checks also `file-name-as-directory', `file-name-directory', (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)) + (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)) @@ -621,13 +613,11 @@ This checks also `file-name-as-directory', `file-name-directory', (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 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)) @@ -655,7 +645,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should-error (insert-directory (expand-file-name "baz" tramp-archive-test-archive) nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -715,7 +705,7 @@ This tests also `access-file', `file-readable-p' and `file-regular-p'." ;; Check error case. (should-error (access-file tmp-name4 "error") - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) @@ -854,38 +844,27 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." ;; Cleanup. (tramp-archive-cleanup-hash)))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-archive-test40-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)))) + (should (stringp (temporary-file-directory))) + (should-not (tramp-archive-file-name-p (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"))) + (setq tmp-file (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))) + (setq tmp-file (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)) @@ -909,7 +888,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (zerop (nth 1 fsi)) (zerop (nth 2 fsi)))))) -(ert-deftest tramp-archive-test45-auto-load () +(ert-deftest tramp-archive-test46-auto-load () "Check that `tramp-archive' autoloads properly." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) @@ -949,7 +928,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code file)))))))))) -(ert-deftest tramp-archive-test45-delay-load () +(ert-deftest tramp-archive-test46-delay-load () "Check that `tramp-archive' is loaded lazily, only when needed." :tags '(:expensive-test) (skip-unless tramp-archive-enabled) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 8e11e509b59..ea0ff3c760e 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,8 +43,10 @@ (require 'cl-lib) (require 'dired) +(require 'dired-aux) (require 'ert) (require 'ert-x) +(require 'seq) ; For `seq-random-elt', autoloaded since Emacs 28.1 (require 'trace) (require 'tramp) (require 'vc) @@ -74,11 +76,6 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 25. -(defvar connection-local-criteria-alist) -(defvar connection-local-profile-alist) -;; Needed for Emacs 26. -(defvar async-shell-command-width) ;; Needed for Emacs 27. (defvar process-file-return-signal-string) (defvar shell-command-dont-erase-buffer) @@ -160,13 +157,6 @@ 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. @@ -222,8 +212,7 @@ is greater than 10. (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) (untrace-all) (dolist (buf (tramp-list-tramp-buffers)) - (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string))) + (message ";; %s\n%s" buf (tramp-get-buffer-string buf)) (kill-buffer buf)))))) (defsubst tramp--test-message (fmt-string &rest arguments) @@ -243,8 +232,7 @@ is greater than 10. (unwind-protect (progn ,@body) (tramp--test-message - "%s %f sec" - ,message (float-time (time-subtract (current-time) start)))))) + "%s %f sec" ,message (float-time (time-subtract nil start)))))) ;; `always' is introduced with Emacs 28.1. (defalias 'tramp--test-always @@ -2083,44 +2071,41 @@ Also see `ignore'." (substitute-in-file-name "/method:host:/:/path//foo") "/method:host:/:/path//foo")) - ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 25, occasionally. No idea what's up. - (when (tramp--test-emacs26-p) - (should - (string-equal - (substitute-in-file-name (concat "/method:host://~" foo)) - (concat "/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/~" foo)) - (concat "/method:host:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/path//~" foo)) - (concat "/~" 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 (concat "/method:host:/path/~" foo)) - (concat "/method:host:/path/~" foo))) - ;; Quoting local part. - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/://~" foo)) - (concat "/method:host:/://~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/~" foo)) - (concat "/method:host:/:/~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) - (concat "/method:host:/:/path//~" foo))) - (should - (string-equal - (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) - (concat "/method:host:/:/path/~" foo)))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host://~" foo)) + (concat "/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/~" foo)) + (concat "/method:host:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/path//~" foo)) + (concat "/~" 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 (concat "/method:host:/path/~" foo)) + (concat "/method:host:/path/~" foo))) + ;; Quoting local part. + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/://~" foo)) + (concat "/method:host:/://~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/~" foo)) + (concat "/method:host:/:/~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path//~" foo)) + (concat "/method:host:/:/path//~" foo))) + (should + (string-equal + (substitute-in-file-name (concat "/method:host:/:/path/~" foo)) + (concat "/method:host:/:/path/~" foo))) (let (process-environment) (should @@ -2294,11 +2279,51 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) +(ert-deftest tramp-test07-abbreviate-file-name () + "Check that Tramp abbreviates file names correctly." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-emacs29-p)) + (skip-unless (not (tramp--test-ange-ftp-p))) + + (let* ((remote-host (file-remote-p tramp-test-temporary-file-directory)) + ;; Not all methods can expand "~". + (home-dir (ignore-errors (expand-file-name (concat remote-host "~"))))) + (skip-unless home-dir) + + ;; Check home-dir abbreviation. + (unless (string-suffix-p "~" home-dir) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/foo/bar"))) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) + (concat remote-host "/nowhere/special")))) + + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist + `((,(concat "\\`" (regexp-quote home-dir) "/foo") + . ,(concat home-dir "/f")) + (,(concat "\\`" (regexp-quote remote-host) "/nowhere") + . ,(concat remote-host "/nw"))))) + (should (equal (abbreviate-file-name (concat home-dir "/foo/bar")) + (concat remote-host "~/f/bar"))) + (should (equal (abbreviate-file-name + (concat remote-host "/nowhere/special")) + (concat remote-host "/nw/special")))) + + ;; Check that home-dir abbreviation doesn't occur when home-dir is just "/". + (setq home-dir (concat remote-host "/")) + ;; The remote home directory is kept in the connection property + ;; "home-directory". We fake this setting. + (tramp-set-connection-property tramp-test-vec "home-directory" home-dir) + (should (equal (concat home-dir "foo/bar") + (abbreviate-file-name (concat home-dir "foo/bar")))) + (tramp-flush-connection-property tramp-test-vec "home-directory"))) + (ert-deftest tramp-test07-file-exists-p () "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-p) '(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) @@ -2306,8 +2331,10 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-not (file-exists-p tmp-name)) - ;; Trashing files doesn't work on MS Windows, and for crypted remote files. - (unless (or (tramp--test-windows-nt-p) (tramp--test-crypt-p)) + ;; Trashing files doesn't work when `system-move-file-to-trash' + ;; is defined (on MS Windows and macOS), and for crypted remote + ;; files. + (unless (or (fboundp 'system-move-file-to-trash) (tramp--test-crypt-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2331,7 +2358,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-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) tmp-name2) (unwind-protect @@ -2352,7 +2379,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name2) (should-error (setq tmp-name2 (file-local-copy tmp-name1)) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors @@ -2363,7 +2390,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-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (with-temp-buffer @@ -2391,7 +2418,7 @@ This checks also `file-name-as-directory', `file-name-directory', (delete-file tmp-name) (should-error (insert-file-contents tmp-name) - :type tramp-file-missing)) + :type 'file-missing)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2400,7 +2427,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-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (inhibit-message t)) (unwind-protect @@ -2462,23 +2489,20 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (buffer-string) "34"))) ;; Check message. - ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1. - (with-no-warnings (when (symbol-plist 'ert-with-message-capture) - (let (inhibit-message) - (dolist - (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) - (dolist (visit '(nil t "string" no-message)) - (ert-with-message-capture tramp--test-messages - (write-region "foo" nil tmp-name nil visit) - ;; We must check the last line. There could be - ;; other messages from the progress reporter. - (should - (string-match-p - (if (and (null noninteractive) - (or (eq visit t) (null visit) (stringp visit))) - (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) - "^\\'") - tramp--test-messages)))))))) + (let (inhibit-message) + (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) + (dolist (visit '(nil t "string" no-message)) + (ert-with-message-capture tramp--test-messages + (write-region "foo" nil tmp-name nil visit) + ;; We must check the last line. There could be + ;; other messages from the progress reporter. + (should + (string-match-p + (if (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (format "^Wrote %s\n\\'" (regexp-quote tmp-name)) + "^\\'") + tramp--test-messages)))))) ;; We do not test lockname here. See ;; `tramp-test39-make-lock-file-name'. @@ -2488,17 +2512,15 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Ange-FTP. ((symbol-function 'yes-or-no-p) #'tramp--test-always)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - ;; `mustbenew' is passed to Tramp since Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (cl-letf (((symbol-function #'y-or-n-p) #'ignore) - ;; Ange-FTP. - ((symbol-function #'yes-or-no-p) #'ignore)) - (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) - :type 'file-already-exists) - (should-error - (write-region "foo" nil tmp-name nil nil nil 'excl) - :type 'file-already-exists))) + (should-error + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) + ;; Ange-FTP. + ((symbol-function #'yes-or-no-p) #'ignore)) + (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) + :type 'file-already-exists) + (should-error + (write-region "foo" nil tmp-name nil nil nil 'excl) + :type 'file-already-exists)) ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) @@ -2541,8 +2563,9 @@ 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)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (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)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2561,7 +2584,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (copy-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (copy-file source target) @@ -2569,7 +2592,7 @@ This checks also `file-name-as-directory', `file-name-directory', (with-temp-buffer (insert-file-contents target) (should (string-equal (buffer-string) "foo"))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists)) @@ -2587,8 +2610,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test-p) (should-error (copy-file source target) :type 'file-already-exists) @@ -2653,8 +2675,9 @@ 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)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (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)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -2673,7 +2696,7 @@ This checks also `file-name-as-directory', `file-name-directory', (progn (should-error (rename-file source target) - :type tramp-file-missing) + :type 'file-missing) (write-region "foo" nil source) (should (file-exists-p source)) (rename-file source target) @@ -2684,7 +2707,7 @@ 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)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists)) @@ -2702,8 +2725,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (file-exists-p source)) (make-directory target) (should (file-directory-p target)) - ;; This has been changed in Emacs 26.1. - (when (and (tramp--test-expensive-test) (tramp--test-emacs26-p)) + (when (tramp--test-expensive-test-p) (should-error (rename-file source target) :type 'file-already-exists) @@ -2771,7 +2793,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-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) (unusual-file-mode-1 #o740) @@ -2809,7 +2831,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-p) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (expand-file-name "foo" tmp-name1))) ;; Delete empty directory. @@ -2833,9 +2855,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should-not (file-directory-p tmp-name1)) ;; Trashing directories works only since Emacs 27.1. It doesn't - ;; work on MS Windows, for crypted remote directories and for ange-ftp. - (when (and (not (tramp--test-windows-nt-p)) (not (tramp--test-crypt-p)) - (not (tramp--test-ftp-p)) (tramp--test-emacs27-p)) + ;; work when `system-move-file-to-trash' is defined (on MS + ;; Windows and macOS), for crypted remote directories and for + ;; ange-ftp. + (when (and (not (fboundp 'system-move-file-to-trash)) + (not (tramp--test-crypt-p)) (not (tramp--test-ftp-p)) + (tramp--test-emacs27-p)) (let ((trash-directory (tramp--test-make-temp-name 'local quoted)) (delete-by-moving-to-trash t)) (make-directory trash-directory) @@ -2881,9 +2906,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test15-copy-directory () "Check `copy-directory'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(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 @@ -2898,7 +2923,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (copy-directory tmp-name1 tmp-name2) - :type tramp-file-missing) + :type 'file-missing) ;; Copy empty directory. (make-directory tmp-name1) (write-region "foo" nil tmp-name4) @@ -2908,11 +2933,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (should (file-directory-p tmp-name2)) (should (file-exists-p tmp-name5)) ;; Target directory does exist already. - ;; This has been changed in Emacs 26.1. - (when (tramp--test-emacs26-p) - (should-error - (copy-directory tmp-name1 tmp-name2) - :type 'file-already-exists)) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-already-exists) (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) (should (file-directory-p tmp-name3)) (should (file-exists-p tmp-name6))) @@ -2994,7 +3017,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-p) '(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))) @@ -3002,7 +3025,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (progn (should-error (directory-files tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (write-region "foo" nil tmp-name2) (write-region "bla" nil tmp-name3) @@ -3038,7 +3061,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-p) '(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)) @@ -3108,7 +3131,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Emacs 27.1. (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3125,14 +3148,12 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (insert-directory tmp-name1 nil) (goto-char (point-min)) (should (looking-at-p (regexp-quote tmp-name1)))) - ;; This has been fixed in Emacs 26.1. See Bug#29423. - (when (tramp--test-emacs26-p) - (with-temp-buffer - (insert-directory (file-name-as-directory tmp-name1) nil) - (goto-char (point-min)) - (should - (looking-at-p - (regexp-quote (file-name-as-directory tmp-name1)))))) + (with-temp-buffer + (insert-directory (file-name-as-directory tmp-name1) nil) + (goto-char (point-min)) + (should + (looking-at-p + (regexp-quote (file-name-as-directory tmp-name1))))) (with-temp-buffer (insert-directory tmp-name1 "-al") (goto-char (point-min)) @@ -3164,7 +3185,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; modes are still "accessible". (not (tramp--test-sshfs-p)) ;; A directory is always accessible for user "root". - (not (zerop (tramp-compat-file-attribute-user-id + (not (zerop (file-attribute-user-id (file-attributes tmp-name1))))) (set-file-modes tmp-name1 0) (with-temp-buffer @@ -3176,7 +3197,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (with-temp-buffer (should-error (insert-directory tmp-name1 nil) - :type tramp-file-missing))) + :type 'file-missing))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -3190,10 +3211,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (not (tramp--test-rsync-p))) ;; Wildcards are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-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-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 @@ -3297,7 +3316,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Relative file names in dired are not supported in tramp-crypt.el. (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let* ((tmp-name1 (expand-file-name (tramp--test-make-temp-name nil quoted))) (tmp-name2 (expand-file-name "foo" tmp-name1)) @@ -3320,7 +3339,7 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (goto-char (point-min)) (while (not (or (eobp) (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2)))) (forward-line 1)) (should-not (eobp)) @@ -3330,14 +3349,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Point shall still be the recent file. (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name2))) (should-not (re-search-forward "dired" nil t)) ;; The copied file has been inserted the line before. (forward-line -1) (should (string-equal - (dired-get-filename 'localp 'no-error) + (dired-get-filename 'no-dir 'no-error) (file-name-nondirectory tmp-name3)))) (kill-buffer buffer)) @@ -3351,7 +3370,7 @@ 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-p) '(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. @@ -3379,25 +3398,24 @@ This tests also `access-file', `file-readable-p', (file-modes tramp-test-temporary-file-directory)))) (write-region "foo" nil tmp-name1) (setq test-file-ownership-preserved-p - (= (tramp-compat-file-attribute-group-id - (file-attributes tmp-name1)) + (= (file-attribute-group-id (file-attributes tmp-name1)) (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) (when (tramp--test-supports-set-file-modes-p) (write-region "foo" nil tmp-name1) ;; A file is always accessible for user "root". - (when (not (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)))) + (unless + (zerop (file-attribute-user-id (file-attributes tmp-name1))) (set-file-modes tmp-name1 0) (should-error (access-file tmp-name1 "error") - :type 'file-error) + :type tramp-permission-denied) (set-file-modes tmp-name1 #o777)) (delete-file tmp-name1)) (should-error (access-file tmp-name1 "error") - :type tramp-file-missing) + :type 'file-missing) ;; `file-ownership-preserved-p' should return t for ;; non-existing files. @@ -3414,33 +3432,29 @@ This tests also `access-file', `file-readable-p', ;; We do not test inodes and device numbers. (setq attr (file-attributes tmp-name1)) (should (consp attr)) - (should (null (tramp-compat-file-attribute-type attr))) - (should (numberp (tramp-compat-file-attribute-link-number attr))) - (should (numberp (tramp-compat-file-attribute-user-id attr))) - (should (numberp (tramp-compat-file-attribute-group-id attr))) + (should (null (file-attribute-type attr))) + (should (numberp (file-attribute-link-number attr))) + (should (numberp (file-attribute-user-id attr))) + (should (numberp (file-attribute-group-id attr))) (should - (stringp - (current-time-string - (tramp-compat-file-attribute-access-time attr)))) + (stringp (current-time-string (file-attribute-access-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-modification-time attr)))) + (current-time-string (file-attribute-modification-time attr)))) (should (stringp - (current-time-string - (tramp-compat-file-attribute-status-change-time attr)))) - (should (numberp (tramp-compat-file-attribute-size attr))) - (should (stringp (tramp-compat-file-attribute-modes attr))) + (current-time-string (file-attribute-status-change-time attr)))) + (should (numberp (file-attribute-size attr))) + (should (stringp (file-attribute-modes attr))) (setq attr (file-attributes tmp-name1 'string)) - (should (stringp (tramp-compat-file-attribute-user-id attr))) - (should (stringp (tramp-compat-file-attribute-group-id attr))) + (should (stringp (file-attribute-user-id attr))) + (should (stringp (file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error (should-error (access-file tmp-name2 "error") - :type tramp-file-missing) + :type 'file-missing) (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) @@ -3454,7 +3468,7 @@ This tests also `access-file', `file-readable-p', (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type attr)) + (file-attribute-type attr)) (file-remote-p (file-truename tmp-name1) 'localname))) (delete-file tmp-name2)) @@ -3473,7 +3487,7 @@ This tests also `access-file', `file-readable-p', (setq attr (file-attributes tmp-name2)) (should (string-equal - (tramp-compat-file-attribute-type attr) + (file-attribute-type attr) (tramp-file-name-localname (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) @@ -3489,7 +3503,7 @@ This tests also `access-file', `file-readable-p', (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) - (should (eq (tramp-compat-file-attribute-type attr) t))) + (should (eq (file-attribute-type attr) t))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1)) @@ -3507,9 +3521,9 @@ They might differ only in time attributes or directory size." (start-time (- tramp--test-start-time 10))) ;; Link number. For directories, it includes the number of ;; subdirectories. Set it to 1. - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 1 attr1) 1)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 1 attr2) 1)) ;; Access time. (setcar (nthcdr 4 attr1) tramp-time-dont-know) @@ -3522,42 +3536,33 @@ They might differ only in time attributes or directory size." ;; order to compensate a possible timestamp resolution higher than ;; a second on the remote machine. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr1) - tramp-time-dont-know) + (file-attribute-modification-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time attr2) - tramp-time-dont-know)) + (file-attribute-modification-time attr2) tramp-time-dont-know)) (setcar (nthcdr 5 attr1) tramp-time-dont-know) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr1))) + (float-time (file-attribute-modification-time attr1))) (setcar (nthcdr 5 attr1) tramp-time-dont-know)) (when (< start-time - (float-time (tramp-compat-file-attribute-modification-time attr2))) + (float-time (file-attribute-modification-time attr2))) (setcar (nthcdr 5 attr2) tramp-time-dont-know)) ;; Status change time. Ditto. (when (or (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr1) - tramp-time-dont-know) + (file-attribute-status-change-time attr1) tramp-time-dont-know) (tramp-compat-time-equal-p - (tramp-compat-file-attribute-status-change-time attr2) - tramp-time-dont-know)) + (file-attribute-status-change-time attr2) tramp-time-dont-know)) (setcar (nthcdr 6 attr1) tramp-time-dont-know) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) - (when - (< start-time - (float-time - (tramp-compat-file-attribute-status-change-time attr1))) + (when (< start-time (float-time (file-attribute-status-change-time attr1))) (setcar (nthcdr 6 attr1) tramp-time-dont-know)) - (when - (< start-time - (float-time (tramp-compat-file-attribute-status-change-time attr2))) + (when (< start-time (float-time (file-attribute-status-change-time attr2))) (setcar (nthcdr 6 attr2) tramp-time-dont-know)) ;; Size. Set it to 0 for directories, because it might have ;; changed. For example the upper directory "../". - (when (eq (tramp-compat-file-attribute-type attr1) t) + (when (eq (file-attribute-type attr1) t) (setcar (nthcdr 7 attr1) 0)) - (when (eq (tramp-compat-file-attribute-type attr2) t) + (when (eq (file-attribute-type attr2) t) (setcar (nthcdr 7 attr2) 0)) ;; The check. (unless (equal attr1 attr2) (tramp--test-message "%S\n%S" attr1 attr2)) @@ -3570,7 +3575,7 @@ They might differ only in time attributes or directory size." "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-p) '(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. @@ -3581,12 +3586,12 @@ They might differ only in time attributes or directory size." (progn (should-error (directory-files-and-attributes tmp-name1) - :type tramp-file-missing) + :type 'file-missing) (make-directory tmp-name1) (should (file-directory-p tmp-name1)) (setq tramp--test-start-time (float-time - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)))) (make-directory tmp-name2) (should (file-directory-p tmp-name2)) @@ -3628,7 +3633,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-set-file-modes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted))) @@ -3644,8 +3649,7 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (should (= (file-modes tmp-name1) #o444)) (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". - (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1))) + (unless (zerop (file-attribute-user-id (file-attributes tmp-name1))) (should-not (file-writable-p tmp-name1))) ;; Check the NOFOLLOW arg. It exists since Emacs 28. For ;; regular files, there shouldn't be a difference. @@ -3719,11 +3723,8 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "Check `file-symlink-p'. This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) - ;; 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-p) '(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. @@ -3748,11 +3749,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (if quoted #'tramp-compat-file-name-unquote #'identity) (file-remote-p tmp-name1 'localname)) (file-symlink-p tmp-name2))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name2) :type 'file-already-exists)) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) ;; A number means interactive case. (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error @@ -3792,7 +3793,7 @@ 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) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (make-symbolic-link tmp-name1 tmp-name4) :type 'file-already-exists)) @@ -3820,7 +3821,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Check `add-name-to-file'. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-add-name-to-file-error (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) @@ -3935,14 +3936,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (string-equal (file-truename tmp-name2) (file-truename tmp-name3))) - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name2)) - :type tramp-file-missing)) - (when (tramp--test-expensive-test) + :type 'file-missing)) + (when (tramp--test-expensive-test-p) (should-error (with-temp-buffer (insert-file-contents tmp-name3)) - :type tramp-file-missing)) + :type 'file-missing)) ;; `directory-files' does not show symlinks to ;; non-existing targets in the "smb" case. So we remove ;; the symlinks manually. @@ -3957,7 +3958,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Detect cyclic symbolic links. (unwind-protect - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) @@ -3995,7 +3996,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (or (tramp--test-adb-p) (tramp--test-gvfs-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-p) '(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))) @@ -4003,7 +4004,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (progn (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) - (should (consp (tramp-compat-file-attribute-modification-time + (should (consp (file-attribute-modification-time (file-attributes tmp-name1)))) ;; Skip the test, if the remote handler is not able to set ;; the correct time. @@ -4011,13 +4012,12 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Dumb remote shells without perl(1) or stat(1) are not ;; able to return the date correctly. They say "don't know". (unless (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) tramp-time-dont-know) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time - (file-attributes tmp-name1)) + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))) (write-region "bla" nil tmp-name2) (should (file-exists-p tmp-name2)) @@ -4032,7 +4032,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) (should (tramp-compat-time-equal-p - (tramp-compat-file-attribute-modification-time + (file-attribute-modification-time (file-attributes tmp-name1)) (seconds-to-time 1))))))) @@ -4045,7 +4045,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-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4078,8 +4078,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `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)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (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)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4094,7 +4095,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-acl tmp-name2)) (should (string-equal (file-acl tmp-name1) (file-acl tmp-name2))) ;; Different permissions mean different ACLs. - (when (not (tramp--test-windows-nt-or-smb-p)) + (unless (tramp--test-windows-nt-or-smb-p) (set-file-modes tmp-name1 #o777) (set-file-modes tmp-name2 #o444) (should-not @@ -4157,8 +4158,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (tramp--test-crypt-p))) ;; `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)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (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)) (tmp-name3 (tramp--test-make-temp-name 'local quoted))) @@ -4295,7 +4297,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Method and host name in completion mode. This kind of completion ;; does not work on MS Windows. - (when (not (memq system-type '(cygwin windows-nt))) + (unless (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)) (orig-syntax tramp-syntax)) @@ -4305,7 +4307,7 @@ 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-p) (tramp-syntax-values) `(,orig-syntax))) (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used @@ -4347,7 +4349,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax orig-syntax)))) (dolist (non-essential '(nil t)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect @@ -4414,7 +4416,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-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4443,7 +4445,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(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) @@ -4519,11 +4521,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test29-start-file-process () "Check `start-file-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(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) @@ -4586,8 +4588,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; "telnet" and "sshfs" do not cooperate with disabled filter. - (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + ;; Disabled process filter. "sshfs" does not cooperate. + (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer (setq proc (start-file-process "test3" (current-buffer) "cat")) @@ -4596,8 +4598,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-process-filter proc t) (process-send-string proc "foo\n") (process-send-eof proc) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) + ;; Read output. There shouldn't be any. + (with-timeout (10) (while (process-live-p proc) (while (accept-process-output proc 0 nil t)))) ;; No output due to process filter. @@ -4675,7 +4677,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring - :tags (if ,unstable '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and ,unstable '(:unstable))) (skip-unless (tramp--test-enabled)) (let ((default-directory tramp-test-temporary-file-directory) (ert-test (ert-get-test ',test)) @@ -4698,13 +4701,13 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test30-make-process () "Check `make-process'." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(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) @@ -4778,8 +4781,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; "telnet" and "sshfs" do not cooperate with disabled filter. - (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + ;; Disabled process filter. "sshfs" does not cooperate. + (unless (tramp--test-sshfs-p) (unwind-protect (with-temp-buffer (setq proc @@ -4792,8 +4795,8 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (should (equal (process-status proc) 'run)) (process-send-string proc "foo\n") (process-send-eof proc) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) + ;; Read output. There shouldn't be any. + (with-timeout (10) (while (process-live-p proc) (while (accept-process-output proc 0 nil t)))) ;; No output due to process filter. @@ -4941,13 +4944,12 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." - :tags (if (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (or (getenv "EMACS_HYDRA_CI") (getenv "EMACS_EMBA_CI")) + '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - ;; Since Emacs 26.1. - (skip-unless (boundp 'interrupt-process-functions)) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous @@ -5009,7 +5011,7 @@ INPUT, if non-nil, is a string sent to the process." (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) (default-directory tramp-test-temporary-file-directory) ;; Suppress nasty messages. @@ -5017,10 +5019,12 @@ INPUT, if non-nil, is a string sent to the process." kill-buffer-query-functions) (dolist (this-shell-command - '(;; Synchronously. - shell-command - ;; Asynchronously. - tramp--test-async-shell-command)) + (append + ;; Synchronously. + '(shell-command) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-async-shell-command)))) ;; Test ordinary `{async-}shell-command'. (unwind-protect @@ -5054,38 +5058,41 @@ INPUT, if non-nil, is a string sent to the process." "echo foo >&2; echo bar" (current-buffer) stderr) (should (string-equal "bar\n" (buffer-string))) ;; Check stderr. - (with-current-buffer stderr - (should (string-equal "foo\n" (buffer-string))))) + (should + (string-equal "foo\n" (tramp-get-buffer-string stderr)))) ;; Cleanup. (ignore-errors (kill-buffer stderr)))))) ;; Test sending string to `async-shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (tramp--test-async-shell-command - "read line; ls $line" (current-buffer) nil - ;; String to be sent. - (format "%s\n" (file-name-nondirectory tmp-name))) - (should - (string-equal - ;; tramp-adb.el echoes, so we must add the string. - (if (and (tramp--test-adb-p) (not (tramp-direct-async-process-p))) - (format - "%s\n%s\n" - (file-name-nondirectory tmp-name) - (file-name-nondirectory tmp-name)) - (format "%s\n" (file-name-nondirectory tmp-name))) - (buffer-string)))) + (when (tramp--test-asynchronous-processes-p) + (unwind-protect + (with-temp-buffer + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) + (should + (string-equal + ;; tramp-adb.el echoes, so we must add the string. + (if (and (tramp--test-adb-p) + (not (tramp-direct-async-process-p))) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) + (buffer-string)))) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))))) + ;; Cleanup. + (ignore-errors (delete-file tmp-name)))))) ;; Test `async-shell-command-width'. It exists since Emacs 26.1, ;; but seems to work since Emacs 27.1 only. - (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (when (and (tramp--test-asynchronous-processes-p) + (tramp--test-sh-p) (tramp--test-emacs27-p)) (let* ((async-shell-command-width 1024) (default-directory tramp-test-temporary-file-directory) (cols (ignore-errors @@ -5232,10 +5239,12 @@ INPUT, if non-nil, is a string sent to the process." (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string - '(;; Synchronously. - shell-command-to-string - ;; Asynchronously. - tramp--test-shell-command-to-string-asynchronously)) + (append + ;; Synchronously. + '(shell-command-to-string) + ;; Asynchronously. + (and (tramp--test-asynchronous-processes-p) + '(tramp--test-shell-command-to-string-asynchronously)))) (let ((default-directory tramp-test-temporary-file-directory) (shell-file-name "/bin/sh") @@ -5362,9 +5371,6 @@ Use direct async.") ;; 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)) @@ -5380,23 +5386,22 @@ Use direct async.") ;; `local-variable' is buffer-local due to explicit setting. (with-no-warnings - (defvar-local local-variable 'buffer)) + (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)) + (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))) @@ -5421,23 +5426,16 @@ Use direct async.") ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test34-explicit-shell-file-name () "Check that connection-local `explicit-shell-file-name' is set." - :tags '(:expensive-test) + :tags '(:expensive-test :tramp-asynchronous-processes) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (when (tramp--test-adb-p) (skip-unless (tramp--test-emacs27-p))) - ;; Since Emacs 26.1. - (skip-unless (and (fboundp 'connection-local-set-profile-variables) - (fboundp 'connection-local-set-profiles))) - ;; `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) explicit-shell-file-name kill-buffer-query-functions connection-local-profile-alist connection-local-criteria-alist) @@ -5446,19 +5444,16 @@ Use direct async.") ;; `shell-mode' would ruin our test, because it deletes all ;; buffer local variables. Not needed in Emacs 27.1. (put 'explicit-shell-file-name 'permanent-local t) - ;; 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 . ,(tramp--test-shell-file-name)) - (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)) + (connection-local-set-profile-variables + 'remote-sh + `((explicit-shell-file-name . ,(tramp--test-shell-file-name)) + (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) @@ -5598,7 +5593,7 @@ Use direct async.") (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-crypt-p))) - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in ;; order to establish the connection prior running an asynchronous ;; process. @@ -5668,7 +5663,7 @@ Use direct async.") "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-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) tramp-allow-unsafe-temporary-files) @@ -5761,7 +5756,7 @@ Use direct async.") ;; files, owned by root. (let ((tramp-auto-save-directory temporary-file-directory)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (with-temp-buffer @@ -5791,7 +5786,7 @@ Use direct async.") "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-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (ange-ftp-make-backup-files t) @@ -5908,8 +5903,7 @@ Use direct async.") (let ((backup-directory-alist `(("." . ,temporary-file-directory))) tramp-backup-directory-alist) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -5943,7 +5937,7 @@ Use direct async.") ;; `lock-file', `unlock-file', `file-locked-p' and ;; `make-lock-file-name' exists since Emacs 28.1. We don't want to ;; see compiler warnings for older Emacsen. - (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) + (dolist (quoted (if (tramp--test-expensive-test-p) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) (tmp-name2 (tramp--test-make-temp-name nil quoted)) (remote-file-name-inhibit-cache t) @@ -6045,8 +6039,7 @@ Use direct async.") ;; files, owned by root. (let ((lock-file-name-transforms auto-save-file-name-transforms)) (write-region "foo" nil tmp-name1) - (when (zerop (or (tramp-compat-file-attribute-user-id - (file-attributes tmp-name1)) + (when (zerop (or (file-attribute-user-id (file-attributes tmp-name1)) tramp-unknown-id-integer)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) @@ -6064,29 +6057,22 @@ Use direct async.") (ignore-errors (delete-file tmp-name1)) (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password))))) -;; The functions were introduced in Emacs 26.1. (ert-deftest tramp-test40-make-nearby-temp-file () "Check `make-nearby-temp-file' and `temporary-file-directory'." (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-ange-ftp-p))) - ;; 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-test-temporary-file-directory) tmp-file) ;; The remote host shall know a temporary file directory. - (should (stringp (with-no-warnings (temporary-file-directory)))) + (should (stringp (temporary-file-directory))) (should (string-equal (file-remote-p default-directory) - (file-remote-p (with-no-warnings (temporary-file-directory))))) + (file-remote-p (temporary-file-directory)))) ;; The temporary file shall be located on the remote host. - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test"))) + (setq tmp-file (make-nearby-temp-file "tramp-test")) (should (file-exists-p tmp-file)) (should (file-regular-p tmp-file)) (should @@ -6096,18 +6082,12 @@ Use direct async.") (delete-file tmp-file) (should-not (file-exists-p tmp-file)) - (setq tmp-file (with-no-warnings (make-nearby-temp-file "tramp-test" 'dir))) + (setq tmp-file (make-nearby-temp-file "tramp-test" 'dir)) (should (file-exists-p tmp-file)) (should (file-directory-p tmp-file)) (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--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--test-emacs27-p () "Check for Emacs version >= 27.1. Some semantics has been changed for there, w/o new functions or @@ -6120,6 +6100,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 28)) +(defun tramp--test-emacs29-p () + "Check for Emacs version >= 29.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 29)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -6131,6 +6117,15 @@ This requires restrictions of file name syntax." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-ftp-file-name-handler)) +(defun tramp--test-asynchronous-processes-p () + "Whether asynchronous processes tests are run. +This is used in tests which we dont't want to tag +`:tramp-asynchronous-processes' completely." + (ert-select-tests + (ert--stats-selector ert--current-run-stats) + (list (make-ert-test :name (ert-test-name (ert-running-test)) + :body nil :tags '(:tramp-asynchronous-processes))))) + (defun tramp--test-crypt-p () "Check, whether the remote directory is crypted." (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) @@ -6141,6 +6136,15 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-expensive-test-p () + "Whether expensive tests are run. +This is used in tests which we dont't want to tag `:expensive' +completely." + (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-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -6284,8 +6288,9 @@ 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)) - '(nil t) '(nil))) + (dolist (quoted + (if (and (tramp--test-expensive-test-p) (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 ;; would let the test fail. @@ -6335,7 +6340,7 @@ This requires restrictions of file name syntax." (string-equal (funcall (if quoted #'tramp-compat-file-name-quote #'identity) - (tramp-compat-file-attribute-type (file-attributes file3))) + (file-attribute-type (file-attributes file3))) (file-remote-p (file-truename file1) 'localname))) ;; Check file contents. (with-temp-buffer @@ -6366,7 +6371,7 @@ This requires restrictions of file name syntax." (setq buffer (dired-noselect tmp-name1 "--dired -al")) (goto-char (point-min)) (while (not (eobp)) - (when-let ((name (dired-get-filename 'localp 'no-error))) + (when-let ((name (dired-get-filename 'no-dir 'no-error))) (unless (string-match-p name directory-files-no-dot-files-regexp) (should (member name files)))) @@ -6445,7 +6450,7 @@ This requires restrictions of file name syntax." ;; Check, that environment variables are set correctly. ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. - (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (when (and (tramp--test-expensive-test-p) (tramp--test-sh-p) (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) @@ -6527,7 +6532,7 @@ This requires restrictions of file name syntax." "{foo}bar{baz}"))) ;; Simplify test in order to speed up. (apply #'tramp--test-check-files - (if (tramp--test-expensive-test) + (if (tramp--test-expensive-test-p) files (list (mapconcat #'identity files "")))))) ;; These tests are inspired by Bug#17238. @@ -6536,7 +6541,7 @@ This requires restrictions of file name syntax." (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-special-characters)) @@ -6626,13 +6631,13 @@ Use the \"ls\" command." ;; to U+1FFFF). "🌈🍒👋") - (when (tramp--test-expensive-test) + (when (tramp--test-expensive-test-p) (delete-dups (mapcar ;; Use all available language specific snippets. (lambda (x) (and - (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) + (stringp (setq x (eval (get-language-info (car x) 'sample-text) t))) ;; Filter out strings which use unencodable characters. (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) (unencodable-char-position @@ -6659,7 +6664,7 @@ Use the \"ls\" command." (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-gdrive-p))) (skip-unless (not (tramp--test-crypt-p))) - (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) + (skip-unless (not (tramp--test-rclone-p))) (tramp--test-utf8)) @@ -6798,8 +6803,8 @@ This is needed in timer functions as well as process filters and sentinels." "Check parallel asynchronous requests. Such requests could arrive from timers, process filters and process sentinels. They shall not disturb each other." - :tags (if (getenv "EMACS_EMBA_CI") - '(:expensive-test :unstable) '(:expensive-test)) + :tags (append '(:expensive-test :tramp-asynchronous-processes) + (and (getenv "EMACS_HYDRA_CI") '(:unstable))) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for @@ -6871,11 +6876,7 @@ process sentinels. They shall not disturb each other." (when buffers (let ((time (float-time)) (default-directory tmp-name) - (file - (buffer-name - ;; Use `seq-random-elt' once <26.1 support - ;; is dropped. - (nth (random (length buffers)) buffers))) + (file (buffer-name (seq-random-elt buffers))) ;; A remote operation in a timer could ;; confuse Tramp heavily. So we ignore this ;; error here. @@ -6940,8 +6941,7 @@ process sentinels. They shall not disturb each other." ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers - ;; Use `seq-random-elt' once <26.1 support is dropped. - (let* ((buf (nth (random (length buffers)) buffers)) + (let* ((buf (seq-random-elt buffers)) (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) @@ -6997,8 +6997,51 @@ process sentinels. They shall not disturb each other." ;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) +(ert-deftest tramp-test45-dired-compress-file () + "Check that Tramp (un)compresses normal files." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (skip-unless (not (tramp--test-emacs29-p))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (write-region "foo" nil tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-file tmp-name))) + +(ert-deftest tramp-test45-dired-compress-dir () + "Check that Tramp (un)compresses directories." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) + ;; Starting with Emacs 29.1, `dired-compress-file' is performed by + ;; default handler. + (skip-unless (not (tramp--test-emacs29-p))) + + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (make-directory tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".tar.gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-directory tmp-name) + (delete-file (concat tmp-name ".tar.gz")))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test45-auto-load () +(ert-deftest tramp-test46-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -7023,12 +7066,8 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-delay-load () +(ert-deftest tramp-test46-delay-load () "Check that Tramp is loaded lazily, only when needed." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; Tramp is neither loaded at Emacs startup, nor when completing a ;; non-Tramp file name like "/foo". Completing a Tramp-alike file ;; name like "/foo:" autoloads Tramp, when `tramp-mode' is t. @@ -7056,7 +7095,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test45-recursive-load () +(ert-deftest tramp-test46-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -7080,12 +7119,8 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test45-remote-load-path () +(ert-deftest tramp-test46-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; `tramp-cleanup-all-connections' is autoloaded from tramp-cmds.el. ;; It shall still work, when a remote file name is in the ;; `load-path'. @@ -7109,15 +7144,11 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-unload () +(ert-deftest tramp-test47-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) (skip-unless noninteractive) - ;; The autoloaded Tramp objects are different since Emacs 26.1. We - ;; cannot test older Emacsen, therefore. - (skip-unless (tramp--test-emacs26-p)) - ;; 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) @@ -7177,8 +7208,7 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; TODO: -;; * dired-compress-file -;; * dired-uncache +;; * dired-uncache (partly done in other test functions) ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p diff --git a/test/lisp/obsolete/cl-tests.el b/test/lisp/obsolete/cl-tests.el index 14205c83a38..5a701a1e550 100644 --- a/test/lisp/obsolete/cl-tests.el +++ b/test/lisp/obsolete/cl-tests.el @@ -25,12 +25,11 @@ (require 'cl)) (require 'ert) - - (ert-deftest labels-function-quoting () "Test that #'foo does the right thing in `labels'." ; Bug#31792. - (should (eq (funcall (labels ((foo () t)) - #'foo)) - t))) + (with-suppressed-warnings ((obsolete labels)) + (should (eq (funcall (labels ((foo () t)) + #'foo)) + t)))) ;;; cl-tests.el ends here diff --git a/test/lisp/paren-tests.el b/test/lisp/paren-tests.el index f7d8658e875..baf5590cb94 100644 --- a/test/lisp/paren-tests.el +++ b/test/lisp/paren-tests.el @@ -117,5 +117,36 @@ (- (point-max) 1) (point-max) nil))))) +(ert-deftest paren-tests-open-paren-line () + (cl-flet ((open-paren-line () + (let* ((data (show-paren--default)) + (here-beg (nth 0 data)) + (there-beg (nth 2 data))) + (blink-paren-open-paren-line-string + (min here-beg there-beg))))) + ;; Lisp-like + (with-temp-buffer + (insert "(defun foo () + (dummy))") + (goto-char (point-max)) + (should (string= "(defun foo ()" (open-paren-line)))) + + ;; C-like + (with-temp-buffer + (insert "int foo() { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo() {" (open-paren-line)))) + + ;; C-like with hanging { + (with-temp-buffer + (insert "int foo() + { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo()...{" (open-paren-line)))))) + (provide 'paren-tests) ;;; paren-tests.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el new file mode 100644 index 00000000000..7a3ab5fbda0 --- /dev/null +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -0,0 +1,128 @@ +;;; bug-reference-tests.el --- Tests for bug-reference.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'bug-reference) +(require 'ert) + +(defun test--get-github-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "github.com" 'github "https")) + url) + (match-string 1 url))) + +(defun test--get-gitlab-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitlab.com" 'gitlab "https")) + url) + (match-string 1 url))) + +(defun test--get-gitea-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitea.com" 'gitea "https")) + url) + (match-string 1 url))) + +(ert-deftest test-github-entry () + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitlab-entry () + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitea-entry () + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit/") + "magit/magit"))) + +;;; bug-reference-tests.el ends here diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 7af4ff33716..774370be4cf 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -230,6 +230,7 @@ (gnu "foo.c:8:23:information: message" 1 23 8 "foo.c") (gnu "foo.c:8.23-45: Informational: message" 1 (23 . 45) (8 . nil) "foo.c") (gnu "foo.c:8-23: message" 1 nil (8 . 23) "foo.c") + (gnu " |foo.c:8: message" 1 nil 8 "foo.c") ;; The next one is not in the GNU standards AFAICS. ;; Here we seem to interpret it as LINE1-LINE2.COL2. (gnu "foo.c:8-45.3: message" 1 (nil . 3) (8 . 45) "foo.c") @@ -491,7 +492,7 @@ The test data is in `compile-tests--test-regexps-data'." (compilation-num-warnings-found 0) (compilation-num-infos-found 0)) (mapc #'compile--test-error-line compile-tests--test-regexps-data) - (should (eq compilation-num-errors-found 96)) + (should (eq compilation-num-errors-found 97)) (should (eq compilation-num-warnings-found 35)) (should (eq compilation-num-infos-found 28))))) diff --git a/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts new file mode 100644 index 00000000000..2c0d51edae8 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts @@ -0,0 +1,88 @@ +Code: + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))) + +Name: defun + +=-= +(defun foo () +"doc" +(+ 1 2)) +=-= +(defun foo () + "doc" + (+ 1 2)) +=-=-= + +Name: function call + +=-= +(foo zot +bar +(zot bar)) +=-= +(foo zot + bar + (zot bar)) +=-=-= + +Name: lisp data + +=-= +( foo zot +bar +(zot bar)) +=-= +( foo zot + bar + (zot bar)) +=-=-= + +Name: defun-space + +=-= +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) +=-=-= + +Name: defvar-keymap + +=-= +(defvar-keymap eww-link-keymap + :copy shr-map + :foo bar + "\r" #'eww-follow-link) +=-=-= + +Name: def-indent1 + +=-= +(defzot-does-not-exist 1 + 2 3) +=-=-= + +Name: def-indent2 + +=-= +(define-keymap 1 + 2 3) +=-=-= + +Name: elisp-indents1 + +=-= +(defvar foo + () + "bar") +=-=-= + +Name: elisp-indents2 + +=-= +(defvar foo () + "bar") +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/flet.erts b/test/lisp/progmodes/elisp-mode-resources/flet.erts new file mode 100644 index 00000000000..da3dcb6ec3e --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/flet.erts @@ -0,0 +1,353 @@ +Name: flet1 + +=-= +(cl-flet () + (a (dangerous-position + b))) +=-=-= + +Name: flet2 + +=-= +(cl-flet wrong-syntax-but-should-not-obstruct-indentation + (a (dangerous-position + b))) +=-=-= + +Name: flet3 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c))) +=-=-= + +Name: flet4 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet5 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet6 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (irregular-local-def (form returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet7 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet8 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +;; (setf _) not yet supported but looks like it will be +Name: flet9 + +=-= +(cl-flet (((setf a) (new value) + stuff) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet10 + +=-= +(cl-flet ( (a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet11 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet12 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet13 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet14 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation)) +=-=-= + +Name: flet15 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet16 + +=-= +(cl-flet ((f (x) + (g x))) + (pcase e + ((dangerous-expression) + (form)))) +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-1 +Code: (lambda () (emacs-lisp-mode) (setq indent-tabs-mode nil) (newline nil t)) +Point-Char: | + +=-= +(let ((x (and y| +=-= +(let ((x (and y + | +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-2 + +=-= +(let ((x| +=-= +(let ((x + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-1 +Point-Char: | + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-2 +Point-Char: | + +=-= +(cl-flet((f(x)| +=-= +(cl-flet((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-3 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-5 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-1 + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-2 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-3 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-5 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-6 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el index 14c8e845d11..9b41fb5426c 100644 --- a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el +++ b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el @@ -1,3 +1,5 @@ +;;; simple-shorthand-test.el --- -*- lexical-binding: t; -*- + (defun f-test () (let ((read-symbol-shorthands '(("foo-" . "bar-")))) (with-temp-buffer diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index d2230583066..8e4dfa8bb83 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -26,6 +26,7 @@ (require 'ert-x) (require 'xref) (eval-when-compile (require 'cl-lib)) +(require 'ert-x) ;;; Completion @@ -108,7 +109,7 @@ (should (member "backup-inhibited" comps)) (should-not (member "backup-buffer" comps)))))) -(ert-deftest elisp-completes-functions-after-let-bindings () +(ert-deftest elisp-completes-functions-after-let-bindings-2 () (with-temp-buffer (emacs-lisp-mode) (insert "(let ((bar 1) (baz 2)) (ba") @@ -301,12 +302,9 @@ ;; tmp may be on a different filesystem to the tests, but, ehh. (defvar xref--case-insensitive - (let ((dir (make-temp-file "xref-test" t))) - (unwind-protect - (progn - (with-temp-file (expand-file-name "hElLo" dir) "hello") - (file-exists-p (expand-file-name "HELLO" dir))) - (delete-directory dir t))) + (ert-with-temp-directory dir + (with-temp-file (expand-file-name "hElLo" dir) "hello") + (file-exists-p (expand-file-name "HELLO" dir))) "Non-nil if file system seems to be case-insensitive.") (defun xref-elisp-test-run (xrefs expected-xrefs) @@ -440,7 +438,8 @@ to (xref-elisp-test-descr-to-target xref)." ;; track down the problem. (cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) "Doc string generic no-default xref-elisp-root-type." - "non-default for no-default") + "non-default for no-default" + (list this arg2)) ; silence byte-compiler ;; defgeneric after defmethod in file to ensure the fallback search ;; method of just looking for the function name will fail. @@ -450,13 +449,15 @@ to (xref-elisp-test-descr-to-target xref)." ;; dispatching code. ) -(cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) - "Doc string generic co-located-default." - "co-located default") +(with-no-warnings ; FIXME: Make more specific. + (cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) + "Doc string generic co-located-default." + "co-located default")) -(cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) - "Doc string generic co-located-default xref-elisp-root-type." - "non-default for co-located-default") +(with-no-warnings ; FIXME: Make more specific. + (cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) + "Doc string generic co-located-default xref-elisp-root-type." + "non-default for co-located-default")) (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) "Doc string generic separate-default." @@ -465,19 +466,23 @@ to (xref-elisp-test-descr-to-target xref)." (cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) "Doc string generic separate-default default." - "separate default") + "separate default" + (list arg1 arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) "Doc string generic separate-default xref-elisp-root-type." - "non-default for separate-default") + "non-default for separate-default" + (list this arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) "Doc string generic implicit-generic default." - "default for implicit generic") + "default for implicit generic" + (list arg1 arg2)) ; silence byte-compiler (cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) "Doc string generic implicit-generic xref-elisp-root-type." - "non-default for implicit generic") + "non-default for implicit generic" + (list this arg2)) ; silence byte-compiler (xref-elisp-deftest find-defs-defgeneric-no-methods @@ -612,7 +617,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-defgeneric-eval - (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()))) + (elisp--xref-find-definitions (eval '(cl-defgeneric stephe-leake-cl-defgeneric ()) t)) nil) ;; Define some mode-local overloadable/overridden functions for xref to find @@ -714,7 +719,7 @@ to (xref-elisp-test-descr-to-target xref)." (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))))) (xref-elisp-deftest find-defs-defun-eval - (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()))) + (elisp--xref-find-definitions (eval '(defun stephe-leake-defun ()) t)) nil) (xref-elisp-deftest find-defs-defun-c @@ -781,11 +786,11 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-defvar-el - (elisp--xref-find-definitions 'xref--marker-ring) + (elisp--xref-find-definitions 'xref--history) (list - (xref-make "(defvar xref--marker-ring)" + (xref-make "(defvar xref--history)" (xref-make-elisp-location - 'xref--marker-ring 'defvar + 'xref--history 'defvar (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) )) @@ -799,7 +804,7 @@ to (xref-elisp-test-descr-to-target xref)." "DEFVAR_PER_BUFFER (\"default-directory\""))) (xref-elisp-deftest find-defs-defvar-eval - (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil))) + (elisp--xref-find-definitions (eval '(defvar stephe-leake-defvar nil) t)) nil) (xref-elisp-deftest find-defs-face-el @@ -817,7 +822,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-face-eval - (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil ""))) + (elisp--xref-find-definitions (eval '(defface stephe-leake-defface nil "") t)) nil) (xref-elisp-deftest find-defs-feature-el @@ -832,7 +837,7 @@ to (xref-elisp-test-descr-to-target xref)." )) (xref-elisp-deftest find-defs-feature-eval - (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature))) + (elisp--xref-find-definitions (eval '(provide 'stephe-leake-feature) t)) nil) (ert-deftest elisp--preceding-sexp--char-name () @@ -841,25 +846,14 @@ to (xref-elisp-test-descr-to-target xref)." (insert "?\\N{HEAVY CHECK MARK}") (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) -(ert-deftest elisp-indent-basic () - (with-temp-buffer - (emacs-lisp-mode) - (let ((orig "(defun x () - (print (quote ( thingy great - stuff))) - (print (quote (thingy great - stuff))))")) - (insert orig) - (indent-region (point-min) (point-max)) - (should (equal (buffer-string) orig))))) - (defun test--font (form search) (with-temp-buffer (emacs-lisp-mode) (if (stringp form) (insert form) (pp form (current-buffer))) - (font-lock-debug-fontify) + (with-suppressed-warnings ((interactive-only font-lock-debug-fontify)) + (font-lock-debug-fontify)) (goto-char (point-min)) (and (re-search-forward search nil t) (get-text-property (match-beginning 1) 'face)))) @@ -1115,17 +1109,12 @@ evaluation of BODY." (buffer-string))))))) (should (equal observed expected-longhand-form)))) -(ert-deftest test-cl-flet-indentation () - :expected-result :failed ; FIXME: bug#9622 - (should (equal - (with-temp-buffer - (emacs-lisp-mode) - (insert "(cl-flet ((bla (x)\n(* x x)))\n(bla 42))") - (indent-region (point-min) (point-max)) - (buffer-string)) - "(cl-flet ((bla (x) - (* x x))) - (bla 42))"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "elisp-indents.erts")) + (ert-test-erts-file (ert-resource-file "flet.erts") + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))))) (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index b25958148d3..673c582cc7a 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'etags) (eval-when-compile (require 'cl-lib)) @@ -95,21 +96,19 @@ (ert-deftest etags-buffer-local-tags-table-list () "Test that a buffer-local value of `tags-table-list' is used." - (let ((file (make-temp-file "etag-test-tmpfile"))) - (unwind-protect - (progn - (set-buffer (find-file-noselect file)) - (fundamental-mode) - (setq-local tags-table-list - (list (expand-file-name "manual/etags/ETAGS.good_3" - etags-tests--test-dir))) - (cl-letf ((tag-tables tags-table-list) - (tags-file-name nil) - ((symbol-function 'read-file-name) - (lambda (&rest _) - (error "We should not prompt the user")))) - (should (visit-tags-table-buffer)) - (should (equal tags-file-name (car tag-tables))))) - (delete-file file)))) + (ert-with-temp-file file + :suffix "etag-test-tmpfile" + (set-buffer (find-file-noselect file)) + (fundamental-mode) + (setq-local tags-table-list + (list (expand-file-name "manual/etags/ETAGS.good_3" + etags-tests--test-dir))) + (cl-letf ((tag-tables tags-table-list) + (tags-file-name nil) + ((symbol-function 'read-file-name) + (lambda (&rest _) + (error "We should not prompt the user")))) + (should (visit-tags-table-buffer)) + (should (equal tags-file-name (car tag-tables)))))) ;;; etags-tests.el ends here diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index 2eb4004f10d..9e5147726f9 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'flymake) (eval-when-compile (require 'subr-x)) ; string-trim @@ -123,22 +124,21 @@ SEVERITY-PREDICATE is used to setup "Test the ruby backend." (skip-unless (executable-find "ruby")) ;; Some versions of ruby fail if HOME doesn't exist (bug#29187). - (let* ((tempdir (make-temp-file "flymake-tests-ruby" t)) - (process-environment (cons (format "HOME=%s" tempdir) - process-environment)) - ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 - ;; for this particular yuckiness - (abbreviated-home-dir nil)) - (unwind-protect - (let ((ruby-mode-hook - (lambda () - (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) - (flymake-tests--with-flymake ("test.rb") - (flymake-goto-next-error) - (should (eq 'flymake-warning (face-at-point))) - (flymake-goto-next-error) - (should (eq 'flymake-error (face-at-point))))) - (delete-directory tempdir t)))) + (ert-with-temp-directory tempdir + :suffix "flymake-tests-ruby" + (let* ((process-environment (cons (format "HOME=%s" tempdir) + process-environment)) + ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 + ;; for this particular yuckiness + (abbreviated-home-dir nil) + (ruby-mode-hook + (lambda () + (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) + (flymake-tests--with-flymake ("test.rb") + (flymake-goto-next-error) + (should (eq 'flymake-warning (face-at-point))) + (flymake-goto-next-error) + (should (eq 'flymake-error (face-at-point))))))) (ert-deftest different-diagnostic-types () "Test GCC warning via function predicate." diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el index e2286349359..91f1db23d62 100644 --- a/test/lisp/progmodes/perl-mode-tests.el +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -37,4 +37,6 @@ (file-name-directory (or load-file-name buffer-file-name))))) +(setq ert-load-file-name load-file-name) + ;;; perl-mode-tests.el ends here diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index fe4fb2912fa..d4b6bca7e8f 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -29,29 +29,17 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'grep) (require 'xref) -(defmacro project-tests--with-temporary-directory (var &rest body) - "Create a new temporary directory. -Bind VAR to the name of the directory, and evaluate BODY. Delete -the directory after BODY exits." - (declare (debug (symbolp body)) (indent 1)) - (cl-check-type var symbol) - (let ((directory (make-symbol "directory"))) - `(let ((,directory (make-temp-file "project-tests-" :directory))) - (unwind-protect - (let ((,var ,directory)) - ,@body) - (delete-directory ,directory :recursive))))) - (ert-deftest project/quoted-directory () "Check that `project-files' and `project-find-regexp' deal with quoted directory names (Bug#47799)." (skip-unless (executable-find find-program)) (skip-unless (executable-find "xargs")) (skip-unless (executable-find "grep")) - (project-tests--with-temporary-directory directory + (ert-with-temp-directory directory (let ((default-directory directory) (project-current-inhibit-prompt t) (project-find-functions nil) @@ -95,7 +83,7 @@ quoted directory names (Bug#47799)." returned by `project-ignores' if the root directory is a directory name (Bug#48471)." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (make-empty-file (expand-file-name "ignored-file" dir)) (let* ((project (make-project-tests--trivial @@ -111,7 +99,7 @@ directory name (Bug#48471)." "Check that `project-files' does not ignore all files. When `project-ignores' includes a name matching project dir." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (let* ((project (make-project-tests--trivial :root (file-name-as-directory dir) diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index bfb931851de..0eb1c087f4c 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'python) ;; Dependencies for testing: @@ -48,17 +49,17 @@ BODY is code to be executed within the temp buffer. Point is always located at the beginning of buffer." (declare (indent 1) (debug t)) ;; temp-file never actually used for anything? - `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) - (buffer (find-file-noselect temp-file)) - (python-indent-guess-indent-offset nil)) - (unwind-protect - (with-current-buffer buffer - (python-mode) - (insert ,contents) - (goto-char (point-min)) - ,@body) - (and buffer (kill-buffer buffer)) - (delete-file temp-file)))) + `(ert-with-temp-file temp-file + :suffix "-python.py" + (let ((buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)))))) (defun python-tests-look-at (string &optional num restore-point) "Move point at beginning of STRING in the current buffer. diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 51d76fba727..7e36d845e2c 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -28,6 +28,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'sql) (ert-deftest sql-tests-postgres-list-databases () @@ -63,52 +64,49 @@ Identify tests by ID. Set :sql-login dialect attribute to LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED string of values passed to the comint function for validation." (declare (indent 2)) - `(cl-letf - ((sql-test-login-params ' ,login-params) - ((symbol-function 'sql-comint-test) - (lambda (product options &optional buf-name) - (with-current-buffer (get-buffer-create buf-name) - (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) - ((symbol-function 'sql-run-test) - (lambda (&optional buffer) - (interactive "P") - (sql-product-interactive 'sqltest buffer))) - (sql-user nil) - (sql-server nil) - (sql-database nil) - (sql-product-alist - '((ansi) - (sqltest - :name "SqlTest" - :sqli-login sql-test-login-params - :sqli-comint-func sql-comint-test))) - (sql-connection-alist - '((,(format "test-%s" id) - ,@connection))) - (sql-password-wallet - (list - (make-temp-file - "sql-test-netrc" nil nil - (mapconcat #'identity - '("machine aMachine user aUserName password \"netrc-A aPassword\"" - "machine aServer user aUserName password \"netrc-B aPassword\"" - "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" - "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" - "machine aDatabase user aUserName password \"netrc-E aPassword\"" - "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" - "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" - ) "\n"))))) - - (let* ((connection ,(format "test-%s" id)) - (buffername (format "*SQL: ERT TEST <%s>*" connection))) - (when (get-buffer buffername) - (kill-buffer buffername)) - (sql-connect connection buffername) - (should (get-buffer buffername)) - (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) - (when (get-buffer buffername) - (kill-buffer buffername)) - (delete-file (car sql-password-wallet))))) + `(ert-with-temp-file tempfile + :suffix "sql-test-netrc" + :text (concat + "machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + "\n") + (cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet (list tempfile))) + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)))))) (ert-deftest sql-test-connect () "Test of basic `sql-connect'." @@ -416,6 +414,16 @@ The ACTION will be tested after set-up of PRODUCT." (kill-buffer "*SQL: exist*"))) +(ert-deftest sql-tests-comint-automatic-password () + (let ((sql-password nil)) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "")) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password "Password: ")))) + ;; Also, we shouldn't care what the password is - we rely on comint for that. + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password ""))))) (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/repeat-tests.el b/test/lisp/repeat-tests.el index b71c333a2da..1382d003599 100644 --- a/test/lisp/repeat-tests.el +++ b/test/lisp/repeat-tests.el @@ -34,20 +34,16 @@ (interactive "p") (push `(,arg b) repeat-tests-calls)) -(defvar repeat-tests-map - (let ((map (make-sparse-keymap))) - (define-key map (kbd "C-x w a") 'repeat-tests-call-a) - (define-key map (kbd "M-C-a") 'repeat-tests-call-a) - (define-key map (kbd "M-C-z") 'repeat-tests-call-a) - map) - "Keymap for keys that initiate repeating sequences.") - -(defvar repeat-tests-repeat-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'repeat-tests-call-a) - (define-key map "b" 'repeat-tests-call-b) - map) - "Keymap for repeating sequences.") +(defvar-keymap repeat-tests-map + :doc "Keymap for keys that initiate repeating sequences." + "C-x w a" 'repeat-tests-call-a + "C-M-a" 'repeat-tests-call-a + "C-M-z" 'repeat-tests-call-a) + +(defvar-keymap repeat-tests-repeat-map + :doc "Keymap for repeating sequences." + "a" 'repeat-tests-call-a + "b" 'repeat-tests-call-b) (put 'repeat-tests-call-a 'repeat-map 'repeat-tests-repeat-map) (put 'repeat-tests-call-b 'repeat-map repeat-tests-repeat-map) diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index fa28789da99..5ba11ed0d57 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -599,11 +599,12 @@ bound to HIGHLIGHT-LOCUS." (with-temp-buffer (insert before) (goto-char (point-min)) - (replace-regexp - "\\(\\(L\\)\\|\\(R\\)\\)" - '(replace-eval-replacement - replace-quote - (if (match-string 2) "R" "L"))) + (with-suppressed-warnings ((interactive-only replace-regexp)) + (replace-regexp + "\\(\\(L\\)\\|\\(R\\)\\)" + '(replace-eval-replacement + replace-quote + (if (match-string 2) "R" "L")))) (should (equal (buffer-string) after))))) (ert-deftest test-count-matches () diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el index 24cd5be5f5b..6f66f3fa345 100644 --- a/test/lisp/saveplace-tests.el +++ b/test/lisp/saveplace-tests.el @@ -41,49 +41,42 @@ (ert-deftest saveplace-test-save-place-to-alist/file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile (file-truename tmpfile)) - (save-place-alist nil) - (save-place-loaded t) - (loc tmpfile) - (pos 4)) - (unwind-protect - (save-window-excursion - (find-file loc) - (insert "abc") ; must insert something - (save-place-to-alist) - (should (equal save-place-alist (list (cons tmpfile pos))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + (let* ((tmpfile (file-truename tmpfile)) + (save-place-alist nil) + (save-place-loaded t) + (loc tmpfile) + (pos 4)) + (save-window-excursion + (find-file loc) + (insert "abc") ; must insert something + (save-place-to-alist) + (should (equal save-place-alist (list (cons tmpfile pos)))))))) (ert-deftest saveplace-test-forget-unreadable-files () (save-place-mode) - (let* ((save-place-loaded t) - (tmpfile (make-temp-file "emacs-test-saveplace-")) - (alist-orig (list (cons "/this/file/does/not/exist" 10) - (cons tmpfile 1917))) - (save-place-alist alist-orig)) - (unwind-protect - (progn - (save-place-forget-unreadable-files) - (should (equal save-place-alist (cdr alist-orig)))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix "-saveplace" + (let* ((save-place-loaded t) + (alist-orig (list (cons "/this/file/does/not/exist" 10) + (cons tmpfile 1917))) + (save-place-alist alist-orig)) + (save-place-forget-unreadable-files) + (should (equal save-place-alist (cdr alist-orig)))))) (ert-deftest saveplace-test-place-alist-to-file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile2 (make-temp-file "emacs-test-saveplace-")) - (save-place-file tmpfile) - (save-place-alist (list (cons tmpfile2 99)))) - (unwind-protect - (progn (save-place-alist-to-file) - (setq save-place-alist nil) - (save-window-excursion - (find-file save-place-file) - (unwind-protect - (should (string-match tmpfile2 (buffer-string))) - (kill-buffer)))) - (delete-file tmpfile) - (delete-file tmpfile2)))) + (ert-with-temp-file tmpfile + (ert-with-temp-file tmpfile2 + (let* ((save-place-file tmpfile) + (save-place-alist (list (cons tmpfile2 99)))) + (save-place-alist-to-file) + (setq save-place-alist nil) + (save-window-excursion + (find-file save-place-file) + (unwind-protect + (should (string-match tmpfile2 (buffer-string))) + (kill-buffer))))))) (ert-deftest saveplace-test-load-alist-from-file () (save-place-mode) diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index 3fcb4ffa180..cd524cbf6e0 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -24,6 +24,10 @@ (require 'ert) (require 'ses) +;; Silence byte-compiler. +(with-suppressed-warnings ((lexical A2) (lexical A3)) + (defvar A2) + (defvar A3)) ;; PLAIN FORMULA TESTS ;; ====================================================================== diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index 23a5660df59..d83ed34e274 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -32,7 +32,7 @@ ;; Running manually: ;; ;; for test in lisp/so-long-tests/*-tests.el; do make ${test%.el}; done \ -;; 2>&1 | egrep -v '^(Loading|Source file|make|Changed to so-long-mode)' +;; 2>&1 | grep -E -v '^(Loading|Source file|make|Changed to so-long-mode)' ;; ;; Which is equivalent to: ;; @@ -41,7 +41,7 @@ ;; "../src/emacs" --no-init-file --no-site-file --no-site-lisp \ ;; -L ":." -l ert -l "$test" --batch --eval \ ;; '(ert-run-tests-batch-and-exit (quote (not (tag :unstable))))'; \ -;; done 2>&1 | egrep -v '^(Loading|Source file|Changed to so-long-mode)' +;; done 2>&1 | grep -E -v '^(Loading|Source file|Changed to so-long-mode)' ;; ;; See also `ert-run-tests-batch-and-exit'. diff --git a/test/lisp/so-long-tests/spelling-tests.el b/test/lisp/so-long-tests/spelling-tests.el index eb1014dd8a7..317513e9a91 100644 --- a/test/lisp/so-long-tests/spelling-tests.el +++ b/test/lisp/so-long-tests/spelling-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ispell) (require 'cl-lib) @@ -50,20 +51,19 @@ ;; The Emacs test Makefile's use of HOME=/nonexistent triggers an error ;; when starting the inferior ispell process, so we set HOME to a valid ;; (but empty) temporary directory for this test. - (let* ((tmpdir (make-temp-file "so-long." :dir ".ispell")) - (process-environment (cons (format "HOME=%s" tmpdir) - process-environment)) - (find-spelling-mistake - (unwind-protect - (cl-letf (((symbol-function 'ispell-command-loop) - (lambda (_miss _guess word _start _end) - (message "Unrecognised word: %s." word) - (throw 'mistake t)))) - (catch 'mistake - (find-library "so-long") - (ispell-buffer) - nil)) - (delete-directory tmpdir)))) - (should (not find-spelling-mistake))))) + (ert-with-temp-file tmpdir + :suffix "so-long.ispell" + (let* ((process-environment (cons (format "HOME=%s" tmpdir) + process-environment)) + (find-spelling-mistake + (cl-letf (((symbol-function 'ispell-command-loop) + (lambda (_miss _guess word _start _end) + (message "Unrecognised word: %s." word) + (throw 'mistake t)))) + (catch 'mistake + (find-library "so-long") + (ispell-buffer) + nil)))) + (should (not find-spelling-mistake)))))) ;;; spelling-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index dde501d520c..9be7511bdc9 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -84,16 +84,237 @@ ;;;; Keymap support. (ert-deftest subr-test-kbd () + (should (equal (kbd "") "")) (should (equal (kbd "f") "f")) + (should (equal (kbd "X") "X")) + (should (equal (kbd "foobar") "foobar")) ; 6 characters + (should (equal (kbd "return") "return")) ; 6 characters + + (should (equal (kbd "<F2>") [F2])) + (should (equal (kbd "<f1> <f2> TAB") [f1 f2 ?\t])) + (should (equal (kbd "<f1> RET") [f1 ?\r])) + (should (equal (kbd "<f1> SPC") [f1 ? ])) (should (equal (kbd "<f1>") [f1])) - (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "<f1>") [f1])) + (should (equal (kbd "[f1]") "[f1]")) + (should (equal (kbd "<return>") [return])) + (should (equal (kbd "< right >") "<right>")) ; 7 characters + + ;; Modifiers: + (should (equal (kbd "C-x") "\C-x")) (should (equal (kbd "C-x a") "\C-xa")) - ;; Check that kbd handles both new and old style key descriptions - ;; (bug#45536). + (should (equal (kbd "C-;") [?\C-\;])) + (should (equal (kbd "C-a") "\C-a")) + (should (equal (kbd "C-c SPC") "\C-c ")) + (should (equal (kbd "C-c TAB") "\C-c\t")) + (should (equal (kbd "C-c c") "\C-cc")) + (should (equal (kbd "C-x 4 C-f") "\C-x4\C-f")) + (should (equal (kbd "C-x C-f") "\C-x\C-f")) + (should (equal (kbd "C-M-<down>") [C-M-down])) + (should (equal (kbd "<C-M-down>") [C-M-down])) + (should (equal (kbd "C-RET") [?\C-\C-m])) + (should (equal (kbd "C-SPC") [?\C- ])) + (should (equal (kbd "C-TAB") [?\C-\t])) + (should (equal (kbd "C-<down>") [C-down])) + (should (equal (kbd "C-c C-c C-c") "\C-c\C-c\C-c")) + + (should (equal (kbd "M-a") [?\M-a])) + (should (equal (kbd "M-<DEL>") [?\M-\d])) + (should (equal (kbd "M-C-a") [?\M-\C-a])) + (should (equal (kbd "M-ESC") [?\M-\e])) + (should (equal (kbd "M-RET") [?\M-\r])) + (should (equal (kbd "M-SPC") [?\M- ])) + (should (equal (kbd "M-TAB") [?\M-\t])) + (should (equal (kbd "M-x a") [?\M-x ?a])) + (should (equal (kbd "M-<up>") [M-up])) + (should (equal (kbd "M-c M-c M-c") [?\M-c ?\M-c ?\M-c])) + + (should (equal (kbd "s-SPC") [?\s- ])) + (should (equal (kbd "s-a") [?\s-a])) + (should (equal (kbd "s-x a") [?\s-x ?a])) + (should (equal (kbd "s-c s-c s-c") [?\s-c ?\s-c ?\s-c])) + + (should (equal (kbd "S-H-a") [?\S-\H-a])) + (should (equal (kbd "S-a") [?\S-a])) + (should (equal (kbd "S-x a") [?\S-x ?a])) + (should (equal (kbd "S-c S-c S-c") [?\S-c ?\S-c ?\S-c])) + + (should (equal (kbd "H-<RET>") [?\H-\r])) + (should (equal (kbd "H-DEL") [?\H-\d])) + (should (equal (kbd "H-a") [?\H-a])) + (should (equal (kbd "H-x a") [?\H-x ?a])) + (should (equal (kbd "H-c H-c H-c") [?\H-c ?\H-c ?\H-c])) + + (should (equal (kbd "A-H-a") [?\A-\H-a])) + (should (equal (kbd "A-SPC") [?\A- ])) + (should (equal (kbd "A-TAB") [?\A-\t])) + (should (equal (kbd "A-a") [?\A-a])) + (should (equal (kbd "A-c A-c A-c") [?\A-c ?\A-c ?\A-c])) + + (should (equal (kbd "C-M-a") [?\C-\M-a])) + (should (equal (kbd "C-M-<up>") [C-M-up])) + + ;; Special characters. + (should (equal (kbd "DEL") "\d")) + (should (equal (kbd "ESC C-a") "\e\C-a")) + (should (equal (kbd "ESC") "\e")) + (should (equal (kbd "LFD") "\n")) + (should (equal (kbd "NUL") "\0")) + (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "SPC") "\s")) + (should (equal (kbd "TAB") "\t")) + (should (equal (kbd "\^i") "")) + (should (equal (kbd "^M") "\^M")) + + ;; With numbers. + (should (equal (kbd "\177") "\^?")) + (should (equal (kbd "\000") "\0")) + (should (equal (kbd "\\177") "\^?")) + (should (equal (kbd "\\000") "\0")) + (should (equal (kbd "C-x \\150") "\C-xh")) + + ;; Multibyte + (should (equal (kbd "ñ") [?ñ])) + (should (equal (kbd "ü") [?ü])) + (should (equal (kbd "ö") [?ö])) + (should (equal (kbd "ğ") [?ğ])) + (should (equal (kbd "ա") [?ա])) + (should (equal (kbd "üüöö") [?ü ?ü ?ö ?ö])) + (should (equal (kbd "C-ü") [?\C-ü])) + (should (equal (kbd "M-ü") [?\M-ü])) + (should (equal (kbd "H-ü") [?\H-ü])) + + ;; Handle both new and old style key descriptions (bug#45536). (should (equal (kbd "s-<return>") [s-return])) (should (equal (kbd "<s-return>") [s-return])) (should (equal (kbd "C-M-<return>") [C-M-return])) - (should (equal (kbd "<C-M-return>") [C-M-return]))) + (should (equal (kbd "<C-M-return>") [C-M-return])) + + ;; Error. + (should-error (kbd "C-xx")) + (should-error (kbd "M-xx")) + (should-error (kbd "M-x<TAB>")) + + ;; These should be equivalent: + (should (equal (kbd "\C-xf") (kbd "C-x f")))) + +(ert-deftest subr-test-key-valid-p () + (should (not (key-valid-p ""))) + (should (key-valid-p "f")) + (should (key-valid-p "X")) + (should (not (key-valid-p " X"))) + (should (key-valid-p "X f")) + (should (not (key-valid-p "a b"))) + (should (not (key-valid-p "foobar"))) + (should (not (key-valid-p "return"))) + + (should (key-valid-p "<F2>")) + (should (key-valid-p "<f1> <f2> TAB")) + (should (key-valid-p "<f1> RET")) + (should (key-valid-p "<f1> SPC")) + (should (key-valid-p "<f1>")) + (should (not (key-valid-p "[f1]"))) + (should (key-valid-p "<return>")) + (should (not (key-valid-p "< right >"))) + + ;; Modifiers: + (should (key-valid-p "C-x")) + (should (key-valid-p "C-x a")) + (should (key-valid-p "C-;")) + (should (key-valid-p "C-a")) + (should (key-valid-p "C-c SPC")) + (should (key-valid-p "C-c TAB")) + (should (key-valid-p "C-c c")) + (should (key-valid-p "C-x 4 C-f")) + (should (key-valid-p "C-x C-f")) + (should (key-valid-p "C-M-<down>")) + (should (not (key-valid-p "<C-M-down>"))) + (should (key-valid-p "C-RET")) + (should (key-valid-p "C-SPC")) + (should (key-valid-p "C-TAB")) + (should (key-valid-p "C-<down>")) + (should (key-valid-p "C-c C-c C-c")) + + (should (key-valid-p "M-a")) + (should (key-valid-p "M-<DEL>")) + (should (not (key-valid-p "M-C-a"))) + (should (key-valid-p "C-M-a")) + (should (key-valid-p "M-ESC")) + (should (key-valid-p "M-RET")) + (should (key-valid-p "M-SPC")) + (should (key-valid-p "M-TAB")) + (should (key-valid-p "M-x a")) + (should (key-valid-p "M-<up>")) + (should (key-valid-p "M-c M-c M-c")) + + (should (key-valid-p "s-SPC")) + (should (key-valid-p "s-a")) + (should (key-valid-p "s-x a")) + (should (key-valid-p "s-c s-c s-c")) + + (should (not (key-valid-p "S-H-a"))) + (should (key-valid-p "S-a")) + (should (key-valid-p "S-x a")) + (should (key-valid-p "S-c S-c S-c")) + + (should (key-valid-p "H-<RET>")) + (should (key-valid-p "H-DEL")) + (should (key-valid-p "H-a")) + (should (key-valid-p "H-x a")) + (should (key-valid-p "H-c H-c H-c")) + + (should (key-valid-p "A-H-a")) + (should (key-valid-p "A-SPC")) + (should (key-valid-p "A-TAB")) + (should (key-valid-p "A-a")) + (should (key-valid-p "A-c A-c A-c")) + + (should (key-valid-p "C-M-a")) + (should (key-valid-p "C-M-<up>")) + + ;; Special characters. + (should (key-valid-p "DEL")) + (should (key-valid-p "ESC C-a")) + (should (key-valid-p "ESC")) + (should (key-valid-p "LFD")) + (should (key-valid-p "NUL")) + (should (key-valid-p "RET")) + (should (key-valid-p "SPC")) + (should (key-valid-p "TAB")) + (should (not (key-valid-p "\^i"))) + (should (not (key-valid-p "^M"))) + + ;; With numbers. + (should (not (key-valid-p "\177"))) + (should (not (key-valid-p "\000"))) + (should (not (key-valid-p "\\177"))) + (should (not (key-valid-p "\\000"))) + (should (not (key-valid-p "C-x \\150"))) + + ;; Multibyte + (should (key-valid-p "ñ")) + (should (key-valid-p "ü")) + (should (key-valid-p "ö")) + (should (key-valid-p "ğ")) + (should (key-valid-p "ա")) + (should (not (key-valid-p "üüöö"))) + (should (key-valid-p "C-ü")) + (should (key-valid-p "M-ü")) + (should (key-valid-p "H-ü")) + + ;; Handle both new and old style key descriptions (bug#45536). + (should (key-valid-p "s-<return>")) + (should (not (key-valid-p "<s-return>"))) + (should (key-valid-p "C-M-<return>")) + (should (not (key-valid-p "<C-M-return>"))) + + (should (key-valid-p "<mouse-1>")) + (should (key-valid-p "<Scroll_Lock>")) + + (should (not (key-valid-p "c-x"))) + (should (not (key-valid-p "C-xx"))) + (should (not (key-valid-p "M-xx"))) + (should (not (key-valid-p "M-x<TAB>")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) @@ -390,12 +611,13 @@ indirectly `mapbacktrace'." (ert-deftest subr-tests--dolist--wrong-number-of-args () "Test that `dolist' doesn't accept wrong types or length of SPEC, cf. Bug#25477." - (should-error (eval '(dolist (a))) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist (a () 'result 'invalid)) t) - :type 'wrong-number-of-arguments) - (should-error (eval '(dolist "foo") t) - :type 'wrong-type-argument)) + (dolist (lb '(nil t)) + (should-error (eval '(dolist (a)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist (a () 'result 'invalid)) lb) + :type 'wrong-number-of-arguments) + (should-error (eval '(dolist "foo") lb) + :type 'wrong-type-argument))) (ert-deftest subr-tests-bug22027 () "Test for https://debbugs.gnu.org/22027 ." @@ -704,6 +926,7 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-not (apropos-internal "^next-line$" #'keymapp))) +(defvar test-global-boundp) (ert-deftest test-buffer-local-boundp () (let ((buf (generate-new-buffer "boundp"))) (with-current-buffer buf @@ -776,7 +999,8 @@ mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the fin or penultimate step during initialization.")) "In addition to any hooks its parent mode might have run, this mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the -final or penultimate step during initialization."))) +final or penultimate step during initialization.")) + (should-error (internal--format-docstring-line "foo\nbar"))) (ert-deftest test-ensure-list () (should (equal (ensure-list nil) nil)) diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 6dd16d18fd0..47c658eb9ad 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -32,7 +32,8 @@ (cons 1024 "-----S---") (cons 2048 "--S------")))) (dolist (x alist) - (should (equal (cdr x) (tar-grind-file-mode (car x))))))) + (with-suppressed-warnings ((obsolete tar-grind-file-mode)) + (should (equal (cdr x) (tar-grind-file-mode (car x)))))))) (ert-deftest tar-mode-test-tar-extract-gz () (skip-unless (executable-find "gzip")) diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index 90f682a580c..f60d2ff5747 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -42,36 +42,50 @@ `( :foreground "unspecified-fg" :background ,(face-background 'term-color-bright-yellow nil 'default) :inverse-video nil)) +(defvar custom-color-fg-props + `( :foreground "#87FFFF" + :background "unspecified-bg" :inverse-video nil)) (defvar ansi-test-strings `(("\e[33mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face yellow-fg-props)) + ,(propertize "Hello World" 'font-lock-face `(,yellow-fg-props))) ("\e[43mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face yellow-bg-props)) + ,(propertize "Hello World" 'font-lock-face `(,yellow-bg-props))) ("\e[93mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face bright-yellow-fg-props)) + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-fg-props))) ("\e[103mHello World\e[0m" - ,(propertize "Hello World" 'font-lock-face bright-yellow-bg-props)) + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-bg-props))) ("\e[1;33mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[33;1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[1m\e[33mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))) + `(,bright-yellow-fg-props term-bold))) ("\e[33m\e[1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,yellow-fg-props :inherit term-bold)) + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;3;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;123;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))) + ("\e[38;2;135;255;255;1mHello World\e[0m" ,(propertize "Hello World" 'font-lock-face - `(,bright-yellow-fg-props :inherit term-bold))))) + `(,custom-color-fg-props term-bold))))) (defun term-test-screen-from-input (width height input &optional return-var) (with-temp-buffer diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el index 39e5dd3d26c..a3265e24451 100644 --- a/test/lisp/textmodes/fill-tests.el +++ b/test/lisp/textmodes/fill-tests.el @@ -76,6 +76,28 @@ (buffer-string) "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n"))))) +(ert-deftest test-fill-end-period () + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.") + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius. ")) + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.Foo") + (forward-char -3) + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do +eius. Foo"))) + (provide 'fill-tests) ;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index 0051bf3fd0c..9ef41088d1e 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) ;;; reftex (require 'reftex) @@ -33,32 +34,31 @@ (ert-deftest reftex-locate-bibliography-files () "Test `reftex-locate-bibliography-files'." - (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) - (files '("ref1.bib" "ref2.bib")) - (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) - ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) - ("\\begin{document}\n\\bibliographystyle{plain}\n + (ert-with-temp-directory temp-dir + (let ((files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n \\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) - (reftex-bibliography-commands - ;; Default value: See reftex-vars.el `reftex-bibliography-commands' - '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" - "addbibresource"))) - (with-temp-buffer - (insert "test\n") + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) (mapc - (lambda (file) - (write-region (point-min) (point-max) (expand-file-name file - temp-dir))) - files)) - (mapc - (lambda (data) - (with-temp-buffer - (insert (car data)) - (let ((res (mapcar #'file-name-nondirectory - (reftex-locate-bibliography-files temp-dir)))) - (should (equal res (cdr data)))))) - test) - (delete-directory temp-dir 'recursive))) + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test)))) (ert-deftest reftex-what-environment-test () "Test `reftex-what-environment'." @@ -102,12 +102,12 @@ ;; reason. (An alternative solution would be to use file-equal-p, ;; but I'm too lazy to do that, as one of the tests compares a ;; list.) - (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) - (tex-file (expand-file-name "test.tex" temp-dir)) - (bib-file (expand-file-name "ref.bib" temp-dir))) - (with-temp-buffer - (insert -"\\begin{document} + (ert-with-temp-directory temp-dir + (let* ((tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert + "\\begin{document} \\section{test}\\label{sec:test} \\subsection{subtest} @@ -118,27 +118,26 @@ \\bibliographystyle{plain} \\bibliography{ref} \\end{document}") - (write-region (point-min) (point-max) tex-file)) - (with-temp-buffer - (insert "test\n") - (write-region (point-min) (point-max) bib-file)) - (reftex-ensure-compiled-variables) - (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) - (should (equal (car parsed) `(eof ,tex-file))) - (pop parsed) - (while parsed - (let ((entry (pop parsed))) - (cond - ((eq (car entry) 'bib) - (should (string= (cadr entry) bib-file))) - ((eq (car entry) 'toc)) ;; ... - ((string= (car entry) "eq:foo")) - ((string= (car entry) "sec:test")) - ((eq (car entry) 'bof) - (should (string= (cadr entry) tex-file)) - (should (null parsed))) - (t (should-not t))))) - (delete-directory temp-dir 'recursive)))) + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))))))) ;;; reftex-cite (require 'reftex-cite) diff --git a/test/lisp/textmodes/texinfo-resources/fill.erts b/test/lisp/textmodes/texinfo-resources/fill.erts new file mode 100644 index 00000000000..95f3b09eba8 --- /dev/null +++ b/test/lisp/textmodes/texinfo-resources/fill.erts @@ -0,0 +1,70 @@ +Code: + (lambda () + (texinfo-mode) + (fill-paragraph)) + +Name: fill1 +Point-Char: | + +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +=-=-= + +Name: fill2 +Point-Char: | + +=-= +@cindex relative| remapping, faces +@cindex base remapping, faces + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + + +Name: fill3 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces| + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + +Name: fill4 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to @code{face-remapping-alist}. +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to +@code{face-remapping-alist}. +=-=-= + +Name: fill5 +Point-Char: | + +=-= +@defun face-remap-add-relative face &rest specs +|This function adds the face spec in @var{specs} as relative +remappings for face @var{face} in the current buffer. The remaining +arguments, @var{specs}, should form either a list of face names, or a +property list of attribute/value pairs. +=-= +@defun face-remap-add-relative face &rest specs +This function adds the face spec in @var{specs} as relative remappings +for face @var{face} in the current buffer. The remaining arguments, +@var{specs}, should form either a list of face names, or a property +list of attribute/value pairs. +=-=-= + +Name: fill6 + +=-= +@subsection This is a very very very very very very very very very very long subsection name +=-=-= diff --git a/test/lisp/textmodes/texinfo-tests.el b/test/lisp/textmodes/texinfo-tests.el new file mode 100644 index 00000000000..fa0c4de005e --- /dev/null +++ b/test/lisp/textmodes/texinfo-tests.el @@ -0,0 +1,33 @@ +;;; texinfo-tests.el --- Tests for texinfo.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'texinfo) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-filling () + (ert-test-erts-file (ert-resource-file "fill.erts"))) + +;;; texinfo-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 8d794f25f43..b6d0b1446a3 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -170,21 +170,13 @@ position to retrieve THING.") (forward-char -1) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-2 () - (with-temp-buffer - (insert " bar ") - (goto-char (point-max)) - (should (eq (symbol-at-point) nil)) - (forward-char -1) - (should (eq (symbol-at-point) 'bar)))) - (ert-deftest test-symbol-thing-3 () (with-temp-buffer (insert "bar") (goto-char 2) (should (eq (symbol-at-point) 'bar)))) -(ert-deftest test-symbol-thing-3 () +(ert-deftest test-symbol-thing-4 () (with-temp-buffer (insert "`[[`(") (goto-char 2) diff --git a/test/lisp/thumbs-tests.el b/test/lisp/thumbs-tests.el index 3c14840c722..a8972394fa5 100644 --- a/test/lisp/thumbs-tests.el +++ b/test/lisp/thumbs-tests.el @@ -20,15 +20,13 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'thumbs) (ert-deftest thumbs-tests-thumbsdir/create-if-missing () - (let ((thumbs-thumbsdir (make-temp-file "thumbs-test" t))) - (unwind-protect - (progn - (delete-directory thumbs-thumbsdir) - (should (file-directory-p (thumbs-thumbsdir)))) - (delete-directory thumbs-thumbsdir)))) + (ert-with-temp-directory thumbs-thumbsdir + (delete-directory thumbs-thumbsdir) + (should (file-directory-p (thumbs-thumbsdir))))) (provide 'thumbs-tests) ;;; thumbs-tests.el ends here diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index fca35329b1b..d52a19ef5d1 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -595,8 +595,12 @@ ;; incorrectly nested parens do not crash us (should-not (equal (time-stamp-string "%(stuffB" ref-time3) May)) (should-not (equal (time-stamp-string "%)B" ref-time3) May)) + ;; unterminated format does not crash us + (should-not (equal (time-stamp-string "%" ref-time3) May)) ;; not all punctuation is allowed - (should-not (equal (time-stamp-string "%&B" ref-time3) May))))) + (should-not (equal (time-stamp-string "%&B" ref-time3) May)) + (should-not (equal (time-stamp-string "%/B" ref-time3) May)) + (should-not (equal (time-stamp-string "%;B" ref-time3) May))))) (ert-deftest time-stamp-format-non-conversions () "Test that without a %, the text is copied literally." @@ -635,8 +639,8 @@ (concat Mon "." Monday "." Mon))) (should (equal (time-stamp-string "%5z.%5::z.%5z" ref-time1) "+0000.+00:00:00.+0000")) - ;; format letter is independent - (should (equal (time-stamp-string "%H:%M" ref-time1) "15:04"))))) + ;; format character is independent + (should (equal (time-stamp-string "%H:%M%%%S" ref-time1) "15:04%05"))))) (ert-deftest time-stamp-format-string-width () "Test time-stamp string width modifiers." diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 214c82530a0..19e3dbb42a6 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -173,35 +173,33 @@ wristwatches wrongheadedly wrongheadedness youthfulness -") - (temp-dir (make-temp-file "diff-mode-test" 'dir))) - - (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) - (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) - (unwind-protect - (progn - (with-current-buffer buf (insert fil_before) (save-buffer)) - (with-current-buffer buf2 (insert fil2_before) (save-buffer)) - - (with-temp-buffer - (cd temp-dir) - (insert patch) - (goto-char (point-min)) - (diff-apply-hunk) - (diff-apply-hunk) - (diff-apply-hunk)) - - (should (equal (with-current-buffer buf (buffer-string)) - fil_after)) - (should (equal (with-current-buffer buf2 (buffer-string)) - fil2_after))) - - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf) - (with-current-buffer buf2 (set-buffer-modified-p nil)) - (kill-buffer buf2) - (delete-directory temp-dir 'recursive)))))) +")) + (ert-with-temp-directory temp-dir + (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) + (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) + (unwind-protect + (progn + (with-current-buffer buf (insert fil_before) (save-buffer)) + (with-current-buffer buf2 (insert fil2_before) (save-buffer)) + + (with-temp-buffer + (cd temp-dir) + (insert patch) + (goto-char (point-min)) + (diff-apply-hunk) + (diff-apply-hunk) + (diff-apply-hunk)) + + (should (equal (with-current-buffer buf (buffer-string)) + fil_after)) + (should (equal (with-current-buffer buf2 (buffer-string)) + fil2_after))) + + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf) + (with-current-buffer buf2 (set-buffer-modified-p nil)) + (kill-buffer buf2))))))) (ert-deftest diff-mode-test-hunk-text-no-newline () "Check output of `diff-hunk-text' with no newline at end of file." diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index 21b9b0cab76..935046198f3 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ediff-ptch) (ert-deftest ediff-ptch-test-bug25010 () @@ -45,34 +46,33 @@ index 6a07f80..6e8e947 100644 "Test for https://debbugs.gnu.org/26084 ." (skip-unless (executable-find "git")) (skip-unless (executable-find ediff-patch-program)) - (let* ((tmpdir (make-temp-file "ediff-ptch-test" t)) - (default-directory (file-name-as-directory tmpdir)) - (patch (make-temp-file "ediff-ptch-test")) - (qux (expand-file-name "qux.txt" tmpdir)) - (bar (expand-file-name "bar.txt" tmpdir)) - (git-program (executable-find "git"))) - ;; Create repository. - (with-temp-buffer - (insert "qux here\n") - (write-region nil nil qux nil 'silent) - (erase-buffer) - (insert "bar here\n") - (write-region nil nil bar nil 'silent)) - (call-process git-program nil nil nil "init") - (call-process git-program nil nil nil "add" ".") - (call-process git-program nil nil nil "commit" "-m" "Test repository.") - ;; Update repo., save the diff and reset to initial state. - (with-temp-buffer - (insert "foo here\n") - (write-region nil nil qux nil 'silent) - (write-region nil nil bar nil 'silent)) - (call-process git-program nil `(:file ,patch) nil "diff") - (call-process git-program nil nil nil "reset" "--hard" "HEAD") - ;; Visit the diff file i.e., patch; extract from it the parts - ;; affecting just each of the files: store in patch-bar the part - ;; affecting 'bar', and in patch-qux the part affecting 'qux'. - (find-file patch) - (unwind-protect + (ert-with-temp-directory tmpdir + (ert-with-temp-file patch + (let* ((default-directory (file-name-as-directory tmpdir)) + (qux (expand-file-name "qux.txt" tmpdir)) + (bar (expand-file-name "bar.txt" tmpdir)) + (git-program (executable-find "git"))) + ;; Create repository. + (with-temp-buffer + (insert "qux here\n") + (write-region nil nil qux nil 'silent) + (erase-buffer) + (insert "bar here\n") + (write-region nil nil bar nil 'silent)) + (call-process git-program nil nil nil "init") + (call-process git-program nil nil nil "add" ".") + (call-process git-program nil nil nil "commit" "-m" "Test repository.") + ;; Update repo., save the diff and reset to initial state. + (with-temp-buffer + (insert "foo here\n") + (write-region nil nil qux nil 'silent) + (write-region nil nil bar nil 'silent)) + (call-process git-program nil `(:file ,patch) nil "diff") + (call-process git-program nil nil nil "reset" "--hard" "HEAD") + ;; Visit the diff file i.e., patch; extract from it the parts + ;; affecting just each of the files: store in patch-bar the part + ;; affecting 'bar', and in patch-qux the part affecting 'qux'. + (find-file patch) (let* ((info (progn (ediff-map-patch-buffer (current-buffer)) ediff-patch-map)) (patch-bar @@ -116,9 +116,7 @@ index 6a07f80..6e8e947 100644 (buffer-string)) (with-temp-buffer (insert-file-contents backup) - (buffer-string))))))) - (delete-directory tmpdir 'recursive) - (delete-file patch))))) + (buffer-string)))))))))))) (provide 'ediff-ptch-tests) diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index 86d497631cb..12f1e9034c3 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc-bzr) (require 'vc-dir) @@ -51,106 +52,97 @@ ;; temporary directory. ;; TODO does this means tests should be setting XDG_ variables (not ;; just HOME) to temporary values too? - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (ignored-dir (progn - (make-directory bzrdir) - (expand-file-name "ignored-dir" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (make-directory ignored-dir) - (with-temp-buffer - (insert (file-name-nondirectory ignored-dir)) - (write-region nil nil (expand-file-name ".bzrignore" bzrdir) - nil 'silent)) - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (with-temp-buffer - (insert "unregistered file") - (write-region nil nil (expand-file-name "testfile2" ignored-dir) - nil 'silent)) - (vc-dir ignored-dir) - (while (vc-dir-busy) - (sit-for 0.1)) - ;; FIXME better to explicitly test for error from process sentinel. - (with-current-buffer "*vc-dir*" - (goto-char (point-min)) - (should (search-forward "unregistered" nil t)))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (ignored-dir (progn + (make-directory bzrdir) + (expand-file-name "ignored-dir" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (make-directory ignored-dir) + (with-temp-buffer + (insert (file-name-nondirectory ignored-dir)) + (write-region nil nil (expand-file-name ".bzrignore" bzrdir) + nil 'silent)) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (with-temp-buffer + (insert "unregistered file") + (write-region nil nil (expand-file-name "testfile2" ignored-dir) + nil 'silent)) + (vc-dir ignored-dir) + (while (vc-dir-busy) + (sit-for 0.1)) + ;; FIXME better to explicitly test for error from process sentinel. + (with-current-buffer "*vc-dir*" + (goto-char (point-min)) + (should (search-forward "unregistered" nil t)))))) ;; Not specific to bzr. (ert-deftest vc-bzr-test-bug9781 () "Test for https://debbugs.gnu.org/9781 ." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (subdir (progn - (make-directory bzrdir) - (expand-file-name "subdir" bzrdir))) - (file (expand-file-name "file" bzrdir)) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (make-directory subdir) - (with-temp-buffer - (insert "text") - (write-region nil nil file nil 'silent) - (write-region nil nil (expand-file-name "subfile" subdir) - nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (call-process vc-bzr-program nil nil nil "remove" subdir) - (with-temp-buffer - (insert "different text") - (write-region nil nil file nil 'silent)) - (vc-dir bzrdir) - (while (vc-dir-busy) - (sit-for 0.1)) - (vc-dir-mark-all-files t) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) - (vc-next-action nil)) - (should (get-buffer "*vc-log*"))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (subdir (progn + (make-directory bzrdir) + (expand-file-name "subdir" bzrdir))) + (file (expand-file-name "file" bzrdir)) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (make-directory subdir) + (with-temp-buffer + (insert "text") + (write-region nil nil file nil 'silent) + (write-region nil nil (expand-file-name "subfile" subdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (call-process vc-bzr-program nil nil nil "remove" subdir) + (with-temp-buffer + (insert "different text") + (write-region nil nil file nil 'silent)) + (vc-dir bzrdir) + (while (vc-dir-busy) + (sit-for 0.1)) + (vc-dir-mark-all-files t) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) + (vc-next-action nil)) + (should (get-buffer "*vc-log*"))))) ;; https://lists.gnu.org/r/help-gnu-emacs/2012-04/msg00145.html (ert-deftest vc-bzr-test-faulty-bzr-autoloads () "Test we can generate autoloads in a bzr directory when bzr is faulty." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (file (progn - (make-directory bzrdir) - (expand-file-name "foo.el" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (call-process vc-bzr-program nil nil nil "init") - (with-temp-buffer - (insert ";;;###autoload + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (file (progn + (make-directory bzrdir) + (expand-file-name "foo.el" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (call-process vc-bzr-program nil nil nil "init") + (with-temp-buffer + (insert ";;;###autoload \(defun foo () \"foo\" (interactive) (message \"foo!\"))") - (write-region nil nil file nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - ;; Deleting dirstate ensures both that vc-bzr's status heuristic - ;; fails, so it has to call the external bzr status, and - ;; causes bzr status to fail. This simulates a broken bzr - ;; installation. - (delete-file ".bzr/checkout/dirstate") - (should (progn (make-directory-autoloads - default-directory - (expand-file-name "loaddefs.el" bzrdir)) - t))) - (delete-directory homedir t)))) + (write-region nil nil file nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + ;; Deleting dirstate ensures both that vc-bzr's status heuristic + ;; fails, so it has to call the external bzr status, and + ;; causes bzr status to fail. This simulates a broken bzr + ;; installation. + (delete-file ".bzr/checkout/dirstate") + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) + t))))) ;;; vc-bzr-tests.el ends here diff --git a/test/lisp/vc/vc-git-tests.el b/test/lisp/vc/vc-git-tests.el new file mode 100644 index 00000000000..997ab3c4b5c --- /dev/null +++ b/test/lisp/vc/vc-git-tests.el @@ -0,0 +1,67 @@ +;;; vc-git-tests.el --- tests for vc/vc-git.el -*- lexical-binding:t -*- + +;; Copyright (C) 2016-2021 Free Software Foundation, Inc. + +;; Author: Justin Schell <justinmschell@gmail.com> +;; Maintainer: emacs-devel@gnu.org + +;; 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 'vc-git) + +(ert-deftest vc-git-test-program-version-general () + (vc-git-test--run-program-version-test + "git version 2.30.1.0" + "2.30.1.0")) + +(ert-deftest vc-git-test-program-version-windows () + (vc-git-test--run-program-version-test + "git version 2.30.1.1.windows.1" + "2.30.1.1")) + +(ert-deftest vc-git-test-program-version-apple () + (vc-git-test--run-program-version-test + "git version 2.30.1.2 (Apple Git-130)" + "2.30.1.2")) + +(ert-deftest vc-git-test-program-version-other () + (vc-git-test--run-program-version-test + "git version 2.30.1.3.foo.bar" + "2.30.1.3")) + +(ert-deftest vc-git-test-program-version-invalid-leading-string () + (vc-git-test--run-program-version-test + "git version foo.bar.2.30.1.4" + "0")) + +(ert-deftest vc-git-test-program-version-invalid-leading-dot () + (vc-git-test--run-program-version-test + "git version .2.30.1.5" + "0")) + +(defun vc-git-test--run-program-version-test + (mock-version-string expected-output) + (cl-letf* (((symbol-function 'vc-git--run-command-string) + (lambda (_file _args) mock-version-string)) + (vc-git--program-version nil) + (actual-output (vc-git--program-version))) + (should (equal actual-output expected-output)))) + +;;; vc-git-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 5e2a0c555f9..7bf5ae6bc1d 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -109,6 +109,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc) (require 'log-edit) @@ -178,41 +179,38 @@ For backends which dont support it, it is emulated." (defun vc-test--create-repo (backend) "Create a test repository in `default-directory', a temporary directory." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--create-repo" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Check the revision granularity. - (should (memq (vc-test--revision-granularity-function backend) - '(file repository))) - - ;; Create empty repository. - (make-directory default-directory) - (should (file-directory-p default-directory)) - (vc-test--create-repo-function backend) - (should (eq (vc-responsible-backend default-directory) backend))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; FIXME: Why isn't there `vc-unregister'? (defun vc-test--unregister-function (backend file) @@ -235,447 +233,429 @@ Catch the `vc-not-supported' error." (defun vc-test--register (backend) "Register and unregister a file. This checks also `vc-backend' and `vc-responsible-backend'." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--register" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - ;; For file oriented backends CVS, RCS and SVN the backend is - ;; returned, and the directory is registered already. - (should (if (vc-backend default-directory) - (vc-registered default-directory) - (not (vc-registered default-directory)))) - (should (eq (vc-responsible-backend default-directory) backend)) - - (let ((tmp-name1 (expand-file-name "foo" default-directory)) - (tmp-name2 "bla")) - ;; Register files. Check for it. - (write-region "foo" nil tmp-name1 nil 'nomessage) - (should (file-exists-p tmp-name1)) - (should-not (vc-backend tmp-name1)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should-not (vc-registered tmp-name1)) - - (write-region "bla" nil tmp-name2 nil 'nomessage) - (should (file-exists-p tmp-name2)) - (should-not (vc-backend tmp-name2)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should-not (vc-registered tmp-name2)) - - (vc-register (list backend (list tmp-name1 tmp-name2))) - (should (file-exists-p tmp-name1)) - (should (eq (vc-backend tmp-name1) backend)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should (vc-registered tmp-name1)) - - (should (file-exists-p tmp-name2)) - (should (eq (vc-backend tmp-name2) backend)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should (vc-registered tmp-name2)) - - ;; `vc-backend' accepts also a list of files, - ;; `vc-responsible-backend' doesn't. - (should (vc-backend (list tmp-name1 tmp-name2))) - - ;; Unregister the files. - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name1) - 'vc-not-supported) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + ;; For file oriented backends CVS, RCS and SVN the backend is + ;; returned, and the directory is registered already. + (should (if (vc-backend default-directory) + (vc-registered default-directory) + (not (vc-registered default-directory)))) + (should (eq (vc-responsible-backend default-directory) backend)) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) (should-not (vc-backend tmp-name1)) - (should-not (vc-registered tmp-name1))) - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name2) - 'vc-not-supported) - (should-not (vc-backend tmp-name2)) - (should-not (vc-registered tmp-name2))) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should-not (vc-registered tmp-name1)) - ;; The files should still exist. - (should (file-exists-p tmp-name1)) - (should (file-exists-p tmp-name2)))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-backend tmp-name2)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should-not (vc-registered tmp-name2)) + + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (eq (vc-backend tmp-name1) backend)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should (vc-registered tmp-name1)) + + (should (file-exists-p tmp-name2)) + (should (eq (vc-backend tmp-name2) backend)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should (vc-registered tmp-name2)) + + ;; `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. + (should (vc-backend (list tmp-name1 tmp-name2))) + + ;; Unregister the files. + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name1) + 'vc-not-supported) + (should-not (vc-backend tmp-name1)) + (should-not (vc-registered tmp-name1))) + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name2) + 'vc-not-supported) + (should-not (vc-backend tmp-name2)) + (should-not (vc-registered tmp-name2))) + + ;; The files should still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--state (backend) "Check the different states of a file." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--state" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of a nonexistent file. - - (message "vc-state2 %s" (vc-state tmp-name)) - (should (null (vc-state tmp-name))) - - ;; Write a new file. Check state. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; nil: Mtn - ;; unregistered: Bzr CVS Git Hg SVN RCS - (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) '(nil unregistered))) - - ;; Register a file. Check state. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; FIXME: nil is definitely wrong. - ;; nil: SRC - ;; added: Bzr CVS Git Hg Mtn SVN - ;; up-to-date: RCS SCCS - (message "vc-state4 %s" (vc-state tmp-name)) - (should (memq (vc-state tmp-name) '(nil added up-to-date))) - - ;; Unregister the file. Check state. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-state5 unsupported") - ;; unregistered: Bzr Git RCS Hg - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) - '(nil unregistered)))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of a nonexistent file. + + (message "vc-state2 %s" (vc-state tmp-name)) + (should (null (vc-state tmp-name))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; unregistered: Bzr CVS Git Hg SVN RCS + (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) '(nil unregistered))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; FIXME: nil is definitely wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) + + ;; Unregister the file. Check state. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-state5 unsupported") + ;; unregistered: Bzr Git RCS Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) + '(nil unregistered)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--working-revision (backend) "Check the working revision of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--working-revision" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check working revision of - ;; repository, should be nil. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; FIXME: Is the value for SVN correct? - ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC - ;; "0": SVN - (message - "vc-working-revision1 %s" (vc-working-revision default-directory)) - (should (member (vc-working-revision default-directory) '(nil "0"))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check initial working revision, should be nil until - ;; it's registered. - - (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Write a new file. Check working revision. - (write-region "foo" nil tmp-name nil 'nomessage) - - (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Register a file. Check working revision. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; XXX: nil is fine, at least in Git's case, because - ;; `vc-register' only makes the file `added' in this case. - ;; nil: Git Mtn - ;; "0": Bzr CVS Hg SRC SVN - ;; "1.1": RCS SCCS - ;; "-1": Hg versions before 5 (probably) - (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) - (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) - - ;; TODO: Call `vc-checkin', and check the resulting - ;; working revision. None of the return values should be - ;; nil then. - - ;; Unregister the file. Check working revision. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-working-revision5 unsupported") - ;; nil: Bzr Git Hg RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; FIXME: Is the value for SVN correct? + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC + ;; "0": SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; XXX: nil is fine, at least in Git's case, because + ;; `vc-register' only makes the file `added' in this case. + ;; nil: Git Mtn + ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1": RCS SCCS + ;; "-1": Hg versions before 5 (probably) + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) + + ;; TODO: Call `vc-checkin', and check the resulting + ;; working revision. None of the return values should be + ;; nil then. + + ;; Unregister the file. Check working revision. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-working-revision5 unsupported") + ;; nil: Bzr Git Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--checkout-model (backend) "Check the checkout model of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--checkout-model" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; Surprisingly, none of the backends returns 'announce. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model1 %s" - (vc-checkout-model backend default-directory)) - (should (memq (vc-checkout-model backend default-directory) - '(announce implicit locking))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of a nonexistent file. - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; Surprisingly, none of the backends returns 'announce. + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) - ;; Write a new file. Check checkout model. - (write-region "foo" nil tmp-name nil 'nomessage) + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of a nonexistent file. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) - ;; Register a file. Check checkout model. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Unregister the file. Check checkout model. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-checkout-model5 unsupported") - ;; implicit: Bzr Git Hg - ;; locking: RCS - ;; unsupported: CVS Mtn SCCS SRC SVN + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking)))))) + '(announce implicit locking))) - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-checkout-model5 unsupported") + ;; implicit: Bzr Git Hg + ;; locking: RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--rename-file (backend) "Check the rename-file action." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--rename-file" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory)) - (new-name (expand-file-name "bar" default-directory))) - ;; Write a new file. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; Register it. Renaming can fail otherwise. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - (vc-rename-file tmp-name new-name) - - (should (not (file-exists-p tmp-name))) - (should (file-exists-p new-name)) - - (should (equal (vc-state new-name) - (if (memq backend '(RCS SCCS)) - 'up-to-date - 'added))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory)) + (new-name (expand-file-name "bar" default-directory))) + ;; Write a new file. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; Register it. Renaming can fail otherwise. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + (vc-rename-file tmp-name new-name) + + (should (not (file-exists-p tmp-name))) + (should (file-exists-p new-name)) + + (should (equal (vc-state new-name) + (if (memq backend '(RCS SCCS)) + 'up-to-date + 'added))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (declare-function log-edit-done "vc/log-edit") (defun vc-test--version-diff (backend) "Check the diff version of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--version-diff" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - ;; git tries various approaches to guess a user name and email, - ;; which can fail depending on how the system is configured. - ;; Eg if the user account has no GECOS, git commit can fail with - ;; status 128 "fatal: empty ident name". - (when (memq backend '(Bzr Git)) - (setq process-environment (cons "EMAIL=john@doe.ee" - process-environment))) - (if (eq backend 'Git) - (setq process-environment (append '("GIT_AUTHOR_NAME=A" - "GIT_COMMITTER_NAME=C") - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let* ((tmp-name (expand-file-name "foo" default-directory)) - (files (list (file-name-nondirectory tmp-name)))) - ;; Write and register a new file. - (write-region "originaltext" nil tmp-name nil 'nomessage) - (vc-register (list backend files)) - - (let ((buff (find-file tmp-name))) - (with-current-buffer buff + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + ;; git tries various approaches to guess a user name and email, + ;; which can fail depending on how the system is configured. + ;; Eg if the user account has no GECOS, git commit can fail with + ;; status 128 "fatal: empty ident name". + (when (memq backend '(Bzr Git)) + (setq process-environment (cons "EMAIL=john@doe.ee" + process-environment))) + (if (eq backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let* ((tmp-name (expand-file-name "foo" default-directory)) + (files (list (file-name-nondirectory tmp-name)))) + ;; Write and register a new file. + (write-region "originaltext" nil tmp-name nil 'nomessage) + (vc-register (list backend files)) + + (let ((buff (find-file tmp-name))) + (with-current-buffer buff + (progn + ;; Optionally checkout file. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + + ;; Checkin file. + (vc-checkin files backend) + (insert "Testing vc-version-diff") + (log-edit-done)))) + + ;; Modify file content. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + (write-region "updatedtext" nil tmp-name nil 'nomessage) + + ;; Check version diff. + (vc-version-diff files nil nil) + (should (bufferp (get-buffer "*vc-diff*"))) + + (with-current-buffer "*vc-diff*" (progn - ;; Optionally checkout file. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) - - ;; Checkin file. - (vc-checkin files backend) - (insert "Testing vc-version-diff") - (log-edit-done)))) - - ;; Modify file content. - (when (memq backend '(RCS CVS SCCS)) - (vc-checkout tmp-name)) - (write-region "updatedtext" nil tmp-name nil 'nomessage) - - ;; Check version diff. - (vc-version-diff files nil nil) - (should (bufferp (get-buffer "*vc-diff*"))) - - (with-current-buffer "*vc-diff*" - (progn - (let ((rawtext (buffer-substring-no-properties (point-min) - (point-max)))) - (should (string-search "-originaltext" rawtext)) - (should (string-search "+updatedtext" rawtext))))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (let ((rawtext (buffer-substring-no-properties (point-min) + (point-max)))) + (should (string-search "-originaltext" rawtext)) + (should (string-search "+updatedtext" rawtext))))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; Create the test cases. diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index 596c9881077..58caa1deda8 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -20,7 +20,9 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) +(require 'dired-x) (require 'wdired) (defvar dired-query) ; Pacify byte compiler. @@ -28,108 +30,100 @@ (ert-deftest wdired-test-bug32173-01 () "Test using non-nil wdired-use-interactive-rename. Partially modifying a file name should succeed." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (string-replace "foo" replace test-file)) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. - :override - (lambda (_sym _prompt &rest _args) (setq dired-query t)) - '((name . "advice-dired-query"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (wdired-finish-edit) - (should (equal (dired-file-name-at-point) new-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file)) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. + :override + (lambda (_sym _prompt &rest _args) (setq dired-query t)) + '((name . "advice-dired-query"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (wdired-finish-edit) + (should (equal (dired-file-name-at-point) new-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-bug32173-02 () "Test using non-nil wdired-use-interactive-rename. Aborting an edit should leaving original file name unchanged." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - ;; Make dired-do-create-files-regexp a noop to mimic typing C-g - ;; at its prompt before wdired-finish-edit returns. - (advice-add 'dired-do-create-files-regexp - :override - (lambda (&rest _) (ignore)) - '((name . "advice-dired-do-create-files-regexp"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert "bar") - (wdired-finish-edit) - (should (equal (dired-get-filename) test-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + ;; Make dired-do-create-files-regexp a noop to mimic typing C-g + ;; at its prompt before wdired-finish-edit returns. + (advice-add 'dired-do-create-files-regexp + :override + (lambda (&rest _) (ignore)) + '((name . "advice-dired-do-create-files-regexp"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert "bar") + (wdired-finish-edit) + (should (equal (dired-get-filename) test-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-symlink-name () "Test the file name of a symbolic link. The Dired and WDired functions returning the name should include only the name before the link arrow." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (link-name "foo")) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (skip-unless - ;; This check is for wdired, not symbolic links, so skip - ;; it when make-symbolic-link fails for any reason (like - ;; insufficient privileges). - (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) - (revert-buffer) - (let* ((file-name (dired-get-filename)) - (dir-part (file-name-directory file-name)) - (lf-name (concat dir-part link-name))) - (should (equal file-name lf-name)) - (dired-toggle-read-only) - (should (equal (wdired-get-filename) lf-name)) - (dired-toggle-read-only))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((link-name "foo")) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (skip-unless + ;; This check is for wdired, not symbolic links, so skip + ;; it when make-symbolic-link fails for any reason (like + ;; insufficient privileges). + (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) + (revert-buffer) + (let* ((file-name (dired-get-filename)) + (dir-part (file-name-directory file-name)) + (lf-name (concat dir-part link-name))) + (should (equal file-name lf-name)) + (dired-toggle-read-only) + (should (equal (wdired-get-filename) lf-name)) + (dired-toggle-read-only))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-unfinished-edit-01 () "Test editing a file name without saving the change. Finding the new name should be possible while still in wdired-mode." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (string-replace "foo" replace test-file))) - (write-region "" nil test-file nil 'silent) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (should (equal (dired-get-filename) new-file))) - (when buf - (with-current-buffer buf - ;; Prevent kill-buffer-query-functions from chiming in. - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory test-dir t))))) - -(defvar server-socket-dir) -(declare-function dired-smart-shell-command "dired-x" - (command &optional output-buffer error-buffer)) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file))) + (write-region "" nil test-file nil 'silent) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (should (equal (dired-get-filename) new-file))) + (when buf + (with-current-buffer buf + ;; Prevent kill-buffer-query-functions from chiming in. + (set-buffer-modified-p nil) + (kill-buffer buf)))))))) (ert-deftest wdired-test-bug34915 () "Test editing when dired-listing-switches includes -F. @@ -139,61 +133,61 @@ dired-move-to-end-of-filename handles indicator characters, it suffices to compare the return values of dired-get-filename and wdired-get-filename before and after editing." ;; FIXME: Add a test for a door (indicator ">") only under Solaris? - (let* ((test-dir (make-temp-file "test-dir-" t)) - (server-socket-dir test-dir) - (dired-listing-switches "-Fl") - (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) - (unwind-protect - (progn - (with-current-buffer buf - (dired-create-empty-file "foo") - (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) - (make-symbolic-link "foo" "bar") - (make-directory "foodir") - (require 'dired-x) - (dired-smart-shell-command "mkfifo foopipe") - (server-force-delete) - ;; FIXME? This seems a heavy-handed way of making a socket. - (server-start) ; Add a socket file. - (kill-buffer buf)) - (dired test-dir) - (dired-toggle-read-only) - (let (names) - ;; Test that the file names are the same in Dired and WDired. - (while (not (eobp)) - (should (equal (dired-get-filename 'no-dir t) - (wdired-get-filename t))) - (insert "w") - (push (wdired-get-filename t) names) - (dired-next-line 1)) - (wdired-finish-edit) - ;; Test that editing the file names ignores the indicator - ;; character. - (let (dir) - (while (and (dired-previous-line 1) - (setq dir (dired-get-filename 'no-dir t))) - (should (equal dir (pop names))))))) - (kill-buffer (get-buffer test-dir)) - (server-force-delete) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let* ((dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) + (buf (find-file-noselect test-dir)) + proc) + (unwind-protect + (progn + (with-current-buffer buf + (dired-create-empty-file "foo") + (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) + (make-symbolic-link "foo" "bar") + (make-directory "foodir") + (dired-smart-shell-command "mkfifo foopipe") + (when (featurep 'make-network-process '(:family local)) + (setq proc (make-network-process + :name "foo" + :family 'local + :server t + :service (expand-file-name "foosocket" test-dir)))) + (kill-buffer buf)) + (dired test-dir) + (dired-toggle-read-only) + (let (names) + ;; Test that the file names are the same in Dired and WDired. + (while (not (eobp)) + (should (equal (dired-get-filename 'no-dir t) + (wdired-get-filename t))) + (insert "w") + (push (wdired-get-filename t) names) + (dired-next-line 1)) + (wdired-finish-edit) + ;; Test that editing the file names ignores the indicator + ;; character. + (let (dir) + (while (and (dired-previous-line 1) + (setq dir (dired-get-filename 'no-dir t))) + (should (equal dir (pop names))))))) + (kill-buffer (get-buffer test-dir)) + (ignore-errors (delete-process proc)))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." - (let* ((test-dir (make-temp-file "test-dir" 'dir)) - (fname "foo") - (full-fname (expand-file-name fname test-dir))) - (make-empty-file full-fname) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (dired-toggle-read-only) - (dolist (old '(t nil)) - (should (equal fname (wdired-get-filename 'nodir old))) - (should (equal full-fname (wdired-get-filename nil old)))) - (wdired-finish-edit)) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf))))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/manual/cedet/cedet-utests.el b/test/manual/cedet/cedet-utests.el index 8ebc7a2e155..b365908c639 100644 --- a/test/manual/cedet/cedet-utests.el +++ b/test/manual/cedet/cedet-utests.el @@ -252,9 +252,7 @@ Optional argument TITLE is the title of this testing session." (defun cedet-utest-elapsed-time (start end) "Copied from elp.el. Was elp-elapsed-time. Argument START and END bound the time being calculated." - (+ (* (- (car end) (car start)) 65536.0) - (- (car (cdr end)) (car (cdr start))) - (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0))) + (float-time (time-subtract start end))) (defun cedet-utest-log-shutdown (title &optional _errorcondition) "Shut-down a larger test suite. diff --git a/test/manual/cedet/tests/test.el b/test/manual/cedet/tests/test.el index de1cd814a6b..a523438f68f 100644 --- a/test/manual/cedet/tests/test.el +++ b/test/manual/cedet/tests/test.el @@ -63,11 +63,11 @@ ;;; Methods ;; -(defmethod a-method ((obj some-class) &optional arg2) +(cl-defmethod a-method ((obj some-class) &optional arg2) "Doc String for a method." (call-next-method)) -(defgeneric a-generic (arg1 arg2) +(cl-defgeneric a-generic (arg1 arg2) "General description of a-generic.") ;;; Advice diff --git a/test/manual/indent/perl.perl b/test/manual/indent/perl.perl index 6ec04303b4f..db94552a928 100755 --- a/test/manual/indent/perl.perl +++ b/test/manual/indent/perl.perl @@ -95,3 +95,15 @@ s#ijk#lmn#g; # This is a regular expression sustitution. s #lmn#opq#g; # FIXME: this should be a comment starting with "#lmn" /lmn/rst/g; # and this is the actual regular expression print; # prints "rstrst\n" + +given ($num) { + when ($num>10) { + printf "number is greater than 10\n"; + } + when ($num<10) { + printf "number is less than 10\n"; + } + default { + printf "number is equal to 10\n"; + } +} diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 04c7eea62b1..967833e1903 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -30,7 +30,7 @@ (require 'cl-lib) (ert-deftest finalizer-object-type () - (should (equal (type-of (make-finalizer nil)) 'finalizer))) + (should (equal (type-of (make-finalizer #'ignore)) 'finalizer))) (ert-deftest record-1 () (let ((x (record 'foo 1 2 3))) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 908bff91a0b..31a4b1ac71b 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -19,6 +19,8 @@ ;;; Code: +(require 'ert) +(require 'ert-x) (require 'cl-lib) (ert-deftest overlay-modification-hooks-message-other-buf () @@ -145,7 +147,7 @@ with parameters from the *Messages* buffer modification." (defmacro deftest-overlayp-1 (id arg-expr should-expr) (declare (indent 1)) - `(ert-deftest ,(buffer-tests--make-test-name 'overlay-buffer 1 id) () + `(ert-deftest ,(buffer-tests--make-test-name 'overlayp 1 id) () (with-temp-buffer (should (equal ,should-expr (overlayp ,arg-expr)))))) @@ -434,14 +436,14 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 I 10 (point-max) (10 10)) (deftest-next-overlay-change-1 J 20 (point-max) (10 10)) ;; 2 non-empty, non-intersecting -(deftest-next-overlay-change-1 D 10 20 (20 30) (40 50)) -(deftest-next-overlay-change-1 E 35 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 F 60 (point-max) (20 30) (40 50)) -(deftest-next-overlay-change-1 G 30 40 (20 30) (40 50)) -(deftest-next-overlay-change-1 H 50 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 D2 10 20 (20 30) (40 50)) +(deftest-next-overlay-change-1 E2 35 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 F2 60 (point-max) (20 30) (40 50)) +(deftest-next-overlay-change-1 G2 30 40 (20 30) (40 50)) +(deftest-next-overlay-change-1 H2 50 (point-max) (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-next-overlay-change-1 I 10 20 (20 30) (25 35)) -(deftest-next-overlay-change-1 J 20 25 (20 30) (25 35)) +(deftest-next-overlay-change-1 I2 10 20 (20 30) (25 35)) +(deftest-next-overlay-change-1 J2 20 25 (20 30) (25 35)) (deftest-next-overlay-change-1 K 23 25 (20 30) (25 35)) (deftest-next-overlay-change-1 L 25 30 (20 30) (25 35)) (deftest-next-overlay-change-1 M 28 30 (20 30) (25 35)) @@ -471,11 +473,11 @@ with parameters from the *Messages* buffer modification." (deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) (deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting at end -(deftest-next-overlay-change-1 h 10 20 (30 30) (20 30)) -(deftest-next-overlay-change-1 i 20 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 j 25 30 (30 30) (20 30)) -(deftest-next-overlay-change-1 k 30 (point-max) (20 20) (20 30)) -(deftest-next-overlay-change-1 l 40 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 h2 10 20 (30 30) (20 30)) +(deftest-next-overlay-change-1 i2 20 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 j2 25 30 (30 30) (20 30)) +(deftest-next-overlay-change-1 k2 30 (point-max) (20 20) (20 30)) +(deftest-next-overlay-change-1 l2 40 (point-max) (20 20) (20 30)) ;; 1 empty, 1 non-empty, intersecting in the middle (deftest-next-overlay-change-1 m 10 20 (25 25) (20 30)) (deftest-next-overlay-change-1 n 20 25 (25 25) (20 30)) @@ -522,14 +524,14 @@ with parameters from the *Messages* buffer modification." (deftest-previous-overlay-change-1 I 10 1 (10 10)) (deftest-previous-overlay-change-1 J 20 10 (10 10)) ;; 2 non-empty, non-intersecting -(deftest-previous-overlay-change-1 D 10 1 (20 30) (40 50)) -(deftest-previous-overlay-change-1 E 35 30 (20 30) (40 50)) -(deftest-previous-overlay-change-1 F 60 50 (20 30) (40 50)) -(deftest-previous-overlay-change-1 G 30 20 (20 30) (40 50)) -(deftest-previous-overlay-change-1 H 50 40 (20 30) (40 50)) +(deftest-previous-overlay-change-1 D2 10 1 (20 30) (40 50)) +(deftest-previous-overlay-change-1 E2 35 30 (20 30) (40 50)) +(deftest-previous-overlay-change-1 F2 60 50 (20 30) (40 50)) +(deftest-previous-overlay-change-1 G2 30 20 (20 30) (40 50)) +(deftest-previous-overlay-change-1 H2 50 40 (20 30) (40 50)) ;; 2 non-empty, intersecting -(deftest-previous-overlay-change-1 I 10 1 (20 30) (25 35)) -(deftest-previous-overlay-change-1 J 20 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 I2 10 1 (20 30) (25 35)) +(deftest-previous-overlay-change-1 J2 20 1 (20 30) (25 35)) (deftest-previous-overlay-change-1 K 23 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 L 25 20 (20 30) (25 35)) (deftest-previous-overlay-change-1 M 28 25 (20 30) (25 35)) @@ -619,28 +621,28 @@ with parameters from the *Messages* buffer modification." (deftest-overlays-at-1 P 50 () (a 10 20) (b 30 40)) ;; 2 non-empty overlays intersecting -(deftest-overlays-at-1 G 1 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 H 10 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 I 15 (a) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 K 20 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 L 25 (a b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 M 30 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 N 35 (b) (a 10 30) (b 20 40)) -(deftest-overlays-at-1 O 40 () (a 10 30) (b 20 40)) -(deftest-overlays-at-1 P 50 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 G2 1 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 H2 10 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 I2 15 (a) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 K2 20 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 L2 25 (a b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 M2 30 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 N2 35 (b) (a 10 30) (b 20 40)) +(deftest-overlays-at-1 O2 40 () (a 10 30) (b 20 40)) +(deftest-overlays-at-1 P2 50 () (a 10 30) (b 20 40)) ;; 2 non-empty overlays continuous -(deftest-overlays-at-1 G 1 () (a 10 20) (b 20 30)) -(deftest-overlays-at-1 H 10 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 I 15 (a) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 K 20 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 L 25 (b) (a 10 20) (b 20 30)) -(deftest-overlays-at-1 M 30 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 G3 1 () (a 10 20) (b 20 30)) +(deftest-overlays-at-1 H3 10 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 I3 15 (a) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 K3 20 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 L3 25 (b) (a 10 20) (b 20 30)) +(deftest-overlays-at-1 M3 30 () (a 10 20) (b 20 30)) ;; overlays-at never returns empty overlays. -(deftest-overlays-at-1 N 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 O 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) -(deftest-overlays-at-1 P 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 N3 1 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 O3 20 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) +(deftest-overlays-at-1 P3 30 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 Q 40 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 R 50 (a) (a 1 60) (c 1 1) (b 30 30) (d 50 50)) (deftest-overlays-at-1 S 60 () (a 1 60) (c 1 1) (b 30 30) (d 50 50)) @@ -1107,7 +1109,7 @@ with parameters from the *Messages* buffer modification." (should (eq ov (car (overlays-in 1 1))))))))) ;; properties -(ert-deftest test-buffer-swap-text-1 () +(ert-deftest test-buffer-swap-text-2 () (buffer-tests--with-temp-buffers (buffer other) (with-current-buffer other (overlay-put (make-overlay 1 1) 'buffer 'other)) @@ -1421,66 +1423,63 @@ with parameters from the *Messages* buffer modification." (should (= (length (overlays-in (point-min) (point-max))) 0)))) (ert-deftest test-kill-buffer-auto-save-default () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) (ert-deftest test-kill-buffer-auto-save-delete () - (let ((file (make-temp-file "ert")) - auto-save) - (should (file-exists-p file)) - (setq kill-buffer-delete-auto-save-files t) - ;; Always answer yes. - (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should delete the auto-save file. - (kill-buffer (current-buffer)) - (should-not (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))) - ;; Answer no to deletion. - (cl-letf (((symbol-function #'yes-or-no-p) - (lambda (prompt) - (not (string-search "Delete auto-save file" prompt))))) - (unwind-protect - (progn - (find-file file) - (auto-save-mode t) - (insert "foo\n") - (should buffer-auto-save-file-name) - (setq auto-save buffer-auto-save-file-name) - (do-auto-save) - (should (file-exists-p auto-save)) - ;; This should not delete the auto-save file. - (kill-buffer (current-buffer)) - (should (file-exists-p auto-save))) - (ignore-errors (delete-file file)) - (when auto-save - (ignore-errors (delete-file auto-save))))))) + (ert-with-temp-file file + (let (auto-save) + (should (file-exists-p file)) + (setq kill-buffer-delete-auto-save-files t) + ;; Always answer yes. + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_) t))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should delete the auto-save file. + (kill-buffer (current-buffer)) + (should-not (file-exists-p auto-save))) + (ignore-errors (delete-file file)) + (when auto-save + (ignore-errors (delete-file auto-save))))) + ;; Answer no to deletion. + (cl-letf (((symbol-function #'yes-or-no-p) + (lambda (prompt) + (not (string-search "Delete auto-save file" prompt))))) + (unwind-protect + (progn + (find-file file) + (auto-save-mode t) + (insert "foo\n") + (should buffer-auto-save-file-name) + (setq auto-save buffer-auto-save-file-name) + (do-auto-save) + (should (file-exists-p auto-save)) + ;; This should not delete the auto-save file. + (kill-buffer (current-buffer)) + (should (file-exists-p auto-save))) + (when auto-save + (ignore-errors (delete-file auto-save)))))))) ;;; buffer-tests.el ends here diff --git a/test/src/casefiddle-tests.el b/test/src/casefiddle-tests.el index 19a8aad9ce8..eb096f21129 100644 --- a/test/src/casefiddle-tests.el +++ b/test/src/casefiddle-tests.el @@ -278,4 +278,20 @@ (with-temp-buffer (should-error (upcase-region nil nil t))))) +(ert-deftest casefiddle-turkish () + (skip-unless (member "tr_TR.utf8" (get-locale-names))) + ;; See bug#50752. The point is that unibyte and multibyte strings + ;; are upcased differently in the "dotless i" case in Turkish, + ;; turning ASCII into non-ASCII, which is very unusual. + (with-locale-environment "tr_TR.utf8" + (should (string-equal (downcase "I ı") "ı ı")) + (should (string-equal (downcase "İ i") "i̇ i")) + (should (string-equal (downcase "I") "i")) + (should (string-equal (capitalize "bIte") "Bite")) + (should (string-equal (capitalize "bIté") "Bıté")) + (should (string-equal (capitalize "indIa") "India")) + ;; This does not work -- it produces "Indıa". + ;;(should (string-equal (capitalize "indIá") "İndıa")) + )) + ;;; casefiddle-tests.el ends here diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index eb84262dc8e..89cb3d153d8 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -28,17 +28,23 @@ (require 'ert) (require 'ert-x) (require 'cl-lib) +(require 'comp) +(require 'comp-cstr) -(defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) +(eval-and-compile + (defconst comp-test-src (ert-resource-file "comp-test-funcs.el")) + (defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el"))) -(defconst comp-test-dyn-src (ert-resource-file "comp-test-funcs-dyn.el")) - -(when (featurep 'native-compile) - (require 'comp) +(when (native-comp-available-p) (message "Compiling tests...") (load (native-compile comp-test-src)) (load (native-compile comp-test-dyn-src))) +;; Load the test code here so the compiler can check the function +;; names used in this file. +(require 'comp-test-funcs comp-test-src) +(require 'comp-test-dyn-funcs comp-test-dyn-src) ;Non-standard feature name! + (defmacro comp-deftest (name args &rest docstring-and-body) "Define a test for the native compiler tagging it as :nativecomp." (declare (indent defun) @@ -53,30 +59,32 @@ "Compile the compiler and load it to compile it-self. Check that the resulting binaries do not differ." :tags '(:expensive-test :nativecomp) - (let* ((byte+native-compile t) ; FIXME HACK - (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" + (ert-with-temp-file comp1-src + :suffix "-comp-stage1.el" + (ert-with-temp-file comp2-src + :suffix "-comp-stage2.el" + (let* ((byte+native-compile t) ; FIXME HACK + (comp-src (expand-file-name "../../../lisp/emacs-lisp/comp.el" (ert-resource-directory))) - (comp1-src (make-temp-file "stage1-" nil ".el")) - (comp2-src (make-temp-file "stage2-" nil ".el")) - ;; Can't use debug symbols. - (native-comp-debug 0)) - (copy-file comp-src comp1-src t) - (copy-file comp-src comp2-src t) - (let ((load-no-native t)) - (load (concat comp-src "c") nil nil t t)) - (should-not (subr-native-elisp-p (symbol-function #'native-compile))) - (message "Compiling stage1...") - (let* ((t0 (current-time)) - (comp1-eln (native-compile comp1-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (load comp1-eln nil nil t t) - (should (subr-native-elisp-p (symbol-function 'native-compile))) - (message "Compiling stage2...") - (let ((t0 (current-time)) - (comp2-eln (native-compile comp2-src))) - (message "Done in %d secs" (float-time (time-since t0))) - (message "Comparing %s %s" comp1-eln comp2-eln) - (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))) + ;; Can't use debug symbols. + (native-comp-debug 0)) + (copy-file comp-src comp1-src t) + (copy-file comp-src comp2-src t) + (let ((load-no-native t)) + (load (concat comp-src "c") nil nil t t)) + (should-not (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage1...") + (let* ((t0 (current-time)) + (comp1-eln (native-compile comp1-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (load comp1-eln nil nil t t) + (should (subr-native-elisp-p (symbol-function 'native-compile))) + (message "Compiling stage2...") + (let ((t0 (current-time)) + (comp2-eln (native-compile comp2-src))) + (message "Done in %d secs" (float-time (time-since t0))) + (message "Comparing %s %s" comp1-eln comp2-eln) + (should (= (call-process "cmp" nil nil nil comp1-eln comp2-eln) 0)))))))) (comp-deftest provide () "Testing top level provide." @@ -350,6 +358,8 @@ Check that the resulting binaries do not differ." comp-test-interactive-form2-f))) (should-not (commandp #'comp-tests-doc-f))) +(declare-function comp-tests-free-fun-f nil) + (comp-deftest free-fun () "Check we are able to compile a single function." (eval '(defun comp-tests-free-fun-f () @@ -359,7 +369,7 @@ Check that the resulting binaries do not differ." t) (native-compile #'comp-tests-free-fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-free-fun-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-free-fun-f))) (should (= (comp-tests-free-fun-f) 3)) (should (string= (documentation #'comp-tests-free-fun-f) "Some doc.")) @@ -367,11 +377,13 @@ Check that the resulting binaries do not differ." (should (equal (interactive-form #'comp-tests-free-fun-f) '(interactive)))) +(declare-function comp-tests/free\fun-f nil) + (comp-deftest free-fun-silly-name () "Check we are able to compile a single function." (eval '(defun comp-tests/free\fun-f ()) t) (native-compile #'comp-tests/free\fun-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests/free\fun-f)))) + (should (subr-native-elisp-p (symbol-function 'comp-tests/free\fun-f)))) (comp-deftest bug-40187 () "Check function name shadowing. @@ -382,7 +394,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest speed--1 () "Check that at speed -1 we do not native compile." (should (= (comp-test-speed--1-f) 3)) - (should-not (subr-native-elisp-p (symbol-function #'comp-test-speed--1-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-speed--1-f)))) (comp-deftest bug-42360 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-07/msg00418.html>." @@ -431,7 +443,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest primitive-redefine () "Test effectiveness of primitive redefinition." (cl-letf ((comp-test-primitive-redefine-args nil) - ((symbol-function #'-) + ((symbol-function '-) (lambda (&rest args) (setq comp-test-primitive-redefine-args args) 'xxx))) @@ -452,11 +464,11 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest comp-test-defsubst () ;; Bug#42664, Bug#43280, Bug#44209. - (should-not (subr-native-elisp-p (symbol-function #'comp-test-defsubst-f)))) + (should-not (subr-native-elisp-p (symbol-function 'comp-test-defsubst-f)))) (comp-deftest primitive-redefine-compile-44221 () "Test the compiler still works while primitives are redefined (bug#44221)." - (cl-letf (((symbol-function #'delete-region) + (cl-letf (((symbol-function 'delete-region) (lambda (_ _)))) (should (subr-native-elisp-p (native-compile @@ -492,12 +504,12 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest 45603-1 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-12/msg01994.html>" (load (native-compile (ert-resource-file "comp-test-45603.el"))) - (should (fboundp #'comp-test-45603--file-local-name))) + (should (fboundp 'comp-test-45603--file-local-name))) (comp-deftest 46670-1 () "<https://lists.gnu.org/archive/html/bug-gnu-emacs/2021-02/msg01413.html>" (should (string= (comp-test-46670-2-f "foo") "foo")) - (should (equal (subr-type (symbol-function #'comp-test-46670-2-f)) + (should (equal (subr-type (symbol-function 'comp-test-46670-2-f)) '(function (t) t)))) (comp-deftest 46824-1 () @@ -727,7 +739,7 @@ https://lists.gnu.org/archive/html/bug-gnu-emacs/2020-03/msg00914.html." (comp-deftest dynamic-help-arglist () "Test `help-function-arglist' works on lisp/d (bug#42572)." (should (equal (help-function-arglist - (symbol-function #'comp-tests-ffuncall-callee-opt-rest-dyn-f) + (symbol-function 'comp-tests-ffuncall-callee-opt-rest-dyn-f) t) '(a b &optional c &rest d)))) @@ -784,6 +796,8 @@ Return a list of results." (comp-tests-mentioned-p (comp-c-func-name 'comp-tests-tco-f "F" t) insn))))))) +(declare-function comp-tests-tco-f nil) + (comp-deftest tco () "Check for tail recursion elimination." (let ((native-comp-speed 3) @@ -798,7 +812,7 @@ Return a list of results." (comp-tests-tco-f (+ a b) a (- count 1)))) t) (native-compile #'comp-tests-tco-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-tco-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-tco-f))) (should (= (comp-tests-tco-f 1 0 10) 55)))) (defun comp-tests-fw-prop-checker-1 (_) @@ -812,6 +826,8 @@ Return a list of results." (or (comp-tests-mentioned-p 'concat insn) (comp-tests-mentioned-p 'length insn))))))) +(declare-function comp-tests-fw-prop-1-f nil) + (comp-deftest fw-prop-1 () "Some tests for forward propagation." (let ((native-comp-speed 2) @@ -823,7 +839,7 @@ Return a list of results." (length c))) ; <= has to optimize t) (native-compile #'comp-tests-fw-prop-1-f) - (should (subr-native-elisp-p (symbol-function #'comp-tests-fw-prop-1-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-fw-prop-1-f))) (should (= (comp-tests-fw-prop-1-f) 6)))) (defun comp-tests-check-ret-type-spec (func-form ret-type) @@ -1403,11 +1419,13 @@ folded." (comp-post-pass-hooks '((comp-final comp-tests-pure-checker-1 comp-tests-pure-checker-2)))) (load (native-compile (ert-resource-file "comp-test-pure.el"))) + (declare-function comp-tests-pure-caller-f nil) + (declare-function comp-tests-pure-fibn-entry-f nil) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-caller-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-caller-f))) (should (= (comp-tests-pure-caller-f) 4)) - (should (subr-native-elisp-p (symbol-function #'comp-tests-pure-fibn-entry-f))) + (should (subr-native-elisp-p (symbol-function 'comp-tests-pure-fibn-entry-f))) (should (= (comp-tests-pure-fibn-entry-f) 6765)))) (defvar comp-tests-cond-rw-checked-function nil diff --git a/test/src/data-tests.el b/test/src/data-tests.el index 6de178743e6..7d8535f5f37 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -419,7 +419,7 @@ comparing the subr with a much slower Lisp implementation." "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) -(ert-deftest binding-test-set-constant-nil () +(ert-deftest binding-test-set-constant-itself () "Test setting a keyword to itself." (with-no-warnings (should (setq :keyword :keyword)))) @@ -433,26 +433,27 @@ comparing the subr with a much slower Lisp implementation." ;; More specifically, test the problem seen in bug#41029 where setting ;; the default value of a variable takes time proportional to the ;; number of buffers. - (let* ((fun #'error) - (test (lambda () - (with-temp-buffer - (let ((st (car (current-cpu-time)))) - (dotimes (_ 1000) - (let ((case-fold-search 'data-test)) - ;; Use an indirection through a mutable var - ;; to try and make sure the byte-compiler - ;; doesn't optimize away the let bindings. - (funcall fun))) - ;; FIXME: Handle the wraparound, if any. - (- (car (current-cpu-time)) st))))) - (_ (setq fun #'ignore)) - (time1 (funcall test)) - (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) - (make-list 1000 nil))) - (time2 (funcall test))) - (mapc #'kill-buffer bufs) - ;; Don't divide one time by the other since they may be 0. - (should (< time2 (* time1 5))))) + (when (fboundp 'current-cpu-time) ; silence byte-compiler + (let* ((fun #'error) + (test (lambda () + (with-temp-buffer + (let ((st (car (current-cpu-time)))) + (dotimes (_ 1000) + (let ((case-fold-search 'data-test)) + ;; Use an indirection through a mutable var + ;; to try and make sure the byte-compiler + ;; doesn't optimize away the let bindings. + (funcall fun))) + ;; FIXME: Handle the wraparound, if any. + (- (car (current-cpu-time)) st))))) + (_ (setq fun #'ignore)) + (time1 (funcall test)) + (bufs (mapcar (lambda (_) (generate-new-buffer " data-test")) + (make-list 1000 nil))) + (time2 (funcall test))) + (mapc #'kill-buffer bufs) + ;; Don't divide one time by the other since they may be 0. + (should (< time2 (* time1 5)))))) ;; More tests to write - ;; kill-local-variable @@ -690,7 +691,7 @@ comparing the subr with a much slower Lisp implementation." (let ((n (* 2 most-negative-fixnum))) (should (= (logand -1 n) n)))) -(ert-deftest data-tests-logcount () +(ert-deftest data-tests-logcount-2 () (should (= (logcount (read "#xffffffffffffffffffffffffffffffff")) 128))) (ert-deftest data-tests-logior () diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index b910709183f..47d67b7bda4 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -23,6 +23,8 @@ (require 'ert) +(declare-function zlib-decompress-region "decompress.c") + (defvar zlib-tests-data-directory (expand-file-name "data/decompress" (getenv "EMACS_TEST_DIRECTORY")) "Directory containing zlib test data.") diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index a3dd7bd466a..5fe896fbbd1 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -23,16 +23,16 @@ (ert-deftest format-properties () ;; Bug #23730 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%d" 'face '(:background "red")) 1) #("1" 0 1 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%2d" 'face '(:background "red")) 1) #(" 1" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "%02d" 'face '(:background "red")) 1) #("01" 0 2 (face (:background "red"))))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%2d" 'x 'X) (propertize "a" 'a 'A) (propertize "b" 'b 'B)) @@ -40,27 +40,27 @@ #(" 1ab" 0 2 (x X) 2 3 (a A) 3 4 (b B)))) ;; Bug #5306 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "1234567890aaaa" (propertize "12345678901234567890" 'xxx 25))) "1234567890")) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%.10s" (concat "123456789" (propertize "12345678901234567890" 'xxx 25))) #("1234567891" 9 10 (xxx 25)))) ;; Bug #23859 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%4s" (propertize "hi" 'face 'bold)) #(" hi" 2 4 (face bold)))) ;; Bug #23897 - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789" 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) @@ -68,63 +68,63 @@ ;; The last property range is extended to include padding on the ;; right, but the first range is not extended to the left to include ;; padding on the left! - (should (ert-equal-including-properties + (should (equal-including-properties (format "%12s" (concat (propertize "01234" 'face 'bold) "56789")) #(" 0123456789" 2 7 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-12s" (concat (propertize "01234" 'face 'bold) "56789")) #("0123456789 " 0 5 (face bold)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #(" 012345" 4 6 (face bold) 6 8 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) "45")) #("012345 " 0 2 (face bold) 2 4 (face underline)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format "%-10s" (concat (propertize "01" 'face 'bold) (propertize "23" 'face 'underline) (propertize "45" 'face 'italic))) #("012345 " 0 2 (face bold) 2 4 (face underline) 4 10 (face italic)))) ;; Bug #38191 - (should (ert-equal-including-properties + (should (equal-including-properties (format (propertize "‘foo’ %s bar" 'face 'bold) "xxx") #("‘foo’ xxx bar" 0 13 (face bold)))) ;; Bug #32404 - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat (propertize "%s" 'face 'bold) "" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 0 3 (face bold) 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s" (propertize "%s" 'face 'error)) "foo" "bar") #("foobar" 3 6 (face error)))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%s " (propertize "%s" 'face 'error)) "foo" "bar") #("foo bar" 4 7 (face error)))) ;; Bug #46317 (let ((s (propertize "X" 'prop "val"))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3s/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3S/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%3d/" s) 12) #(" 12/X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3s/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3S/" s) 12) #("12 /X" 4 5 (prop "val")))) - (should (ert-equal-including-properties + (should (equal-including-properties (format (concat "%-3d/" s) 12) #("12 /X" 4 5 (prop "val")))))) @@ -413,4 +413,17 @@ (translate-region-internal (point-min) (point-max) tt) (should (string-equal (buffer-string) "*"))))) +(ert-deftest find-fields () + (with-temp-buffer + (insert "foo" (propertize "bar" 'field 'bar) "zot") + (goto-char (point-min)) + (should (= (field-beginning) (point-min))) + (should (= (field-end) 4)) + (goto-char 5) + (should (= (field-beginning) 4)) + (should (= (field-end) 7)) + (goto-char 8) + (should (= (field-beginning) 7)) + (should (= (field-end) (point-max))))) + ;;; editfns-tests.el ends here diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 57321a951de..2ff33644a8e 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -32,6 +32,11 @@ (require 'help-fns) (require 'subr-x) +;; Catch information for bug#50902. +(when (getenv "EMACS_EMBA_CI") + (start-process-shell-command + "*timeout*" nil (format "sleep 60; kill -ABRT %d" (emacs-pid)))) + (defconst mod-test-emacs (expand-file-name invocation-name invocation-directory) "File name of the Emacs binary currently running.") @@ -206,20 +211,6 @@ changes." (should (equal (help-function-arglist #'mod-test-sum) '(arg1 arg2)))) -(defmacro module--with-temp-directory (name &rest body) - "Bind NAME to the name of a temporary directory and evaluate BODY. -NAME must be a symbol. Delete the temporary directory after BODY -exits normally or non-locally. NAME will be bound to the -directory name (not the directory file name) of the temporary -directory." - (declare (indent 1)) - (cl-check-type name symbol) - `(let ((,name (file-name-as-directory - (make-temp-file "emacs-module-test" :directory)))) - (unwind-protect - (progn ,@body) - (delete-directory ,name :recursive)))) - (defmacro module--test-assertion (pattern &rest body) "Test that PATTERN matches the assertion triggered by BODY. Run Emacs as a subprocess, load the test module `mod-test-file', @@ -228,7 +219,7 @@ assertion message that matches PATTERN. PATTERN is evaluated and must evaluate to a regular expression string." (declare (indent 1)) ;; To contain any core dumps. - `(module--with-temp-directory tempdir + `(ert-with-temp-directory tempdir (with-temp-buffer (let* ((default-directory tempdir) (status (call-process mod-test-emacs nil t nil @@ -256,6 +247,7 @@ must evaluate to a regular expression string." (ert-deftest module--test-assertions--load-non-live-object () "Check that -module-assertions verify that non-live objects aren't accessed." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -274,6 +266,7 @@ must evaluate to a regular expression string." This differs from `module--test-assertions-load-non-live-object' in that it stows away a global reference. The module assertions should nevertheless detect the invalid load." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -290,6 +283,7 @@ should nevertheless detect the invalid load." (ert-deftest module--test-assertions--call-emacs-from-gc () "Check that -module-assertions prevents calling Emacs functions during garbage collection." + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) @@ -301,7 +295,8 @@ during garbage collection." (ert-deftest module--test-assertions--globref-invalid-free () "Check that -module-assertions detects invalid freeing of a local reference." - (skip-unless (or (file-executable-p mod-test-emacs) + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) + (skip-unless (or (file-executable-p mod-test-emacs) (and (eq system-type 'windows-nt) (file-executable-p (concat mod-test-emacs ".exe"))))) (module--test-assertion diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el index 930cc9fa214..52888135c12 100644 --- a/test/src/emacs-tests.el +++ b/test/src/emacs-tests.el @@ -25,6 +25,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-file (require 'rx) (require 'subr-x) @@ -46,22 +47,6 @@ "--seccomp=/does-not-exist.bpf") 0)))) -(cl-defmacro emacs-tests--with-temp-file - (var (prefix &optional suffix text) &rest body) - "Evaluate BODY while a new temporary file exists. -Bind VAR to the name of the file. Pass PREFIX, SUFFIX, and TEXT -to `make-temp-file', which see." - (declare (indent 2) (debug (symbolp (form form form) body))) - (cl-check-type var symbol) - ;; Use an uninterned symbol so that the code still works if BODY - ;; changes VAR. - (let ((filename (make-symbol "filename"))) - `(let ((,filename (make-temp-file ,prefix nil ,suffix ,text))) - (unwind-protect - (let ((,var ,filename)) - ,@body) - (delete-file ,filename))))) - (ert-deftest emacs-tests/seccomp/empty-file () (skip-unless (string-match-p (rx bow "SECCOMP" eow) system-configuration-features)) @@ -69,7 +54,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -94,9 +80,9 @@ to `make-temp-file', which see." ;; Either 8 or 16, but 16 should be large enough in all cases. (filter-size 16)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file - filter ("seccomp-too-large-" ".bpf" - (make-string (* (1+ ushort-max) filter-size) ?a)) + (ert-with-temp-file filter + :prefix "seccomp-too-large-" :suffix ".bpf" + :text (make-string (* (1+ ushort-max) filter-size) ?a) ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. @@ -117,8 +103,8 @@ to `make-temp-file', which see." (expand-file-name invocation-name invocation-directory)) (process-environment nil)) (skip-unless (file-executable-p emacs)) - (emacs-tests--with-temp-file filter ("seccomp-invalid-" ".bpf" - "123456") + (ert-with-temp-file filter + :prefix "seccomp-invalid-" :suffix ".bpf" :text "123456" ;; The --seccomp option is processed early, without filename ;; handlers. Therefore remote or quoted filenames wouldn't ;; work. diff --git a/test/src/eval-tests.el b/test/src/eval-tests.el index 797d5a6f7a6..e4230c10efd 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -86,23 +86,27 @@ Bug#24912." (ert-deftest eval-tests--if-dot-string () "Check that Emacs rejects (if . \"string\")." - (should-error (eval '(if . "abc")) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") nil) :type 'wrong-type-argument) + (should-error (eval '(if . "abc") t) :type 'wrong-type-argument) (let ((if-tail (list '(setcdr if-tail "abc") t))) - (should-error (eval (cons 'if if-tail)))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable)) (let ((if-tail (list '(progn (setcdr if-tail "abc") nil) t))) - (should-error (eval (cons 'if if-tail))))) + (should-error (eval (cons 'if if-tail) nil) :type 'void-variable) + (should-error (eval (cons 'if if-tail) t) :type 'void-variable))) (ert-deftest eval-tests--let-with-circular-defs () "Check that Emacs reports an error for (let VARS ...) when VARS is circular." (let ((vars (list 'v))) (setcdr vars vars) (dolist (let-sym '(let let*)) - (should-error (eval (list let-sym vars)))))) + (should-error (eval (list let-sym vars) nil))))) (ert-deftest eval-tests--mutating-cond () "Check that Emacs doesn't crash on a cond clause that mutates during eval." (let ((clauses (list '((progn (setcdr clauses "ouch") nil))))) - (should-error (eval (cons 'cond clauses))))) + (should-error (eval (cons 'cond clauses) nil)) + (should-error (eval (cons 'cond clauses) t)))) (defun eval-tests--exceed-specbind-limit () (defvar eval-tests--var1) @@ -179,12 +183,13 @@ are found on the stack and therefore not garbage collected." "Remove the Lisp reference to the byte-compiled object." (setf (symbol-function #'eval-tests-33014-func) nil)) -(defun eval-tests-19790-backquote-comma-dot-substitution () +(ert-deftest eval-tests-19790-backquote-comma-dot-substitution () "Regression test for Bug#19790. Don't handle destructive splicing in backquote expressions (like in Common Lisp). Instead, make sure substitution in backquote expressions works for identifiers starting with period." - (should (equal (let ((.x 'identity)) (eval `(,.x 'ok))) 'ok))) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) nil)) 'ok)) + (should (equal (let ((.x 'identity)) (eval `(,.x 'ok) t)) 'ok))) (ert-deftest eval-tests/backtrace-in-batch-mode () (let ((emacs (expand-file-name invocation-name invocation-directory))) diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el index ae59d2ddc11..21478a1a0f2 100644 --- a/test/src/filelock-tests.el +++ b/test/src/filelock-tests.el @@ -28,6 +28,7 @@ (require 'cl-macs) (require 'ert) +(require 'ert-x) (require 'seq) (defun filelock-tests--fixture (test-function) @@ -36,22 +37,20 @@ Create a test directory and a buffer whose `buffer-file-name' and `buffer-file-truename' are a file within it, then call TEST-FUNCTION. Finally, delete the buffer and the test directory." - (let* ((temp-dir (make-temp-file "filelock-tests" t)) - (name (concat (file-name-as-directory temp-dir) - "userfile")) - (create-lockfiles t)) - (unwind-protect - (with-temp-buffer - (setq buffer-file-name name - buffer-file-truename name) - (unwind-protect - (save-current-buffer - (funcall test-function)) - ;; Set `buffer-file-truename' nil to prevent unlocking, - ;; which might prompt the user and/or signal errors. - (setq buffer-file-name nil - buffer-file-truename nil))) - (delete-directory temp-dir t nil)))) + (ert-with-temp-directory temp-dir + (let ((name (concat (file-name-as-directory temp-dir) + "userfile")) + (create-lockfiles t)) + (with-temp-buffer + (setq buffer-file-name name + buffer-file-truename name) + (unwind-protect + (save-current-buffer + (funcall test-function)) + ;; Set `buffer-file-truename' nil to prevent unlocking, + ;; which might prompt the user and/or signal errors. + (setq buffer-file-name nil + buffer-file-truename nil)))))) (defun filelock-tests--make-lock-name (file-name) "Return the lock file name for FILE-NAME. @@ -124,7 +123,9 @@ the case)." (filelock-tests--spoil-lock-file buffer-file-truename) (let ((err (should-error (file-locked-p (buffer-file-name))))) (should (equal (seq-subseq err 0 2) - '(file-error "Testing file lock"))))))) + (if (eq system-type 'windows-nt) + '(permission-denied "Testing file lock") + '(file-error "Testing file lock")))))))) (ert-deftest filelock-tests-unlock-spoiled () "Check that `unlock-buffer' fails if the lockfile is \"spoiled\"." @@ -145,8 +146,11 @@ the case)." (lambda (err) (push err errors)))) (unlock-buffer)) (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (car errors) 0 2))) (should (equal (length errors) 1)))))) (ert-deftest filelock-tests-kill-buffer-spoiled () @@ -175,8 +179,11 @@ the case)." (lambda (err) (push err errors)))) (kill-buffer)) (should (consp errors)) - (should (equal '(file-error "Unlocking file") - (seq-subseq (car errors) 0 2))) + (should (equal + (if (eq system-type 'windows-nt) + '(permission-denied "Unlocking file") + '(file-error "Unlocking file")) + (seq-subseq (car errors) 0 2))) (should (equal (length errors) 1)))))) (provide 'filelock-tests) diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index d887939c999..aa709e3c2f5 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -21,6 +21,68 @@ (require 'ert) +(ert-deftest floatfns-tests-cos () + (should (= (cos 0) 1.0)) + (should (= (cos float-pi) -1.0))) + +(ert-deftest floatfns-tests-sin () + (should (= (sin 0) 0.0))) + +(ert-deftest floatfns-tests-tan () + (should (= (tan 0) 0.0))) + +(ert-deftest floatfns-tests-isnan () + (should (isnan 0.0e+NaN)) + (should (isnan -0.0e+NaN)) + (should-error (isnan "foo") :type 'wrong-type-argument)) + +(ert-deftest floatfns-tests-exp () + (should (= (exp 0) 1.0))) + +(ert-deftest floatfns-tests-expt () + (should (= (expt 2 8) 256))) + +(ert-deftest floatfns-tests-log () + (should (= (log 1000 10) 3.0))) + +(ert-deftest floatfns-tests-sqrt () + (should (= (sqrt 25) 5))) + +(ert-deftest floatfns-tests-abs () + (should (= (abs 10) 10)) + (should (= (abs -10) 10))) + +(ert-deftest floatfns-tests-logb () + (should (= (logb 10000) 13))) + +(ert-deftest floatfns-tests-ceiling () + (should (= (ceiling 0.5) 1))) + +(ert-deftest floatfns-tests-floor () + (should (= (floor 1.5) 1))) + +(ert-deftest floatfns-tests-round () + (should (= (round 1.49999999999) 1)) + (should (= (round 1.50000000000) 2)) + (should (= (round 1.50000000001) 2))) + +(ert-deftest floatfns-tests-truncate () + (should (= (truncate float-pi) 3))) + +(ert-deftest floatfns-tests-fceiling () + (should (= (fceiling 0.5) 1.0))) + +(ert-deftest floatfns-tests-ffloor () + (should (= (ffloor 1.5) 1.0))) + +(ert-deftest floatfns-tests-fround () + (should (= (fround 1.49999999999) 1.0)) + (should (= (fround 1.50000000000) 2.0)) + (should (= (fround 1.50000000001) 2.0))) + +(ert-deftest floatfns-tests-ftruncate () + (should (= (ftruncate float-pi) 3.0))) + (ert-deftest divide-extreme-sign () (should (= (ceiling most-negative-fixnum -1.0) (- most-negative-fixnum))) (should (= (floor most-negative-fixnum -1.0) (- most-negative-fixnum))) diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 4d59f349bab..f74e925d3b6 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -23,6 +23,29 @@ (require 'cl-lib) +(ert-deftest fns-tests-identity () + (let ((num 12345)) (should (eq (identity num) num))) + (let ((str "foo")) (should (eq (identity str) str))) + (let ((lst '(11))) (should (eq (identity lst) lst)))) + +(ert-deftest fns-tests-random () + (should (integerp (random))) + (should (>= (random 10) 0)) + (should (< (random 10) 10))) + +(ert-deftest fns-tests-length () + (should (= (length nil) 0)) + (should (= (length '(1 2 3)) 3)) + (should (= (length '[1 2 3]) 3)) + (should (= (length "foo") 3)) + (should-error (length t))) + +(ert-deftest fns-tests-safe-length () + (should (= (safe-length '(1 2 3)) 3))) + +(ert-deftest fns-tests-string-bytes () + (should (= (string-bytes "abc") 3))) + ;; Test that equality predicates work correctly on NaNs when combined ;; with hash tables based on those predicates. This was not the case ;; for eql in Emacs 26. @@ -34,6 +57,33 @@ (puthash nan t h) (should (eq (funcall test nan -nan) (gethash -nan h)))))) +(ert-deftest fns-tests-equal-including-properties () + (should (equal-including-properties "" "")) + (should (equal-including-properties "foo" "foo")) + (should (equal-including-properties #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should (equal-including-properties #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k v)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("a" 0 1 (k x)))) + (should-not (equal-including-properties #("a" 0 1 (k v)) + #("b" 0 1 (k v)))) + (should-not (equal-including-properties #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)))) + +(ert-deftest fns-tests-equal-including-properties/string-prop-vals () + "Handle string property values. (Bug#6581)" + (should (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "v")))) + (should (equal-including-properties #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("a" 0 1 (k "x")))) + (should-not (equal-including-properties #("a" 0 1 (k "v")) + #("b" 0 1 (k "v"))))) + (ert-deftest fns-tests-reverse () (should-error (reverse)) (should-error (reverse 1)) @@ -268,7 +318,10 @@ (should (equal (base64-encode-string "fooba") "Zm9vYmE=")) (should (equal (base64-encode-string "foobar") "Zm9vYmFy")) (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7e") "FPucA9l+")) - (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/"))) + (should (equal (base64-encode-string "\x14\xfb\x9c\x03\xd9\x7f") "FPucA9l/")) + + (should-error (base64-encode-string "ƒ")) + (should-error (base64-encode-string "ü"))) (ert-deftest fns-test-base64url-encode-region () ;; url variant with padding @@ -310,7 +363,11 @@ (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) (should (equal (fns-tests--with-region base64url-encode-region (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) - (fns-tests--string-repeat "FPucA9l_" 10)))) + (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (fns-tests--with-region base64url-encode-region "ƒ")) + (should-error (fns-tests--with-region base64url-encode-region "ü"))) + (ert-deftest fns-test-base64url-encode-string () ;; url variant with padding @@ -344,7 +401,10 @@ (should (equal (base64url-encode-string (fns-tests--string-repeat "fooba" 15) t) (fns-tests--string-repeat "Zm9vYmFmb29iYWZvb2Jh" 5))) (should (equal (base64url-encode-string (fns-tests--string-repeat "foobar" 15) t) (concat (fns-tests--string-repeat "Zm9vYmFyZm9vYmFy" 7) "Zm9vYmFy"))) (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7e" 10) t) (fns-tests--string-repeat "FPucA9l-" 10))) - (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10)))) + (should (equal (base64url-encode-string (fns-tests--string-repeat "\x14\xfb\x9c\x03\xd9\x7f" 10) t) (fns-tests--string-repeat "FPucA9l_" 10))) + + (should-error (base64url-encode-string "ƒ")) + (should-error (base64url-encode-string "ü"))) (ert-deftest fns-tests-base64-decode-string () ;; standard variant RFC2045 @@ -430,6 +490,23 @@ (buffer-hash)) (sha1 "foo")))) +(ert-deftest fns-tests-mapconcat () + (should (string= (mapconcat #'identity '()) "")) + (should (string= (mapconcat #'identity '("a" "b")) "ab")) + (should (string= (mapconcat #'identity '() "_") "")) + (should (string= (mapconcat #'identity '("A") "_") "A")) + (should (string= (mapconcat #'identity '("A" "B") "_") "A_B")) + (should (string= (mapconcat #'identity '("A" "B" "C") "_") "A_B_C")) + ;; non-ASCII strings + (should (string= (mapconcat #'identity '("Ä" "ø" "☭" "தமிழ்") "_漢字_") + "Ä_漢字_ø_漢字_☭_漢字_தமிழ்")) + ;; vector + (should (string= (mapconcat #'identity ["a" "b"] "") "ab")) + ;; bool-vector + (should (string= (mapconcat #'identity [nil nil] "") "")) + (should-error (mapconcat #'identity [nil nil t]) + :type 'wrong-type-argument)) + (ert-deftest fns-tests-mapcan () (should-error (mapcan)) (should-error (mapcan #'identity)) diff --git a/test/src/image-tests.el b/test/src/image-tests.el new file mode 100644 index 00000000000..e54d0df71f1 --- /dev/null +++ b/test/src/image-tests.el @@ -0,0 +1,244 @@ +;;; image-tests.el --- Tests for image.c -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefan@marxist.se> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Most of these tests will only run in a GUI session, and not with +;; "make check". Run them manually in an interactive session with +;; `M-x eval-buffer' followed by `M-x ert'. + +;;; Code: + +(require 'ert) + +(defmacro image-skip-unless (format) + `(skip-unless (and (display-images-p) + (image-type-available-p ,format)))) + +;;;; Images + +(defconst image-tests--images + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(find-image '((:file "splash.svg" :type svg)))) + (png . ,(find-image '((:file "splash.png" :type png)))) + (svg . ,(find-image '((:file "splash.pbm" :type pbm)))) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(find-image '((:file "gnus/gnus.xbm" :type xbm)))) + (xpm . ,(find-image '((:file "splash.xpm" :type xpm)))))) + +;;;; image-test-size + +(ert-deftest image-tests-image-size/gif () + (image-skip-unless 'gif) + (pcase (image-size (create-image (cdr (assq 'gif image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/jpeg () + (image-skip-unless 'jpeg) + (pcase (image-size (create-image (cdr (assq 'jpeg image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/pbm () + (image-skip-unless 'pbm) + (pcase (image-size (cdr (assq 'pbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/png () + (image-skip-unless 'png) + (pcase (image-size (cdr (assq 'png image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/svg () + (image-skip-unless 'svg) + (pcase (image-size (cdr (assq 'svg image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/tiff () + (image-skip-unless 'tiff) + (pcase (image-size (create-image (cdr (assq 'tiff image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/webp () + (image-skip-unless 'webp) + (pcase (image-size (create-image (cdr (assq 'webp image-tests--images)))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xbm () + (image-skip-unless 'xbm) + (pcase (image-size (cdr (assq 'xbm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/xpm () + (image-skip-unless 'xpm) + (pcase (image-size (cdr (assq 'xpm image-tests--images))) + (`(,a . ,b) + (should (floatp a)) + (should (floatp b))))) + +(ert-deftest image-tests-image-size/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-size 'invalid-spec))) + +(ert-deftest image-tests-image-size/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-size 'invalid-spec))) + +;;;; image-mask-p + +(ert-deftest image-tests-image-mask-p/gif () + (image-skip-unless 'gif) + (should-not (image-mask-p (create-image + (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-mask-p (create-image + (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/pbm () + (image-skip-unless 'pbm) + (should-not (image-mask-p (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/png () + (image-skip-unless 'png) + (should-not (image-mask-p (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/svg () + (image-skip-unless 'svg) + (should-not (image-mask-p (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/tiff () + (image-skip-unless 'tiff) + (should-not (image-mask-p (create-image + (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/webp () + (image-skip-unless 'webp) + (should-not (image-mask-p (create-image + (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-mask-p/xbm () + (image-skip-unless 'xbm) + (should-not (image-mask-p (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/xpm () + (image-skip-unless 'xpm) + (should-not (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-mask-p/error-on-invalid-spec () + (skip-unless (display-images-p)) + (should-error (image-mask-p 'invalid-spec))) + +(ert-deftest image-tests-image-mask-p/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-mask-p (cdr (assq 'xpm image-tests--images))))) + +;;;; image-metadata + +;; TODO: These tests could be expanded with files that actually +;; contain metadata. + +(ert-deftest image-tests-image-metadata/gif () + (image-skip-unless 'gif) + (should-not (image-metadata + (create-image (cdr (assq 'gif image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/jpeg () + (image-skip-unless 'jpeg) + (should-not (image-metadata + (create-image (cdr (assq 'jpeg image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/pbm () + (image-skip-unless 'pbm) + (should-not (image-metadata (cdr (assq 'pbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/png () + (image-skip-unless 'png) + (should-not (image-metadata (cdr (assq 'png image-tests--images))))) + +(ert-deftest image-tests-image-metadata/svg () + (image-skip-unless 'svg) + (should-not (image-metadata (cdr (assq 'svg image-tests--images))))) + +(ert-deftest image-tests-image-metadata/tiff () + (image-skip-unless 'tiff) + (should-not (image-metadata + (create-image (cdr (assq 'tiff image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/webp () + (image-skip-unless 'webp) + (should-not (image-metadata + (create-image (cdr (assq 'webp image-tests--images)))))) + +(ert-deftest image-tests-image-metadata/xbm () + (image-skip-unless 'xbm) + (should-not (image-metadata (cdr (assq 'xbm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/xpm () + (image-skip-unless 'xpm) + (should-not (image-metadata (cdr (assq 'xpm image-tests--images))))) + +(ert-deftest image-tests-image-metadata/nil-on-invalid-spec () + (skip-unless (display-images-p)) + (should-not (image-metadata 'invalid-spec))) + +(ert-deftest image-tests-image-metadata/error-on-nongraphical-display () + (skip-unless (not (display-images-p))) + (should-error (image-metadata (cdr (assq 'xpm image-tests--images))))) + +;;;; ImageMagick + +(ert-deftest image-tests-imagemagick-types () + (skip-unless (fboundp 'imagemagick-types)) + (when (fboundp 'imagemagick-types) + (should (listp (imagemagick-types))))) + +;;;; Initialization + +(ert-deftest image-tests-init-image-library () + (skip-unless (fboundp 'init-image-library)) + (should (init-image-library 'pbm)) ; built-in + (should-not (init-image-library 'invalid-image-type))) + +;;; image-tests.el ends here diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el index d9390b638b6..295b184be0e 100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@ -24,9 +24,11 @@ ;;; Code: (require 'ert) +(require 'ert-x) (declare-function inotify-add-watch "inotify.c" (file-name aspect callback)) (declare-function inotify-rm-watch "inotify.c" (watch-descriptor)) +(declare-function inotify-valid-p "inotify.c" (watch-descriptor)) (ert-deftest inotify-valid-p-simple () "Simple tests for `inotify-valid-p'." @@ -37,8 +39,7 @@ ;; (ert-deftest filewatch-file-watch-aspects-check () ;; "Test whether `file-watch' properly checks the aspects." -;; (let ((temp-file (make-temp-file "filewatch-aspects"))) -;; (should (stringp temp-file)) +;; (ert-with-temp-file temp-file ;; (should-error (file-watch temp-file 'wrong nil) ;; :type 'error) ;; (should-error (file-watch temp-file '(modify t) nil) @@ -50,23 +51,21 @@ (ert-deftest inotify-file-watch-simple () "Test if watching a normal file works." - (skip-unless (featurep 'inotify)) - (let ((temp-file (make-temp-file "inotify-simple")) - (events 0)) - (let ((wd - (inotify-add-watch temp-file t (lambda (_ev) - (setq events (1+ events)))))) - (unwind-protect - (progn - (with-temp-file temp-file - (insert "Foo\n")) - (read-event nil nil 5) - (should (> events 0))) - (should (inotify-valid-p wd)) - (inotify-rm-watch wd) - (should-not (inotify-valid-p wd)) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + (let ((events 0)) + (let ((wd + (inotify-add-watch temp-file t (lambda (_ev) + (setq events (1+ events)))))) + (unwind-protect + (progn + (with-temp-file temp-file + (insert "Foo\n")) + (read-event nil nil 5) + (should (> events 0))) + (should (inotify-valid-p wd)) + (inotify-rm-watch wd) + (should-not (inotify-valid-p wd))))))) (provide 'inotify-tests) diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index 1dbaf7ef2e7..69aa7238493 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -134,6 +134,45 @@ (define-key map [menu-bar i-bar] 'foo) (should (eq (lookup-key map [menu-bar I-bar]) 'foo)))) +(ert-deftest keymap-lookup-key/mixed-case-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + ;; (downcase "Åäö") => "åäö" + (define-key map [menu-bar åäö bar] 'foo) + (should (eq (lookup-key map [menu-bar åäö bar]) 'foo)) + (should (eq (lookup-key map [menu-bar Åäö Bar]) 'foo)) + ;; (downcase "Γ") => "γ" + (define-key map [menu-bar γ bar] 'baz) + (should (eq (lookup-key map [menu-bar γ bar]) 'baz)) + (should (eq (lookup-key map [menu-bar Γ Bar]) 'baz)))) + +(ert-deftest keymap-lookup-key/menu-non-symbol () + "Test for Bug#51527." + (let ((map (make-keymap))) + (define-key map [menu-bar buffer 1] 'foo) + (should (eq (lookup-key map [menu-bar buffer 1]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar foo-bar] 'foo) + (should (eq (lookup-key map [menu-bar Foo\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte () + "Backwards compatibility behaviour (Bug#50752)." + (let ((map (make-keymap))) + (define-key map [menu-bar åäö-bar] 'foo) + (should (eq (lookup-key map [menu-bar Åäö\ Bar]) 'foo)))) + +(ert-deftest keymap-lookup-keymap/with-spaces-multibyte-lang-env () + "Backwards compatibility behaviour (Bug#50752)." + (let ((lang-env current-language-environment)) + (set-language-environment "Turkish") + (let ((map (make-keymap))) + (define-key map [menu-bar i-bar] 'foo) + (should (eq (lookup-key map [menu-bar I-bar]) 'foo))) + (set-language-environment lang-env))) + (ert-deftest describe-buffer-bindings/header-in-current-buffer () "Header should be inserted into the current buffer. https://debbugs.gnu.org/39149#31" @@ -237,15 +276,11 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (should (equal (where-is-internal 'foo map t) [?y])) (should (equal (where-is-internal 'bar map t) [?y])))) -(defvar keymap-tests-minor-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-2) - map)) +(defvar-keymap keymap-tests-minor-mode-map + "x" 'keymap-tests--command-2) -(defvar keymap-tests-major-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "x" 'keymap-tests--command-1) - map)) +(defvar-keymap keymap-tests-major-mode-map + "x" 'keymap-tests--command-1) (define-minor-mode keymap-tests-minor-mode "Test.") @@ -284,12 +319,12 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (with-temp-buffer (help--describe-vector (cadr orig-map) nil #'help--describe-command t shadow-map orig-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " e foo f foo (currently shadowed by `bar') g .. h foo -"))))) +")))))) (ert-deftest help--describe-vector/bug-9293-same-command-does-not-shadow () "Check that a command can't be shadowed by the same command." @@ -310,10 +345,10 @@ g .. h foo (with-temp-buffer (help--describe-vector (cadr range-map) nil #'help--describe-command t shadow-map range-map t) - (should (equal (buffer-string) - " + (should (equal (buffer-substring-no-properties (point-min) (point-max)) + (string-replace "\t" "" " 0 .. 3 foo -"))))) +")))))) (ert-deftest keymap--key-description () (should (equal (key-description [right] [?\C-x]) @@ -327,6 +362,62 @@ g .. h foo (should (equal (single-key-description 'C-s-home) "C-s-<home>"))) +(ert-deftest keymap-test-lookups () + (should (eq (lookup-key (current-global-map) "\C-x\C-f") 'find-file)) + (should (eq (lookup-key (current-global-map) [(control x) (control f)]) + 'find-file)) + (should (eq (lookup-key (current-global-map) ["C-x C-f"]) 'find-file)) + (should (eq (lookup-key (current-global-map) [?\C-x ?\C-f]) 'find-file))) + +(ert-deftest keymap-removal () + ;; Set to nil. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil) + (should (equal map '(keymap (97))))) + ;; Remove. + (let ((map (define-keymap "a" 'foo))) + (should (equal map '(keymap (97 . foo)))) + (define-key map "a" nil t) + (should (equal map '(keymap))))) + +(ert-deftest keymap-removal-inherit () + ;; Set to nil. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil) + (should (eq (lookup-key child [?a]) nil))) + ;; Remove. + (let ((parent (make-sparse-keymap)) + (child (make-keymap))) + (set-keymap-parent child parent) + (define-key parent [?a] 'foo) + (define-key child [?a] 'bar) + + (should (eq (lookup-key child [?a]) 'bar)) + (define-key child [?a] nil t) + (should (eq (lookup-key child [?a]) 'foo)))) + +(ert-deftest keymap-text-char-description () + (should (equal (text-char-description ?a) "a")) + (should (equal (text-char-description ?\s) " ")) + (should (equal (text-char-description ?\t) "^I")) + (should (equal (text-char-description ?\^C) "^C")) + (should (equal (text-char-description ?\^?) "^?")) + (should (equal (text-char-description #x80) "")) + (should (equal (text-char-description ?å) "å")) + (should (equal (text-char-description ?Ş) "Ş")) + (should (equal (text-char-description ?Ā) "Ā")) + (should-error (text-char-description "c")) + (should-error (text-char-description [?\C-x ?l])) + (should-error (text-char-description ?\M-c)) + (should-error (text-char-description ?\s-c))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el index 0f4bbd3ef62..1829a7ea1f1 100644 --- a/test/src/lcms-tests.el +++ b/test/src/lcms-tests.el @@ -35,6 +35,13 @@ (require 'ert) (require 'color) +(declare-function lcms-jab->jch "lcms.c") +(declare-function lcms-jch->jab "lcms.c") +(declare-function lcms-xyz->jch "lcms.c") +(declare-function lcms-jch->xyz "lcms.c") +(declare-function lcms-temp->white-point "lcms.c") +(declare-function lcms-cam02-ucs "lcms.c") + (defconst lcms-colorspacious-d65 '(0.95047 1.0 1.08883) "D65 white point from colorspacious.") diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index d337563728b..862f6a6595f 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -115,18 +115,14 @@ (should-error (read "#24r") :type 'invalid-read-syntax) (should-error (read "#") :type 'invalid-read-syntax)) +(ert-deftest lread-char-modifiers () + (should (eq ?\C-\M-é (+ (- ?\M-a ?a) ?\C-é))) + (should (eq (- ?\C-ŗ ?ŗ) (- ?\C-é ?é)))) + (ert-deftest lread-record-1 () (should (equal '(#s(foo) #s(foo)) (read "(#1=#s(foo) #1#)")))) -(defmacro lread-tests--with-temp-file (file-name-var &rest body) - (declare (indent 1)) - (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,file-name-var)))) - (defun lread-tests--last-message () (with-current-buffer "*Messages*" (save-excursion @@ -137,7 +133,7 @@ (ert-deftest lread-tests--unescaped-char-literals () "Check that loading warns about unescaped character literals (Bug#20852)." - (lread-tests--with-temp-file file-name + (ert-with-temp-file file-name (write-region "?) ?( ?; ?\" ?[ ?]" nil file-name) (should (equal (load file-name nil :nomessage :nosuffix) t)) (should (equal (lread-tests--last-message) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 14092187e0b..f5908d3cda5 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -25,11 +25,16 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'puny) (require 'subr-x) (require 'dns) (require 'url-http) +(declare-function thread-last-error "thread.c") +(declare-function thread-join "thread.c") +(declare-function make-thread "thread.c") + ;; Timeout in seconds; the test fails if the timeout is reached. (defvar process-test-sentinel-wait-timeout 2.0) @@ -64,24 +69,22 @@ (when (eq system-type 'windows-nt) (ert-deftest process-test-quoted-batfile () "Check that Emacs hides CreateProcess deficiency (bug#18745)." - (let (batfile) - (unwind-protect - (progn - ;; CreateProcess will fail when both the bat file and 1st - ;; argument are quoted, so include spaces in both of those - ;; to force quoting. - (setq batfile (make-temp-file "echo args" nil ".bat")) - (with-temp-file batfile - (insert "@echo arg1=%1, arg2=%2\n")) - (with-temp-buffer - (call-process batfile nil '(t t) t "x &y") - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) - (with-temp-buffer - (call-process-shell-command - (mapconcat #'shell-quote-argument (list batfile "x &y") " ") - nil '(t t) t) - (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))) - (when batfile (delete-file batfile)))))) + (ert-with-temp-file batfile + ;; CreateProcess will fail when both the bat file and 1st + ;; argument are quoted, so include spaces in both of those + ;; to force quoting. + :prefix "echo args" + :suffix ".bat" + (with-temp-file batfile + (insert "@echo arg1=%1, arg2=%2\n")) + (with-temp-buffer + (call-process batfile nil '(t t) t "x &y") + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n"))) + (with-temp-buffer + (call-process-shell-command + (mapconcat #'shell-quote-argument (list batfile "x &y") " ") + nil '(t t) t) + (should (string= (buffer-string) "arg1=\"x &y\", arg2=\n")))))) (ert-deftest process-test-stderr-buffer () (skip-unless (executable-find "bash")) @@ -531,18 +534,6 @@ FD_SETSIZE." (delete-process (pop ,processes)) ,@body))))) -(defmacro process-tests--with-temp-directory (var &rest body) - "Bind VAR to the name of a new directory and evaluate BODY. -Afterwards, delete the directory." - (declare (indent 1) (debug (symbolp body))) - (cl-check-type var symbol) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (make-temp-file "emacs-test-" :dir))) - (unwind-protect - (let ((,var ,dir)) - ,@body) - (delete-directory ,dir :recursive))))) - ;; Tests for FD_SETSIZE overflow (Bug#24325). The following tests ;; generate lots of process objects of the various kinds. Running the ;; tests with assertions enabled should not result in any crashes due @@ -630,7 +621,7 @@ FD_SETSIZE file descriptors (Bug#24325)." ;; Avoid hang due to connect/accept handshake on Cygwin (bug#49496). (skip-unless (not (eq system-type 'cygwin))) (with-timeout (60 (ert-fail "Test timed out")) - (process-tests--with-temp-directory directory + (ert-with-temp-directory directory (process-tests--with-processes processes (let* ((num-clients 10) (socket-name (expand-file-name "socket" directory)) @@ -800,6 +791,7 @@ have written output." (list (list process "finished\n")))))))))) (ert-deftest process-tests/multiple-threads-waiting () + :tags (if (getenv "EMACS_EMBA_CI") '(:unstable)) (skip-unless (fboundp 'make-thread)) (with-timeout (60 (ert-fail "Test timed out")) (process-tests--with-processes processes diff --git a/test/src/search-tests.el b/test/src/search-tests.el index c7d6004ce44..2fa23842841 100644 --- a/test/src/search-tests.el +++ b/test/src/search-tests.el @@ -28,7 +28,7 @@ (setq ov-set (make-overlay 3 5)) (overlay-put ov-set 'modification-hooks - (list (lambda (o after &rest _args) + (list (lambda (_o after &rest _args) (when after (let ((inhibit-modification-hooks t)) (save-excursion diff --git a/test/src/sqlite-tests.el b/test/src/sqlite-tests.el new file mode 100644 index 00000000000..d7100537a4e --- /dev/null +++ b/test/src/sqlite-tests.el @@ -0,0 +1,219 @@ +;;; sqlite-tests.el --- Tests for sqlite.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'ert-x) + +(declare-function sqlite-execute "sqlite.c") +(declare-function sqlite-close "sqlite.c") +(declare-function sqlitep "sqlite.c") +(declare-function sqlite-available-p "sqlite.c") +(declare-function sqlite-finalize "sqlite.c") +(declare-function sqlite-next "sqlite.c") +(declare-function sqlite-more-p "sqlite.c") +(declare-function sqlite-select "sqlite.c") +(declare-function sqlite-open "sqlite.c") +(declare-function sqlite-load-extension "sqlite.c") + +(ert-deftest sqlite-select () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open))) + (should (eq (type-of db) 'sqlite)) + (should (sqlitep db)) + (should-not (sqlitep 'foo)) + + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer, col3 float, col4 blob)"))) + + (should-error + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar', 'zot')")) + + (should + (= + (sqlite-execute + db "insert into test1 (col1, col2, col3, col4) values ('foo', 2, 9.45, 'bar')") + 1)) + + (should + (equal + (sqlite-select db "select * from test1" nil 'full) + '(("col1" "col2" "col3" "col4") ("foo" 2 9.45 "bar")))))) + +(ert-deftest sqlite-set () + (skip-unless (sqlite-available-p)) + (let ((db (sqlite-open)) + set) + (should + (zerop + (sqlite-execute + db "create table if not exists test1 (col1 text, col2 integer)"))) + + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('foo', 1)") + 1)) + (should + (= + (sqlite-execute db "insert into test1 (col1, col2) values ('bar', 2)") + 1)) + + (setq set (sqlite-select db "select * from test1" nil 'set)) + (should (sqlitep set)) + (should (sqlite-more-p set)) + (should (equal (sqlite-next set) + '("foo" 1))) + (should (equal (sqlite-next set) + '("bar" 2))) + (should-not (sqlite-next set)) + (should-not (sqlite-more-p set)) + (sqlite-finalize set) + (should-error (sqlite-next set)))) + +(ert-deftest sqlite-chars () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test2 (col1 text, col2 integer)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fóo', 3)") + (sqlite-execute + db "insert into test2 (col1, col2) values ('fo', 4)") + (should + (equal (sqlite-select db "select * from test2" nil 'full) + '(("col1" "col2") ("fóo" 3) ("fóo" 3) ("fo" 4)))))) + +(ert-deftest sqlite-numbers () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test3 (col1 integer)") + (let ((big (expt 2 50)) + (small (expt 2 10))) + (sqlite-execute db (format "insert into test3 values (%d)" small)) + (sqlite-execute db (format "insert into test3 values (%d)" big)) + (should + (equal + (sqlite-select db "select * from test3") + (list (list small) (list big))))))) + +(ert-deftest sqlite-param () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test4 (col1 text, col2 number)") + (sqlite-execute db "insert into test4 values (?, ?)" (list "foo" 1)) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" '(1)) + '(("foo" 1)))) + (should + (equal + (sqlite-select db "select * from test4 where col2 = ?" [1]) + '(("foo" 1)))))) + +(ert-deftest sqlite-binary () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test5 (col1 text, col2 number)") + (let ((string (with-temp-buffer + (set-buffer-multibyte nil) + (insert 0 1 2) + (buffer-string)))) + (should-not (multibyte-string-p string)) + (sqlite-execute + db "insert into test5 values (?, ?)" (list string 2)) + (let ((out (caar + (sqlite-select db "select col1 from test5 where col2 = 2")))) + (should (equal out string)))))) + +(ert-deftest sqlite-different-dbs () + (skip-unless (sqlite-available-p)) + (let (db1 db2) + (setq db1 (sqlite-open)) + (setq db2 (sqlite-open)) + (sqlite-execute + db1 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db2 "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute + db1 "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db1 "select * from test6")) + (should-not (sqlite-select db2 "select * from test6")))) + +(ert-deftest sqlite-close-dbs () + (skip-unless (sqlite-available-p)) + (let (db) + (setq db (sqlite-open)) + (sqlite-execute + db "create table if not exists test6 (col1 text, col2 number)") + (sqlite-execute db "insert into test6 values (?, ?)" '("foo" 2)) + (should (sqlite-select db "select * from test6")) + (sqlite-close db) + (should-error (sqlite-select db "select * from test6")))) + +(ert-deftest sqlite-load-extension () + (skip-unless (sqlite-available-p)) + (skip-unless (fboundp 'sqlite-load-extension)) + (let (db) + (setq db (sqlite-open)) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/notpcre.so")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/n")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3/")) + (should-error + (sqlite-load-extension db "/usr/lib/sqlite3")) + (should + (memq + (sqlite-load-extension db "/usr/lib/sqlite3/pcre.so") + '(nil t))) + + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_notcsvtable.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtablen.so")) + (should-error + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable")) + (should + (memq + (sqlite-load-extension + db "/usr/lib/x86_64-linux-gnu/libsqlite3_mod_csvtable.so") + '(nil t))))) + +;;; sqlite-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index d521f89f7df..b7ab31120aa 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -389,6 +389,7 @@ (should (equal (thread-last-error) '(error "Die, die, die!"))))) (ert-deftest threads-test-bug33073 () + (skip-unless (fboundp 'make-thread)) (let ((th (make-thread 'ignore))) (should-not (equal th main-thread)))) diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 2288a9ef613..1b49e0622f5 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -242,4 +242,16 @@ a fixed place on the right and are padded on the left." (should (= xdiv (float-time (time-convert xdiv t)))))) (setq x (* x 2))))) +(ert-deftest time-convert-forms () + ;; These computations involve numbers that should have exact + ;; representations on any Emacs platform. + (dolist (time '(-86400 -1 0 1 86400)) + (dolist (delta '(0 0.0 0.25 3.25 1000 1000.25)) + (let ((time+ (+ time delta)) + (time- (- time delta))) + (dolist (form '(nil t list 4 1000 1000000 1000000000)) + (should (time-equal-p time (time-convert time form))) + (should (time-equal-p time- (time-convert time- form))) + (should (time-equal-p time+ (time-convert time+ form)))))))) + ;;; timefns-tests.el ends here diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 63e7a3f8cb5..c84ed74f0b1 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -46,6 +46,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'facemenu) (ert-deftest undo-test0 () @@ -218,17 +219,14 @@ (ert-deftest undo-test-file-modified () "Test undoing marks buffer visiting file unmodified." - (let ((tempfile (make-temp-file "undo-test"))) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect tempfile) - (insert "1") - (undo-boundary) - (set-buffer-modified-p nil) - (insert "2") - (undo) - (should-not (buffer-modified-p)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + (with-current-buffer (find-file-noselect tempfile) + (insert "1") + (undo-boundary) + (set-buffer-modified-p nil) + (insert "2") + (undo) + (should-not (buffer-modified-p))))) (ert-deftest undo-test-region-not-most-recent () "Test undo in region of an edit not the most recent." diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el index c487ba286c8..0870dc9de4d 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -99,4 +99,75 @@ (width-in-chars (/ (car size) char-width))) (should (equal width-in-chars 3))))) +(ert-deftest xdisp-tests--find-directional-overrides-case-1 () + (with-temp-buffer + (insert "\ +int main() { + bool isAdmin = false; + /* }if (isAdmin) begin admins only */ + printf(\"You are an admin.\\n\"); + /* end admins only { */ + return 0; +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 46)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-2 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? 0 : 1 \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest xdisp-tests--find-directional-overrides-case-3 () + (with-temp-buffer + (insert "\ +#define is_restricted_user(user) \\ + !strcmp (user, \"root\") ? 0 : \\ + !strcmp (user, \"admin\") ? 0 : \\ + !strcmp (user, \"superuser? '#' : '!' \") + +int main () { + printf (\"root: %d\\n\", is_restricted_user (\"root\")); + printf (\"admin: %d\\n\", is_restricted_user (\"admin\")); + printf (\"superuser: %d\\n\", is_restricted_user (\"superuser\")); + printf (\"luser: %d\\n\", is_restricted_user (\"luser\")); + printf (\"nobody: %d\\n\", is_restricted_user (\"nobody\")); +}") + (goto-char (point-min)) + (should (eq (bidi-find-overridden-directionality (point-min) (point-max) + nil) + 138)))) + +(ert-deftest test-get-display-property () + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '(height 2.0))) + (should (equal (get-display-property 2 'height) 2.0))) + (with-temp-buffer + (insert (propertize "foo" 'face 'bold 'display '((height 2.0) + (space-width 2.0)))) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 2.0))) + (with-temp-buffer + (insert (propertize "foo bar" 'face 'bold + 'display '[(height 2.0) + (space-width 20)])) + (should (equal (get-display-property 2 'height) 2.0)) + (should (equal (get-display-property 2 'space-width) 20)))) + ;;; xdisp-tests.el ends here diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 62054ce0e3c..6a8290bd0c8 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -27,6 +27,8 @@ (require 'ert) +(declare-function libxml-parse-xml-region "xml.c") + (defvar libxml-tests--data-comments-preserved `(;; simple case ("<?xml version=\"1.0\"?><foo baz=\"true\">bar</foo>" |
