diff options
Diffstat (limited to 'test')
258 files changed, 9611 insertions, 3568 deletions
diff --git a/test/Makefile.in b/test/Makefile.in index 7047c244824..7bef1c36605 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -75,11 +75,16 @@ EMACS_EXTRAOPT= EMACSOPT = --no-init-file --no-site-file --no-site-lisp -L "$(SEPCHAR)$(srcdir)" $(elpa_opts) $(EMACS_EXTRAOPT) # Prevent any settings in the user environment causing problems. -unexport EMACSDATA EMACSDOC EMACSPATH GREP_OPTIONS +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 \ +lisp/filenotify-tests.log lisp/net/tramp-tests.log src/emacs-module-tests.log \ : WRITE_LOG = 2>&1 | tee $@ endif diff --git a/test/README b/test/README index 97611cf8644..4d447c9bf15 100644 --- a/test/README +++ b/test/README @@ -22,6 +22,10 @@ following tags are recognized: to run on a regular basis by users. Instead, it runs on demand only, or during regression tests. +* :nativecomp + The test runs only if Emacs is configured with Lisp native compiler + support. + * :unstable The test is under development. It shall run on demand only. @@ -136,6 +140,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 9f03482c3fd..aef68c6e81e 100644 --- a/test/infra/Dockerfile.emba +++ b/test/infra/Dockerfile.emba @@ -28,21 +28,23 @@ 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 git texinfo \ + libc-dev gcc g++ make autoconf automake libncurses-dev gnutls-dev \ + libdbus-1-dev libacl1-dev acl git texinfo gdb \ && rm -rf /var/lib/apt/lists/* FROM emacs-base as emacs-inotify RUN apt-get update && \ - apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 inotify-tools \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ + inotify-tools \ && rm -rf /var/lib/apt/lists/* COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure -RUN make -j4 bootstrap -RUN make -j4 +# 'make -j4 bootstrap' does not work reliably. +RUN make bootstrap FROM emacs-base as emacs-filenotify-gio @@ -55,13 +57,13 @@ COPY . /checkout WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-file-notification=gfile -RUN make -j4 bootstrap -RUN make -j4 +RUN make bootstrap FROM emacs-base as emacs-gnustep RUN apt-get update && \ - apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 gnustep-devel \ + apt-get install -y --no-install-recommends -o=Dpkg::Use-Pty=0 \ + gnustep-devel \ && rm -rf /var/lib/apt/lists/* COPY . /checkout @@ -69,19 +71,35 @@ WORKDIR /checkout RUN ./autogen.sh autoconf RUN ./configure --with-ns RUN make bootstrap -RUN make -j4 -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 \ + 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 +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-nativecomp -RUN make bootstrap -j2 NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -RUN make -j4 +RUN ./configure --with-native-compilation +RUN make bootstrap -j2 diff --git a/test/infra/gitlab-ci.yml b/test/infra/gitlab-ci.yml index 6876a8b11d8..001c7795725 100644 --- a/test/infra/gitlab-ci.yml +++ b/test/infra/gitlab-ci.yml @@ -44,13 +44,18 @@ workflow: variables: GIT_STRATEGY: fetch EMACS_EMBA_CI: 1 + # Three hours, see below. + EMACS_TEST_TIMEOUT: 10800 EMACS_TEST_VERBOSE: 1 # # 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 avoid conflicts + # Put the configuration for each run in a separate directory to + # avoid conflicts. DOCKER_CONFIG: "/.docker-config-${CI_COMMIT_SHA}" - # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap across multiple builds + DOCKER_BUILDKIT: 1 + # We don't use ${CI_COMMIT_SHA} to be able to do one bootstrap + # across multiple builds. BUILD_TAG: ${CI_COMMIT_REF_SLUG} default: @@ -66,57 +71,61 @@ default: test_name: ${CI_JOB_NAME}-${CI_COMMIT_SHORT_SHA} rules: - changes: - - "**/Makefile.in" + - "**Makefile.in" - .gitlab-ci.yml - aclocal.m4 - autogen.sh - configure.ac - lib/*.{h,c} - - lisp/**/*.el + - lisp/**.el - src/*.{h,c} - test/infra/* - test/lib-src/*.el - - test/lisp/**/*.el + - test/lisp/**.el + - test/misc/*.el - test/src/*.el - changes: # gfilemonitor, kqueue - src/gfilenotify.c - src/kqueue.c # MS Windows - - "**/w32*" + - "**w32*" # GNUstep - lisp/term/ns-win.el - src/ns*.{h,m} - src/macfont.{h,m} when: never - # these will be cached across builds + # These will be cached across builds. cache: key: ${CI_COMMIT_SHA} paths: [] policy: pull-push - # these will be saved for followup builds + # These will be saved for followup builds. artifacts: expire_in: 24 hrs paths: [] - # using the variables for each job + # Using the variables for each job. script: - docker pull ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} - # TODO: with make -j4 several of the tests were failing, for example shadowfile-tests, but passed without it + # 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_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 - ) - 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} + # - ls -alR ${test_name} .build-template: + needs: [] rules: - if: '$CI_PIPELINE_SOURCE == "web"' when: always - changes: - - "**/Makefile.in" + - "**Makefile.in" - .gitlab-ci.yml - aclocal.m4 - autogen.sh @@ -130,7 +139,7 @@ default: - src/gfilenotify.c - src/kqueue.c # MS Windows - - "**/w32*" + - "**w32*" # GNUstep - lisp/term/ns-win.el - src/ns*.{h,m} @@ -141,7 +150,7 @@ default: - docker push ${CI_REGISTRY_IMAGE}:${target}-${BUILD_TAG} .test-template: - # Do not run fast and normal test jobs when scheduled + # Do not run fast and normal test jobs when scheduled. rules: - if: '$CI_JOB_STAGE =~ "fast|normal" && $CI_PIPELINE_SOURCE == "schedule"' when: never @@ -151,20 +160,23 @@ default: public: true expire_in: 1 week paths: - - "${test_name}/**/*.log" + - ${test_name}/**/*.log + - ${test_name}/**/core + - ${test_name}/core + when: always .gnustep-template: rules: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" + - "**Makefile.in" - .gitlab-ci.yml - configure.ac - src/ns*.{h,m} - src/macfont.{h,m} - lisp/term/ns-win.el - - nextstep/**/* + - nextstep/** - test/infra/* .filenotify-gio-template: @@ -172,7 +184,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" + - "**Makefile.in" - .gitlab-ci.yml - lisp/autorevert.el - lisp/filenotify.el @@ -187,7 +199,7 @@ default: - if: '$CI_PIPELINE_SOURCE == "web"' - if: '$CI_PIPELINE_SOURCE == "schedule"' changes: - - "**/Makefile.in" + - "**Makefile.in" - .gitlab-ci.yml - lisp/emacs-lisp/comp.el - lisp/emacs-lisp/comp-cstr.el @@ -198,9 +210,8 @@ default: timeout: 8 hours stages: - - prep-images - build-images - - fast +# - fast - normal - platform-images - platforms @@ -208,25 +219,20 @@ stages: - native-comp - slow -prep-image-base: - stage: prep-images - extends: [.job-template, .build-template] - variables: - target: emacs-base - build-image-inotify: stage: build-images extends: [.job-template, .build-template] - needs: [prep-image-base] variables: target: emacs-inotify +# Temporarily. + timeout: 8 hours -test-fast-inotify: - stage: fast - extends: [.job-template, .test-template] - variables: - target: emacs-inotify - make_params: "-C test check" +# test-fast-inotify: +# stage: fast +# extends: [.job-template, .test-template] +# variables: +# target: emacs-inotify +# make_params: "-C test check" test-lisp-inotify: stage: normal @@ -245,14 +251,12 @@ test-lisp-net-inotify: build-image-filenotify-gio: stage: platform-images extends: [.job-template, .build-template, .filenotify-gio-template] - needs: [prep-image-base] variables: target: emacs-filenotify-gio build-image-gnustep: stage: platform-images extends: [.job-template, .build-template, .gnustep-template] - needs: [prep-image-base] variables: target: emacs-gnustep @@ -266,7 +270,7 @@ test-filenotify-gio: make_params: "-k -C test autorevert-tests.log filenotify-tests.log" test-gnustep: - # This tests the GNUstep build process + # This tests the GNUstep build process. stage: platforms needs: [build-image-gnustep] extends: [.job-template, .gnustep-template] @@ -274,56 +278,48 @@ test-gnustep: 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] - needs: [prep-image-base] 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-nativecomp -# - make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2 -# 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-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-nativecomp -# - make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"' -# 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 -# 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-nativecomp -# - make bootstrap -# timeout: 8 hours +test-native-comp-speed0: + stage: native-comp + needs: [build-native-comp-speed0] + extends: [.job-template, .test-template, .native-comp-template] + variables: + target: emacs-native-comp-speed0 + make_params: >- + -C test check EXCLUDE_TESTS=%emacs-module-tests.el + SELECTOR='(not (tag :unstable))' 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 + # 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: check-expensive + make_params: check-expensive EXCLUDE_TESTS=%emacs-module-tests.el + # Two hours. + EMACS_TEST_TIMEOUT: 7200 # Local Variables: # add-log-current-defun-header-regexp: "^\\([-_.[:alnum:]]+\\)[ \t]*:" diff --git a/test/lisp/abbrev-tests.el b/test/lisp/abbrev-tests.el index 2a42d5636d3..863806af7b3 100644 --- a/test/lisp/abbrev-tests.el +++ b/test/lisp/abbrev-tests.el @@ -28,6 +28,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'abbrev) (require 'seq) @@ -106,7 +107,7 @@ (should (abbrev-table-empty-p table)))) (ert-deftest kill-all-abbrevs-test () - "Test undefining all defined abbrevs" + "Test undefining all defined abbrevs." (unless noninteractive (ert-skip "Cannot test kill-all-abbrevs in interactive mode")) @@ -125,14 +126,14 @@ abbrev-table-name-list)))))) (ert-deftest abbrev-table-name-test () - "Test returning name of abbrev-table" + "Test returning name of abbrev-table." (let ((ert-test-abbrevs (setup-test-abbrev-table)) (no-such-table nil)) (should (equal 'ert-test-abbrevs (abbrev-table-name ert-test-abbrevs))) (should (equal nil (abbrev-table-name no-such-table))))) (ert-deftest clear-abbrev-table-test () - "Test clearing single abbrev table" + "Test clearing single abbrev table." (let ((ert-test-abbrevs (setup-test-abbrev-table))) (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) (clear-abbrev-table ert-test-abbrevs) @@ -140,7 +141,7 @@ (should (equal t (abbrev-table-empty-p ert-test-abbrevs))))) (ert-deftest list-abbrevs-test () - "Test generation of abbrev list buffer" + "Test generation of abbrev list buffer." ;; Somewhat redundant as prepare-abbrev-list-buffer is also tested. ;; all abbrevs (let ((abbrev-buffer (prepare-abbrev-list-buffer))) @@ -152,7 +153,7 @@ (kill-buffer abbrev-buffer))) (ert-deftest prepare-abbrev-list-buffer-test () - "Test generation of abbrev list buffer" + "Test generation of abbrev list buffer." ;; all abbrevs (let ((ert-test-abbrevs (setup-test-abbrev-table))) (with-current-buffer (prepare-abbrev-list-buffer) @@ -180,7 +181,7 @@ (kill-buffer "*Abbrevs*")))) (ert-deftest insert-abbrevs-test () - "Test inserting abbrev definitions into buffer" + "Test inserting abbrev definitions into buffer." (with-temp-buffer (insert-abbrevs) (should (progn @@ -188,7 +189,7 @@ (search-forward "global-abbrev-table"))))) (ert-deftest edit-abbrevs-test () - "Test editing abbrevs from buffer" + "Test editing abbrevs from buffer." (defvar ert-edit-abbrevs-test-table nil) (let ((ert-test-abbrevs (setup-test-abbrev-table))) (with-temp-buffer @@ -205,7 +206,7 @@ (abbrev-expansion "e-a-t" ert-edit-abbrevs-test-table)))))) (ert-deftest define-abbrevs-test () - "Test defining abbrevs from buffer" + "Test defining abbrevs from buffer." (defvar ert-bad-abbrev-table nil) (defvar ert-good-abbrev-table nil) (defvar ert-redefine-abbrev-table nil) @@ -235,45 +236,42 @@ (should (equal nil (abbrev-expansion "g-a-t" ert-good-abbrev-table))))) (ert-deftest read-write-abbrev-file-test () - "Test reading and writing abbrevs from file" - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs))) - (delete-file temp-test-file))) + "Test reading and writing abbrevs from file." + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "abbrev-ert-test" (abbrev-expansion "a-e-t" ert-test-abbrevs)))))) (ert-deftest read-write-abbrev-file-test-with-props () - "Test reading and writing abbrevs from file" - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table-with-props))) - (write-abbrev-file temp-test-file) - (clear-abbrev-table ert-test-abbrevs) - (should (abbrev-table-empty-p ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs))) - (delete-file temp-test-file))) + "Test reading and writing abbrevs from file." + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table-with-props))) + (write-abbrev-file temp-test-file) + (clear-abbrev-table ert-test-abbrevs) + (should (abbrev-table-empty-p ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "fooBar" (abbrev-expansion "fb" ert-test-abbrevs)))))) (ert-deftest abbrev-edit-save-to-file-test () - "Test saving abbrev definitions in buffer to file" + "Test saving abbrev definitions in buffer to file." (defvar ert-save-test-table nil) - (let ((temp-test-file (make-temp-file "ert-abbrev-test")) - (ert-test-abbrevs (setup-test-abbrev-table))) - (with-temp-buffer - (goto-char (point-min)) - (insert "(ert-save-test-table)\n") - (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") - (should (equal "abbrev-ert-test" - (abbrev-expansion "a-e-t" ert-test-abbrevs))) - ;; clears abbrev tables - (abbrev-edit-save-to-file temp-test-file) - (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) - (read-abbrev-file temp-test-file) - (should (equal "save-abbrevs-test" - (abbrev-expansion "s-a-t" ert-save-test-table))) - (delete-file temp-test-file)))) + (ert-with-temp-file temp-test-file + (let ((ert-test-abbrevs (setup-test-abbrev-table))) + (with-temp-buffer + (goto-char (point-min)) + (insert "(ert-save-test-table)\n") + (insert "\n" "\"s-a-t\"\t" "0\t" "\"save-abbrevs-test\"\n") + (should (equal "abbrev-ert-test" + (abbrev-expansion "a-e-t" ert-test-abbrevs))) + ;; clears abbrev tables + (abbrev-edit-save-to-file temp-test-file) + (should-not (abbrev-expansion "a-e-t" ert-test-abbrevs)) + (read-abbrev-file temp-test-file) + (should (equal "save-abbrevs-test" + (abbrev-expansion "s-a-t" ert-save-test-table))))))) (ert-deftest inverse-add-abbrev-skips-trailing-nonword () "Test that adding an inverse abbrev skips trailing nonword characters." diff --git a/test/lisp/ansi-color-tests.el b/test/lisp/ansi-color-tests.el index 107dc8e400b..14a14ca4f06 100644 --- a/test/lisp/ansi-color-tests.el +++ b/test/lisp/ansi-color-tests.el @@ -3,7 +3,6 @@ ;; Copyright (C) 2020-2021 Free Software Foundation, Inc. ;; Author: Pablo Barbáchano <pablob@amazon.com> -;; Keywords: ansi ;; This file is part of GNU Emacs. @@ -25,24 +24,154 @@ ;;; Code: (require 'ansi-color) +(eval-when-compile (require 'cl-lib)) -(defvar test-strings '(("\e[33mHello World\e[0m" . "Hello World") - ("\e[1m\e[3m\e[5mbold italics blink\e[0m" . "bold italics blink"))) +(defvar ansi-color-tests--strings + (let ((bright-yellow (face-foreground 'ansi-color-bright-yellow nil 'default)) + (yellow (face-foreground 'ansi-color-yellow nil 'default)) + (custom-color "#87FFFF")) + `(("Hello World" "Hello World") + ("\e[33mHello World\e[0m" "Hello World" + (:foreground ,yellow)) + ("\e[43mHello World\e[0m" "Hello World" + (:background ,yellow)) + ("\e[93mHello World\e[0m" "Hello World" + (:foreground ,bright-yellow)) + ("\e[103mHello World\e[0m" "Hello World" + (:background ,bright-yellow)) + ("\e[1;33mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[33;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[1m\e[33mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[33m\e[1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[1m\e[3m\e[5mbold italics blink\e[0m" "bold italics blink" + (ansi-color-bold ansi-color-italic ansi-color-slow-blink)) + ("\e[10munrecognized\e[0m" "unrecognized") + ("\e[38;5;3;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:foreground ,yellow)) + (ansi-color-bold (:foreground ,bright-yellow))) + ("\e[48;5;123;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color))) + ("\e[48;2;135;255;255;1mHello World\e[0m" "Hello World" + (ansi-color-bold (:background ,custom-color)))))) + +(defun ansi-color-tests-equal-props (o1 o2) + "Return t if two Lisp objects have similar structure and contents. +While `equal-including-properties' compares text properties of +strings with `eq', this function compares them with `equal'." + (or (equal-including-properties o1 o2) + (and (stringp o1) + (equal o1 o2) + (cl-loop for i below (length o1) + always (equal (text-properties-at i o1) + (text-properties-at i o2)))))) (ert-deftest ansi-color-apply-on-region-test () - (dolist (pair test-strings) - (with-temp-buffer - (insert (car pair)) + (pcase-dolist (`(,input ,text ,face) ansi-color-tests--strings) + (with-temp-buffer + (insert input) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (equal (buffer-string) text)) + (should (equal (get-char-property (point-min) 'face) face)) + (when face + (should (overlays-at (point-min))))))) + +(ert-deftest ansi-color-apply-on-region-bold-is-bright-test () + (pcase-dolist (`(,input ,text ,normal-face ,bright-face) + ansi-color-tests--strings) + (with-temp-buffer + (let ((ansi-color-bold-is-bright t) + (face (or bright-face normal-face))) + (insert input) (ansi-color-apply-on-region (point-min) (point-max)) - (should (equal (buffer-string) (cdr pair))) - (should (not (equal (overlays-at (point-min)) nil)))))) + (should (equal (buffer-string) text)) + (should (equal (get-char-property (point-min) 'face) face)) + (when face + (should (overlays-at (point-min)))))))) (ert-deftest ansi-color-apply-on-region-preserving-test () - (dolist (pair test-strings) - (with-temp-buffer - (insert (car pair)) - (ansi-color-apply-on-region (point-min) (point-max) t) - (should (equal (buffer-string) (car pair)))))) + (dolist (pair ansi-color-tests--strings) + (with-temp-buffer + (insert (car pair)) + (ansi-color-apply-on-region (point-min) (point-max) t) + (should (equal (buffer-string) (car pair)))))) + +(ert-deftest ansi-color-incomplete-sequences-test () + (let* ((strs (list "\e[" "2;31m Hello World " + "\e" "[108;5;12" "3m" "Greetings" + "\e[0m\e[35;6m" "Hello")) + (complete-str (apply #'concat strs)) + (filtered-str) + (propertized-str) + (ansi-color-apply-face-function + #'ansi-color-apply-text-property-face) + (ansi-filt (lambda (str) (ansi-color-filter-apply + (copy-sequence str)))) + (ansi-app (lambda (str) (ansi-color-apply + (copy-sequence str))))) + + (with-temp-buffer + (setq filtered-str + (replace-regexp-in-string "\e\\[.*?m" "" complete-str)) + (setq propertized-str (funcall ansi-app complete-str)) + + (should-not (ansi-color-tests-equal-props + filtered-str propertized-str)) + (should (equal filtered-str propertized-str))) + + ;; Tests for `ansi-color-filter-apply' + (with-temp-buffer + (should (equal-including-properties + filtered-str + (funcall ansi-filt complete-str)))) + + (with-temp-buffer + (should (equal-including-properties + filtered-str + (mapconcat ansi-filt strs "")))) + + ;; Tests for `ansi-color-filter-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-filter-region (point-min) (point-max)) + (should (equal-including-properties + filtered-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-filter-region opoint (point)))) + (should (equal-including-properties + filtered-str (buffer-string)))) + + ;; Test for `ansi-color-apply' + (with-temp-buffer + (should (ansi-color-tests-equal-props + propertized-str + (mapconcat ansi-app strs "")))) + + ;; Tests for `ansi-color-apply-on-region' + (with-temp-buffer + (insert complete-str) + (ansi-color-apply-on-region (point-min) (point-max)) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))) + + (with-temp-buffer + (dolist (str strs) + (let ((opoint (point))) + (insert str) + (ansi-color-apply-on-region opoint (point)))) + (should (ansi-color-tests-equal-props + propertized-str (buffer-string)))))) (provide 'ansi-color-tests) diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index 5c6af9b45cf..b05a9629c16 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -48,4 +48,4 @@ (provide 'arc-mode-tests) -;; arc-mode-tests.el ends here +;;; arc-mode-tests.el ends here diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index d050ac5b695..3da6f3e9b7b 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -56,10 +56,10 @@ ("key2" . "please: keep my space after colon")))))) (defvar auth-source-pass--debug-log nil - "Contains a list of all messages passed to `auth-source-do-debug`.") + "Contains a list of all messages passed to `auth-source-do-debug'.") (defun auth-source-pass--have-message-matching (regexp) - "Return non-nil iff at least one `auth-source-do-debug` match REGEXP." + "Return non-nil iff at least one `auth-source-do-debug' match REGEXP." (seq-find (lambda (message) (string-match regexp message)) auth-source-pass--debug-log)) @@ -75,8 +75,8 @@ REGEXP is the same as in `auth-source-pass--have-message-matching'." (put #'auth-source-pass--have-message-matching 'ert-explainer #'auth-source-pass--explain--have-message-matching) (defun auth-source-pass--debug (&rest msg) - "Format MSG and add that to `auth-source-pass--debug-log`. -This function is intended to be set to `auth-source-debug`." + "Format MSG and add that to `auth-source-pass--debug-log'. +This function is intended to be set to `auth-source-debug'." (add-to-list 'auth-source-pass--debug-log (apply #'format msg) t)) (defvar auth-source-pass--parse-log nil) @@ -97,7 +97,8 @@ This function is intended to be set to `auth-source-debug`." (defun auth-source-pass--explain-match-entry-p (entry hostname &optional user port) "Explainer function for `auth-source-pass-match-entry-p'. -ENTRY, HOSTNAME, USER and PORT are the same as in `auth-source-pass-match-entry-p'." +ENTRY, HOSTNAME, USER and PORT are the same as in +`auth-source-pass-match-entry-p'." `(entry ,entry store @@ -122,7 +123,8 @@ HOSTNAME, USER and PORT are passed unchanged to (defun auth-source-pass--explain-includes-sorted-entries (entries hostname &optional user port) "Explainer function for `auth-source-pass--includes-sorted-entries'. -ENTRIES, HOSTNAME, USER and PORT are the same as in `auth-source-pass--includes-sorted-entries'." +ENTRIES, HOSTNAME, USER and PORT are the same as in +`auth-source-pass--includes-sorted-entries'." `(store ,(auth-source-pass-entries) matching-entries diff --git a/test/lisp/auth-source-tests.el b/test/lisp/auth-source-tests.el index 1c4bd8d36d4..34c68b421c9 100644 --- a/test/lisp/auth-source-tests.el +++ b/test/lisp/auth-source-tests.el @@ -27,6 +27,7 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (require 'cl-lib) (require 'auth-source) (require 'secrets) @@ -247,7 +248,7 @@ (should-not (auth-source-remembered-p '(:host t))))) (ert-deftest auth-source-test-searches () - "Test auth-source searches with various parameters" + "Test auth-source searches with various parameters." :tags '(auth-source auth-source/netrc) (let* ((entries '("machine a1 port a2 user a3 password a4" "machine b1 port b2 user b3 password b4" @@ -277,34 +278,33 @@ "((:host \"a1\" :port \"a2\" :user \"a3\" :secret \"a4\") (:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\") (:host \"c1\" :port \"c2\" :user \"c3\" :secret \"c4\"))" :host t :max 4) ("host b1, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1") ("host b1, port b2, user b3, default max is 1" - "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" + "((:host \"b1\" :port \"b2\" :user \"b3\" :secret \"b4\"))" :host "b1" :port "b2" :user "b3") - )) - - (netrc-file (make-temp-file "auth-source-test" nil nil - (mapconcat 'identity entries "\n"))) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - found found-as-string) - - (dolist (test tests) - (cl-destructuring-bind (testname needed &rest parameters) test - (setq found (apply #'auth-source-search parameters)) - (when (listp found) - (dolist (f found) - (setf f (plist-put f :secret - (let ((secret (plist-get f :secret))) - (if (functionp secret) - (funcall secret) - secret)))))) - - (setq found-as-string (format "%s: %S" testname found)) - ;; (message "With parameters %S found: [%s] needed: [%s]" parameters found-as-string needed) - (should (equal found-as-string (concat testname ": " needed))))) - (delete-file netrc-file))) + ))) + (ert-with-temp-file netrc-file + :text (mapconcat 'identity entries "\n") + (let ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + found found-as-string) + + (dolist (test tests) + (cl-destructuring-bind (testname needed &rest parameters) test + (setq found (apply #'auth-source-search parameters)) + (when (listp found) + (dolist (f found) + (setf f (plist-put f :secret + (let ((secret (plist-get f :secret))) + (if (functionp secret) + (funcall secret) + secret)))))) + + (setq found-as-string (format "%s: %S" testname found)) + ;; (message "With parameters %S found: [%s] needed: [%s]" + ;; parameters found-as-string needed) + (should (equal found-as-string (concat testname ": " needed))))))))) (ert-deftest auth-source-test-secrets-create-secret () (skip-unless secrets-enabled) @@ -312,59 +312,121 @@ ;; Emacs process. Therefore, we don't care to delete it. (let ((auth-sources '((:source (:secrets "session")))) (auth-source-save-behavior t) - (host (md5 (concat (prin1-to-string process-environment) - (current-time-string)))) - (passwd (md5 (concat (prin1-to-string process-environment) - (current-time-string) (current-time-string)))) - auth-info auth-passwd) - ;; Redefine `read-*' in order to avoid interactive input. - (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) - ((symbol-function 'read-string) - (lambda (_prompt &optional _initial _history default - _inherit-input-method) - default))) - (setq auth-info - (car (auth-source-search - :max 1 :host host :require '(:user :secret) :create t)))) - (should (functionp (plist-get auth-info :save-function))) - (funcall (plist-get auth-info :save-function)) - - ;; Check, that the item has been created indeed. - (auth-source-forget+ :host t) - (setq auth-info (car (auth-source-search :host host)) - auth-passwd (plist-get auth-info :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (should (string-equal (plist-get auth-info :user) (user-login-name))) - (should (string-equal (plist-get auth-info :host) host)) - (should (string-equal auth-passwd passwd)) - - ;; Cleanup. - ;; Should use `auth-source-delete' when implemented for :secrets backend. - (secrets-delete-item - "session" - (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host))))) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + (unwind-protect + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd)) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd))))) + + ;; Cleanup. + ;; Should use `auth-source-delete' when implemented for :secrets backend. + (secrets-delete-item + "session" + (format "%s@%s" (plist-get auth-info :user) (plist-get auth-info :host)))))) + +(ert-deftest auth-source-test-netrc-create-secret () + (ert-with-temp-file netrc-file + :suffix "auth-source-test" + (let* ((auth-sources (list netrc-file)) + (auth-source-save-behavior t) + host auth-info auth-passwd) + (dolist (passwd '("foo" "" nil)) + ;; Redefine `read-*' in order to avoid interactive input. + (cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd)) + ((symbol-function 'read-string) + (lambda (_prompt &optional _initial _history default + _inherit-input-method) + default))) + (setq host + (md5 (concat (prin1-to-string process-environment) passwd)) + auth-info + (car (auth-source-search + :max 1 :host host :require '(:user :secret) :create t)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (should (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (equal auth-passwd passwd)) + (when (functionp (plist-get auth-info :save-function)) + (funcall (plist-get auth-info :save-function))) + + ;; Check, that the item has been created indeed. + (auth-source-forget+ :host t) + (setq auth-source-netrc-cache nil) + (setq auth-info (car (auth-source-search :host host)) + auth-passwd (plist-get auth-info :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (with-temp-buffer + (insert-file-contents netrc-file) + (if (zerop (length passwd)) + (progn + (should-not (plist-get auth-info :user)) + (should-not (plist-get auth-info :host)) + (should-not auth-passwd) + (should-not (search-forward host nil 'noerror))) + (should + (string-equal (plist-get auth-info :user) (user-login-name))) + (should (string-equal (plist-get auth-info :host) host)) + (should (string-equal auth-passwd passwd)) + (should (search-forward host nil 'noerror))))))))) (ert-deftest auth-source-delete () - (let* ((netrc-file (make-temp-file "auth-source-test" nil nil "\ + (ert-with-temp-file netrc-file + :suffix "auth-source-test" :text "\ machine a1 port a2 user a3 password a4 machine b1 port b2 user b3 password b4 -machine c1 port c2 user c3 password c4\n")) - (auth-sources (list netrc-file)) - (auth-source-do-cache nil) - (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) - (parameters '(:max 1 :host t))) - (unwind-protect - (let ((found (apply #'auth-source-delete parameters))) - (dolist (f found) - (let ((s (plist-get f :secret))) - (setf f (plist-put f :secret - (if (functionp s) (funcall s) s))))) - ;; Note: The netrc backend doesn't delete anything, so - ;; this is actually the same as `auth-source-search'. - (should (equal found expected))) - (delete-file netrc-file)))) +machine c1 port c2 user c3 password c4\n" + (let* ((auth-sources (list netrc-file)) + (auth-source-do-cache nil) + (expected '((:host "a1" :port "a2" :user "a3" :secret "a4"))) + (parameters '(:max 1 :host t)) + (found (apply #'auth-source-delete parameters))) + (dolist (f found) + (let ((s (plist-get f :secret))) + (setf f (plist-put f :secret + (if (functionp s) (funcall s) s))))) + ;; Note: The netrc backend doesn't delete anything, so + ;; this is actually the same as `auth-source-search'. + (should (equal found expected))))) (provide 'auth-source-tests) ;;; auth-source-tests.el ends here diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 7ec4bf63791..b264323ca15 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -28,6 +28,7 @@ (require 'autoinsert) (require 'ert) +(require 'ert-x) (ert-deftest autoinsert-tests-auto-insert-skeleton () (let ((auto-insert-alist '((text-mode nil "f" _ "oo"))) @@ -39,16 +40,14 @@ (should (equal (point) (+ (point-min) 1)))))) (ert-deftest autoinsert-tests-auto-insert-file () - (let ((temp-file (make-temp-file "autoinsert-tests" nil nil "foo"))) - (unwind-protect - (let ((auto-insert-alist `((text-mode . ,temp-file))) - (auto-insert-query nil)) - (with-temp-buffer - (text-mode) - (auto-insert) - (should (equal (buffer-string) "foo")))) - (when (file-exists-p temp-file) - (delete-file temp-file))))) + (ert-with-temp-file temp-file + :text "foo" + (let ((auto-insert-alist `((text-mode . ,temp-file))) + (auto-insert-query nil)) + (with-temp-buffer + (text-mode) + (auto-insert) + (should (equal (buffer-string) "foo")))))) (ert-deftest autoinsert-tests-auto-insert-function () (let ((auto-insert-alist '((text-mode . (lambda () (insert "foo"))))) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index 3e97e9cfa5b..b9d45324cb7 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -174,42 +174,41 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(60 30 15)) - buf) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (ert-with-message-capture auto-revert--messages - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf)) - (should (string-match "another text" (buffer-string))) - - ;; When the buffer is modified, it shall not be reverted. - (ert-with-message-capture auto-revert--messages - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - ;; Check, that the buffer hasn't been reverted. - (auto-revert--wait-for-revert buf)) - (should-not (string-match "any text" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let ((times '(60 30 15)) + buf) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (ert-with-message-capture auto-revert--messages + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf)) + (should (string-match "another text" (buffer-string))) + + ;; When the buffer is modified, it shall not be reverted. + (ert-with-message-capture auto-revert--messages + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + ;; Check, that the buffer hasn't been reverted. + (auto-revert--wait-for-revert buf)) + (should-not (string-match "any text" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test00-auto-revert-mode "Check autorevert for a remote file.") @@ -219,63 +218,61 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for several files at once." (skip-unless (executable-find "cp" (file-remote-p temporary-file-directory))) - (with-auto-revert-test - (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) - (tmpdir1 (make-temp-file "auto-revert-test" 'dir)) - (tmpdir2 (make-temp-file "auto-revert-test" 'dir)) - (tmpfile1 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (tmpfile2 - (make-temp-file (expand-file-name "auto-revert-test" tmpdir1))) - (times '(120 60 30 15)) - buf1 buf2) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) - (setq buf1 (find-file-noselect tmpfile1)) - (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) - (setq buf2 (find-file-noselect tmpfile2)) - - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode))) - - ;; Modify files. We wait for a second, in order to have - ;; another timestamp. - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) - (pop times)) - (auto-revert-tests--write-file - "another text" - (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) - (pop times)) - ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) - ;; Strange, that `copy-directory' does not work as expected. - ;; The following shell command is not portable on all - ;; platforms, unfortunately. - (shell-command - (format "%s -f %s/* %s" - cp (file-local-name tmpdir2) (file-local-name tmpdir1))) - - ;; Check, that the buffers have been reverted. - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf - (auto-revert--wait-for-revert buf) - (should (string-match "another text" (buffer-string)))))) - - ;; Exit. - (ignore-errors - (dolist (buf (list buf1 buf2)) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-directory tmpdir1 'recursive)) - (ignore-errors (delete-directory tmpdir2 'recursive)))))) + (ert-with-temp-directory tmpdir1 + (ert-with-temp-directory tmpdir2 + (ert-with-temp-file tmpfile1 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (ert-with-temp-file tmpfile2 + :prefix (expand-file-name "auto-revert-test" tmpdir1) + (with-auto-revert-test + (let* ((cp (executable-find "cp" (file-remote-p temporary-file-directory))) + (times '(120 60 30 15)) + buf1 buf2) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile1 (pop times)) + (setq buf1 (find-file-noselect tmpfile1)) + (auto-revert-tests--write-file "any text" tmpfile2 (pop times)) + (setq buf2 (find-file-noselect tmpfile2)) + + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode))) + + ;; Modify files. We wait for a second, in order to have + ;; another timestamp. + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile1) tmpdir2) + (pop times)) + (auto-revert-tests--write-file + "another text" + (expand-file-name (file-name-nondirectory tmpfile2) tmpdir2) + (pop times)) + ;;(copy-directory tmpdir2 tmpdir1 nil 'copy-contents) + ;; Strange, that `copy-directory' does not work as expected. + ;; The following shell command is not portable on all + ;; platforms, unfortunately. + (shell-command + (format "%s -f %s/* %s" + cp (file-local-name tmpdir2) (file-local-name tmpdir1))) + + ;; Check, that the buffers have been reverted. + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf + (auto-revert--wait-for-revert buf) + (should (string-match "another text" (buffer-string)))))) + + ;; Exit. + (ignore-errors + (dolist (buf (list buf1 buf2)) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))))))) (auto-revert--deftest-remote auto-revert-test01-auto-revert-several-files "Check autorevert for several remote files at once.") @@ -285,79 +282,78 @@ This expects `auto-revert--messages' to be bound by "Check autorevert for a deleted file." ;; Repeated unpredictable failures, bug#32645. ;; Unlikely to be hydra-specific? -; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - + ; (skip-unless (not (getenv "EMACS_HYDRA_CI"))) + :tags '(:unstable) (with-auto-revert-test - (let ((tmpfile (make-temp-file "auto-revert-test")) - ;; Try to catch bug#32645. - (auto-revert-debug (getenv "EMACS_HYDRA_CI")) - (file-notify-debug (getenv "EMACS_HYDRA_CI")) - (times '(120 60 30 15)) - buf desc) - (unwind-protect - (progn - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor)) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (setq desc auto-revert-notify-watch-descriptor) - - ;; Remove file while reverting. We simulate this by - ;; modifying `before-revert-hook'. - (add-hook - 'before-revert-hook - (lambda () - (when auto-revert-debug - (message "%s deleted" buffer-file-name)) - (delete-file buffer-file-name)) - nil t) - - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer hasn't been reverted. File - ;; notification should be disabled, falling back to - ;; polling. - (should (string-match "any text" (buffer-string))) - ;; With w32notify, and on emba, the `stopped' events are not sent. - (or (eq file-notify--library 'w32notify) - (getenv "EMACS_EMBA_CI") - (should-not - (file-notify-valid-p auto-revert-notify-watch-descriptor))) - - ;; Once the file has been recreated, the buffer shall be - ;; reverted. - (kill-local-variable 'before-revert-hook) - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-match "another text" (buffer-string))) - ;; When file notification is used, it must be reenabled - ;; after recreation of the file. We cannot expect that - ;; the descriptor is the same, so we just check the - ;; existence. - (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) - - ;; An empty file shall still be reverted. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "" tmpfile (pop times)) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should (string-equal "" (buffer-string))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let (;; Try to catch bug#32645. + (auto-revert-debug (getenv "EMACS_HYDRA_CI")) + (file-notify-debug (getenv "EMACS_HYDRA_CI")) + (times '(120 60 30 15)) + buf desc) + (unwind-protect + (progn + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor)) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (setq desc auto-revert-notify-watch-descriptor) + + ;; Remove file while reverting. We simulate this by + ;; modifying `before-revert-hook'. + (add-hook + 'before-revert-hook + (lambda () + (when auto-revert-debug + (message "%s deleted" buffer-file-name)) + (delete-file buffer-file-name)) + nil t) + + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer hasn't been reverted. File + ;; notification should be disabled, falling back to + ;; polling. + (should (string-match "any text" (buffer-string))) + ;; With w32notify, and on emba, the `stopped' events are not sent. + (or (eq file-notify--library 'w32notify) + (getenv "EMACS_EMBA_CI") + (should-not + (file-notify-valid-p auto-revert-notify-watch-descriptor))) + + ;; Once the file has been recreated, the buffer shall be + ;; reverted. + (kill-local-variable 'before-revert-hook) + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-match "another text" (buffer-string))) + ;; When file notification is used, it must be reenabled + ;; after recreation of the file. We cannot expect that + ;; the descriptor is the same, so we just check the + ;; existence. + (should (eq (null desc) (null auto-revert-notify-watch-descriptor))) + + ;; An empty file shall still be reverted. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "" tmpfile (pop times)) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should (string-equal "" (buffer-string))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test02-auto-revert-deleted-file "Check autorevert for a deleted remote file.") @@ -366,34 +362,33 @@ This expects `auto-revert--messages' to be bound by "Check autorevert tail mode." ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. - (let ((tmpfile (make-temp-file "auto-revert-test")) - (times '(30 15)) - buf) - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (setq buf (find-file-noselect tmpfile)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-tail-mode 1) - (should auto-revert-tail-mode) - (erase-buffer) - (insert "modified text\n") - (set-buffer-modified-p nil) - - ;; Modify file. - (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) - - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert buf) - (should - (string-match "modified text\nanother text" (buffer-string))))) - - ;; Exit. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (let ((times '(30 15)) + buf) + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (setq buf (find-file-noselect tmpfile)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-tail-mode 1) + (should auto-revert-tail-mode) + (erase-buffer) + (insert "modified text\n") + (set-buffer-modified-p nil) + + ;; Modify file. + (auto-revert-tests--write-file "another text" tmpfile (pop times) 'append) + + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert buf) + (should + (string-match "modified text\nanother text" (buffer-string))))) + + ;; Exit. + (ignore-errors (kill-buffer buf)))))) (auto-revert--deftest-remote auto-revert-test03-auto-revert-tail-mode "Check remote autorevert tail mode.") @@ -403,46 +398,45 @@ This expects `auto-revert--messages' to be bound by ;; `auto-revert-buffers' runs every 5". And we must wait, until the ;; file has been reverted. (with-auto-revert-test - (let* ((tmpfile (make-temp-file "auto-revert-test")) - (name (file-name-nondirectory tmpfile)) - (times '(30)) - buf) - (unwind-protect - (progn - (setq buf (dired-noselect temporary-file-directory)) - (with-current-buffer buf - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that it - ;; returns nil. - (auto-revert-mode 1) - (should auto-revert-mode) - (should - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Delete file. - (delete-file tmpfile) - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should-not - (string-match name (substring-no-properties (buffer-string)))) - - (ert-with-message-capture auto-revert--messages - ;; Make dired buffer modified. Check, that the buffer has - ;; been still reverted. - (set-buffer-modified-p t) - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (auto-revert--wait-for-revert buf)) - ;; Check, that the buffer has been reverted. - (should - (string-match name (substring-no-properties (buffer-string)))))) - - ;; Exit. - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf)) - (ignore-errors (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (let* ((name (file-name-nondirectory tmpfile)) + (times '(30)) + buf) + (unwind-protect + (progn + (setq buf (dired-noselect temporary-file-directory)) + (with-current-buffer buf + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that it + ;; returns nil. + (auto-revert-mode 1) + (should auto-revert-mode) + (should + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Delete file. + (delete-file tmpfile) + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should-not + (string-match name (substring-no-properties (buffer-string)))) + + (ert-with-message-capture auto-revert--messages + ;; Make dired buffer modified. Check, that the buffer has + ;; been still reverted. + (set-buffer-modified-p t) + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (auto-revert--wait-for-revert buf)) + ;; Check, that the buffer has been reverted. + (should + (string-match name (substring-no-properties (buffer-string)))))) + + ;; Exit. + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))))))) (auto-revert--deftest-remote auto-revert-test04-auto-revert-mode-dired "Check remote autorevert for dired.") @@ -469,86 +463,114 @@ This expects `auto-revert--messages' to be bound by (lambda () (string-equal (auto-revert-test--buffer-string buffer) string)) max-wait)) +(defun auto-revert-test--instrument-kill-buffer-hook (buffer) + "Instrument local `kill-buffer-hook' with messages." + (when auto-revert-debug + (with-current-buffer buffer + (add-hook + 'kill-buffer-hook + (lambda () + (message + "%s killed\n%s" (current-buffer) (with-output-to-string (backtrace)))) + nil 'local)))) + (ert-deftest auto-revert-test05-global-notify () "Test `global-auto-revert-mode' without polling." (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (auto-revert-avoid-polling t) - (was-in-global-auto-revert-mode global-auto-revert-mode) - (file-1 (make-temp-file "global-auto-revert-test-1")) - (file-2 (make-temp-file "global-auto-revert-test-2")) - (file-3 (make-temp-file "global-auto-revert-test-3")) - (file-2b (concat file-2 "-b")) - require-final-newline buf-1 buf-2 buf-3) - (unwind-protect - (progn - (setq buf-1 (find-file-noselect file-1)) - (setq buf-2 (find-file-noselect file-2)) - (auto-revert-test--write-file "1-a" file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "")) - - (global-auto-revert-mode 1) ; Turn it on. - - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2)) - - ;; buf-1 should have been reverted immediately when the mode - ;; was enabled. - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - - ;; Alter a file. - (auto-revert-test--write-file "2-a" file-2) - ;; Allow for some time to handle notification events. - (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - - ;; Visit a file, and modify it on disk. - (setq buf-3 (find-file-noselect file-3)) - ;; Newly opened buffers won't be use notification until the - ;; first poll cycle; wait for it. - (auto-revert-test--wait-for - (lambda () (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-3)) - (auto-revert-test--write-file "3-a" file-3) - (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) - (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) - - ;; Delete a visited file, and re-create it with new contents. - (delete-file file-1) - (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) - (auto-revert-test--write-file "1-b" file-1) - (auto-revert-test--wait-for-buffer-text - buf-1 "1-b" (auto-revert--timeout)) - ;; On emba, `buf-1' is a killed buffer. - (when (buffer-live-p buf-1) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-1))) - - ;; Write a buffer to a new file, then modify the new file on disk. - (with-current-buffer buf-2 - (write-file file-2b)) - (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) - (auto-revert-test--write-file "2-b" file-2b) - (auto-revert-test--wait-for-buffer-text - buf-2 "2-b" (auto-revert--timeout)) - (should (buffer-local-value - 'auto-revert-notify-watch-descriptor buf-2))) - - ;; Clean up. - (unless was-in-global-auto-revert-mode - (global-auto-revert-mode 0)) ; Turn it off. - (dolist (buf (list buf-1 buf-2 buf-3)) - (ignore-errors (kill-buffer buf))) - (dolist (file (list file-1 file-2 file-2b file-3)) - (ignore-errors (delete-file file))) - )))) + (ert-with-temp-file file-1 + (ert-with-temp-file file-2 + (ert-with-temp-file file-3 + (let* ((auto-revert-use-notify t) + (auto-revert-avoid-polling t) + (auto-revert-debug (getenv "EMACS_EMBA_CI")) + (file-notify-debug (getenv "EMACS_EMBA_CI")) + (was-in-global-auto-revert-mode global-auto-revert-mode) + (file-2b (concat file-2 "-b")) + require-final-newline buf-1 buf-2 buf-3) + (unwind-protect + (progn + (setq buf-1 (find-file-noselect file-1)) + (auto-revert-test--instrument-kill-buffer-hook buf-1) + (setq buf-2 (find-file-noselect file-2)) + (auto-revert-test--instrument-kill-buffer-hook buf-2) + (auto-revert-test--write-file "1-a" file-1) + (should (equal (auto-revert-test--buffer-string buf-1) "")) + + (global-auto-revert-mode 1) ; Turn it on. + + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2)) + + ;; buf-1 should have been reverted immediately when the mode + ;; was enabled. + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + + ;; Alter a file. + (auto-revert-test--write-file "2-a" file-2) + ;; Allow for some time to handle notification events. + (auto-revert-test--wait-for-buffer-text buf-2 "2-a" 1) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + + ;; Visit a file, and modify it on disk. + (setq buf-3 (find-file-noselect file-3)) + (auto-revert-test--instrument-kill-buffer-hook buf-3) + ;; Newly opened buffers won't be use notification until the + ;; first poll cycle; wait for it. + (auto-revert-test--wait-for + (lambda () (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-3)) + (auto-revert-test--write-file "3-a" file-3) + (auto-revert-test--wait-for-buffer-text buf-3 "3-a" 1) + (should (equal (auto-revert-test--buffer-string buf-3) "3-a")) + + ;; Delete a visited file, and re-create it with new contents. + (when auto-revert-debug (message "Hallo0")) + (delete-file file-1) + (when auto-revert-debug (message "Hallo1")) + (should (equal (auto-revert-test--buffer-string buf-1) "1-a")) + (when auto-revert-debug (message "Hallo2")) + (auto-revert-test--write-file "1-b" file-1) + (when auto-revert-debug (message "Hallo3")) + (auto-revert-test--wait-for-buffer-text + buf-1 "1-b" (auto-revert--timeout)) + ;; On emba, `buf-1' is a killed buffer. + (when auto-revert-debug + (message + "Hallo4 %s %s %s %s %s %s %s" + buf-1 (buffer-name buf-1) (buffer-live-p buf-1) + file-1 (get-file-buffer file-1) + (buffer-name (get-file-buffer file-1)) + (buffer-live-p (get-file-buffer file-1))) + (with-current-buffer buf-1 + (message "Hallo5\n%s" (buffer-local-variables)))) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-1)) + (when auto-revert-debug (message "Hallo6")) + + ;; Write a buffer to a new file, then modify the new file on disk. + (with-current-buffer buf-2 + (write-file file-2b)) + (should (equal (auto-revert-test--buffer-string buf-2) "2-a")) + (auto-revert-test--write-file "2-b" file-2b) + (auto-revert-test--wait-for-buffer-text + buf-2 "2-b" (auto-revert--timeout)) + (should (buffer-local-value + 'auto-revert-notify-watch-descriptor buf-2))) + + ;; Clean up. + (unless was-in-global-auto-revert-mode + (global-auto-revert-mode 0)) ; Turn it off. + (dolist (buf (list buf-1 buf-2 buf-3)) + (with-current-buffer buf (setq-local kill-buffer-hook nil)) + (ignore-errors (kill-buffer buf))) + (ignore-errors (delete-file file-2b))))))))) (auto-revert--deftest-remote auto-revert-test05-global-notify "Test `global-auto-revert-mode' without polling for remote buffers.") @@ -558,31 +580,30 @@ This expects `auto-revert--messages' to be bound by (skip-unless (or file-notify--library (file-remote-p temporary-file-directory))) (with-auto-revert-test - (let* ((auto-revert-use-notify t) - (file-1 (make-temp-file "auto-revert-test")) - (file-2 (concat file-1 "-2")) - require-final-newline buf) - (unwind-protect - (progn - (setq buf (find-file-noselect file-1)) - (with-current-buffer buf - (insert "A") - (save-buffer) + (ert-with-temp-file file-1 + (let* ((auto-revert-use-notify t) + (file-2 (concat file-1 "-2")) + require-final-newline buf) + (unwind-protect + (progn + (setq buf (find-file-noselect file-1)) + (with-current-buffer buf + (insert "A") + (save-buffer) - (auto-revert-mode 1) + (auto-revert-mode 1) - (insert "B") - (write-file file-2) + (insert "B") + (write-file file-2) - (auto-revert-test--write-file "C" file-2) - (auto-revert-test--wait-for-buffer-text - buf "C" (auto-revert--timeout)) - (should (equal (buffer-string) "C")))) + (auto-revert-test--write-file "C" file-2) + (auto-revert-test--wait-for-buffer-text + buf "C" (auto-revert--timeout)) + (should (equal (buffer-string) "C")))) - ;; Clean up. - (ignore-errors (kill-buffer buf)) - (ignore-errors (delete-file file-1)) - (ignore-errors (delete-file file-2)))))) + ;; Clean up. + (ignore-errors (kill-buffer buf)) + (ignore-errors (delete-file file-2))))))) (auto-revert--deftest-remote auto-revert-test06-write-file "Test `write-file' in `auto-revert-mode' for remote buffers.") @@ -591,86 +612,91 @@ This expects `auto-revert--messages' to be bound by (ert-deftest auto-revert-test07-auto-revert-several-buffers () "Check autorevert for several buffers visiting the same file." ;; (with-auto-revert-test - (let ((auto-revert-use-notify t) - (tmpfile (make-temp-file "auto-revert-test")) - (times '(120 60 30 15)) - (num-buffers 10) - require-final-newline buffers) - - (unwind-protect - ;; Check indirect buffers. - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - (push (find-file-noselect tmpfile) buffers) - (with-current-buffer (car buffers) - (should (string-equal (buffer-string) "any text")) - ;; `buffer-stale--default-function' checks for - ;; `verify-visited-file-modtime'. We must ensure that - ;; it returns nil. - (auto-revert-mode 1) - (should auto-revert-mode)) - - (dotimes (i num-buffers) - (push (make-indirect-buffer - (car buffers) - (format "%s-%d" (buffer-file-name (car buffers)) i) - 'clone) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "any text")) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffer has been reverted. - (auto-revert--wait-for-revert (car buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (setq buffers nil) - (ignore-errors (delete-file tmpfile))) - - ;; Check direct buffers. - (unwind-protect - (ert-with-message-capture auto-revert--messages - (auto-revert-tests--write-file "any text" tmpfile (pop times)) - - (dotimes (i num-buffers) - (push (generate-new-buffer - (format "%s-%d" (file-name-nondirectory tmpfile) i)) - buffers)) - (setq buffers (nreverse buffers)) - (dolist (buf buffers) - (with-current-buffer buf - (insert-file-contents tmpfile 'visit) - (should (string-equal (buffer-string) "any text")) - (auto-revert-mode 1) - (should auto-revert-mode))) - - (auto-revert-tests--write-file "another text" tmpfile (pop times)) - ;; Check, that the buffers have been reverted. - (dolist (buf buffers) - (auto-revert--wait-for-revert buf) - (with-current-buffer buf - (should (string-equal (buffer-string) "another text"))))) - - ;; Exit. - (ignore-errors - (dolist (buf buffers) - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf))) - (ignore-errors (delete-file tmpfile)))));) + (ert-with-temp-file tmpfile + (let ((auto-revert-use-notify t) + (times '(120 60 30 15)) + (num-buffers 10) + require-final-newline buffers) + + (unwind-protect + ;; Check indirect buffers. + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + (push (find-file-noselect tmpfile) buffers) + (with-current-buffer (car buffers) + (should (string-equal (buffer-string) "any text")) + ;; `buffer-stale--default-function' checks for + ;; `verify-visited-file-modtime'. We must ensure that + ;; it returns nil. + (auto-revert-mode 1) + (should auto-revert-mode)) + + (dotimes (i num-buffers) + (push (make-indirect-buffer + (car buffers) + (format "%s-%d" (buffer-file-name (car buffers)) i) + 'clone) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "any text")) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffer has been reverted. + (auto-revert--wait-for-revert (car buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf))) + (setq buffers nil) + (ignore-errors (delete-file tmpfile))) + + ;; Check direct buffers. + (unwind-protect + (ert-with-message-capture auto-revert--messages + (auto-revert-tests--write-file "any text" tmpfile (pop times)) + + (dotimes (i num-buffers) + (push (generate-new-buffer + (format "%s-%d" (file-name-nondirectory tmpfile) i)) + buffers)) + (setq buffers (nreverse buffers)) + (dolist (buf buffers) + (with-current-buffer buf + (insert-file-contents tmpfile 'visit) + (should (string-equal (buffer-string) "any text")) + (auto-revert-mode 1) + (should auto-revert-mode))) + + (auto-revert-tests--write-file "another text" tmpfile (pop times)) + ;; Check, that the buffers have been reverted. + (dolist (buf buffers) + (auto-revert--wait-for-revert buf) + (with-current-buffer buf + (should (string-equal (buffer-string) "another text"))))) + + ;; Exit. + (ignore-errors + (dolist (buf buffers) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)))))));) (auto-revert--deftest-remote auto-revert-test07-auto-revert-several-buffers "Check autorevert for several buffers visiting the same remote file.") +;; Mark all tests as unstable on Cygwin (bug#49665). +(when (eq system-type 'cygwin) + (dolist (test (apropos-internal "^auto-revert" #'ert-test-boundp)) + (setf (ert-test-tags (ert-get-test test)) + (cons :unstable (ert-test-tags (ert-get-test test)))))) + (defun auto-revert-test-all (&optional interactive) "Run all tests for \\[auto-revert]." (interactive "p") @@ -679,4 +705,4 @@ This expects `auto-revert--messages' to be bound by (ert-run-tests-batch "^auto-revert-"))) (provide 'auto-revert-tests) -;;; auto-revert-tests.el ends here +;;; autorevert-tests.el ends here diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 9c33a27288a..dc2dec68ee3 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -371,16 +371,14 @@ Same as `with-bookmark-test' but also sets a temporary `bookmark-default-file', evaluates BODY, and then runs the test that saves and then loads the bookmark file." `(with-bookmark-test - (let ((file (make-temp-file "bookmark-tests-"))) - (unwind-protect - (let ((bookmark-default-file file) - (old-alist bookmark-alist)) - ,@body - (bookmark-save nil file t) - (setq bookmark-alist nil) - (bookmark-load file nil t) - (should (equal bookmark-alist old-alist))) - (delete-file file))))) + (ert-with-temp-file file + (let ((bookmark-default-file file) + (old-alist bookmark-alist)) + ,@body + (bookmark-save nil file t) + (setq bookmark-alist nil) + (bookmark-load file nil t) + (should (equal bookmark-alist old-alist)))))) (defvar bookmark-tests-non-ascii-data (concat "Здра́вствуйте!" "中文,普通话,汉语" "åäöøñ" diff --git a/test/lisp/buff-menu-tests.el b/test/lisp/buff-menu-tests.el index 18c988656d3..b223a643083 100644 --- a/test/lisp/buff-menu-tests.el +++ b/test/lisp/buff-menu-tests.el @@ -24,19 +24,20 @@ ;;; Code: (require 'ert) +(eval-when-compile (require 'ert-x)) (ert-deftest buff-menu-24962 () "Test for https://debbugs.gnu.org/24962 ." - (let* ((file (make-temp-file "foo")) - (buf (find-file file))) - (unwind-protect - (progn - (rename-buffer " foo") - (list-buffers) - (with-current-buffer "*Buffer List*" - (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) - (and (buffer-live-p buf) (kill-buffer buf)) - (and (file-exists-p file) (delete-file file))))) + (ert-with-temp-file file + :suffix "foo" + (let ((buf (find-file file))) + (unwind-protect + (progn + (rename-buffer " foo") + (list-buffers) + (with-current-buffer "*Buffer List*" + (should (string= " foo" (buffer-name (Buffer-menu-buffer)))))) + (and (buffer-live-p buf) (kill-buffer buf)))))) (provide 'buff-menu-tests) diff --git a/test/lisp/button-tests.el b/test/lisp/button-tests.el index e0944afa344..2f5ad795df2 100644 --- a/test/lisp/button-tests.el +++ b/test/lisp/button-tests.el @@ -59,6 +59,7 @@ "Test `button--help-echo' with forms." (with-temp-buffer ;; Test text property buttons with dynamic scoping. + (setq lexical-binding nil) (let* ((help (make-symbol "help")) (form `(funcall (let ((,help "lexical form")) (lambda () ,help)))) diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 13dd228d3b3..3eb6b34c132 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -53,7 +53,7 @@ A and B should be calc expressions." (defun calc-tests-simple (fun string &rest args) "Push STRING on the calc stack, then call FUN and return the new top. -The result is a calc (i.e., lisp) expression, not its string representation. +The result is a calc (i.e., Lisp) expression, not its string representation. Also pop the entire stack afterwards. An existing calc stack is reused, otherwise a new one is created." (calc-eval string 'push) @@ -448,7 +448,7 @@ An existing calc stack is reused, otherwise a new one is created." ;; Generalisation for any n, integral k≥0: use falling product (/ (apply '* (number-sequence n (- n (1- k)) -1)) (calc-tests--fac k))) - (t (error "case not covered")))) + (t (error "Case not covered")))) (defun calc-tests--calc-to-number (x) "Convert a Calc object to a Lisp number." @@ -810,6 +810,12 @@ An existing calc stack is reused, otherwise a new one is created." (should (equal (calcFunc-test6 3) (* (* 3 2) (- 3 1)))) (should (equal (calcFunc-test7 3) (* 3 2)))) +(ert-deftest calc-nth-root () + ;; bug#51209 + (let* ((calc-display-working-message nil) + (x (calc-tests--calc-to-number (math-pow 8 '(frac 1 6))))) + (should (< (abs (- x (sqrt 2.0))) 1.0e-10)))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calculator-tests.el b/test/lisp/calculator-tests.el index 9551b1a4c61..f24ca97310c 100644 --- a/test/lisp/calculator-tests.el +++ b/test/lisp/calculator-tests.el @@ -48,4 +48,4 @@ (should (equal (calculator-string-to-number str) expected))))))) (provide 'calculator-tests) -;; calculator-tests.el ends here +;;; calculator-tests.el ends here diff --git a/test/lisp/calendar/cal-french-tests.el b/test/lisp/calendar/cal-french-tests.el index ab62c1e6fc1..1de5dea0882 100644 --- a/test/lisp/calendar/cal-french-tests.el +++ b/test/lisp/calendar/cal-french-tests.el @@ -111,3 +111,4 @@ (should (equal (calendar-french-date-string (list m d y)) str)))) (provide 'cal-french-tests) +;;; cal-french-tests.el ends here diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 6973f7e5c95..9e8a8e7b479 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -698,17 +698,18 @@ and ISO style input data must use english month names." "Actually perform export test. Argument INPUT input diary string. Argument EXPECTED-OUTPUT expected iCalendar result string." - (let ((temp-file (make-temp-file "icalendar-tests-ics"))) + (ert-with-temp-file temp-file + :suffix "icalendar-tests-ics" (unwind-protect - (progn - (with-temp-buffer - (insert input) - (icalendar-export-region (point-min) (point-max) temp-file)) - (save-excursion - (find-file temp-file) - (goto-char (point-min)) - (cond (expected-output - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + (progn + (with-temp-buffer + (insert input) + (icalendar-export-region (point-min) (point-max) temp-file)) + (save-excursion + (find-file temp-file) + (goto-char (point-min)) + (cond (expected-output + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 BEGIN:VEVENT @@ -717,23 +718,22 @@ UID:emacs[0-9]+ END:VEVENT END:VCALENDAR \\s-*$" - nil t)) - (should (string-match - (concat "^\\s-*" - (regexp-quote (buffer-substring-no-properties - (match-beginning 1) (match-end 1))) - "\\s-*$") - expected-output))) - (t - (should (re-search-forward "^\\s-*BEGIN:VCALENDAR + nil t)) + (should (string-match + (concat "^\\s-*" + (regexp-quote (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + "\\s-*$") + expected-output))) + (t + (should (re-search-forward "^\\s-*BEGIN:VCALENDAR PRODID:-//Emacs//NONSGML icalendar.el//EN VERSION:2.0 END:VCALENDAR \\s-*$" - nil t)))))) + nil t)))))) ;; cleanup!! - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-export-ordinary-no-time () "Perform export test." @@ -1031,7 +1031,8 @@ During import test the timezone is set to Central European Time." (defun icalendar-tests--do-test-import (expected-output) "Actually perform import test. Argument EXPECTED-OUTPUT file containing expected diary string." - (let ((temp-file (make-temp-file "icalendar-test-diary"))) + (ert-with-temp-file temp-file + :suffix "icalendar-test-diary" ;; Test the Catch-the-mysterious-coding-header logic below. ;; Ruby-mode adds an after-save-hook which inserts the header! ;; (save-excursion @@ -1061,8 +1062,7 @@ Argument EXPECTED-OUTPUT file containing expected diary string." (let ((result (buffer-substring-no-properties (point-min) (point-max)))) (should (string= expected-output result))) - (kill-buffer (find-buffer-visiting temp-file)) - (delete-file temp-file)))) + (kill-buffer (find-buffer-visiting temp-file))))) (ert-deftest icalendar-import-non-recurring () "Perform standard import tests." @@ -1240,35 +1240,33 @@ Argument INPUT icalendar event string." (defun icalendar-tests--do-test-cycle () "Actually perform import/export cycle test." - (let ((temp-diary (make-temp-file "icalendar-test-diary")) - (temp-ics (make-temp-file "icalendar-test-ics")) - (org-input (buffer-substring-no-properties (point-min) (point-max)))) - - (unwind-protect - (progn - ;; step 1: import - (icalendar-import-buffer temp-diary t t) - - ;; step 2: export what was just imported - (save-excursion - (find-file temp-diary) - (icalendar-export-region (point-min) (point-max) temp-ics)) - - ;; compare the output of step 2 with the input of step 1 - (save-excursion - (find-file temp-ics) - (goto-char (point-min)) - ;;(when (re-search-forward "\nUID:.*\n" nil t) - ;;(replace-match "\n")) - (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= org-input cycled))))) - ;; clean up - (kill-buffer (find-buffer-visiting temp-diary)) - (with-current-buffer (find-buffer-visiting temp-ics) - (set-buffer-modified-p nil) - (kill-buffer (current-buffer))) - (delete-file temp-diary) - (delete-file temp-ics)))) + (ert-with-temp-file temp-diary + (ert-with-temp-file temp-ics + (let ((org-input (buffer-substring-no-properties (point-min) (point-max)))) + + (unwind-protect + (progn + ;; step 1: import + (icalendar-import-buffer temp-diary t t) + + ;; step 2: export what was just imported + (save-excursion + (find-file temp-diary) + (icalendar-export-region (point-min) (point-max) temp-ics)) + + ;; compare the output of step 2 with the input of step 1 + (save-excursion + (find-file temp-ics) + (goto-char (point-min)) + ;;(when (re-search-forward "\nUID:.*\n" nil t) + ;;(replace-match "\n")) + (let ((cycled (buffer-substring-no-properties (point-min) (point-max)))) + (should (string= org-input cycled))))) + ;; clean up + (kill-buffer (find-buffer-visiting temp-diary)) + (with-current-buffer (find-buffer-visiting temp-ics) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)))))))) (ert-deftest icalendar-cycle () "Perform cycling tests. @@ -1442,6 +1440,13 @@ RRULE:FREQ=YEARLY;INTERVAL=1;BYMONTH=09;BYMONTHDAY=21 SUMMARY:ff birthday (%d years old)") + (icalendar-tests--test-export + nil + nil + "%%(diary-offset '(diary-float t 3 4) 1) asdf" + nil) + + ;; FIXME! ;; export 2004-10-28 monthly, weekly entries @@ -1629,7 +1634,7 @@ SUMMARY:NNN Wwwwwwww Wwwww - Aaaaaa Pppppppp rrrrrr ddd oo Nnnnnnnn 30 (format-time-string "%FT%T%z" (encode-time time) 0))) (defun icalendar-tests--decode-isodatetime (_ical-string) - "Test icalendar--decode-isodatetime." + "Test `icalendar--decode-isodatetime'." (should (equal (icalendar-test--format "20040917T050910-0200") "2004-09-17T03:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910") diff --git a/test/lisp/calendar/solar-tests.el b/test/lisp/calendar/solar-tests.el index 337deb8ce9a..921be1d2d48 100644 --- a/test/lisp/calendar/solar-tests.el +++ b/test/lisp/calendar/solar-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'solar) @@ -42,3 +44,5 @@ (should (< (abs (- sunset 17.72)) epsilon))))) (provide 'solar-tests) + +;;; solar-tests.el ends here diff --git a/test/lisp/calendar/todo-mode-tests.el b/test/lisp/calendar/todo-mode-tests.el index 6fa2b9d7c35..79978a2041f 100644 --- a/test/lisp/calendar/todo-mode-tests.el +++ b/test/lisp/calendar/todo-mode-tests.el @@ -35,27 +35,26 @@ "Todo Archive mode test file.") (defmacro with-todo-test (&rest body) - "Set up an isolated todo-mode test environment." + "Set up an isolated `todo-mode' test environment." (declare (debug (body))) - `(let* ((todo-test-home (make-temp-file "todo-test-home-" t)) - ;; Since we change HOME, clear this to avoid a conflict - ;; e.g. if Emacs runs within the user's home directory. - (abbreviated-home-dir nil) - (process-environment (cons (format "HOME=%s" todo-test-home) - process-environment)) - (todo-directory (ert-resource-directory)) - (todo-default-todo-file (todo-short-file-name - (car (funcall todo-files-function))))) - (unwind-protect - (progn ,@body) - ;; Restore pre-test-run state of test files. - (dolist (f (directory-files todo-directory)) - (let ((buf (get-file-buffer f))) - (when buf - (with-current-buffer buf - (restore-buffer-modified-p nil) - (kill-buffer))))) - (delete-directory todo-test-home t)))) + `(ert-with-temp-directory todo-test-home + (let* (;; Since we change HOME, clear this to avoid a conflict + ;; e.g. if Emacs runs within the user's home directory. + (abbreviated-home-dir nil) + (process-environment (cons (format "HOME=%s" todo-test-home) + process-environment)) + (todo-directory (ert-resource-directory)) + (todo-default-todo-file (todo-short-file-name + (car (funcall todo-files-function))))) + (unwind-protect + (progn ,@body) + ;; Restore pre-test-run state of test files. + (dolist (f (directory-files todo-directory)) + (let ((buf (get-file-buffer f))) + (when buf + (with-current-buffer buf + (restore-buffer-modified-p nil) + (kill-buffer))))))))) (defun todo-test--show (num &optional archive) "Display category NUM of test todo file. @@ -567,7 +566,7 @@ The remaining arguments (except _ARG, which is ignored) specify item insertion parameters. This provides a noninteractive API for todo-insert-item for use in automatic testing." (cl-letf (((symbol-function 'read-from-minibuffer) - (lambda (_prompt) item)) + (lambda (_prompt &rest _) item)) ((symbol-function 'read-number) ; For todo-set-item-priority (lambda (_prompt &optional _default) (or priority 1)))) (todo-insert-item--basic nil diary-type date-type time where))) diff --git a/test/lisp/cedet/semantic-utest-c.el b/test/lisp/cedet/semantic-utest-c.el index d08c79cad3e..c5eb5b0ec06 100644 --- a/test/lisp/cedet/semantic-utest-c.el +++ b/test/lisp/cedet/semantic-utest-c.el @@ -60,7 +60,7 @@ (semantic-fetch-tags)))) (when (or (not tags-expected) (not tags-actual)) (message "Tried to find test files in: %s" semantic-utest-c-test-directory) - (error "Failed: Discovered no tags in test files or test file not found.")) + (error "Failed: Discovered no tags in test files or test file not found")) ;; Now that we have the tags, compare them for SPP accuracy. (dolist (tag tags-actual) diff --git a/test/lisp/cedet/semantic-utest-ia.el b/test/lisp/cedet/semantic-utest-ia.el index 122c431d472..6ea4ca1a16a 100644 --- a/test/lisp/cedet/semantic-utest-ia.el +++ b/test/lisp/cedet/semantic-utest-ia.el @@ -489,4 +489,4 @@ tag that contains point, and return that." (provide 'semantic-ia-utest) -;;; semantic-ia-utest.el ends here +;;; semantic-utest-ia.el ends here diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index 172ab62f895..3e4cfb0f0cb 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -29,6 +29,8 @@ (require 'cedet) (require 'semantic) +;;; Code: + (defvar cedet-utest-directory (let* ((C (file-name-directory (locate-library "cedet"))) (D (expand-file-name "../../test/manual/cedet/" C))) @@ -103,7 +105,7 @@ int calc_sv(int); (defvar semantic-utest-C-filename-h (concat (file-name-sans-extension semantic-utest-C-filename) ".h") - "Header file filename for C") + "Header file filename for C.") (defvar semantic-utest-C-name-contents @@ -424,8 +426,7 @@ class aClass { nil (overlay 135 262 "phptest.php")) ) - "Expected results from the PHP Unit test" - ) + "Expected results from the PHP Unit test.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/test/lisp/cedet/semantic/bovine/gcc-tests.el b/test/lisp/cedet/semantic/bovine/gcc-tests.el index 93677d6c871..d049f95b4cd 100644 --- a/test/lisp/cedet/semantic/bovine/gcc-tests.el +++ b/test/lisp/cedet/semantic/bovine/gcc-tests.el @@ -124,6 +124,11 @@ gcc version 2.95.2 19991024 (release)" "Test the output parser against the machine currently running Emacs." (skip-unless (executable-find "gcc")) (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v")))) - (semantic-gcc-test-output-parser))) + ;; Some macOS machines run llvm when you type gcc. (!) + ;; We can't even check if it's a symlink; it's a binary placed in + ;; "/usr/bin/gcc". So check the output and just skip this test if + ;; it says "Apple LLVM". + (unless (string-match "Apple LLVM" (car semantic-gcc-test-strings)) + (semantic-gcc-test-output-parser)))) ;;; gcc-tests.el ends here diff --git a/test/lisp/cedet/semantic/fw-tests.el b/test/lisp/cedet/semantic/fw-tests.el index 7b1cd21bd1b..6a5f3c85fc6 100644 --- a/test/lisp/cedet/semantic/fw-tests.el +++ b/test/lisp/cedet/semantic/fw-tests.el @@ -42,4 +42,4 @@ ;; retrieve cached data (should (equal (semantic-get-cache-data 'moose) data))))) -;;; gw-tests.el ends here +;;; fw-tests.el ends here diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 8a9a41f452f..0bd5c1e9d15 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -1,4 +1,4 @@ -;;; comint-tests.el -*- lexical-binding:t -*- +;;; comint-tests.el --- Tests for comint.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. @@ -43,6 +43,11 @@ "PIN for user:" ; Bug#35523 "Password (again):" "Enter password:" + "(user@host) Password: " ; openssh-8.6p1 + "Current password:" ; "passwd" (to change password) in Debian. + "Enter encryption key: " ; ccrypt + "Enter decryption key: " ; ccrypt + "Enter encryption key: (repeat) " ; ccrypt "Enter Auth Password:" ; OpenVPN (Bug#35724) "Verify password: " ; zip -e zipfile.zip ... (Bug#47209) "Mot de Passe :" ; localized (Bug#29729) @@ -94,4 +99,4 @@ password flow if it returns a nil value." ;; no-byte-compile: t ;; End: -;;; comint-testsuite.el ends here +;;; comint-tests.el ends here diff --git a/test/lisp/cus-edit-tests.el b/test/lisp/cus-edit-tests.el index 97b3349000c..f7d52834370 100644 --- a/test/lisp/cus-edit-tests.el +++ b/test/lisp/cus-edit-tests.el @@ -37,7 +37,7 @@ ;;;; showing/hiding obsolete options -(defgroup cus-edit-tests nil "test" +(defgroup cus-edit-tests nil "Test." :group 'test-group) (defcustom cus-edit-tests--obsolete-option-tag nil diff --git a/test/lisp/custom-tests.el b/test/lisp/custom-tests.el index e93c96e1d93..769db6ceab4 100644 --- a/test/lisp/custom-tests.el +++ b/test/lisp/custom-tests.el @@ -25,20 +25,9 @@ (require 'wid-edit) (require 'cus-edit) -(defmacro custom-tests--with-temp-dir (&rest body) - "Eval BODY with `temporary-file-directory' bound to a fresh directory. -Ensure the directory is recursively deleted after the fact." - (declare (debug t) (indent 0)) - (let ((dir (make-symbol "dir"))) - `(let ((,dir (file-name-as-directory (make-temp-file "custom-tests-" t)))) - (unwind-protect - (let ((temporary-file-directory ,dir)) - ,@body) - (delete-directory ,dir t))))) - (ert-deftest custom-theme--load-path () "Test `custom-theme--load-path' behavior." - (custom-tests--with-temp-dir + (ert-with-temp-directory temporary-file-directory ;; Path is empty. (let ((custom-theme-load-path ())) (should (null (custom-theme--load-path)))) @@ -50,28 +39,28 @@ Ensure the directory is recursively deleted after the fact." (should (null (custom-theme--load-path)))) ;; Path comprises existing file. - (let* ((file (make-temp-file "file")) - (custom-theme-load-path (list file))) - (should (file-exists-p file)) - (should (not (file-directory-p file))) - (should (null (custom-theme--load-path)))) + (ert-with-temp-file file + (let* ((custom-theme-load-path (list file))) + (should (file-exists-p file)) + (should (not (file-directory-p file))) + (should (null (custom-theme--load-path))))) ;; Path comprises existing directory. - (let* ((dir (make-temp-file "dir" t)) - (custom-theme-load-path (list dir))) - (should (file-directory-p dir)) - (should (equal (custom-theme--load-path) custom-theme-load-path))) + (ert-with-temp-directory dir + (let* ((custom-theme-load-path (list dir))) + (should (file-directory-p dir)) + (should (equal (custom-theme--load-path) custom-theme-load-path)))) ;; Expand `custom-theme-directory' path element. (let ((custom-theme-load-path '(custom-theme-directory))) (let ((custom-theme-directory (make-temp-name temporary-file-directory))) (should (not (file-exists-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "file"))) + (ert-with-temp-file custom-theme-directory (should (file-exists-p custom-theme-directory)) (should (not (file-directory-p custom-theme-directory))) (should (null (custom-theme--load-path)))) - (let ((custom-theme-directory (make-temp-file "dir" t))) + (ert-with-temp-directory custom-theme-directory (should (file-directory-p custom-theme-directory)) (should (equal (custom-theme--load-path) (list custom-theme-directory))))) @@ -96,7 +85,8 @@ Ensure the directory is recursively deleted after the fact." (ert-deftest custom-tests-require-theme () "Test `require-theme'." - (custom-tests--with-temp-dir + (require 'warnings) + (ert-with-temp-directory temporary-file-directory (let* ((default-directory temporary-file-directory) (custom-theme-load-path (list default-directory)) (load-path ())) diff --git a/test/lisp/dabbrev-tests.el b/test/lisp/dabbrev-tests.el index 0b20dcf9213..d3fe78b6185 100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@ -29,16 +29,15 @@ (ert-deftest dabbrev-expand-test () "Test for bug#1948. -When DABBREV-ELIMINATE-NEWLINES is non-nil (the default), -repeated calls to DABBREV-EXPAND can result in the source of +When `dabbrev-eliminate-newlines' is non-nil (the default), +repeated calls to `dabbrev-expand' can result in the source of first expansion being replaced rather than the destination." (with-temp-buffer (insert "ab x\na\nab y") (goto-char 8) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; M-/ SPC M-/ M-/ - (execute-kbd-macro "\257 \257\257")) + (execute-kbd-macro (kbd "M-/ SPC M-/ M-/"))) (should (string= (buffer-string) "ab x\nab y\nab y")))) (ert-deftest dabbrev-completion-test () @@ -52,8 +51,7 @@ buffers unless a prefix argument is used." (goto-char 6) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; C-M-/ - (execute-kbd-macro [201326639])) + (execute-kbd-macro (kbd "C-M-/"))) (should (string= (buffer-string) "abc\nabc"))))) (ert-deftest dabbrev-completion-test-with-argument () @@ -67,6 +65,7 @@ multiple expansions." (goto-char 6) (save-window-excursion (set-window-buffer nil (current-buffer)) - ;; C-u C-u C-M-/ - (execute-kbd-macro [21 21 201326639])) + (execute-kbd-macro (kbd "C-u C-u C-M-/"))) (should (string= (buffer-string) "abc\na"))))) + +;;; dabbrev-tests.el ends here diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el index 2052dc0e38c..715fafa44c3 100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@ -91,4 +91,4 @@ (provide 'descr-text-test) -;;; descr-text-test.el ends here +;;; descr-text-tests.el ends here diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index 7f1743f88d7..374164f1f9b 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -19,26 +19,25 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-aux) (eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." (skip-unless (executable-find shell-file-name)) - (let* ((foo (make-temp-file "foo")) - (files (list foo))) - (unwind-protect - (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) - (dired temporary-file-directory) - (dired-goto-file foo) - ;; `dired-do-shell-command' returns nil on success. - (should-error (dired-do-shell-command "ls ? ./?" nil files)) - (should-error (dired-do-shell-command "ls ./? ?" nil files)) - (should-not (dired-do-shell-command "ls ? ?" nil files)) - (should-error (dired-do-shell-command "ls * ./*" nil files)) - (should-not (dired-do-shell-command "ls * *" nil files)) - (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) - (delete-file foo)))) + (ert-with-temp-file foo + (let* ((files (list foo))) + (cl-letf (((symbol-function 'read-char-from-minibuffer) 'error)) + (dired temporary-file-directory) + (dired-goto-file foo) + ;; `dired-do-shell-command' returns nil on success. + (should-error (dired-do-shell-command "ls ? ./?" nil files)) + (should-error (dired-do-shell-command "ls ./? ?" nil files)) + (should-not (dired-do-shell-command "ls ? ?" nil files)) + (should-error (dired-do-shell-command "ls * ./*" nil files)) + (should-not (dired-do-shell-command "ls * *" nil files)) + (should-not (dired-do-shell-command "ls ? ./`?`" nil files)))))) ;; Auxiliary macro for `dired-test-bug28834': it binds ;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. @@ -47,24 +46,21 @@ (defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) (declare (debug (form symbolp body))) (let ((foo (make-symbol "foo"))) - `(let* ((,foo (make-temp-file "foo" 'dir)) - (dired-create-destination-dirs ,create-dirs)) - (setq from (make-temp-file "from")) - (setq to-cp - (expand-file-name - "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) - (setq to-mv - (expand-file-name - "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) - (unwind-protect - (if ,yes-or-no - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (_prompt) (eq ,yes-or-no 'yes)))) - ,@body) - ,@body) - ;; clean up - (delete-directory ,foo 'recursive) - (delete-file from))))) + `(ert-with-temp-directory ,foo + (ert-with-temp-file from + (let* ((dired-create-destination-dirs ,create-dirs)) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (_prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body))))))) (ert-deftest dired-test-bug28834 () "test for https://debbugs.gnu.org/28834 ." @@ -159,4 +155,4 @@ (dired-test--check-highlighting (nth 0 lines) '(8)))) (provide 'dired-aux-tests) -;; dired-aux-tests.el ends here +;;; dired-aux-tests.el ends here diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index aac78c64c69..ad1bca923d9 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (ert-deftest dired-autoload () @@ -141,116 +142,113 @@ (ert-deftest dired-test-bug27243-01 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#5 ." - (let* ((test-dir (file-name-as-directory (make-temp-file "test-dir-" t))) - (save-pos (lambda () - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (dired-save-positions)))) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; dired-buffers-for-dir. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (should-not (dired-buffers-for-dir test-dir)) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (message "Saved pos: %S" (funcall save-pos)) - ;; Point must be at end-of-buffer. - (with-current-buffer (car (dired-buffers-for-dir test-dir)) - (should (eobp))) - (push (dired test-dir) buffers) - (message "Saved pos: %S" (funcall save-pos)) - ;; Previous dired call shouldn't create a new buffer: must visit the one - ;; created by `find-file-noselect' above. - (should (eq 1 (length (dired-buffers-for-dir test-dir)))) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (message "Saved pos: %S" (funcall save-pos)) - (write-region "Test" nil test-file nil 'silent nil 'excl) - (message "Saved pos: %S" (funcall save-pos)) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat test-dir (file-name-as-directory "test-subdir")))) - (message "Saved pos: %S" (funcall save-pos)) - (push (dired-find-file) buffers) - (let ((pt2 (point))) ; Point is on test-file. - (pop-to-buffer-same-window buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) + (ert-with-temp-directory test-dir + (let* ((save-pos (lambda () + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (dired-save-positions)))) + (dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; dired-buffers-for-dir. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (should-not (dired-buffers-for-dir test-dir)) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (message "Saved pos: %S" (funcall save-pos)) + ;; Point must be at end-of-buffer. + (with-current-buffer (car (dired-buffers-for-dir test-dir)) + (should (eobp))) + (push (dired test-dir) buffers) + (message "Saved pos: %S" (funcall save-pos)) + ;; Previous dired call shouldn't create a new buffer: must visit the one + ;; created by `find-file-noselect' above. + (should (eq 1 (length (dired-buffers-for-dir test-dir)))) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (message "Saved pos: %S" (funcall save-pos)) + (write-region "Test" nil test-file nil 'silent nil 'excl) + (message "Saved pos: %S" (funcall save-pos)) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat test-dir (file-name-as-directory "test-subdir")))) + (message "Saved pos: %S" (funcall save-pos)) (push (dired-find-file) buffers) - (should (eq (point) pt2)))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (let ((pt2 (point))) ; Point is on test-file. + (pop-to-buffer-same-window buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired-find-file) buffers) + (should (eq (point) pt2)))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-02 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#28 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) buffers) - ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the - ;; corresponding long file names exist, otherwise such names trip - ;; string comparisons below. - (if (eq system-type 'windows-nt) - (setq test-dir (file-truename test-dir))) - (with-current-buffer (find-file-noselect test-dir) - (make-directory "test-subdir")) - (push (dired test-dir) buffers) - (unwind-protect - (let ((buf (current-buffer)) - (pt1 (point)) - (test-file (concat (file-name-as-directory "test-subdir") - "test-file"))) - (write-region "Test" nil test-file nil 'silent nil 'excl) - ;; Sanity check: point should now be on the subdirectory. - (should (equal (dired-file-name-at-point) - (concat (file-name-as-directory test-dir) - (file-name-as-directory "test-subdir")))) - (push (dired-find-file) buffers) - ;; Point is on test-file. - (switch-to-buffer buf) - ;; Sanity check: point should now be back on the subdirectory. - (should (eq (point) pt1)) - (push (dired test-dir) buffers) - (should (eq (point) pt1))) - (dolist (buf buffers) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) buffers) + ;; On MS-Windows, get rid of 8+3 short names in test-dir, if the + ;; corresponding long file names exist, otherwise such names trip + ;; string comparisons below. + (if (eq system-type 'windows-nt) + (setq test-dir (file-truename test-dir))) + (with-current-buffer (find-file-noselect test-dir) + (make-directory "test-subdir")) + (push (dired test-dir) buffers) + (unwind-protect + (let ((buf (current-buffer)) + (pt1 (point)) + (test-file (concat (file-name-as-directory "test-subdir") + "test-file"))) + (write-region "Test" nil test-file nil 'silent nil 'excl) + ;; Sanity check: point should now be on the subdirectory. + (should (equal (dired-file-name-at-point) + (concat (file-name-as-directory test-dir) + (file-name-as-directory "test-subdir")))) + (push (dired-find-file) buffers) + ;; Point is on test-file. + (switch-to-buffer buf) + ;; Sanity check: point should now be back on the subdirectory. + (should (eq (point) pt1)) + (push (dired test-dir) buffers) + (should (eq (point) pt1))) + (dolist (buf buffers) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug27243-03 () "Test for https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27243#61 ." - (let ((test-dir (make-temp-file "test-dir-" t)) - (dired-auto-revert-buffer t) - allbufs) - (unwind-protect - (progn - (with-current-buffer (find-file-noselect test-dir) - (push (current-buffer) allbufs) - (make-directory "test-subdir1") - (make-directory "test-subdir2") - (let ((test-file1 "test-file1") - (test-file2 "test-file2")) - (with-current-buffer (find-file-noselect "test-subdir1") - (push (current-buffer) allbufs) - (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) - (with-current-buffer (find-file-noselect "test-subdir2") - (push (current-buffer) allbufs) - (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) - ;; Call find-file with a wild card and test point in each file. - (let ((buffers (find-file (concat (file-name-as-directory test-dir) - "*") - t))) - (dolist (buf buffers) - (let ((pt (with-current-buffer buf (point)))) - (switch-to-buffer (find-file-noselect test-dir)) - (find-file (buffer-name buf)) - (should (equal (point) pt)))) - (append buffers allbufs))) - (dolist (buf allbufs) - (when (buffer-live-p buf) (kill-buffer buf))) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let ((dired-auto-revert-buffer t) + allbufs) + (unwind-protect + (progn + (with-current-buffer (find-file-noselect test-dir) + (push (current-buffer) allbufs) + (make-directory "test-subdir1") + (make-directory "test-subdir2") + (let ((test-file1 "test-file1") + (test-file2 "test-file2")) + (with-current-buffer (find-file-noselect "test-subdir1") + (push (current-buffer) allbufs) + (write-region "Test1" nil test-file1 nil 'silent nil 'excl)) + (with-current-buffer (find-file-noselect "test-subdir2") + (push (current-buffer) allbufs) + (write-region "Test2" nil test-file2 nil 'silent nil 'excl)))) + ;; Call find-file with a wild card and test point in each file. + (let ((buffers (find-file (concat (file-name-as-directory test-dir) + "*") + t))) + (dolist (buf buffers) + (let ((pt (with-current-buffer buf (point)))) + (switch-to-buffer (find-file-noselect test-dir)) + (find-file (buffer-name buf)) + (should (equal (point) pt)))) + (append buffers allbufs))) + (dolist (buf allbufs) + (when (buffer-live-p buf) (kill-buffer buf))))))) (ert-deftest dired-test-bug7131 () "Test for https://debbugs.gnu.org/7131 ." @@ -274,22 +272,21 @@ ;; ls-lisp-tests.el and em-ls-tests.el. (skip-unless (and (not (featurep 'ls-lisp)) (not (featurep 'eshell)))) - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest dired-test-bug27899 () "Test for https://debbugs.gnu.org/27899 ." @@ -310,72 +307,69 @@ (ert-deftest dired-test-bug27968 () "Test for https://debbugs.gnu.org/27968 ." - (let* ((top-dir (make-temp-file "top-dir" t)) - (subdir (expand-file-name "subdir" top-dir)) - (header-len-fn (lambda () - (save-excursion - (goto-char 1) - (forward-line 1) - (- (point-at-eol) (point))))) - orig-len len diff pos line-nb) - (make-directory subdir 'parents) - (unwind-protect - (with-current-buffer (dired-noselect subdir) - (setq orig-len (funcall header-len-fn) - pos (point) - line-nb (line-number-at-pos)) - ;; Bug arises when the header line changes its length; this may - ;; happen if the used space has changed: for instance, with the - ;; creation of additional files. - (make-directory "subdir" t) - (dired-revert) - ;; Change the header line. - (save-excursion - (goto-char 1) - (forward-line 1) - (let ((inhibit-read-only t) - (new-header " test-bug27968")) - (delete-region (point) (point-at-eol)) - (when (= orig-len (length new-header)) - ;; Wow lucky guy! I must buy lottery today. - (setq new-header (concat new-header " :-)"))) - (insert new-header))) - (setq len (funcall header-len-fn) - diff (- len orig-len)) - (should-not (zerop diff)) ; Header length has changed. - ;; If diff > 0, then the point moves back. - ;; If diff < 0, then the point moves forward. - ;; If diff = 0, then the point doesn't move. - ;; Sometimes this point movement causes - ;; line-nb != (line-number-at-pos pos), so that we get - ;; an unexpected file at point if we store buffer points. - ;; Note that the line number before/after revert - ;; doesn't change. - (should (= line-nb - (line-number-at-pos) - (line-number-at-pos (+ pos diff)))) - ;; After revert, the point must be in 'subdir' line. - (should (equal "subdir" (dired-get-filename 'local t)))) - (delete-directory top-dir t)))) + (ert-with-temp-directory top-dir + (let* ((subdir (expand-file-name "subdir" top-dir)) + (header-len-fn (lambda () + (save-excursion + (goto-char 1) + (forward-line 1) + (- (point-at-eol) (point))))) + orig-len len diff pos line-nb) + (make-directory subdir 'parents) + (with-current-buffer (dired-noselect subdir) + (setq orig-len (funcall header-len-fn) + pos (point) + line-nb (line-number-at-pos)) + ;; Bug arises when the header line changes its length; this may + ;; happen if the used space has changed: for instance, with the + ;; creation of additional files. + (make-directory "subdir" t) + (dired-revert) + ;; Change the header line. + (save-excursion + (goto-char 1) + (forward-line 1) + (let ((inhibit-read-only t) + (new-header " test-bug27968")) + (delete-region (point) (point-at-eol)) + (when (= orig-len (length new-header)) + ;; Wow lucky guy! I must buy lottery today. + (setq new-header (concat new-header " :-)"))) + (insert new-header))) + (setq len (funcall header-len-fn) + diff (- len orig-len)) + (should-not (zerop diff)) ; Header length has changed. + ;; If diff > 0, then the point moves back. + ;; If diff < 0, then the point moves forward. + ;; If diff = 0, then the point doesn't move. + ;; Sometimes this point movement causes + ;; line-nb != (line-number-at-pos pos), so that we get + ;; an unexpected file at point if we store buffer points. + ;; Note that the line number before/after revert + ;; doesn't change. + (should (= line-nb + (line-number-at-pos) + (line-number-at-pos (+ pos diff)))) + ;; After revert, the point must be in 'subdir' line. + (should (equal "subdir" (dired-get-filename 'local t))))))) (defmacro dired-test-with-temp-dirs (just-empty-dirs &rest body) "Helper macro for Bug#27940 test." (declare (indent 1) (debug body)) (let ((dir (make-symbol "dir"))) - `(let* ((,dir (make-temp-file "bug27940" t)) - (dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. - (inhibit-message t) - (default-directory ,dir)) - (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) - (unless ,just-empty-dirs - (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) - (make-directory "zeta-empty-dir") - (unwind-protect - (progn - ,@body) - (delete-directory ,dir t) - (kill-buffer (current-buffer)))))) + `(ert-with-temp-directory ,dir + (let* ((dired-deletion-confirmer (lambda (_) "yes")) ; Suppress prompts. + (inhibit-message t) + (default-directory ,dir)) + (dotimes (i 5) (make-directory (format "empty-dir-%d" i))) + (unless ,just-empty-dirs + (dotimes (i 5) (make-directory (format "non-empty-%d/foo" i) 'parents))) + (make-directory "zeta-empty-dir") + (unwind-protect + (progn + ,@body) + (kill-buffer (current-buffer))))))) (ert-deftest dired-test-bug27940 () "Test for https://debbugs.gnu.org/27940 ." @@ -518,4 +512,4 @@ (delete-directory testdir t))))) (provide 'dired-tests) -;; dired-tests.el ends here +;;; dired-tests.el ends here diff --git a/test/lisp/dired-x-tests.el b/test/lisp/dired-x-tests.el index 003923d60fa..fe4b9711d49 100644 --- a/test/lisp/dired-x-tests.el +++ b/test/lisp/dired-x-tests.el @@ -19,6 +19,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired-x) @@ -31,23 +32,20 @@ (append (copy-sequence dirs) (delete "c" (copy-sequence files))) #'string<)) - (dir (make-temp-file "Bug25942" 'dir)) (extension "c")) - (unwind-protect - (progn - (dolist (d dirs) - (make-directory (expand-file-name d dir))) - (dolist (f files) - (write-region nil nil (expand-file-name f dir))) - (dired dir) - (dired-mark-extension extension) - (should (equal '("bar.c" "foo.c") - (sort (dired-get-marked-files 'local) #'string<))) - (dired-unmark-all-marks) - (dired-mark-suffix extension) - (should (equal all-but-c - (sort (dired-get-marked-files 'local) #'string<)))) - (delete-directory dir 'recursive)))) + (ert-with-temp-directory dir + (dolist (d dirs) + (make-directory (expand-file-name d dir))) + (dolist (f files) + (write-region nil nil (expand-file-name f dir))) + (dired dir) + (dired-mark-extension extension) + (should (equal '("bar.c" "foo.c") + (sort (dired-get-marked-files 'local) #'string<))) + (dired-unmark-all-marks) + (dired-mark-suffix extension) + (should (equal all-but-c + (sort (dired-get-marked-files 'local) #'string<)))))) (ert-deftest dired-guess-default () (let ((dired-guess-shell-alist-user nil) @@ -63,4 +61,4 @@ nil)))) (provide 'dired-x-tests) -;; dired-x-tests.el ends here +;;; dired-x-tests.el ends here diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el index 0a0d783b824..b55982c1a15 100644 --- a/test/lisp/dom-tests.el +++ b/test/lisp/dom-tests.el @@ -209,5 +209,13 @@ child results in an error." (dom-pp node t) (should (equal (buffer-string) "(\"foo\" nil)"))))) +(ert-deftest dom-test-search () + (let ((dom '(a nil (b nil (c nil))))) + (should (equal (dom-search dom (lambda (d) (eq (dom-tag d) 'a))) + (list dom))) + (should (equal (dom-search dom (lambda (d) (memq (dom-tag d) '(b c)))) + (list (car (dom-children dom)) + (car (dom-children (car (dom-children dom))))))))) + (provide 'dom-tests) ;;; dom-tests.el ends here diff --git a/test/lisp/edmacro-tests.el b/test/lisp/edmacro-tests.el new file mode 100644 index 00000000000..974f506a367 --- /dev/null +++ b/test/lisp/edmacro-tests.el @@ -0,0 +1,47 @@ +;;; edmacro-tests.el --- Tests for edmacro.el -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'edmacro) + +(ert-deftest edmacro-test-edmacro-parse-keys () + (should (equal (edmacro-parse-keys "") "")) + (should (equal (edmacro-parse-keys "x") "x")) + (should (equal (edmacro-parse-keys "C-a") "\C-a")) + + ;; comments + (should (equal (edmacro-parse-keys ";; foobar") "")) + (should (equal (edmacro-parse-keys ";;;") "")) + (should (equal (edmacro-parse-keys "; ; ;") ";;;")) + (should (equal (edmacro-parse-keys "REM foobar") "")) + (should (equal (edmacro-parse-keys "x ;; foobar") "x")) + (should (equal (edmacro-parse-keys "x REM foobar") "x")) + (should (equal (edmacro-parse-keys "<<goto-line>>") + [134217848 103 111 116 111 45 108 105 110 101 13])) + + ;; repetitions + (should (equal (edmacro-parse-keys "3*x") "xxx")) + (should (equal (edmacro-parse-keys "3*C-m") "\C-m\C-m\C-m")) + (should (equal (edmacro-parse-keys "10*foo") "foofoofoofoofoofoofoofoofoofoo"))) + +;;; edmacro-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 235c02f8e8b..1e32dbfb609 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -35,7 +35,8 @@ (defun call-with-saved-electric-modes (fn) (let ((saved-electric (if electric-pair-mode 1 -1)) (saved-layout (if electric-layout-mode 1 -1)) - (saved-indent (if electric-indent-mode 1 -1))) + (saved-indent (if electric-indent-mode 1 -1)) + (blink-paren-function nil)) (electric-pair-mode -1) (electric-layout-mode -1) (electric-indent-mode -1) @@ -53,17 +54,18 @@ expected-point mode bindings fixture-fn &optional doc-string) (with-temp-buffer - (funcall mode) - (insert fixture) - (save-electric-modes - (let ((last-command-event char) - (transient-mark-mode 'lambda)) - (goto-char where) - (funcall fixture-fn) - (cl-progv - (mapcar #'car bindings) - (mapcar #'cdr bindings) - (call-interactively (key-binding `[,last-command-event]))))) + (dlet ((python-indent-guess-indent-offset-verbose nil)) + (funcall mode) + (insert fixture) + (save-electric-modes + (let ((last-command-event char) + (transient-mark-mode 'lambda)) + (goto-char where) + (funcall fixture-fn) + (cl-progv + (mapcar #'car bindings) + (mapcar #'cdr bindings) + (call-interactively (key-binding `[,last-command-event])))))) (when (and doc-string (not @@ -97,21 +99,22 @@ ;; FIXME: avoid `eval' (mapcar #'car (eval bindings)) (mapcar #'cdr (eval bindings)) - (funcall mode) - (insert fixture) - (goto-char (1+ pos)) - (insert char) - (cond ((eq (aref skip-pair-string pos) - ?p) - (insert (cadr (electric-pair-syntax-info char))) - (backward-char 1)) - ((eq (aref skip-pair-string pos) - ?s) - (delete-char -1) - (forward-char 1))) - (list - (buffer-substring-no-properties (point-min) (point-max)) - (point)))) + (dlet ((python-indent-guess-indent-offset-verbose nil)) + (funcall mode) + (insert fixture) + (goto-char (1+ pos)) + (insert char) + (cond ((eq (aref skip-pair-string pos) + ?p) + (insert (cadr (electric-pair-syntax-info char))) + (backward-char 1)) + ((eq (aref skip-pair-string pos) + ?s) + (delete-char -1) + (forward-char 1))) + (list + (buffer-substring-no-properties (point-min) (point-max)) + (point))))) (list expected-string expected-point))) (expected-string (car expected-string-and-point)) (expected-point (cadr expected-string-and-point)) @@ -146,7 +149,7 @@ The buffer's contents should %s: "") char (if (string= fixture expected-string) "stay" "become") - (replace-regexp-in-string "\n" "\\\\n" expected-string) + (string-replace "\n" "\\n" expected-string) expected-point))) `(ert-deftest ,(intern (format "electric-pair-%s-at-point-%s-in-%s%s" name @@ -173,7 +176,7 @@ The buffer's contents should %s: expected-string expected-point bindings - (modes '(quote (ruby-mode js-mode))) + (modes '(quote (ruby-mode js-mode python-mode c-mode))) (test-in-comments t) (test-in-strings t) (test-in-code t) @@ -190,11 +193,13 @@ The buffer's contents should %s: for (prefix suffix extra-desc) in (append (if test-in-comments `((,(with-temp-buffer - (funcall mode) - (insert "z") - (comment-region (point-min) (point-max)) - (buffer-substring-no-properties (point-min) - (1- (point-max)))) + (dlet ((python-indent-guess-indent-offset-verbose + nil)) + (funcall mode) + (insert "z") + (comment-region (point-min) (point-max)) + (buffer-substring-no-properties (point-min) + (1- (point-max))))) "" "-in-comments"))) (if test-in-strings @@ -296,7 +301,7 @@ The buffer's contents should %s: ;;; Quotes ;;; (define-electric-pair-test pair-some-quotes-skip-others - " \"\" " "-\"\"-----" :skip-pair-string "-ps------" + " \"\" " "-\"\"-\"---" :skip-pair-string "-ps-p----" :test-in-strings nil :bindings `((electric-pair-text-syntax-table . ,prog-mode-syntax-table))) @@ -423,7 +428,9 @@ baz\"\"" :bindings '((electric-pair-skip-whitespace . chomp)) :test-in-strings nil :test-in-code nil - :test-in-comments t) + :test-in-comments t + :fixture-fn (lambda () (when (eq major-mode 'c-mode) + (c-toggle-comment-style -1)))) (define-electric-pair-test whitespace-skipping-for-quotes-not-outside " \" \"" "\"-----" :expected-string "\"\" \" \"" @@ -870,8 +877,8 @@ baz\"\"" (local-set-key (vector key) 'self-insert-command))) (defun electric-layout-for-c-style-du-jour (inserted) - "A function to use in `electric-layout-rules'" - (when (memq inserted '(?{ ?})) + "A function to use in `electric-layout-rules'." + (when (memq inserted '(?\{ ?\})) (save-excursion (backward-char 2) (c-point-syntax) (forward-char) ; silly, but needed (c-brace-newlines (c-point-syntax))))) diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 7c40f7ebca3..dbc0aa3db42 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-tests.el -*- lexical-binding:t -*- +;;; bytecomp-tests.el --- Tests for bytecomp.el -*- lexical-binding:t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -41,6 +41,24 @@ "Identity, but hidden from some optimisations." x) +(defmacro bytecomp-test-loop (outer1 outer2 inner1 inner2) + "Exercise constant propagation inside `while' loops. +OUTER1, OUTER2, INNER1 and INNER2 are forms placed in the outer and +inner loops respectively." + `(let ((x 1) (i 3) (res nil)) + (while (> i 0) + (let ((y 2) (j 2)) + (setq res (cons (list 'outer x y) res)) + (while (> j 0) + (setq res (cons (list 'inner x y) res)) + ,inner1 + ,inner2 + (setq j (1- j))) + ,outer1 + ,outer2) + (setq i (1- i))) + res)) + (defconst bytecomp-tests--test-cases '( ;; some functional tests @@ -432,6 +450,15 @@ (let ((x 2)) (list (or (bytecomp-test-identity 'a) (setq x 3)) x)) + (mapcar (lambda (b) + (let ((a nil)) + (+ 0 + (progn + (setq a b) + (setq b 1) + a)))) + '(10)) + (let* ((x 1) (y (condition-case x (/ 1 0) @@ -445,6 +472,25 @@ (setq x 10)))) 4) + ;; Loop constprop: set the inner and outer variables in the inner + ;; and outer loops, all combinations. + (bytecomp-test-loop nil nil nil nil ) + (bytecomp-test-loop nil nil nil (setq x 6)) + (bytecomp-test-loop nil nil (setq x 5) nil ) + (bytecomp-test-loop nil nil (setq x 5) (setq x 6)) + (bytecomp-test-loop nil (setq x 4) nil nil ) + (bytecomp-test-loop nil (setq x 4) nil (setq x 6)) + (bytecomp-test-loop nil (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop nil (setq x 4) (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) nil nil nil ) + (bytecomp-test-loop (setq x 3) nil nil (setq x 6)) + (bytecomp-test-loop (setq x 3) nil (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) nil (setq x 5) (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) nil nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) nil (setq x 6)) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) nil ) + (bytecomp-test-loop (setq x 3) (setq x 4) (setq x 5) (setq x 6)) + ;; No error, no success handler. (condition-case x (list 42) @@ -503,6 +549,100 @@ (:success 'good)) (1+ x)))) (funcall f 3)) + + ;; Check `not' in cond switch (bug#49746). + (mapcar (lambda (x) (cond ((equal x "a") 1) + ((member x '("b" "c")) 2) + ((not x) 3))) + '("a" "b" "c" "d" nil)) + + ;; `let' and `let*' optimisations with body being constant or variable + (let* (a + (b (progn (setq a (cons 1 a)) 2)) + (c (1+ b)) + (d (list a c))) + d) + (let ((a nil)) + (let ((b (progn (setq a (cons 1 a)) 2)) + (c (progn (setq a (cons 3 a)))) + (d (list a))) + d)) + (let* ((_a 1) + (_b 2)) + 'z) + (let ((_a 1) + (_b 2)) + 'z) + (let (x y) + y) + (let* (x y) + y) + (let (x y) + 'a) + (let* (x y) + 'a) + + ;; Check empty-list optimisations. + (mapcar (lambda (x) (member x nil)) '("a" 2 nil)) + (mapcar (lambda (x) (memql x nil)) '(a 2 nil)) + (mapcar (lambda (x) (memq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (member (setq n (1+ n)) nil)) '(a "nil")) + n)) + (mapcar (lambda (x) (assoc x nil)) '("a" nil)) + (mapcar (lambda (x) (assq x nil)) '(a nil)) + (mapcar (lambda (x) (rassoc x nil)) '("a" nil)) + (mapcar (lambda (x) (rassq x nil)) '(a nil)) + (let ((n 0)) + (list (mapcar (lambda (x) (assoc (setq n (1+ n)) nil)) '(a "nil")) + n)) + + ;; Exercise variable-aliasing optimisations. + (let ((a (list 1))) + (let ((b a)) + (let ((a (list 2))) + (list a b)))) + + (let ((a (list 1))) + (let ((a (list 2)) + (b a)) + (list a b))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (list a b) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2))) + (condition-case a + (/ 0) + (error (list 'error a b)))) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (list x a))))) + (funcall (car f) 3)) + + (let* ((a (list 1)) + (b a) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (let* ((a (list 1)) + (b a) + (a (list 2)) + (f (list (lambda (x) (setq a x))))) + (funcall (car f) 3) + (list a b)) + + (cond) + (mapcar (lambda (x) (cond ((= x 0)))) '(0 1)) ) "List of expressions for cross-testing interpreted and compiled code.") @@ -553,24 +693,19 @@ byte-compiled. Run with dynamic binding." (defun test-byte-comp-compile-and-load (compile &rest forms) (declare (indent 1)) - (let ((elfile nil) - (elcfile nil)) - (unwind-protect - (progn - (setf elfile (make-temp-file "test-bytecomp" nil ".el")) - (when compile - (setf elcfile (make-temp-file "test-bytecomp" nil ".elc"))) - (with-temp-buffer - (dolist (form forms) - (print form (current-buffer))) - (write-region (point-min) (point-max) elfile nil 'silent)) - (if compile - (let ((byte-compile-dest-file-function - (lambda (e) elcfile))) - (byte-compile-file elfile))) - (load elfile nil 'nomessage)) - (when elfile (delete-file elfile)) - (when elcfile (delete-file elcfile))))) + (ert-with-temp-file elfile + :suffix ".el" + (ert-with-temp-file elcfile + :suffix ".elc" + (with-temp-buffer + (dolist (form forms) + (print form (current-buffer))) + (write-region (point-min) (point-max) elfile nil 'silent)) + (if compile + (let ((byte-compile-dest-file-function + (lambda (e) elcfile))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)))) (ert-deftest test-byte-comp-macro-expansion () (test-byte-comp-compile-and-load t @@ -800,10 +935,9 @@ byte-compiled. Run with dynamic binding." "warn-wide-docstring-define-obsolete-variable-alias.el" "defvaralias .foo. docstring wider than .* characters") -;; TODO: We don't yet issue warnings for defuns. (bytecomp--define-warning-file-test "warn-wide-docstring-defun.el" - "wider than .* characters" 'reverse) + "wider than .* characters") (bytecomp--define-warning-file-test "warn-wide-docstring-defvar.el" @@ -877,10 +1011,9 @@ byte-compiled. Run with dynamic binding." (defmacro bytecomp-tests--with-temp-file (file-name-var &rest body) (declare (indent 1)) (cl-check-type file-name-var symbol) - `(let ((,file-name-var (make-temp-file "emacs"))) + `(ert-with-temp-file ,file-name-var (unwind-protect (progn ,@body) - (delete-file ,file-name-var) (let ((elc (concat ,file-name-var ".elc"))) (if (file-exists-p elc) (delete-file elc)))))) @@ -1107,25 +1240,25 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--not-writable-directory () "Test that byte compilation works if the output directory isn't writable (Bug#44631)." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (should (byte-compile-file input-file)) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (unwind-protect + (progn + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (should (byte-compile-file input-file)) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777))))) (ert-deftest bytecomp-tests--dest-mountpoint () "Test that byte compilation works if the destination file is a @@ -1137,56 +1270,53 @@ mountpoint (Bug#44631)." (skip-unless (not (file-remote-p bwrap))) (skip-unless (file-executable-p emacs)) (skip-unless (not (file-remote-p emacs))) - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((input-file (expand-file-name "test.el" directory)) - (output-file (expand-file-name "test.elc" directory)) - (unquoted-file (file-name-unquote output-file)) - (byte-compile-dest-file-function - (lambda (_) output-file)) - (byte-compile-error-on-warn t)) - (should-not (file-remote-p input-file)) - (should-not (file-remote-p output-file)) - (write-region "" nil input-file nil nil nil 'excl) - (write-region "" nil output-file nil nil nil 'excl) - (set-file-modes input-file #o400) - (set-file-modes output-file #o200) - (set-file-modes directory #o500) - (with-temp-buffer - (let ((status (call-process - bwrap nil t nil - "--ro-bind" "/" "/" - "--bind" unquoted-file unquoted-file - emacs "--quick" "--batch" "--load=bytecomp" - (format "--eval=%S" - `(setq byte-compile-dest-file-function - (lambda (_) ,output-file) - byte-compile-error-on-warn t)) - "--funcall=batch-byte-compile" input-file))) - (unless (eql status 0) - (ert-fail `((status . ,status) - (output . ,(buffer-string))))))) - (should (file-regular-p output-file)) - (should (cl-plusp (file-attribute-size - (file-attributes output-file))))) - (with-demoted-errors "Error cleaning up directory: %s" - (set-file-modes directory #o700) - (delete-directory directory :recursive)))))) + (ert-with-temp-directory directory + (let* ((input-file (expand-file-name "test.el" directory)) + (output-file (expand-file-name "test.elc" directory)) + (unquoted-file (file-name-unquote output-file)) + (byte-compile-dest-file-function + (lambda (_) output-file)) + (byte-compile-error-on-warn t)) + (should-not (file-remote-p input-file)) + (should-not (file-remote-p output-file)) + (write-region "" nil input-file nil nil nil 'excl) + (write-region "" nil output-file nil nil nil 'excl) + (unwind-protect + (progn + (set-file-modes input-file #o400) + (set-file-modes output-file #o200) + (set-file-modes directory #o500) + (with-temp-buffer + (let ((status (call-process + bwrap nil t nil + "--ro-bind" "/" "/" + "--bind" unquoted-file unquoted-file + emacs "--quick" "--batch" "--load=bytecomp" + (format "--eval=%S" + `(setq byte-compile-dest-file-function + (lambda (_) ,output-file) + byte-compile-error-on-warn t)) + "--funcall=batch-byte-compile" input-file))) + (unless (eql status 0) + (ert-fail `((status . ,status) + (output . ,(buffer-string))))))) + (should (file-regular-p output-file)) + (should (cl-plusp (file-attribute-size + (file-attributes output-file))))) + ;; Allow the directory to be deleted. + (set-file-modes directory #o777)))))) (ert-deftest bytecomp-tests--target-file-no-directory () "Check that Bug#45287 is fixed." - (let ((directory (make-temp-file "bytecomp-tests-" :directory))) - (unwind-protect - (let* ((default-directory directory) - (byte-compile-dest-file-function (lambda (_) "test.elc")) - (byte-compile-error-on-warn t)) - (write-region "" nil "test.el" nil nil nil 'excl) - (should (byte-compile-file "test.el")) - (should (file-regular-p "test.elc")) - (should (cl-plusp (file-attribute-size - (file-attributes "test.elc"))))) - (with-demoted-errors "Error cleaning up directory: %s" - (delete-directory directory :recursive))))) + (ert-with-temp-directory directory + (let* ((default-directory directory) + (byte-compile-dest-file-function (lambda (_) "test.elc")) + (byte-compile-error-on-warn t)) + (write-region "" nil "test.el" nil nil nil 'excl) + (should (byte-compile-file "test.el")) + (should (file-regular-p "test.elc")) + (should (cl-plusp (file-attribute-size + (file-attributes "test.elc"))))))) (defun bytecomp-tests--get-vars () (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) @@ -1333,9 +1463,33 @@ compiled correctly." (load-file (concat file "c")) (should (equal (bc-test-alpha-f 'a) '(nil a))))) +(ert-deftest bytecomp-tests-byte-compile--wide-docstring-p/func-arg-list () + (should-not (byte-compile--wide-docstring-p "\ +\(dbus-register-property BUS SERVICE PATH INTERFACE PROPERTY ACCESS \ +[TYPE] VALUE &optional EMITS-SIGNAL DONT-REGISTER-SERVICE)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn CMD FLAGS FIS &key (BUF (cvs-temp-buffer)) DONT-CHANGE-DISC CVSARGS \ +POSTPROC)" fill-column)) + ;; Bug#49007 + (should-not (byte-compile--wide-docstring-p "\ +(fn (THIS rudel-protocol-backend) TRANSPORT \ +INFO INFO-CALLBACK &optional PROGRESS-CALLBACK)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +[:tags \\='(TAG...)] BODY...)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(make-soap-xs-element &key NAME NAMESPACE-TAG ID TYPE^ OPTIONAL? MULTIPLE? \ +REFERENCE SUBSTITUTION-GROUP ALTERNATIVES IS-GROUP)" fill-column)) + (should-not (byte-compile--wide-docstring-p "\ +(fn NAME FIXTURE INPUT &key SKIP-PAIR-STRING EXPECTED-STRING \ +EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode js-mode python-mode)) \ +(TEST-IN-COMMENTS t) (TEST-IN-STRINGS t) (TEST-IN-CODE t) \ +(FIXTURE-FN \\='#\\='electric-pair-mode))" fill-column))) + + ;; Local Variables: ;; no-byte-compile: t ;; End: (provide 'bytecomp-tests) -;; bytecomp-tests.el ends here. +;;; bytecomp-tests.el ends here diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 5aeed0cc155..4290571735e 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -1,4 +1,4 @@ -;;; cconv-tests.el -*- lexical-binding: t -*- +;;; cconv-tests.el --- Tests for cconv.el -*- lexical-binding: t -*- ;; Copyright (C) 2018-2021 Free Software Foundation, Inc. @@ -19,6 +19,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'cl-lib) @@ -204,4 +206,4 @@ 42))) (provide 'cconv-tests) -;; cconv-tests.el ends here. +;;; cconv-tests.el ends here diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el index 9552bf0e397..5c9d847e34a 100644 --- a/test/lisp/emacs-lisp/check-declare-tests.el +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -28,6 +28,7 @@ (require 'check-declare) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'subr-x)) (ert-deftest check-declare-tests-locate () @@ -36,62 +37,53 @@ (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) (ert-deftest check-declare-tests-scan () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(declare-function ring-insert \"ring\" (ring item))" - "(let ((foo 'code)) foo)") - "\n"))) - (let ((res (check-declare-scan file))) - (should (= (length res) 1)) - (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) - (should (string-match-p "ring" fnfile)) - (should (equal "ring-insert" fn)) - (should (equal '(ring item) arglist)) - (should-not fileonly)))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly))))) (ert-deftest check-declare-tests-verify () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring item)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should-not - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item))))))) (ert-deftest check-declare-tests-verify-mismatch () - (let ((file (make-temp-file "check-declare-tests-"))) - (unwind-protect - (progn - (with-temp-file file - (insert - (string-join - '(";; foo comment" - "(defun foo-fun ())" - "(defun ring-insert (ring)" - "\"Insert onto ring RING the item ITEM.\"" - "nil)") - "\n"))) - (should - (equal - (check-declare-verify - file '(("foo.el" "ring-insert" (ring item)))) - '(("foo.el" "ring-insert" "arglist mismatch"))))) - (delete-file file)))) + (ert-with-temp-file file + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch")))))) (ert-deftest check-declare-tests-sort () (should-not (check-declare-sort '())) @@ -106,11 +98,11 @@ (let ((res (buffer-string))) ;; Don't care too much about the format of the output, but ;; check that key information is present. - (should (string-match-p "foo-file" res)) - (should (string-match-p "foo-fun" res)) - (should (string-match-p "bar-file" res)) - (should (string-match-p "it wasn't" res)) - (should (string-match-p "999" res)))))) + (should (string-search "foo-file" res)) + (should (string-search "foo-fun" res)) + (should (string-search "bar-file" res)) + (should (string-search "it wasn't" res)) + (should (string-search "999" res)))))) (provide 'check-declare-tests) ;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/checkdoc-tests.el b/test/lisp/emacs-lisp/checkdoc-tests.el index 7a7aa9fb3cd..ef49e71599a 100644 --- a/test/lisp/emacs-lisp/checkdoc-tests.el +++ b/test/lisp/emacs-lisp/checkdoc-tests.el @@ -49,27 +49,27 @@ (with-temp-buffer (emacs-lisp-mode) ;; this method matches if A is the symbol `smthg' and if b is a list: - (insert "(cl-defmethod foo ((a (eql smthg)) (b list)) \"Return A+B.\")") + (insert "(cl-defmethod foo ((a (eql 'smthg)) (b list)) \"Return A+B.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-qualified-ok () "Checkdoc should be happy with a `cl-defmethod' using qualifiers." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defmethod test :around ((a (eql smthg))) \"Return A.\")") + (insert "(cl-defmethod test :around ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-ok () "Checkdoc should be happy with a :extra qualified `cl-defmethod'." (with-temp-buffer (emacs-lisp-mode) - (insert "(cl-defmethod foo :extra \"foo\" ((a (eql smthg))) \"Return A.\")") + (insert "(cl-defmethod foo :extra \"foo\" ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun)) (with-temp-buffer (emacs-lisp-mode) (insert - "(cl-defmethod foo :extra \"foo\" :after ((a (eql smthg))) \"Return A.\")") + "(cl-defmethod foo :extra \"foo\" :after ((a (eql 'smthg))) \"Return A.\")") (checkdoc-defun))) (ert-deftest checkdoc-cl-defmethod-with-extra-qualifier-and-nil-args-ok () @@ -122,4 +122,100 @@ See the comments in Bug#24998." (should (looking-at-p "\"baz\")")) (should-not (checkdoc-next-docstring)))) +(defun checkdoc-tests--abbrev-test (buffer-contents goto-string) + (with-temp-buffer + (emacs-lisp-mode) + (insert buffer-contents) + (goto-char (point-min)) + (re-search-forward goto-string) + (checkdoc-in-abbreviation-p (point)))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/basic-case () + (should (checkdoc-tests--abbrev-test "foo bar e.g. baz" "e.g")) + (should (checkdoc-tests--abbrev-test "behavior/errors etc. that" "etc")) + (should (checkdoc-tests--abbrev-test "foo vs. bar" "vs")) + (should (checkdoc-tests--abbrev-test "spy a.k.a. spy" "a.k.a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-parens () + (should (checkdoc-tests--abbrev-test "foo bar (e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-escaped-parens () + (should (checkdoc-tests--abbrev-test "foo\n\\(e.g. baz)" "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/single-char () + (should (checkdoc-tests--abbrev-test "a. foo bar" "a"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/with-em-dash () + (should (checkdoc-tests--abbrev-test "foo bar baz---e.g." "e.g"))) + +(ert-deftest checkdoc-tests-in-abbrevation-p/incorrect-abbreviation () + (should-not (checkdoc-tests--abbrev-test "foo bar a.b.c." "a.b.c"))) + +(defun checkdoc-test-error-format-is-good (msg &optional reverse literal) + (with-temp-buffer + (erase-buffer) + (emacs-lisp-mode) + (let ((standard-output (current-buffer))) + (if literal + (print (format "(error \"%s\")" msg)) + (prin1 `(error ,msg)))) + (goto-char (length "(error \"")) + (if reverse + (should (checkdoc--error-bad-format-p)) + (should-not (checkdoc--error-bad-format-p))))) + +(defun checkdoc-test-error-format-is-bad (msg &optional literal) + (checkdoc-test-error-format-is-good msg t literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p () + (checkdoc-test-error-format-is-good "Foo") + (checkdoc-test-error-format-is-good "Foo: bar baz") + (checkdoc-test-error-format-is-good "some-symbol: Foo") + (checkdoc-test-error-format-is-good "`some-symbol' foo bar") + (checkdoc-test-error-format-is-good "%sfoo") + (checkdoc-test-error-format-is-good "avl-tree-enter:\\ + Updated data does not match existing data" nil 'literal)) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/defined-symbols () + (defvar checkdoc-tests--var-symbol nil) + (checkdoc-test-error-format-is-good "checkdoc-tests--var-symbol foo bar baz") + (defun checkdoc-tests--fun-symbol ()) + (checkdoc-test-error-format-is-good "checkdoc-tests--fun-symbol foo bar baz")) + +(ert-deftest checkdoc-tests-error-message-bad-format-p/not-capitalized () + (checkdoc-test-error-format-is-bad "foo") + (checkdoc-test-error-format-is-bad "some-symbol: foo") + (checkdoc-test-error-format-is-bad "avl-tree-enter:\ + updated data does not match existing data")) + +(ert-deftest checkdoc-tests-fix-y-or-n-p () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo")) ; "foo" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/no-change () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo?")) ; "foo?" + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo?\")"))))) + +(ert-deftest checkdoc-tests-fix-y-or-n-p/with-space () + (with-temp-buffer + (emacs-lisp-mode) + (let ((standard-output (current-buffer)) + (checkdoc-autofix-flag 'automatic)) + (prin1 '(y-or-n-p "foo? ")) ; "foo? " + (goto-char (length "(y-or-n-p ")) + (checkdoc--fix-y-or-n-p) + (should (equal (buffer-string) "(y-or-n-p \"foo? \")"))))) + ;;; checkdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 9312fb44a1e..dd7511e9afe 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -56,7 +56,14 @@ (should (equal (cl--generic-1 'a nil) '(a))) (should (equal (cl--generic-1 4 nil) '("quatre" 4))) (should (equal (cl--generic-1 5 nil) '("cinq" 5))) - (should (equal (cl--generic-1 6 nil) '("six" a)))) + (should (equal (cl--generic-1 6 nil) '("six" a))) + (defvar cl--generic-fooval 41) + (cl-defmethod cl--generic-1 ((_x (eql (+ cl--generic-fooval 1))) _y) + "forty-two") + (cl-defmethod cl--generic-1 (_x (_y (eql 42))) + "FORTY-TWO") + (should (equal (cl--generic-1 42 nil) "forty-two")) + (should (equal (cl--generic-1 nil 42) "FORTY-TWO"))) (cl-defstruct cl-generic-struct-parent a b) (cl-defstruct (cl-generic-struct-child1 (:include cl-generic-struct-parent)) c) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index a5ec62b9c42..a132d736383 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -417,22 +417,6 @@ (should-error (cl-nth-value -1 (cl-values 2 3)) :type 'args-out-of-range) (should (string= (cl-nth-value 0 "only lists") "only lists"))) -(ert-deftest cl-test-caaar () - (should (null (cl-caaar '()))) - (should (null (cl-caaar '(() (2))))) - (should (null (cl-caaar '((() (2)) (a b))))) - (should-error (cl-caaar '(1 2)) :type 'wrong-type-argument) - (should-error (cl-caaar '((1 2))) :type 'wrong-type-argument) - (should (= 1 (cl-caaar '(((1 2) (3 4)))))) - (should (null (cl-caaar '((() (3 4))))))) - -(ert-deftest cl-test-caadr () - (should (null (cl-caadr '()))) - (should (null (cl-caadr '(1)))) - (should-error (cl-caadr '(1 2)) :type 'wrong-type-argument) - (should (= 2 (cl-caadr '(1 (2 3))))) - (should (equal '((2) (3)) (cl-caadr '((1) (((2) (3))) (4)))))) - (ert-deftest cl-test-ldiff () (let ((l '(1 2 3))) (should (null (cl-ldiff '() '()))) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f4e2e46a019..033764a7f98 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -637,17 +637,26 @@ collection clause." (/ 1 (logand n 1)) (arith-error (len3 (cdr xs) (1+ n))) (:success (len3 (cdr xs) (+ n k)))) - n))) + n)) + + ;; Tail calls in `cond'. + (len4 (xs n) + (cond (xs (cond (nil 'nevertrue) + ((len4 (cdr xs) (1+ n))))) + (t n)))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) + (should (equal (len4 nil 0) 0)) (should (equal (len list-42 0) 42)) (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) + (should (equal (len4 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) - (should (equal (len3 list-42k 0) 42000)))) + (should (equal (len3 list-42k 0) 42000)) + (should (equal (len4 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 2f45050e2eb..9285b2c945c 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -107,27 +107,27 @@ back to the top level.") "Set up the environment for an Edebug test BODY, run it, and clean up." (declare (debug (body))) `(edebug-tests-with-default-config - (let ((edebug-tests-failure-in-post-command nil) - (edebug-tests-temp-file (make-temp-file "edebug-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (edebug-tests-setup-code-file edebug-tests-temp-file) - (ert-with-message-capture - edebug-tests-messages - (unwind-protect - (with-current-buffer (find-file edebug-tests-temp-file) - (read-only-mode) - (setq lexical-binding t) - (eval-buffer) - ,@body - (when edebug-tests-failure-in-post-command - (signal (car edebug-tests-failure-in-post-command) - (cdr edebug-tests-failure-in-post-command)))) - (unload-feature 'edebug-test-code) - (with-current-buffer (find-file-noselect edebug-tests-temp-file) - (set-buffer-modified-p nil)) - (ignore-errors (kill-buffer (find-file-noselect - edebug-tests-temp-file))) - (ignore-errors (delete-file edebug-tests-temp-file))))))) + (ert-with-temp-file edebug-tests-temp-file + :suffix ".el" + (let ((edebug-tests-failure-in-post-command nil) + (find-file-suppress-same-file-warnings t)) + (edebug-tests-setup-code-file edebug-tests-temp-file) + (ert-with-message-capture + edebug-tests-messages + (unwind-protect + (with-current-buffer (find-file edebug-tests-temp-file) + (read-only-mode) + (setq lexical-binding t) + (eval-buffer) + ,@body + (when edebug-tests-failure-in-post-command + (signal (car edebug-tests-failure-in-post-command) + (cdr edebug-tests-failure-in-post-command)))) + (unload-feature 'edebug-test-code) + (with-current-buffer (find-file-noselect edebug-tests-temp-file) + (set-buffer-modified-p nil)) + (ignore-errors (kill-buffer (find-file-noselect + edebug-tests-temp-file))))))))) ;; The following macro and its support functions implement an extension ;; to keyboard macros to allow interleaving of keyboard macro @@ -723,7 +723,7 @@ test and possibly others should be updated." (edebug-on-error nil) error-message (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@" (edebug-tests-should-be-at "format-node" "start") "SPC" (edebug-tests-should-be-at "format-node" "vectorp") @@ -744,7 +744,7 @@ test and possibly others should be updated." (edebug-on-error nil) (error-message "") (command-error-function (lambda (&rest args) - (setq error-message (cl-cadar args))))) + (setq error-message (cadar args))))) (edebug-tests-run-kbd-macro "@ SPC SPC SPC SPC SPC" (edebug-tests-should-be-at "try-flavors" "macro") diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index 9f9bb73133c..d1da066dc45 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -22,22 +22,22 @@ ;;; Commentary: ;; -;; Test method invocation order. From the common lisp reference -;; manual: +;; Test method invocation order. From the Common Lisp Reference +;; Manual: ;; ;; QUOTE: ;; - All the :before methods are called, in most-specific-first ;; order. Their values are ignored. An error is signaled if ;; call-next-method is used in a :before method. ;; -;; - The most specific primary method is called. Inside the body of a +;; - The most specific primary method is called. Inside the body of a ;; primary method, call-next-method may be used to call the next -;; most specific primary method. When that method returns, the +;; most specific primary method. When that method returns, the ;; previous primary method can execute more code, perhaps based on -;; the returned value or values. The generic function no-next-method +;; the returned value or values. The generic function no-next-method ;; is invoked if call-next-method is used and there are no more -;; applicable primary methods. The function next-method-p may be -;; used to determine whether a next method exists. If +;; applicable primary methods. The function next-method-p may be +;; used to determine whether a next method exists. If ;; call-next-method is not used, only the most specific primary ;; method is called. ;; @@ -46,12 +46,14 @@ ;; call-next-method is used in a :after method. ;; ;; -;; Also test behavior of `call-next-method'. From clos.org: +;; Also test behavior of `call-next-method'. From clos.org: ;; ;; QUOTE: ;; When call-next-method is called with no arguments, it passes the ;; current method's original arguments to the next method. +;;; Code: + (require 'eieio) (require 'ert) @@ -403,3 +405,5 @@ (should (equal (eieio-test--1 (make-instance 'CNM-2) 5) '("CNM-1-1" "CNM-1-2" "CNM-0" 7 5))) (should (equal (eieio-test--1 'CNM-2 6) '("subclass CNM-1-2" CNM-2 6)))) + +;;; eieio-test-methodinvoke.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index ddbef02c35a..fd044ff3734 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -165,9 +165,9 @@ Assume SLOTVALUE is a symbol of some sort." ((slot1 :initarg :slot1 :initform 1) (slot2 :initform 2)) - "Class for testing persistent saving of an object that isn't -persistent. This class is instead used as a slot value in a -persistent class.") + "Class for testing persistent saving of an object that isn't persistent. +This class is instead used as a slot value in a persistent +class.") (defclass persistent-with-objs-slot (eieio-persistent) ((pnp :initarg :pnp diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 3ec42343443..ba2e5f7be4a 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -48,13 +48,13 @@ :type (or null class-a) :documentation "Test self referencing types.") ) - "Class A") + "Class A.") (defclass class-b () ((land :initform "Sc" :type string :documentation "Detail about land.")) - "Class B") + "Class B.") (defclass class-ab (class-a class-b) ((amphibian :initform "frog" @@ -160,7 +160,7 @@ ;; error (should-error (abstract-class))) -(defgeneric generic1 () "First generic function") +(defgeneric generic1 () "First generic function.") (ert-deftest eieio-test-03-generics () (defun anormalfunction () "A plain function for error testing." nil) @@ -901,12 +901,12 @@ Subclasses to override slot attributes.") (defclass opt-test1 () () - "Abstract base class" + "Abstract base class." :abstract t) (defclass opt-test2 (opt-test1) () - "Instantiable child") + "Instantiable child.") (ert-deftest eieio-test-36-build-class-alist () (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) @@ -969,6 +969,18 @@ Subclasses to override slot attributes.") (should (eieio-instance-inheritor-slot-boundp C :b)) (should-not (eieio-instance-inheritor-slot-boundp C :c)))) +;;;; Interaction with defstruct + +(cl-defstruct eieio-test--struct a b c) + +(ert-deftest eieio-test-defstruct-slot-value () + (let ((x (make-eieio-test--struct :a 'A :b 'B :c 'C))) + (should (eq (eieio-test--struct-a x) + (slot-value x 'a))) + (should (eq (eieio-test--struct-b x) + (slot-value x 'b))) + (should (eq (eieio-test--struct-c x) + (slot-value x 'c))))) (provide 'eieio-tests) diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 5c9696105e9..79576d24032 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -695,49 +695,40 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert--abbreviate-string "bar" 0 t) ""))) (ert-deftest ert-test-explain-equal-string-properties () - (should - (equal (ert--explain-equal-including-properties #("foo" 0 1 (a b)) - "foo") - '(char 0 "f" - (different-properties-for-key a (different-atoms b nil)) - context-before "" - context-after "oo"))) - (should (equal (ert--explain-equal-including-properties + (should-not (ert--explain-equal-including-properties-rec "foo" "foo")) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b)) + (propertize "foo" 'a 'b))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c d)) + (propertize "foo" 'a 'b 'c 'd))) + (should-not (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a (t))) + (propertize "foo" 'a (list t)))) + + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 3 (a b c e)) + (propertize "foo" 'a 'b 'c 'd)) + '(char 0 "f" (different-properties-for-key c (different-atoms e d)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b)) + "foo") + '(char 0 "f" + (different-properties-for-key a (different-atoms b nil)) + context-before "" + context-after "oo"))) + (should (equal (ert--explain-equal-including-properties-rec #("foo" 1 3 (a b)) #("goo" 0 1 (c d))) '(array-elt 0 (different-atoms (?f "#x66" "?f") (?g "#x67" "?g"))))) - (should - (equal (ert--explain-equal-including-properties - #("foo" 0 1 (a b c d) 1 3 (a b)) - #("foo" 0 1 (c d a b) 1 2 (a foo))) - '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) - context-before "f" context-after "o")))) - -(ert-deftest ert-test-equal-including-properties () - (should (equal-including-properties "foo" "foo")) - (should (ert-equal-including-properties "foo" "foo")) - - (should (equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - (should (ert-equal-including-properties #("foo" 0 3 (a b)) - (propertize "foo" 'a 'b))) - - (should (equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - (should (ert-equal-including-properties #("foo" 0 3 (a b c d)) - (propertize "foo" 'a 'b 'c 'd))) - - (should-not (equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - (should-not (ert-equal-including-properties #("foo" 0 3 (a b c e)) - (propertize "foo" 'a 'b 'c 'd))) - - ;; This is bug 6581. - (should-not (equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t)))) - (should (ert-equal-including-properties #("foo" 0 3 (a (t))) - (propertize "foo" 'a (list t))))) + (should (equal (ert--explain-equal-including-properties-rec + #("foo" 0 1 (a b c d) 1 3 (a b)) + #("foo" 0 1 (c d a b) 1 2 (a foo))) + '(char 1 "o" (different-properties-for-key a (different-atoms b foo)) + context-before "f" context-after "o")))) (ert-deftest ert-test-stats-set-test-and-result () (let* ((test-1 (make-ert-test :name 'test-1 @@ -816,6 +807,10 @@ This macro is used to test if macroexpansion in `should' works." (should (equal (ert-test-failed-condition result) '(ert-test-failed "Boo"))))) +(ert-deftest ert-test-deftest-lexical-binding-t () + "Check that `lexical-binding' in `ert-deftest' has the file value." + (should (equal lexical-binding t))) + (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index 9f40a18d343..9baa9941586 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -90,10 +90,10 @@ "foo baz"))) (ert-deftest ert-propertized-string () - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "a" '(a b) "b" '(c t) "cd") #("abcd" 1 2 (a b) 2 4 (c t)))) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-propertized-string "foo " '(face italic) "bar" " baz" nil " quux") #("foo bar baz quux" 4 11 (face italic))))) @@ -166,7 +166,7 @@ "1 skipped")))) (with-current-buffer buffer-name (font-lock-mode 0) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -175,7 +175,7 @@ ;; pretend we are. (let ((noninteractive nil)) (font-lock-mode 1)) - (should (ert-equal-including-properties + (should (equal-including-properties (ert-filter-string (buffer-string) '("Started at:\\(.*\\)$" 1) '("Finished at:\\(.*\\)$" 1)) @@ -271,6 +271,62 @@ desired effect." (cl-loop for x in '(0 1 2 3 4 t) do (should (equal (c x) (lisp x)))))) +(ert-deftest ert-x-tests--with-temp-file-generate-suffix () + (should (equal (ert--with-temp-file-generate-suffix "foo.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-test.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-tests.el") "-foo")) + (should (equal (ert--with-temp-file-generate-suffix "foo-bar-baz.el") + "-foo-bar-baz")) + (should (equal (ert--with-temp-file-generate-suffix "/foo/bar/baz.el") + "-baz"))) + +(ert-deftest ert-x-tests-with-temp-file () + (let (saved) + (ert-with-temp-file fil + (setq saved fil) + (should (file-exists-p fil)) + (should (file-regular-p fil))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/handle-error () + (let (saved) + (ignore-errors + (ert-with-temp-file fil + (setq saved fil) + (error "foo"))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-file/prefix-and-suffix-kwarg () + (ert-with-temp-file fil + :prefix "foo" + :suffix "bar" + (should (string-match "foo.*bar" fil)))) + +(ert-deftest ert-x-tests-with-temp-file/text-kwarg () + (ert-with-temp-file fil + :text "foobar3" + (let ((buf (find-file-noselect fil))) + (unwind-protect + (with-current-buffer buf + (should (equal (buffer-string) "foobar3"))) + (kill-buffer buf))))) + +(ert-deftest ert-x-tests-with-temp-file/unknown-kwarg-signals-error () + (should-error + (ert-with-temp-file fil :foo "foo" nil))) + +(ert-deftest ert-x-tests-with-temp-directory () + (let (saved) + (ert-with-temp-directory dir + (setq saved dir) + (should (file-exists-p dir)) + (should (file-directory-p dir)) + (should (equal dir (file-name-as-directory dir)))) + (should-not (file-exists-p saved)))) + +(ert-deftest ert-x-tests-with-temp-directory/text-signals-error () + (should-error + (ert-with-temp-directory dir :text "foo" nil))) (provide 'ert-x-tests) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el index 3303e7b178d..9fe5fe9218d 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -22,7 +22,7 @@ ;;; Commentary: -;; Support file for `faceup-test-basics.el'. This file is used to test +;; Support file for `faceup-test-basics.el'. This file is used to test ;; `faceup-this-file-directory' in various contexts. ;;; Code: diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el index 28a9a7ecda3..987e4047d35 100644 --- a/test/lisp/emacs-lisp/find-func-tests.el +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -26,7 +26,7 @@ ;;; Code: -(require 'ert-x) ;For `ert-run-keys'. +(require 'ert-x) ;For `ert-simulate-keys'. (require 'find-func) (ert-deftest find-func-tests--library-completion () ;bug#43393 diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index a1b9f64fdb1..c81d3d09e7d 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -271,7 +271,7 @@ identical output." (unwind-protect (progn (iter-yield 1) - (error "test") + (error "Test") (iter-yield 2)) (cl-incf nr-unwound)))))) (should (equal (iter-next iter) 1)) diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index b9850eca8b9..6ee274ae10f 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -21,22 +21,21 @@ (require 'edebug) (require 'ert) +(require 'ert-x) (eval-when-compile (require 'cl-lib)) (cl-defmacro gv-tests--in-temp-dir ((elvar elcvar) (&rest filebody) &rest body) (declare (indent 2)) - `(let ((default-directory (make-temp-file "gv-test" t))) - (unwind-protect - (let ((,elvar "gv-test-deffoo.el") - (,elcvar "gv-test-deffoo.elc")) - (with-temp-file ,elvar - (insert ";; -*- lexical-binding: t; -*-\n") - (dolist (form ',filebody) - (pp form (current-buffer)))) - ,@body) - (delete-directory default-directory t)))) + `(ert-with-temp-directory default-directory + (let ((,elvar "gv-test-deffoo.el") + (,elcvar "gv-test-deffoo.elc")) + (with-temp-file ,elvar + (insert ";; -*- lexical-binding: t; -*-\n") + (dolist (form ',filebody) + (pp form (current-buffer)))) + ,@body))) (ert-deftest gv-define-expander-in-file () (gv-tests--in-temp-dir (el elc) diff --git a/test/lisp/emacs-lisp/let-alist-tests.el b/test/lisp/emacs-lisp/let-alist-tests.el index d856696da24..88e689c80b8 100644 --- a/test/lisp/emacs-lisp/let-alist-tests.el +++ b/test/lisp/emacs-lisp/let-alist-tests.el @@ -100,4 +100,4 @@ See Bug#24641." `[,(+ .a) ,(+ .a .b .b)]) [1 5]))) -;;; let-alist.el ends here +;;; let-alist-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mnt-tests.el b/test/lisp/emacs-lisp/lisp-mnt-tests.el new file mode 100644 index 00000000000..d77804fbe60 --- /dev/null +++ b/test/lisp/emacs-lisp/lisp-mnt-tests.el @@ -0,0 +1,44 @@ +;;; lisp-mnt-tests.el --- Tests for lisp-mnt -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 2020-2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'lisp-mnt) + +(ert-deftest lm--tests-crack-address () + (should (equal (lm-crack-address + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("Bob Weiner" . "rsw@gnu.org") + ("Mats Lidell" . "matsl@gnu.org"))))) + +(ert-deftest lm--tests-lm-website () + (with-temp-buffer + (insert ";; URL: https://example.org/foo") + (should (string= (lm-website) "https://example.org/foo"))) + (with-temp-buffer + (insert ";; X-URL: <https://example.org/foo>") + (should (string= (lm-website) "https://example.org/foo")))) + +(provide 'lisp-mnt-tests) +;;; lisp-mnt-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index a04c6bef02a..afade8e295b 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -85,11 +85,13 @@ Evaluate BODY for each created map." (should (= 5 (map-elt map 0 5))))) (ert-deftest test-map-elt-testfn () - (let ((map (list (cons "a" 1) (cons "b" 2))) - ;; Make sure to use a non-eq "a", even when compiled. - (noneq-key (string ?a))) - (should-not (map-elt map noneq-key)) - (should (map-elt map noneq-key nil #'equal)))) + (let* ((a (string ?a)) + (map `((,a . 0) (,(string ?b) . 1)))) + (should (= (map-elt map a) 0)) + (should (= (map-elt map "a") 0)) + (should (= (map-elt map (string ?a)) 0)) + (should (= (map-elt map "b") 1)) + (should (= (map-elt map (string ?b)) 1)))) (ert-deftest test-map-elt-with-nil-value () (should-not (map-elt '((a . 1) (b)) 'b 2))) @@ -129,6 +131,19 @@ Evaluate BODY for each created map." (setf (map-elt map size) 'v) (should (eq (map-elt map size) 'v)))))) +(ert-deftest test-map-put!-alist () + "Test `map-put!' test function on alists." + (let ((key (string ?a)) + (val 0) + map) + (should-error (map-put! map key val) :type 'map-not-inplace) + (setq map (list (cons key val))) + (map-put! map key (1- val)) + (should (equal map '(("a" . -1)))) + (map-put! map (string ?a) (1+ val)) + (should (equal map '(("a" . 1)))) + (should-error (map-put! map (string ?a) val #'eq) :type 'map-not-inplace))) + (ert-deftest test-map-put-alist-new-key () "Regression test for Bug#23105." (let ((alist (list (cons 0 'a)))) @@ -197,6 +212,15 @@ Evaluate BODY for each created map." (with-empty-maps-do map (should (eq map (map-delete map t))))) +(ert-deftest test-map-delete-alist () + "Test `map-delete' test function on alists." + (let* ((a (string ?a)) + (map `((,a) (,(string ?b))))) + (setq map (map-delete map a)) + (should (equal map '(("b")))) + (setq map (map-delete map (string ?b))) + (should-not map))) + (ert-deftest test-map-nested-elt () (let ((vec [a b [c d [e f]]])) (should (eq (map-nested-elt vec '(2 2 0)) 'e))) @@ -446,16 +470,24 @@ Evaluate BODY for each created map." (ert-deftest test-map-merge () "Test `map-merge'." - (should (equal (map-merge 'list '(a 1) '((b . 2) (c . 3)) - #s(hash-table data (c 4))) - '((c . 4) (b . 2) (a . 1))))) + (should (equal (sort (map-merge 'list '(a 1) '((b . 2) (c . 3)) + #s(hash-table data (c 4))) + (lambda (x y) (string< (car x) (car y)))) + '((a . 1) (b . 2) (c . 4)))) + (should (equal (map-merge 'list () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'alist () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge 'plist () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-with () - (should (equal (map-merge-with 'list #'+ - '((1 . 2)) - '((1 . 3) (2 . 4)) - '((1 . 1) (2 . 5) (3 . 0))) - '((3 . 0) (2 . 9) (1 . 6))))) + (should (equal (sort (map-merge-with 'list #'+ + '((1 . 2)) + '((1 . 3) (2 . 4)) + '((1 . 1) (2 . 5) (3 . 0))) + #'car-less-than-car) + '((1 . 6) (2 . 9) (3 . 0)))) + (should (equal (map-merge-with 'list #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'alist #'+ () '(:a 1)) '((:a . 1)))) + (should (equal (map-merge-with 'plist #'+ () '(:a 1)) '(:a 1)))) (ert-deftest test-map-merge-empty () "Test merging of empty maps." @@ -513,5 +545,14 @@ Evaluate BODY for each created map." 'value2)) (should (equal (map-elt ht 'key) 'value2)))) +(ert-deftest test-setf-map-with-function () + (let ((num 0) + (map nil)) + (setf (map-elt map 'foo) + (funcall (lambda () + (cl-incf num)))) + ;; Check that the function is only called once. + (should (= num 1)))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/memory-report-tests.el b/test/lisp/emacs-lisp/memory-report-tests.el index da5f4f5700f..d37f09b34f2 100644 --- a/test/lisp/emacs-lisp/memory-report-tests.el +++ b/test/lisp/emacs-lisp/memory-report-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'memory-report) @@ -45,6 +47,7 @@ (should (equal (memory-report-object-size (list 'foo)) 16)) + (should (equal (memory-report-object-size (vector 1 2 3)) 64)) (should (equal (memory-report-object-size (vector 1 2 3 4)) 80)) (should (equal (memory-report-object-size "") 32)) @@ -52,6 +55,29 @@ (should (equal (memory-report-object-size (propertize "a" 'face 'foo)) 81))) +(ert-deftest memory-report-sizes-vectors () + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + ["long string that should be at least 40 bytes"]) + 108)) + (let ((string "long string that should be at least 40 bytes")) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string)) + 108)) + (should (= (memory-report--object-size + (make-hash-table :test #'eq) + (vector string string)) + 124)))) + +(ert-deftest memory-report-sizes-structs () + (cl-defstruct memory-report-test-struct + (item0 nil) + (item1 nil)) + (let ((s (make-memory-report-test-struct :item0 "hello" :item1 "world"))) + (should (= (memory-report-object-size s) + 90)))) + (provide 'memory-report-tests) ;;; memory-report-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index 358d9025ad5..ee33bb0fa40 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -208,4 +208,4 @@ function being an around advice." ;; no-byte-compile: t ;; End: -;;; advice-tests.el ends here. +;;; nadvice-tests.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub index 5e2ebc55d35..99965723baf 100644 --- a/test/lisp/emacs-lisp/package-resources/key.pub +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -1,20 +1,17 @@ -----BEGIN PGP PUBLIC KEY BLOCK----- -mI0EX48EbAEEANrsWXyZ4MRZRjVbLAh5jX/+1+31oB/aJ/q/5DkH1qUHJf0La9LC -sykUSM3H2u5VWLytX/ozrxIRYX13GR2xBxyJlUkDWB209AAVLFrjSp1yUX/Sb5SU -Kb7p421ZAeHiOxfnLRuErFZkTfzY19mUCyw4cdamw430V3mUC9uns/d9ABEBAAG0 -LUouIFJhbmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojO -BBMBCgA4FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJ -CAsCBBYCAwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3 -aDX9jORiNfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQ -rFFiH4IAZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4 -lEPWXW0AycylbdbE7024jQRfjwRsAQQApjTw9kONmSVouCi8ZIQwwYiA9tLzbSZv -CYxbJ6KH0icRhBLfdb1hL/Kn8x3k+xll9A0c/ABVkMxRcbQkY98xsFck7E2GcvnC -sY+w/NdcUUZJYMB3l2MH5ojCbOk5jSAZzxzeFcJhNAhmLqomMHg2LI6KDVey6iYU -FxyIpIQ3SlkAEQEAAYi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+P -BGwCGwwACgkQMKdkJgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKw -wS74Pq407Zv0VD9ual/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYr -YSqWxANyek8otsvppJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOU -Yn923VI= -=NRtx +mQGiBGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBurQnSm9obm55IFJv +Y2tldHMgPGpvaG5ueS5yb2NrZXRzQGdmeS5vcmc+iHgEExECADgWIQRIVz1DPzm4 +REDIXNtltQG5ACv6lwUCYVDINwIbAwULCQgHAgYVCgkICwIEFgIDAQIeAQIXgAAK +CRBltQG5ACv6l4iZAKCqldroRYH7vUzVV0Uv1NcDVcpLngCgmEoLVxGLKSwDEXNq +qjRDzDRpReg= +=/l51 -----END PGP PUBLIC KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/key.sec b/test/lisp/emacs-lisp/package-resources/key.sec index dbc80f43cb7..5bbac1226ae 100644 --- a/test/lisp/emacs-lisp/package-resources/key.sec +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -1,35 +1,17 @@ -----BEGIN PGP PRIVATE KEY BLOCK----- -lQIGBF+PBGwBBADa7Fl8meDEWUY1WywIeY1//tft9aAf2if6v+Q5B9alByX9C2vS -wrMpFEjNx9ruVVi8rV/6M68SEWF9dxkdsQcciZVJA1gdtPQAFSxa40qdclF/0m+U -lCm+6eNtWQHh4jsX5y0bhKxWZE382NfZlAssOHHWpsON9Fd5lAvbp7P3fQARAQAB -/gcDAngNw4ppSPBe/w734cz++xNEv0TDgwxGBWp2wGSwWao04Nl1U4LkjiIy+dkc -uUPwEZMvxXwMcq10PPH26ifP8Xfi/zANXUoLJ0DsG6rtE3BcSC9MPFe3EJENtcIP -a0jFLsbi72aBzolNEDCZCv93znXFPekaXw/RAeeFLJz8GR2Sx6bHbTJKklXgWPHw -C5Dw6xr/kEZktgjlhjkx280STpLGaFO4jiiGZ4Obp5ePp7kyOzDUzaimdZgJwClT -VbZDNQMTzgQrBOP8doXlo9euW4Wo1IYBIOwgeYieM3ZA9YjJAmp4lFnk/KFYt0Ak -0H9IWzDU8VERcU4B04PSXahzvB1Ii7C7bbHxPyuu6sAfMK8DRkrGjwgAlrhuWNLX -M07acT/E9Pm+mBlDcdkyKB2LfwgaVb9F3C25sfcFSvc5p+sqgZp1Zx7Qg9pOhQjw -U7Ln+96c0bUl+iQKdm3TGjOXAFUHYXbRkx2cJ4gxnMVNj0D68xBtBSm0LUouIFJh -bmRvbSBIYWNrZXIgKFRFU1QgS0VZKSA8anJoQGV4YW1wbGUub3JnPojOBBMBCgA4 -FiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwMFCwkIBwIGFQoJCAsCBBYC -AwECHgECF4AACgkQMKdkJgeTYhq9MQP7BYkCk8r5G777Ilp8kWjsEIo3aDX9jORi -NfMAGys/aLjjEajHFAlTQKfSLm/VXLDYtK28c8ACjThQagaDF46MRWqQrFFiH4IA -ZRgj2ELj+/j1ljQZjGjKR2Yx4BCDhbumz8zeMSPL6yFT5+8LOMUAtdv4lEPWXW0A -ycylbdbE702dAgYEX48EbAEEAKY08PZDjZklaLgovGSEMMGIgPbS820mbwmMWyei -h9InEYQS33W9YS/yp/Md5PsZZfQNHPwAVZDMUXG0JGPfMbBXJOxNhnL5wrGPsPzX -XFFGSWDAd5djB+aIwmzpOY0gGc8c3hXCYTQIZi6qJjB4NiyOig1XsuomFBcciKSE -N0pZABEBAAH+BwMCXeUOBwcOsxb/AY6rnHmgACNTGwIa5vgelw0qfET0ms/YzVrN -ufikyV9dEWVxJyuTKav978wanPu7VcCh0pTjL2nTm2nZWyRJN4gb3UIC0MA1xfB2 -yPLTCmsGeJhVOqi4Af/r06mk+NOQ96ivOA2CJuw1LSpcUtuYxB5t/grGyEojYjRP -s0Htvf2bfN9KbFJ26DGsfYzC8bCxm9szPFHBQjw4NboCigUSAHmkoTW01aWZU9Vq -brY4cWhdmCqHgfmsQgzP3LfaAQ6kJ/bkuKef7z57lz5XmlyjMQGWcZWp5xf2n81p -BV6unaIPyavzkKVAXizVfNiHNJgK9PoVoEOJkPLjRfMxVmFSGN/oF7lVTRWfOIwo -68rtNPhr6UzE4ArGHYv/pK3kijUp5daWmfrySWPcwoVAaR3mIIVs/1rhd9aZrwn6 -Q07Yo5u11rH9b8anZQF3BdTcrnU9pUzLYlFPnfhtyGqhikQILtPTf0iwr8hpG9b2 -Zoi2BBgBCgAgFiEEHP310DrP36xrZ1kSMKdkJgeTYhoFAl+PBGwCGwwACgkQMKdk -JgeTYhrtywQAhoCR/skBSQWWBI10N0qhtdlNxbpvK8ErSPKwwS74Pq407Zv0VD9u -al/HC3Uet2z8LeG9ZwU4Jd23g96fmJt7AM9CQWrOhC242JYrYSqWxANyek8otsvp -pJNHtt2Stmknv7XbJFFB1JDC8WKo8lVo9/MkmzROxuEFEvOUYn923VI= -=2DW8 +lQG7BGFQyDcRBACmAI6cfY3fM02vb9JtC1BS19boKXbBsDoVrD9qRf8tDFROOpO3 +ZMlbuz+O9Vnljo6Y4WZGnyeWWAMqCditMOfr1cLbux77wSrmAVgZ9exwtGzkmUhM +xcptzKuyod8NuhghXbJgVbfJZ6HlBkk4kiWv98iJQwUBZJfjBUfIv+acjwCg4M2i +Ifu2A3UYl9VqF7qfcDOZudEEAI7V35yfsBDnr9ndKqdGYNw0alX9BEG3KwnAe0fF +O1jDVW12Y/bwnyyrRTrz6o1G8dj7M4XVZQb5PpT9mpNzOSZ6yxqhg+foeJwn2JkD +vyP+kMYU7SZ/tWuMOCdzN95Ki1rf+ti7pLnSMqKx+t3vOWwQbtnsbI6RCLLwETPA +esghA/0X3Dw7cdiE5Xq4TRaPSGViCWP4ekL2KYKqmKv6M/4f2pgFNJY7C+2SIiiP +T62zFlIjs5tF2Df34/M5mh4Vx6E8341r55+XO++kfFWJ5QjLiydRAY6ochG9IFgB +xyBCkCNpiby9PpKyPodedBScdMxIAe4eJR7rG/j9gFC1MypBugAAn0mvGeJi+oSo +5jXAeXBhRiTyI5WPCuK0J0pvaG5ueSBSb2NrZXRzIDxqb2hubnkucm9ja2V0c0Bn +Znkub3JnPoh4BBMRAgA4FiEESFc9Qz85uERAyFzbZbUBuQAr+pcFAmFQyDcCGwMF +CwkIBwIGFQoJCAsCBBYCAwECHgECF4AACgkQZbUBuQAr+peImQCgqpXa6EWB+71M +1VdFL9TXA1XKS54AoJhKC1cRiyksAxFzaqo0Q8w0aUXo +=cyQm -----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el new file mode 100644 index 00000000000..724f88ec9ea --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin-aux.el @@ -0,0 +1,12 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defun macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el new file mode 100644 index 00000000000..828968a0576 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-1.0/macro-builtin.el @@ -0,0 +1,21 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 1.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defun macro-builtin-func () + "" + (macro-builtin-1 'a 'b) + (macro-builtin-aux-1 'a 'b)) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el new file mode 100644 index 00000000000..9f257d9d22c --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin-aux.el @@ -0,0 +1,16 @@ +;;; macro-builtin-aux.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> + +;;; Code: + +(defmacro macro-builtin-aux-1 ( &rest forms) + "Description" + `(progn ,@forms)) + +(defmacro macro-builtin-aux-3 ( &rest _) + "Description" + 90) + +(provide 'macro-builtin-aux) +;;; macro-builtin-aux.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el new file mode 100644 index 00000000000..5d241c082d0 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/macro-builtin-package-2.0/macro-builtin.el @@ -0,0 +1,30 @@ +;;; macro-builtin.el --- laksd -*- lexical-binding: t; -*- + +;; Author: Artur Malabarba <emacs@endlessparentheses.com> +;; Keywords: tools +;; Version: 2.0 + +;;; Code: + +(require 'macro-builtin-aux) + +(defmacro macro-builtin-1 ( &rest forms) + "Description" + `(progn ,(cadr (car forms)))) + + +(defun macro-builtin-func () + "" + (list (macro-builtin-1 '1 'b) + (macro-builtin-aux-1 'a 'b))) + +(defmacro macro-builtin-3 (&rest _) + "Description" + 10) + +(defun macro-builtin-10-and-90 () + "" + (list (macro-builtin-3 haha) (macro-builtin-aux-3 hehe))) + +(provide 'macro-builtin) +;;; macro-builtin.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el index f43232224af..ad20a3507a6 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-aux.el @@ -5,7 +5,7 @@ ;;; Code: (defun macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el index 0533b1bd9c4..6e5e54e54fd 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-1.0/macro-problem.el @@ -9,11 +9,11 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defun macro-problem-func () - "" + "Description." (macro-problem-1 'a 'b) (macro-aux-1 'a 'b)) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el index 6a55a40e3b4..814d77183ab 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-aux.el @@ -5,11 +5,11 @@ ;;; Code: (defmacro macro-aux-1 ( &rest forms) - "Description" + "Description." `(progn ,@forms)) (defmacro macro-aux-3 ( &rest _) - "Description" + "Description." 90) (provide 'macro-aux) diff --git a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el index cad4ed93f19..aef5eda7c6c 100644 --- a/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el +++ b/test/lisp/emacs-lisp/package-resources/macro-problem-package-2.0/macro-problem.el @@ -9,21 +9,21 @@ (require 'macro-aux) (defmacro macro-problem-1 ( &rest forms) - "Description" + "Description." `(progn ,(cadr (car forms)))) (defun macro-problem-func () - "" + "Description." (list (macro-problem-1 '1 'b) (macro-aux-1 'a 'b))) (defmacro macro-problem-3 (&rest _) - "Description" + "Description." 10) (defun macro-problem-10-and-90 () - "" + "Description." (list (macro-problem-3 haha) (macro-aux-3 hehe))) (provide 'macro-problem) diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el index 301993deb30..be6bedf8a1c 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -7,14 +7,14 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;; ;; This is a new, updated version. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday nil @@ -29,7 +29,7 @@ Default changed to nil." ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig Binary files differindex dac168b0e4c..b40620a0e89 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/archive-contents.sig diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el index ff070c6526f..781077251e9 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-bad-1.0.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-bad nil "Simply a file" +(defgroup signed-bad nil "Simply a file." :group 'lisp) (defcustom signed-bad-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-bad-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-bad) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el index 60b1b8663d9..8a408c1f301 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup signed-good nil "Simply a file" +(defgroup signed-good nil "Simply a file." :group 'lisp) (defcustom signed-good-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode signed-good-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'signed-good) diff --git a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig Binary files differindex 5b1c721e32a..11092411601 100644 --- a/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig +++ b/test/lisp/emacs-lisp/package-resources/signed/signed-good-1.0.el.sig diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el index cb003905bb5..f1ee8627610 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el index 9c3f427ff48..459801d78cf 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -8,12 +8,12 @@ ;;; Commentary: ;; This package provides a minor mode to frobnicate and/or bifurcate -;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" +;; any flanges you desire. To activate it, type "C-M-r M-3 butterfly" ;; and all your dreams will come true. ;;; Code: -(defgroup simple-single nil "Simply a file" +(defgroup simple-single nil "Simply a file." :group 'lisp) (defcustom simple-single-super-sunday t @@ -26,7 +26,7 @@ ;;;###autoload (define-minor-mode simple-single-mode - "It does good things to stuff") + "It does good things to stuff.") (provide 'simple-single) diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el index a0a9607350a..8de6141d67a 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -12,6 +12,6 @@ ;;; Code: (defvar simple-two-depend "Value" - "Some trivial code") + "Some trivial code.") ;;; simple-two-depend.el ends here diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 29435799555..3b12f57e5ce 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -115,57 +115,55 @@ &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (([&rest form]) body))) - `(let* ((package-test-user-dir (make-temp-file "pkg-test-user-dir-" t)) - (process-environment (cons (format "HOME=%s" package-test-user-dir) - process-environment)) - (package-user-dir package-test-user-dir) - (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) - (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) - (default-directory package-test-file-dir) - abbreviated-home-dir - package--initialized - package-alist - ,@(if update-news - '(package-update-news-on-upload t) - (list (cl-gensym))) - ,@(if upload-base - '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) - (package-archive-upload-base package-test-archive-upload-base)) - (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil - (let ((buf (get-buffer "*Packages*"))) - (when (buffer-live-p buf) - (kill-buffer buf))) - (unwind-protect - (progn - ,(if basedir `(cd ,basedir)) - (unless (file-directory-p package-user-dir) - (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - ,@(when install - `((package-initialize) - (package-refresh-contents) - (mapc 'package-install ,install))) - (with-temp-buffer - ,(if file - `(insert-file-contents ,file)) - ,@body))) - - (when ,upload-base - (dolist (f '("archive-contents" - "simple-single-1.3.el" - "simple-single-1.4.el" - "simple-single-readme.txt")) - (ignore-errors - (delete-file - (expand-file-name f package-test-archive-upload-base)))) - (delete-directory package-test-archive-upload-base)) - (when (file-directory-p package-test-user-dir) - (delete-directory package-test-user-dir t)) - - (when (and (boundp 'package-test-archive-upload-base) - (file-directory-p package-test-archive-upload-base)) - (delete-directory package-test-archive-upload-base t))))) + `(ert-with-temp-directory package-test-user-dir + (let* ((process-environment (cons (format "HOME=%s" package-test-user-dir) + process-environment)) + (package-user-dir package-test-user-dir) + (package-gnupghome-dir (expand-file-name "gnupg" package-user-dir)) + (package-archives `(("gnu" . ,(or ,location package-test-data-dir)))) + (default-directory package-test-file-dir) + abbreviated-home-dir + package--initialized + package-alist + ,@(if update-news + '(package-update-news-on-upload t) + (list (cl-gensym))) + ,@(if upload-base + '((package-test-archive-upload-base (make-temp-file "pkg-archive-base-" t)) + (package-archive-upload-base package-test-archive-upload-base)) + (list (cl-gensym)))) ;; Dummy value so `let' doesn't try to bind nil + (let ((buf (get-buffer "*Packages*"))) + (when (buffer-live-p buf) + (kill-buffer buf))) + (unwind-protect + (progn + ,(if basedir `(cd ,basedir)) + (unless (file-directory-p package-user-dir) + (mkdir package-user-dir)) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) + ,@(when install + `((package-initialize) + (package-refresh-contents) + (mapc 'package-install ,install))) + (with-temp-buffer + ,(if file + `(insert-file-contents ,file)) + ,@body))) + + (when ,upload-base + (dolist (f '("archive-contents" + "simple-single-1.3.el" + "simple-single-1.4.el" + "simple-single-readme.txt")) + (ignore-errors + (delete-file + (expand-file-name f package-test-archive-upload-base)))) + (delete-directory package-test-archive-upload-base)) + + (when (and (boundp 'package-test-archive-upload-base) + (file-directory-p package-test-archive-upload-base)) + (delete-directory package-test-archive-upload-base t)))))) (defmacro with-fake-help-buffer (&rest body) "Execute BODY in a temp buffer which is treated as the \"*Help*\" buffer." @@ -180,7 +178,7 @@ (replace-regexp-in-string "-pkg\\.el\\'" "" (package--description-file dir))) (defun package-test-suffix-matches (base suffix-list) - "Return file names matching BASE concatenated with each item in SUFFIX-LIST" + "Return file names matching BASE concatenated with each item in SUFFIX-LIST." (mapcan (lambda (item) (file-expand-wildcards (concat base item))) suffix-list)) @@ -342,9 +340,13 @@ but with a different end of line convention (bug#48137)." (declare-function macro-problem-func "macro-problem" ()) (declare-function macro-problem-10-and-90 "macro-problem" ()) +(declare-function macro-builtin-func "macro-builtin" ()) +(declare-function macro-builtin-10-and-90 "macro-builtin" ()) (ert-deftest package-test-macro-compilation () - "Install a package which includes a dependency." + "\"Activation has to be done before compilation, so that if we're + upgrading and macros have changed we load the new definitions + before compiling.\" -- package.el" (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) @@ -357,6 +359,32 @@ but with a different end of line convention (bug#48137)." ;; `macro-problem-10-and-90' depends on an entirely new macro from `macro-aux'. (should (equal (macro-problem-10-and-90) '(10 90))))) +(ert-deftest package-test-macro-compilation-gz () + "Built-in's can be superseded as well." + (with-package-test (:basedir (ert-resource-directory)) + (let ((dir (expand-file-name "macro-builtin-package-1.0"))) + (unwind-protect + (let ((load-path load-path)) + (add-to-list 'load-path (directory-file-name dir)) + (byte-recompile-directory dir 0 t) + (mapc (lambda (f) (call-process "gzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el\\'")) + (require 'macro-builtin) + (should (member (expand-file-name "macro-builtin-aux.elc" dir) + (mapcar #'car load-history))) + ;; `macro-builtin-func' uses a macro from `macro-aux'. + (should (equal (macro-builtin-func) '(progn a b))) + (package-install-file (expand-file-name "macro-builtin-package-2.0/")) + ;; After upgrading, `macro-builtin-func' depends on a new version + ;; of the macro from `macro-builtin-aux'. + (should (equal (macro-builtin-func) '(1 b))) + ;; `macro-builtin-10-and-90' depends on an entirely new macro from `macro-aux'. + (should (equal (macro-builtin-10-and-90) '(10 90)))) + (mapc #'delete-file + (directory-files-recursively dir "\\`[^\\.].*\\.elc\\'")) + (mapc (lambda (f) (call-process "gunzip" nil nil nil f)) + (directory-files-recursively dir "\\`[^\\.].*\\.el.gz\\'")))))) + (ert-deftest package-test-install-two-dependencies () "Install a package which includes a dependency." (with-package-test () @@ -636,7 +664,7 @@ but with a different end of line convention (bug#48137)." (save-excursion (should (re-search-forward "Status: Installed in ['`‘]simple-single-1.3/['’] (unsigned)." nil t))) (save-excursion (should (search-forward "Version: 1.3" nil t))) (save-excursion (should (search-forward "Summary: A single-file package with no dependencies" nil t))) - (save-excursion (should (search-forward "Homepage: http://doodles.au" nil t))) + (save-excursion (should (search-forward "Website: http://doodles.au" nil t))) (save-excursion (should (re-search-forward "Keywords: \\[?frobnicate\\]?" nil t))) (save-excursion (should (search-forward "This package provides a minor mode to frobnicate" nil t))) @@ -652,7 +680,7 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'multi-file) (goto-char (point-min)) - (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "Website: http://puddles.li" nil t)) (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) @@ -665,7 +693,7 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'simple-single) (goto-char (point-min)) - (should (search-forward "Homepage: http://doodles.au" nil t)) + (should (search-forward "Website: http://doodles.au" nil t)) (should (search-forward "This package provides a minor mode to frobnicate" nil t))))) @@ -678,32 +706,30 @@ but with a different end of line convention (bug#48137)." (with-fake-help-buffer (describe-package 'multi-file) (goto-char (point-min)) - (should (search-forward "Homepage: http://puddles.li" nil t)) + (should (search-forward "Website: http://puddles.li" nil t)) (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) (defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." - (skip-unless (let ((homedir (make-temp-file "package-test" t))) - (unwind-protect - (let ((process-environment - (cons (concat "HOME=" homedir) - process-environment))) - (require 'epg-config) - (defvar epg-config--program-alist) - (epg-find-configuration - 'OpenPGP nil - ;; By default we require gpg2 2.1+ due to some - ;; practical problems with pinentry. But this - ;; test works fine with 2.0 as well. - (let ((prog-alist (copy-tree epg-config--program-alist))) - (setf (alist-get "gpg2" - (alist-get 'OpenPGP prog-alist) - nil nil #'equal) - "2.0") - prog-alist))) - (delete-directory homedir t)))) + (skip-unless (ert-with-temp-directory homedir + (let ((process-environment + (cons (concat "HOME=" homedir) + process-environment))) + (require 'epg-config) + (defvar epg-config--program-alist) + (epg-find-configuration + 'OpenPGP nil + ;; By default we require gpg2 2.1+ due to some + ;; practical problems with pinentry. But this + ;; test works fine with 2.0 as well. + (let ((prog-alist (copy-tree epg-config--program-alist))) + (setf (alist-get "gpg2" + (alist-get 'OpenPGP prog-alist) + nil nil #'equal) + "2.0") + prog-alist))))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 2120139ec18..7ad01e7aef7 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -100,4 +100,61 @@ (should (equal (funcall f 'b1) '(4 5 nil nil))) (should (equal (funcall f 'b2) '(nil nil 8 9))))) +(ert-deftest pcase-tests-cl-type () + (should (equal (pcase 1 + ((cl-type integer) 'integer)) + 'integer)) + (should (equal (pcase 1 + ((cl-type (integer 0 2)) 'integer-0<=n<=2)) + 'integer-0<=n<=2)) + (should-error (pcase 1 + ((cl-type notatype) 'integer)))) + +(ert-deftest pcase-tests-setq () + (should (equal (let (a b) + (pcase-setq `((,a) (,b)) '((1) (2))) + (list a b)) + (list 1 2))) + + (should (equal (list nil nil) + (let ((a 'unset) + (b 'unset)) + (pcase-setq `(head ,a ,b) nil) + (list a b)))) + + (should (equal (let (a b) + (pcase-setq `[,a ,b] [1 2]) + (list a b)) + '(1 2))) + + (should-error (let (a b) + (pcase-setq `[,a ,b] nil) + (list a b))) + + (should (equal (let (a b) + (pcase-setq a 1 b 2) + (list a b)) + '(1 2))) + + (should (= (let (a) + (pcase-setq a 1 `(,a) '(2)) + a) + 2)) + + (should (equal (let (array list-item array-copy) + (pcase-setq (or `(,list-item) array) [1 2 3] + array-copy array + ;; This re-sets `array' to nil. + (or `(,list-item) array) '(4)) + (list array array-copy list-item)) + '(nil [1 2 3] 4))) + + (let ((a nil)) + (should-error (pcase-setq a 1 b) + :type '(wrong-number-of-arguments)) + (should (eq a nil))) + + (should-error (pcase-setq a) + :type '(wrong-number-of-arguments))) + ;;; pcase-tests.el ends here. diff --git a/test/lisp/emacs-lisp/pp-resources/code-formats.erts b/test/lisp/emacs-lisp/pp-resources/code-formats.erts new file mode 100644 index 00000000000..2b2001d0964 --- /dev/null +++ b/test/lisp/emacs-lisp/pp-resources/code-formats.erts @@ -0,0 +1,124 @@ +Code: + (lambda () + (emacs-lisp-mode) + (let ((code (read (current-buffer)))) + (erase-buffer) + (pp-emacs-lisp-code code) + (untabify (point-min) (point-max)))) + +Name: code-formats1 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats2 + +=-= +(defun pp-emacs-lisp-code (sexp) + "Insert SEXP into the current buffer, formatted as Emacs Lisp code." + (require 'edebug) + (let ((start (point)) + (standard-output (current-buffer))) + (pp--insert-lisp sexp) + (insert "\n") + (goto-char start) + (indent-sexp))) +=-=-= + + +Name: code-formats3 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2)) + (zot-zot-zot-zot-zot-zot 1 2 (funcall + bar-bar-bar-bar-bar-bar-bar-bar-bar-bar + 2)))) +=-=-= + + +Name: code-formats4 + +=-= +(defun foo (bar) + "Yes." + (let ((a 1) + (b 2) + foo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo bar zotfoo + bar zot) + (zot 1 2 (funcall bar 2)))) +=-=-= + + +Name: code-formats5 + +=-= +(defgroup pp () + "Pretty printer for Emacs Lisp." + :prefix "pp-" + :group 'lisp) +=-=-= + +Name: code-formats6 + +=-= +(defcustom pp-escape-newlines t + "Value of `print-escape-newlines' used by pp-* functions." + :type 'boolean + :group 'pp) +=-=-= + +Name: code-formats7 + +=-= +(defun pp (object &optional stream) + (princ (pp-to-string object) (or stream standard-output))) +=-=-= + + +Name: code-formats8 + +=-= +(defun pp-eval-expression (expression) + "Evaluate EXPRESSION and pretty-print its value. +Also add the value to the front of the list in the variable `values'." + (interactive (list (read--expression "Eval: "))) + (message "Evaluating...") + (let ((result (eval expression lexical-binding))) + (values--store-value result) + (pp-display-expression result "*Pp Eval Output*"))) +=-=-= + +Name: code-formats9 + +=-= +(lambda () + (interactive) + 1) +=-=-= + + +Name: code-formats10 + +=-= +(funcall foo (concat "zot" (if (length> site 0) site + "bar") + "+" + (string-replace " " "+" query))) +=-=-= + + +Name: code-formats11 + +=-= +(lambda () + [(foo bar) (foo bar)]) +=-=-= diff --git a/test/lisp/emacs-lisp/pp-tests.el b/test/lisp/emacs-lisp/pp-tests.el index b04030cc432..4cae1a73775 100644 --- a/test/lisp/emacs-lisp/pp-tests.el +++ b/test/lisp/emacs-lisp/pp-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'pp) +(require 'ert-x) (ert-deftest pp-print-quote () (should (string= (pp-to-string 'quote) "quote")) @@ -32,4 +33,7 @@ (should (string= (pp-to-string '(quotefoo)) "(quotefoo)\n")) (should (string= (pp-to-string '(a b)) "(a b)\n"))) +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "code-formats.erts"))) + ;;; pp-tests.el ends here. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 940feb5e828..65494e20df6 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -66,4 +66,4 @@ (should (equal (regexp-opt-charset '()) regexp-unmatchable))) -;;; regexp-tests.el ends here. +;;; regexp-opt-tests.el ends here diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 4828df0de92..3bc35feb6dd 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'rx) @@ -583,3 +585,5 @@ "\\(?3:.+$\\)"))) (provide 'rx-tests) + +;;; rx-tests.el ends here diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 05c7fbe781e..8dc0b93b5af 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -336,6 +336,33 @@ Evaluate BODY for each created sequence. (should (same-contents-p list vector)) (should (vectorp vector)))) +(ert-deftest test-seq-union () + (let ((v1 '(1 2 3)) + (v2 '(3 5))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 5)))) + + (let ((v1 '(1 2 3 4 5 6)) + (v2 '(4 5 6 7 8 9))) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 7 8 9)))) + + (let ((v1 [1 2 3 4 5]) + (v2 [4 5 6 "a"])) + (should (same-contents-p (seq-union v1 v2) + '(1 2 3 4 5 6 "a")))) + + (let ((v1 '("a" "b" "c")) + (v2 '("f" "c" "e" "a"))) + (should (same-contents-p (seq-union v1 v2) + '("a" "b" "c" "f" "e")))) + + (let ((v1 '("a")) + (v2 '("a")) + (testfn #'eq)) + (should (same-contents-p (seq-union v1 v2 testfn) + '("a" "a"))))) + (ert-deftest test-seq-intersection () (let ((v1 [2 3 4 5]) (v2 [1 3 5 6 7])) @@ -383,6 +410,30 @@ Evaluate BODY for each created sequence. (should (null b)) (should (null c))))) +(ert-deftest test-seq-setq () + (with-test-sequences (seq '(1 2 3 4)) + (let (a b c d e) + (seq-setq (a b c d e) seq) + (should (= a 1)) + (should (= b 2)) + (should (= c 3)) + (should (= d 4)) + (should (null e))) + (let (a b others) + (seq-setq (a b &rest others) seq) + (should (= a 1)) + (should (= b 2)) + (should (same-contents-p others (seq-drop seq 2))))) + (let ((a) + (seq '(1 (2 (3 (4)))))) + (seq-setq (_ (_ (_ (a)))) seq) + (should (= a 4))) + (let (seq a b c) + (seq-setq (a b c) seq) + (should (null a)) + (should (null b)) + (should (null c)))) + (ert-deftest test-seq-min-max () (with-test-sequences (seq '(4 5 3 2 0 4)) (should (= (seq-min seq) 0)) diff --git a/test/lisp/emacs-lisp/shortdoc-tests.el b/test/lisp/emacs-lisp/shortdoc-tests.el index 3bb3185649b..cfb0b4244bc 100644 --- a/test/lisp/emacs-lisp/shortdoc-tests.el +++ b/test/lisp/emacs-lisp/shortdoc-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'shortdoc) @@ -43,3 +45,5 @@ (setq props (cddr props)))))))) (provide 'shortdoc-tests) + +;;; shortdoc-tests.el ends here diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index ef04cde3867..f9cfea888c7 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -455,18 +455,18 @@ "Test `thread-first' wraps single function names." (should (equal (macroexpand '(thread-first 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-first (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-first-expansion () "Test `thread-first' expands correctly." (should (equal (macroexpand '(thread-first - 5 + 5 (+ 20) (/ 25) - @@ -477,13 +477,13 @@ "Test several `thread-first' examples." (should (equal (thread-first (+ 40 2)) 42)) (should (equal (thread-first - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-first - "this-is-a-string" + "this-is-a-string" (split-string "-") (nbutlast 2) (append (list "good"))) @@ -500,18 +500,18 @@ "Test `thread-last' wraps single function names." (should (equal (macroexpand '(thread-last 5 - -)) + -)) '(- 5))) (should (equal (macroexpand '(thread-last (+ 1 2) - -)) + -)) '(- (+ 1 2))))) (ert-deftest subr-x-test-thread-last-expansion () "Test `thread-last' expands correctly." (should (equal (macroexpand '(thread-last - 5 + 5 (+ 20) (/ 25) - @@ -522,13 +522,13 @@ "Test several `thread-last' examples." (should (equal (thread-last (+ 40 2)) 42)) (should (equal (thread-last - 5 + 5 (+ 20) (/ 25) - (+ 40)) 39)) (should (equal (thread-last - (list 1 -2 3 -4 5) + (list 1 -2 3 -4 5) (mapcar #'abs) (cl-reduce #'+) (format "abs sum is: %s")) @@ -638,5 +638,43 @@ (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) +(ert-deftest subr-ensure-empty-lines () + (should + (equal + (with-temp-buffer + (insert "foo") + (goto-char (point-min)) + (ensure-empty-lines 2) + (buffer-string)) + "\n\nfoo")) + (should + (equal + (with-temp-buffer + (insert "foo") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n\n\n") + (ensure-empty-lines 2) + (buffer-string)) + "foo\n\n\n")) + (should + (equal + (with-temp-buffer + (insert "foo\n\n\n") + (ensure-empty-lines 0) + (buffer-string)) + "foo\n"))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/tabulated-list-test.el b/test/lisp/emacs-lisp/tabulated-list-tests.el index db1ce312586..e376d2f328d 100644 --- a/test/lisp/emacs-lisp/tabulated-list-test.el +++ b/test/lisp/emacs-lisp/tabulated-list-tests.el @@ -1,4 +1,4 @@ -;;; tabulated-list-test.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- +;;; tabulated-list-tests.el --- Tests for emacs-lisp/tabulated-list.el -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2021 Free Software Foundation, Inc. @@ -56,10 +56,10 @@ (tabulated-list--test-with-buffer ;; Basic printing. (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs - 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) ;; Preserve position. (forward-line 3) (let ((pos (thing-at-point 'line))) @@ -67,16 +67,16 @@ (tabulated-list-print t) (should (equal (thing-at-point 'line) pos)) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) ;; Check the UPDATE argument (pop tabulated-list-entries) (setf (cdr (car tabulated-list-entries)) (list ["x" "x" "944" "available" " XX"])) (tabulated-list-print t t) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " x x 944 available XX - mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) + " x x 944 available XX + mode mode 1128 installed A simple mode for editing Actionscript 3 files\n")) (should (equal (thing-at-point 'line) pos))))) (ert-deftest tabulated-list-sort () @@ -86,25 +86,26 @@ (skip-chars-forward "[:blank:]") (tabulated-list-sort) (let ((text (buffer-substring-no-properties (point-min) (point-max)))) - (should (string= text " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions - abc-mode abc-mode 944 available Major mode for editing abc music files - mode mode 1128 installed A simple mode for editing Actionscript 3 files - zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) + (should (string= text + " 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions + abc-mode abc-mode 944 available Major mode for editing abc music files + mode mode 1128 installed A simple mode for editing Actionscript 3 files + zzzz-game zzzz-game 2113 installed play zzzz in Emacs\n")) (skip-chars-forward "^[:blank:]") (skip-chars-forward "[:blank:]") (should (equal (get-text-property (point) 'tabulated-list-column-name) "name-2")) (tabulated-list-sort) - ;; Check a `t' as the sorting predicate. + ;; Check a t as the sorting predicate. (should (string= text (buffer-substring-no-properties (point-min) (point-max)))) ;; Invert. (tabulated-list-sort 1) (should (string= (buffer-substring-no-properties (point-min) (point-max)) - " zzzz-game zzzz-game 2113 installed play zzzz in Emacs - mode mode 1128 installed A simple mode for editing Actionscript 3 files - abc-mode abc-mode 944 available Major mode for editing abc music files - 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) + " zzzz-game zzzz-game 2113 installed play zzzz in Emacs + mode mode 1128 installed A simple mode for editing Actionscript 3 files + abc-mode abc-mode 944 available Major mode for editing abc music files + 4clojure 4clojure 1507 obsolete Open and evaluate 4clojure.com questions\n")) ;; Again (tabulated-list-sort 1) (should (string= text (buffer-substring-no-properties (point-min) (point-max))))) @@ -114,5 +115,4 @@ (should-error (tabulated-list-sort) :type 'user-error) (should-error (tabulated-list-sort 4) :type 'user-error))) -(provide 'tabulated-list-test) -;;; tabulated-list-test.el ends here +;;; tabulated-list-tests.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index 7ced257c6f9..29094526d7e 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -77,12 +77,12 @@ "Testcover doesn't prevent testing of defcustom values." ;; ==== (defgroup testcover-testcase nil - "Test case for testcover" + "Test case for testcover." :group 'lisp :prefix "testcover-testcase-" :version "26.0") (defcustom testcover-testcase-flag t - "Test value used by testcover-tests.el" + "Test value used by testcover-tests.el." :type 'boolean :group 'testcover-testcase) (defun testcover-testcase-get-flag () @@ -111,7 +111,7 @@ "Wrapping a form with noreturn prevents splotching." ;; ==== (defun testcover-testcase-cancel (spacecraft) - (error "no destination for %s" spacecraft)) + (error "No destination for %s" spacecraft)) (defun testcover-testcase-launch (spacecraft planet) (if (null planet) (noreturn (testcover-testcase-cancel spacecraft%%%)) @@ -220,7 +220,7 @@ (defun testcover-testcase-cc (arg) (condition-case nil (if (null arg%%%)%%% - (error "foo") + (error "Foo") "0")!!! (error nil))) (should-not (testcover-testcase-cc nil)) @@ -510,4 +510,4 @@ regarding the odd-looking coverage result for the quoted form." (testcover-testcase-cyc2 1 2) (testcover-testcase-cyc2 1 4) -;; testcases.el ends here. +;;; testcases.el ends here diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 7854e33e77d..a7e055a28b1 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -45,34 +45,34 @@ testcases.el. This can be used to create test cases if Testcover is working correctly on a code sample. OPTARGS are optional arguments for `testcover-start'." (interactive "r") - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t) - (code (buffer-substring beg end)) - (marked-up-code)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert code)) - (save-current-buffer - (let ((buf (find-file-noselect tempfile))) - (set-buffer buf) - (apply 'testcover-start (cons tempfile optargs)) - (testcover-mark-all buf) - (dolist (overlay (overlays-in (point-min) (point-max))) - (let ((ov-face (overlay-get overlay 'face))) - (goto-char (overlay-end overlay)) - (cond - ((eq ov-face 'testcover-nohits) (insert "!!!")) - ((eq ov-face 'testcover-1value) (insert "%%%")) - (t nil)))) - (setq marked-up-code (buffer-string))) - (set-buffer-modified-p nil))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile))) - - ;; Now replace the original code with the marked up code. - (delete-region beg end) - (insert marked-up-code)))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t) + (code (buffer-substring beg end)) + (marked-up-code)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert code)) + (save-current-buffer + (let ((buf (find-file-noselect tempfile))) + (set-buffer buf) + (apply 'testcover-start (cons tempfile optargs)) + (testcover-mark-all buf) + (dolist (overlay (overlays-in (point-min) (point-max))) + (let ((ov-face (overlay-get overlay 'face))) + (goto-char (overlay-end overlay)) + (cond + ((eq ov-face 'testcover-nohits) (insert "!!!")) + ((eq ov-face 'testcover-1value) (insert "%%%")) + (t nil)))) + (setq marked-up-code (buffer-string))) + (set-buffer-modified-p nil))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))) + + ;; Now replace the original code with the marked up code. + (delete-region beg end) + (insert marked-up-code))))) (eval-and-compile (defun testcover-tests-unmarkup-region (beg end) @@ -99,32 +99,32 @@ arguments for `testcover-start'." (eval-and-compile (defun testcover-tests-run-test-case (marked-up-code) "Test the operation of Testcover on the string MARKED-UP-CODE." - (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) - (find-file-suppress-same-file-warnings t)) - (unwind-protect - (progn - (with-temp-file tempfile - (insert marked-up-code)) - ;; Remove the marks and mark the code up again. The original - ;; and recreated versions should match. - (save-current-buffer - (set-buffer (find-file-noselect tempfile)) - ;; Fail the test if the debugger tries to become active, - ;; which can happen if Testcover fails to attach itself - ;; correctly. Note that this will prevent debugging - ;; these tests using Edebug. - (cl-letf (((symbol-function #'edebug-default-enter) - (lambda (&rest _args) - (ert-fail "Debugger invoked during test run")))) - (dolist (byte-compile '(t nil)) - (testcover-tests-unmarkup-region (point-min) (point-max)) - (unwind-protect - (testcover-tests-markup-region (point-min) (point-max) byte-compile) - (set-buffer-modified-p nil)) - (should (string= marked-up-code - (buffer-string))))))) - (ignore-errors (kill-buffer (find-file-noselect tempfile))) - (ignore-errors (delete-file tempfile)))))) + (ert-with-temp-file tempfile + :suffix ".el" + (let ((find-file-suppress-same-file-warnings t)) + (unwind-protect + (progn + (with-temp-file tempfile + (insert marked-up-code)) + ;; Remove the marks and mark the code up again. The original + ;; and recreated versions should match. + (save-current-buffer + (set-buffer (find-file-noselect tempfile)) + ;; Fail the test if the debugger tries to become active, + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) + (lambda (&rest _args) + (ert-fail "Debugger invoked during test run")))) + (dolist (byte-compile '(t nil)) + (testcover-tests-unmarkup-region (point-min) (point-max)) + (unwind-protect + (testcover-tests-markup-region (point-min) (point-max) byte-compile) + (set-buffer-modified-p nil)) + (should (string= marked-up-code + (buffer-string))))))) + (ignore-errors (kill-buffer (find-file-noselect tempfile)))))))) ;; Convert test case file to ert-defmethod. diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el index b2a48d80675..f0d9b032438 100644 --- a/test/lisp/emacs-lisp/unsafep-tests.el +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -105,7 +105,7 @@ . (variable (x))) ( (let (1) 2) . (variable 1)) - ( (error "asdf") + ( (error "Asdf") . #'error) ( (signal 'error "asdf") . #'signal) diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index 0d999763b61..b8efc87ab70 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -21,7 +21,8 @@ ;;; Code: - +(require 'ert) +(require 'ert-x) (require 'viper) (defun viper-test-undo-kmacro (kmacro) @@ -30,47 +31,42 @@ This function makes as many attempts as possible to clean up after itself, although it will leave a buffer called *viper-test-buffer* if it fails (this is deliberate!)." - (let ( - ;; Viper just turns itself off during batch use. - (noninteractive nil) - ;; Switch off start up message or it will chew the key presses. - (viper-inhibit-startup-message 't) - ;; Select an expert-level for the same reason. - (viper-expert-level 5) - ;; viper loads this even with -q so make sure it's empty! - (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc")) - (before-buffer (current-buffer))) - (unwind-protect - (progn - ;; viper-mode is essentially global, so set it here. - (viper-mode) - ;; We must switch to buffer because we are using a keyboard macro - ;; which appears to not go to the current-buffer but what ever is - ;; currently taking keyboard events. We use a named buffer because - ;; then we can see what it in it if it all goes wrong. - (switch-to-buffer - (get-buffer-create - "*viper-test-buffer*")) - (erase-buffer) - ;; The new buffer fails to enter vi state so set it. - (viper-change-state-to-vi) - ;; Run the macro. - (execute-kbd-macro kmacro) - (let ((rtn - (buffer-substring-no-properties - (point-min) - (point-max)))) - ;; Kill the buffer iff the macro succeeds. - (kill-buffer) - rtn)) - ;; Switch everything off and restore the buffer. - (toggle-viper-mode) - (delete-file viper-custom-file-name) - (switch-to-buffer before-buffer)))) - -(ert-deftest viper-test-go () - "Test that this file is running." - (should t)) + (ert-with-temp-file viper-custom-file-name + ;; viper loads this even with -q so make sure it's empty! + :prefix "emacs-viper-tests" :suffix ".elc" + (let (;; Viper just turns itself off during batch use. + (noninteractive nil) + ;; Switch off start up message or it will chew the key presses. + (viper-inhibit-startup-message 't) + ;; Select an expert-level for the same reason. + (viper-expert-level 5) + (before-buffer (current-buffer))) + (unwind-protect + (progn + ;; viper-mode is essentially global, so set it here. + (viper-mode) + ;; We must switch to buffer because we are using a keyboard macro + ;; which appears to not go to the current-buffer but what ever is + ;; currently taking keyboard events. We use a named buffer because + ;; then we can see what it in it if it all goes wrong. + (switch-to-buffer + (get-buffer-create + "*viper-test-buffer*")) + (erase-buffer) + ;; The new buffer fails to enter vi state so set it. + (viper-change-state-to-vi) + ;; Run the macro. + (execute-kbd-macro kmacro) + (let ((rtn + (buffer-substring-no-properties + (point-min) + (point-max)))) + ;; Kill the buffer iff the macro succeeds. + (kill-buffer) + rtn)) + ;; Switch everything off and restore the buffer. + (toggle-viper-mode) + (switch-to-buffer before-buffer))))) (ert-deftest viper-test-fix () "Test that the viper kmacro fixture is working." diff --git a/test/lisp/epg-tests.el b/test/lisp/epg-tests.el index 741574f0adf..1384221c491 100644 --- a/test/lisp/epg-tests.el +++ b/test/lisp/epg-tests.el @@ -58,48 +58,45 @@ (cl-defmacro with-epg-tests ((&optional &key require-passphrase require-public-key require-secret-key) - &rest body) + &rest body) "Set up temporary locations and variables for testing." (declare (indent 1) (debug (sexp body))) - `(let* ((epg-tests-home-directory (make-temp-file "epg-tests-homedir" t)) - (process-environment - (append - (list "GPG_AGENT_INFO" - (format "GNUPGHOME=%s" epg-tests-home-directory)) - process-environment))) - (unwind-protect - ;; GNUPGHOME is needed to find a usable gpg, so we can't - ;; check whether to skip any earlier (Bug#23561). - (let ((epg-config (or (epg-tests-find-usable-gpg-configuration - ,require-passphrase ,require-public-key) - (ert-skip "No usable gpg config"))) - (context (epg-make-context 'OpenPGP))) - (setf (epg-context-program context) - (alist-get 'program epg-config)) - (setf (epg-context-home-directory context) - epg-tests-home-directory) - ,(if require-passphrase - '(with-temp-file (expand-file-name - "gpg-agent.conf" epg-tests-home-directory) - (insert "pinentry-program " - (ert-resource-file "dummy-pinentry") - "\n") - (epg-context-set-passphrase-callback - context - #'epg-tests-passphrase-callback))) - ,(if require-public-key - '(epg-import-keys-from-file - context - (ert-resource-file "pubkey.asc"))) - ,(if require-secret-key - '(epg-import-keys-from-file - context - (ert-resource-file "seckey.asc"))) - (with-temp-buffer - (setq-local epg-tests-context context) - ,@body)) - (when (file-directory-p epg-tests-home-directory) - (delete-directory epg-tests-home-directory t))))) + `(ert-with-temp-directory epg-tests-home-directory + (let* ((process-environment + (append + (list "GPG_AGENT_INFO" + (format "GNUPGHOME=%s" epg-tests-home-directory)) + process-environment))) + ;; GNUPGHOME is needed to find a usable gpg, so we can't + ;; check whether to skip any earlier (Bug#23561). + (let ((epg-config (or (epg-tests-find-usable-gpg-configuration + ,require-passphrase ,require-public-key) + (ert-skip "No usable gpg config"))) + (context (epg-make-context 'OpenPGP))) + (setf (epg-context-program context) + (alist-get 'program epg-config)) + (setf (epg-context-home-directory context) + epg-tests-home-directory) + ,(if require-passphrase + '(with-temp-file (expand-file-name + "gpg-agent.conf" epg-tests-home-directory) + (insert "pinentry-program " + (ert-resource-file "dummy-pinentry") + "\n") + (epg-context-set-passphrase-callback + context + #'epg-tests-passphrase-callback))) + ,(if require-public-key + '(epg-import-keys-from-file + context + (ert-resource-file "pubkey.asc"))) + ,(if require-secret-key + '(epg-import-keys-from-file + context + (ert-resource-file "seckey.asc"))) + (with-temp-buffer + (setq-local epg-tests-context context) + ,@body))))) (ert-deftest epg-decrypt-1 () :expected-result (if (getenv "EMACS_HYDRA_CI") :failed :passed) ; fixme diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index d13397274aa..b2dbc1012de 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -24,6 +24,7 @@ (require 'ert) (require 'erc) (require 'erc-ring) +(require 'erc-networks) (ert-deftest erc--read-time-period () (cl-letf (((symbol-function 'read-string) (lambda (&rest _) ""))) @@ -47,6 +48,85 @@ (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "1d"))) (should (equal (erc--read-time-period "foo: ") 86400)))) +(ert-deftest erc-with-all-buffers-of-server () + (let (proc-exnet + proc-onet + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (with-current-buffer (get-buffer-create "OtherNet") + (erc-mode) + (setq proc-onet (start-process "sleep" (current-buffer) "sleep" "1") + erc-server-process proc-onet + erc-network 'OtherNet) + (set-process-query-on-exit-flag erc-server-process nil)) + + (with-current-buffer (get-buffer-create "ExampleNet") + (erc-mode) + (setq proc-exnet (start-process "sleep" (current-buffer) "sleep" "1") + erc-server-process proc-exnet + erc-network 'ExampleNet) + (set-process-query-on-exit-flag erc-server-process nil)) + + (with-current-buffer (get-buffer-create "#foo") + (erc-mode) + (setq erc-server-process proc-exnet) + (setq erc-default-recipients '("#foo"))) + + (with-current-buffer (get-buffer-create "#spam") + (erc-mode) + (setq erc-server-process proc-onet) + (setq erc-default-recipients '("#spam"))) + + (with-current-buffer (get-buffer-create "#bar") + (erc-mode) + (setq erc-server-process proc-onet) + (setq erc-default-recipients '("#bar"))) + + (with-current-buffer (get-buffer-create "#baz") + (erc-mode) + (setq erc-server-process proc-exnet) + (setq erc-default-recipients '("#baz"))) + + (should (eq (get-buffer-process "ExampleNet") proc-exnet)) + (erc-with-all-buffers-of-server (get-buffer-process "ExampleNet") + nil + (kill-buffer)) + + (should-not (get-buffer "ExampleNet")) + (should-not (get-buffer "#foo")) + (should-not (get-buffer "#baz")) + (should (get-buffer "OtherNet")) + (should (get-buffer "#bar")) + (should (get-buffer "#spam")) + + (let* ((test (lambda () (not (string= (buffer-name) "#spam")))) + (calls 0) + (get-test (lambda () (cl-incf calls) test))) + + (erc-with-all-buffers-of-server proc-onet + (funcall get-test) + (kill-buffer)) + + (should (= calls 1))) + + (should-not (get-buffer "OtherNet")) + (should-not (get-buffer "#bar")) + (should (get-buffer "#spam")) + (kill-buffer "#spam"))) + +(ert-deftest erc-lurker-maybe-trim () + (let (erc-lurker-trim-nicks + (erc-lurker-ignore-chars "_`")) + + (should (string= "nick`" (erc-lurker-maybe-trim "nick`"))) + + (setq erc-lurker-trim-nicks t) + (should (string= "nick" (erc-lurker-maybe-trim "nick`"))) + (should (string= "ni`_ck" (erc-lurker-maybe-trim "ni`_ck__``"))) + + (setq erc-lurker-ignore-chars "_-`") ; set of chars, not character alts + (should (string= "nick" (erc-lurker-maybe-trim "nick-_`"))))) + (ert-deftest erc-ring-previous-command-base-case () (ert-info ("Create ring when nonexistent and do nothing") (let (erc-input-ring @@ -61,13 +141,16 @@ (with-current-buffer (get-buffer-create "*#fake*") (erc-mode) (insert "\n\n") - (setq erc-input-marker (make-marker) ; these are all local - erc-insert-marker (make-marker) - erc-send-completed-hook nil) + (should-not (local-variable-if-set-p 'erc-send-completed-hook)) + (set (make-local-variable 'erc-send-completed-hook) nil) ; skip t (globals) + (setq erc-input-marker (make-marker) + erc-insert-marker (make-marker)) (set-marker erc-insert-marker (point-max)) (erc-display-prompt) (should (= (point) erc-input-marker)) - (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring nil t) + ;; Just in case erc-ring-mode is already on + (setq-local erc-pre-send-functions nil) + (add-hook 'erc-pre-send-functions #'erc-add-to-input-ring) ;; (cl-letf (((symbol-function 'erc-process-input-line) (lambda (&rest _) @@ -109,3 +192,111 @@ (should (looking-at "abc"))))) (when noninteractive (kill-buffer "*#fake*"))) + +(ert-deftest erc-log-irc-protocol () + (should-not erc-debug-irc-protocol) + (with-temp-buffer + (setq erc-server-process (start-process "fake" (current-buffer) "true") + erc-server-current-nick "tester" + erc-session-server "myproxy.localhost" + erc-session-port 6667) + (let ((inhibit-message noninteractive)) + (erc-toggle-debug-irc-protocol) + (erc-log-irc-protocol "PASS changeme\r\n" 'outgoing) + (setq erc-server-announced-name "irc.gnu.org") + (erc-log-irc-protocol ":irc.gnu.org 001 tester :Welcome") + (erc-log-irc-protocol ":irc.gnu.org 002 tester :Your host is irc.gnu.org") + (setq erc-network 'FooNet) + (erc-log-irc-protocol ":irc.gnu.org 422 tester :MOTD missing") + (setq erc-network 'BarNet) + (erc-log-irc-protocol ":irc.gnu.org 221 tester +i") + (set-process-query-on-exit-flag erc-server-process nil))) + (with-current-buffer "*erc-protocol*" + (goto-char (point-min)) + (search-forward "Version") + (search-forward "\r\n\r\n") + (search-forward "myproxy.localhost:6667 >> PASS" (line-end-position)) + (forward-line) + (search-forward "irc.gnu.org << :irc.gnu.org 001" (line-end-position)) + (forward-line) + (search-forward "irc.gnu.org << :irc.gnu.org 002" (line-end-position)) + (forward-line) + (search-forward "FooNet << :irc.gnu.org 422" (line-end-position)) + (forward-line) + (search-forward "BarNet << :irc.gnu.org 221" (line-end-position))) + (when noninteractive + (kill-buffer "*erc-protocol*") + (should-not erc-debug-irc-protocol))) + + +;; The point of this test is to ensure output is handled identically +;; regardless of whether a command handler is summoned. + +(ert-deftest erc-process-input-line () + (let (erc-server-last-sent-time + erc-server-flood-queue + (orig-erc-cmd-MSG (symbol-function 'erc-cmd-MSG)) + (erc-default-recipients '("#chan")) + calls) + (with-temp-buffer + (cl-letf (((symbol-function 'erc-cmd-MSG) + (lambda (line) + (push line calls) + (funcall orig-erc-cmd-MSG line))) + ((symbol-function 'erc-server-buffer) + (lambda () (current-buffer))) + ((symbol-function 'erc-server-process-alive) + (lambda () t)) + ((symbol-function 'erc-server-send-queue) + #'ignore)) + + (ert-info ("Dispatch to user command handler") + + (ert-info ("Baseline") + (erc-process-input-line "/msg #chan hi\n") + (should (equal (pop calls) " #chan hi")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Quote preserves line intact") + (erc-process-input-line "/QUOTE FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Unknown command respected") + (erc-process-input-line "/FAKE foo bar\n") + (should (equal (pop erc-server-flood-queue) + '("FAKE foo bar\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "/msg #chan hi you\n") + (should (equal (pop calls) " #chan hi you")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line honored") + (erc-process-input-line "/msg #chan\n") + (should (equal (pop calls) " #chan")) + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8))))) + + (ert-info ("Implicit cmd via `erc-send-input-line-function'") + + (ert-info ("Baseline") + (erc-process-input-line "hi") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi\r\n" . utf-8)))) + + (ert-info ("Spaces preserved") + (erc-process-input-line "hi you") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :hi you\r\n" . utf-8)))) + + (ert-info ("Empty line transmitted without injected-space kludge") + (erc-process-input-line "") + (should (equal (pop erc-server-flood-queue) + '("PRIVMSG #chan :\r\n" . utf-8)))) + + (should-not calls)))))) + +;;; erc-tests.el ends here diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index 0ce93bd45c6..b2687a96ab3 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -119,3 +119,5 @@ '(bold erc-current-nick-face) str1) (should (erc-faces-in str0)) (should (erc-faces-in str1)) )) + +;;; erc-track-tests.el ends here diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index 31967a61c3c..5bc5690675d 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -20,19 +20,18 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-hist) (ert-deftest eshell-write-readonly-history () "Test that having read-only strings in history is okay." - (let ((histfile (make-temp-file "eshell-history")) - (eshell-history-ring (make-ring 2))) - (ring-insert eshell-history-ring - (propertize "echo foo" 'read-only t)) - (ring-insert eshell-history-ring - (propertize "echo bar" 'read-only t)) - (unwind-protect - (eshell-write-history histfile) - (delete-file histfile)))) + (ert-with-temp-file histfile + (let ((eshell-history-ring (make-ring 2))) + (ring-insert eshell-history-ring + (propertize "echo foo" 'read-only t)) + (ring-insert eshell-history-ring + (propertize "echo bar" 'read-only t)) + (eshell-write-history histfile)))) (provide 'em-hist-test) diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index 5d1742b76fd..3ea11ab2de1 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -25,30 +25,30 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'em-ls) (require 'dired) (ert-deftest em-ls-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - (orig eshell-ls-use-in-dired) - buf) - (unwind-protect - (progn - (customize-set-value 'eshell-ls-use-in-dired t) - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (customize-set-variable 'eshell-ls-use-in-dired orig) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + (orig eshell-ls-use-in-dired) + buf) + (unwind-protect + (progn + (customize-set-value 'eshell-ls-use-in-dired t) + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (customize-set-variable 'eshell-ls-use-in-dired orig) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest em-ls-test-bug27817 () "Test for https://debbugs.gnu.org/27817 ." diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 4f0cc9b6785..0974784ef4c 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -26,23 +26,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'esh-mode) (require 'eshell) (defmacro with-temp-eshell (&rest body) "Evaluate BODY in a temporary Eshell buffer." - `(let* ((eshell-directory-name (make-temp-file "eshell" t)) - ;; We want no history file, so prevent Eshell from falling - ;; back on $HISTFILE. - (process-environment (cons "HISTFILE" process-environment)) - (eshell-history-file-name nil) - (eshell-buffer (eshell t))) - (unwind-protect - (with-current-buffer eshell-buffer - ,@body) - (let (kill-buffer-query-functions) - (kill-buffer eshell-buffer) - (delete-directory eshell-directory-name t))))) + `(ert-with-temp-directory eshell-directory-name + (let* (;; We want no history file, so prevent Eshell from falling + ;; back on $HISTFILE. + (process-environment (cons "HISTFILE" process-environment)) + (eshell-history-file-name nil) + (eshell-buffer (eshell t))) + (unwind-protect + (with-current-buffer eshell-buffer + ,@body) + (let (kill-buffer-query-functions) + (kill-buffer eshell-buffer)))))) (defun eshell-insert-command (text &optional func) "Insert a command at the end of the buffer." @@ -65,11 +65,9 @@ (defun eshell-test-command-result (command) "Like `eshell-command-result', but not using HOME." - (let ((eshell-directory-name (make-temp-file "eshell" t)) - (eshell-history-file-name nil)) - (unwind-protect - (eshell-command-result command) - (delete-directory eshell-directory-name t)))) + (ert-with-temp-directory eshell-directory-name + (let ((eshell-history-file-name nil)) + (eshell-command-result command)))) ;;; Tests: @@ -262,4 +260,4 @@ chars" (provide 'eshell-tests) -;;; tests/eshell-tests.el ends here +;;; eshell-tests.el ends here diff --git a/test/lisp/faces-resources/faces-test-dark-theme.el b/test/lisp/faces-resources/faces-test-dark-theme.el index f3ef6b67fa7..7e8871ec10a 100644 --- a/test/lisp/faces-resources/faces-test-dark-theme.el +++ b/test/lisp/faces-resources/faces-test-dark-theme.el @@ -22,7 +22,7 @@ ;;; Code: (deftheme faces-test-dark - "") + "Dark test theme.") (custom-theme-set-faces 'faces-test-dark diff --git a/test/lisp/faces-resources/faces-test-light-theme.el b/test/lisp/faces-resources/faces-test-light-theme.el index 390b8461644..70a75017614 100644 --- a/test/lisp/faces-resources/faces-test-light-theme.el +++ b/test/lisp/faces-resources/faces-test-light-theme.el @@ -22,7 +22,7 @@ ;;; Code: (deftheme faces-test-light - "") + "Light test theme.") (custom-theme-set-faces 'faces-test-light diff --git a/test/lisp/faces-tests.el b/test/lisp/faces-tests.el index c0db9c9de17..fe5f3ec95f8 100644 --- a/test/lisp/faces-tests.el +++ b/test/lisp/faces-tests.el @@ -25,7 +25,7 @@ (require 'ert) (require 'ert-x) -(defgroup faces--test nil "" +(defgroup faces--test nil "Group to test faces." :group 'faces--test) (defface faces--test1 diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index 3ceb392d7fb..84b9cea6c12 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -25,30 +25,29 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'ffap) (ert-deftest ffap-tests-25243 () "Test for https://debbugs.gnu.org/25243 ." - (let ((file (make-temp-file "test-Bug#25243"))) - (unwind-protect - (with-temp-file file - (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el + (ert-with-temp-file file + :suffix "-bug25243" + (let ((str "diff --git b/lisp/ffap.el a/lisp/ffap.el index 3d7cebadcf..ad4b70d737 100644 --- b/lisp/ffap.el +++ a/lisp/ffap.el @@ -203,6 +203,9 @@ ffap-foo-at-bar-prefix ")) - (transient-mark-mode 1) - (when (natnump ffap-max-region-length) - (insert - (concat - str - (make-string ffap-max-region-length #xa) - (format "%s ENDS HERE" file))) - (call-interactively 'mark-whole-buffer) - (should (equal "" (ffap-string-at-point))) - (should (equal '(1 1) ffap-string-at-point-region))))) - (and (file-exists-p file) (delete-file file))))) + (transient-mark-mode 1) + (when (natnump ffap-max-region-length) + (insert + (concat + str + (make-string ffap-max-region-length #xa) + (format "%s ENDS HERE" file))) + (call-interactively 'mark-whole-buffer) + (should (equal "" (ffap-string-at-point))) + (should (equal '(1 1) ffap-string-at-point-region)))))) (ert-deftest ffap-gopher-at-point () (with-temp-buffer @@ -123,6 +122,25 @@ left alone when opening a URL in an external browser." (save-excursion (insert "type=")) (ffap-guess-file-name-at-point)))) +(ert-deftest ffap-ido-mode () + (require 'ido) + (with-temp-buffer + (let ((ido-mode t) + (read-file-name-function read-file-name-function) + (read-buffer-function read-buffer-function)) + ;; Says ert-deftest: + ;; Macros in BODY are expanded when the test is defined, not when it + ;; is run. If a macro (possibly with side effects) is to be tested, + ;; it has to be wrapped in `(eval (quote ...))'. + (eval (quote (ido-everywhere))) + (let ((read-file-name-function (lambda (&rest args) + (expand-file-name + (nth 4 args) + (nth 1 args))))) + (save-excursion (insert "ffap-tests.el")) + (let (kill-buffer-query-functions) + (kill-buffer (call-interactively #'find-file-at-point))))))) + (provide 'ffap-tests) ;;; ffap-tests.el ends here diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 6125069c6b3..0fe72f278dc 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -162,9 +162,7 @@ Return nil when any other file notification watch is still active." (defun file-notify--test-cleanup () "Cleanup after a test." - (file-notify-rm-watch file-notify--test-desc) - (file-notify-rm-watch file-notify--test-desc1) - (file-notify-rm-watch file-notify--test-desc2) + (file-notify-rm-all-watches) (ignore-errors (delete-file (file-newest-backup file-notify--test-tmpfile))) @@ -421,7 +419,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; This test is inspired by Bug#26126 and Bug#26127. (ert-deftest file-notify-test02-rm-watch () - "Check `file-notify-rm-watch'." + "Check `file-notify-rm-watch' and `file-notify-rm-all-watches'." (skip-unless (file-notify--test-local-enabled)) (unwind-protect @@ -517,6 +515,31 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." (file-notify--test-cleanup-p)))) ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + ;; Check `file-notify-rm-all-watches'. + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name) + file-notify--test-tmpfile1 (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (write-region "any text" nil file-notify--test-tmpfile1 nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile '(change) #'ignore))) + (should + (setq file-notify--test-desc1 + (file-notify-add-watch + file-notify--test-tmpfile1 '(change) #'ignore))) + (file-notify-rm-all-watches) + (delete-file file-notify--test-tmpfile) + (delete-file file-notify--test-tmpfile1) + + ;; The environment shall be cleaned up. + (file-notify--test-cleanup-p)) + + ;; Cleanup. (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test02-rm-watch @@ -743,7 +766,7 @@ delivered." ;; the directory. Except for ;; GFam{File,Directory}Monitor, GPollFileMonitor and ;; kqueue. And GFam{File,Directory}Monitor and - ;; GPollFileMonitordo not raise a `changed' event. + ;; GPollFileMonitor do not raise a `changed' event. ((memq (file-notify--test-monitor) '(GFamFileMonitor GFamDirectoryMonitor GPollFileMonitor)) '(created deleted stopped)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index a5c82360177..1e20317739a 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -154,12 +154,14 @@ form.") (ert-deftest files-tests-permanent-local-variables () (let ((enable-local-variables nil)) (with-temp-buffer + (setq lexical-binding nil) (insert ";;; test-test.el --- tests -*- lexical-binding: t; -*-\n\n") (hack-local-variables) (should (eq lexical-binding t)))) (let ((enable-local-variables nil) (permanently-enabled-local-variables nil)) (with-temp-buffer + (setq lexical-binding nil) (insert ";;; test-test.el --- tests -*- lexical-binding: t; -*-\n\n") (hack-local-variables) (should (eq lexical-binding nil))))) @@ -174,15 +176,14 @@ form.") ;; If called interactively, environment variable ;; $EMACS_TEST_DIRECTORY does not exist. (skip-unless (file-exists-p files-test-bug-18141-file)) - (let ((tempfile (make-temp-file "files-test-bug-18141" nil ".gz"))) - (unwind-protect - (progn - (copy-file files-test-bug-18141-file tempfile t) - (with-current-buffer (find-file-noselect tempfile) - (set-buffer-modified-p t) - (save-buffer) - (should (eq buffer-file-coding-system 'iso-2022-7bit-unix)))) - (delete-file tempfile)))) + (ert-with-temp-file tempfile + :prefix "emacs-test-files-bug-18141" + :suffix ".gz" + (copy-file files-test-bug-18141-file tempfile t) + (with-current-buffer (find-file-noselect tempfile) + (set-buffer-modified-p t) + (save-buffer) + (should (eq buffer-file-coding-system 'iso-2022-7bit-unix))))) (ert-deftest files-tests-make-temp-file-empty-prefix () "Test make-temp-file with an empty prefix." @@ -206,24 +207,24 @@ form.") "Test for https://debbugs.gnu.org/21454 ." (let ((input-result (if (memq system-type '(windows-nt ms-dos)) - '(("x:/foo/bar//baz/;y:/bar/foo/baz//" nil - ("x:/foo/bar/baz/" "y:/bar/foo/baz/")) + '(("/foo/bar//baz/;/bar/foo/baz//" nil + ("/foo/bar//baz/" "/bar/foo/baz//")) ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo" nil ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x://foo/bar/;y:/bar/qux/;z:/qux/foo/" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x://foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo/bar/;y:/bar/qux/;z:/qux/foo/" nil ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo/" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo//bar/;y:/bar/qux/;z:/qux/foo" nil - ("x:/foo/bar/" "y:/bar/qux/" "z:/qux/foo/")) + ("x:/foo//bar/" "y:/bar/qux/" "z:/qux/foo/")) ("x:/foo/bar" "$FOO/baz/;z:/qux/foo/" ("x:/foo/bar/baz/" "z:/qux/foo/")) - ("x://foo/bar/" "$FOO/baz/;z:/qux/foo/" - ("x:/foo/bar/baz/" "z:/qux/foo/"))) + ("//foo/bar/" "$FOO/baz/;/qux/foo/" + ("/foo/bar//baz/" "/qux/foo/"))) '(("/foo/bar//baz/:/bar/foo/baz//" nil - ("/foo/bar/baz/" "/bar/foo/baz/")) + ("/foo/bar//baz/" "/bar/foo/baz//")) ("/foo/bar/:/bar/qux/:/qux/foo" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) ("//foo/bar/:/bar/qux/:/qux/foo/" nil @@ -231,11 +232,11 @@ form.") ("/foo/bar/:/bar/qux/:/qux/foo/" nil ("/foo/bar/" "/bar/qux/" "/qux/foo/")) ("/foo//bar/:/bar/qux/:/qux/foo/" nil - ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) ("/foo//bar/:/bar/qux/:/qux/foo" nil - ("/foo/bar/" "/bar/qux/" "/qux/foo/")) + ("/foo//bar/" "/bar/qux/" "/qux/foo/")) ("/foo/bar" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/")) - ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar/baz/" "/qux/foo/"))))) + ("//foo/bar/" "$FOO/baz/:/qux/foo/" ("/foo/bar//baz/" "/qux/foo/"))))) (foo-env (getenv "FOO")) (bar-env (getenv "BAR"))) (unwind-protect @@ -281,22 +282,20 @@ If we are in a directory named `~', the default value should not be $HOME." (cl-letf (((symbol-function 'completing-read) (lambda (_prompt _coll &optional _pred _req init _hist def _) - (or def init))) - (dir (make-temp-file "read-file-name-test" t))) - (unwind-protect - (let ((subdir (expand-file-name "./~/" dir))) - (make-directory subdir t) - (with-temp-buffer - (setq default-directory subdir) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (expand-file-name "~/"))) - ;; Don't overquote either! - (setq default-directory (concat "/:" subdir)) - (should-not (equal - (expand-file-name (read-file-name "File: ")) - (concat "/:/:" subdir))))) - (delete-directory dir 'recursive)))) + (or def init)))) + (ert-with-temp-directory dir + (let ((subdir (expand-file-name "./~/" dir))) + (make-directory subdir t) + (with-temp-buffer + (setq default-directory subdir) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (expand-file-name "~/"))) + ;; Don't overquote either! + (setq default-directory (concat "/:" subdir)) + (should-not (equal + (expand-file-name (read-file-name "File: ")) + (concat "/:/:" subdir)))))))) (ert-deftest files-tests-file-name-non-special-quote-unquote () (let (;; Just in case it is quoted, who knows. @@ -316,7 +315,9 @@ be $HOME." (ert-deftest files-tests-file-name-non-special--subprocess () "Check that Bug#25949 and Bug#48177 are fixed." - (skip-unless (and (executable-find "true") (file-exists-p null-device))) + (skip-unless (and (executable-find "true") (file-exists-p null-device) + ;; These systems cannot set date of the null device. + (not (memq system-type '(windows-nt ms-dos))))) (let ((default-directory (file-name-quote temporary-file-directory)) (true (file-name-quote (executable-find "true"))) (null (file-name-quote null-device))) @@ -337,14 +338,6 @@ be $HOME." (progn ,@body) (advice-remove #',symbol ,function))))) -(defmacro files-tests--with-temp-file (name &rest body) - (declare (indent 1) (debug (symbolp body))) - (cl-check-type name symbol) - `(let ((,name (make-temp-file "emacs"))) - (unwind-protect - (progn ,@body) - (delete-file ,name)))) - (ert-deftest files-tests-file-name-non-special--buffers () "Check that Bug#25951 is fixed. We call `verify-visited-file-modtime' on a buffer visiting a file @@ -353,7 +346,7 @@ the buffer current and a nil argument, second passing the buffer object explicitly. In both cases no error should be raised and the `file-name-non-special' handler for quoted file names should be invoked with the right arguments." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (let* ((buffer-visiting-file (current-buffer)) (actual-args ()) @@ -608,7 +601,7 @@ unquoted file names." (ert-deftest files-tests-file-name-non-special-dired-compress-handler () ;; `dired-compress-file' can get confused by filenames with ":" in ;; them, which causes this to fail on `windows-nt' systems. - (when (string-match-p ":" (expand-file-name temporary-file-directory)) + (when (string-search ":" (expand-file-name temporary-file-directory)) (ert-skip "FIXME: `dired-compress-file' unreliable when filenames contain `:'.")) (files-tests--with-temp-non-special (tmpfile nospecial) (let ((compressed (dired-compress-file nospecial))) @@ -951,40 +944,51 @@ unquoted file names." (ert-deftest files-test-auto-save-name-default () (with-temp-buffer - (let ((auto-save-file-name-transforms nil)) + (let ((auto-save-file-name-transforms nil) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) (setq buffer-file-name "/tmp/foo.txt") - (should (equal (make-auto-save-file-name) "/tmp/#foo.txt#"))))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/tmp/#foo.txt#"))))) (ert-deftest files-test-auto-save-name-transform () (with-temp-buffer (setq buffer-file-name "/tmp/foo.txt") (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" nil)))) - (should (equal (make-auto-save-file-name) "/var/tmp/#foo.txt#"))))) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" nil))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/var/tmp/#foo.txt#"))))) (ert-deftest files-test-auto-save-name-unique () (with-temp-buffer (setq buffer-file-name "/tmp/foo.txt") (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t)))) - (should (equal (make-auto-save-file-name) "/var/tmp/#!tmp!foo.txt#"))) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) + "/var/tmp/#!tmp!foo.txt#"))) (let ((auto-save-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1)))) - (should (equal (make-auto-save-file-name) + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-auto-save-file-name) name-start) "/var/tmp/#b57c5a04f429a83305859d3350ecdab8315a9037#"))))) (ert-deftest files-test-lock-name-default () - (let ((lock-file-name-transforms nil)) - (should (equal (make-lock-file-name "/tmp/foo.txt") "/tmp/.#foo.txt")))) + (let ((lock-file-name-transforms nil) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) + "/tmp/.#foo.txt")))) (ert-deftest files-test-lock-name-unique () (let ((lock-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t)))) - (should (equal (make-lock-file-name "/tmp/foo.txt") + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" t))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) "/var/tmp/.#!tmp!foo.txt"))) (let ((lock-file-name-transforms - '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1)))) - (should (equal (make-lock-file-name "/tmp/foo.txt") + '(("\\`/.*/\\([^/]+\\)\\'" "/var/tmp/\\1" sha1))) + (name-start (if (memq system-type '(windows-nt ms-dos)) 2 nil))) + (should (equal (substring (make-lock-file-name "/tmp/foo.txt") name-start) "/var/tmp/.#b57c5a04f429a83305859d3350ecdab8315a9037")))) (ert-deftest files-tests-file-name-non-special-make-directory () @@ -1224,26 +1228,26 @@ works as expected if the default directory is quoted." (insert-directory-wildcard-in-dir-p (car path-res))))))) (ert-deftest files-tests-make-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (file (concat dirname "file")) - (subdir1 (concat dirname "subdir1")) - (subdir2 (concat dirname "subdir2")) - (a/b (concat dirname "a/b"))) - (write-region "" nil file) - (should-error (make-directory "/")) - (should-not (make-directory "/" t)) - (should-error (make-directory dir)) - (should-not (make-directory dir t)) - (should-error (make-directory dirname)) - (should-not (make-directory dirname t)) - (should-error (make-directory file)) - (should-error (make-directory file t)) - (should-not (make-directory subdir1)) - (should-not (make-directory subdir2 t)) - (should-error (make-directory a/b)) - (should-not (make-directory a/b t)) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (file (concat dirname "file")) + (subdir1 (concat dirname "subdir1")) + (subdir2 (concat dirname "subdir2")) + (a/b (concat dirname "a/b"))) + (write-region "" nil file) + (should-error (make-directory "/")) + (should-not (make-directory "/" t)) + (should-error (make-directory dir)) + (should-not (make-directory dir t)) + (should-error (make-directory dirname)) + (should-not (make-directory dirname t)) + (should-error (make-directory file)) + (should-error (make-directory file t)) + (should-not (make-directory subdir1)) + (should-not (make-directory subdir2 t)) + (should-error (make-directory a/b)) + (should-not (make-directory a/b t)) + (delete-directory dir 'recursive)))) (ert-deftest files-tests-file-modes-symbolic-to-number () (let ((alist (list (cons "a=rwx" #o777) @@ -1303,7 +1307,7 @@ name (Bug#28412)." (set-buffer-modified-p t) (should-error (save-buffer) :type 'error)) ;; Then a buffer visiting a file: should save normally. - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-current-buffer (find-file-noselect temp-file-name) (setq write-contents-functions nil) (insert "p") @@ -1311,21 +1315,54 @@ name (Bug#28412)." (should (eq (buffer-size) 1)))))) (ert-deftest files-tests-copy-directory () - (let* ((dir (make-temp-file "files-mkdir-test" t)) - (dirname (file-name-as-directory dir)) - (source (concat dirname "source")) - (dest (concat dirname "dest/new/directory/")) - (file (concat (file-name-as-directory source) "file")) - (source2 (concat dirname "source2")) - (dest2 (concat dirname "dest/new2"))) - (make-directory source) - (write-region "" nil file) - (copy-directory source dest t t t) - (should (file-exists-p (concat dest "file"))) - (make-directory (concat (file-name-as-directory source2) "a") t) - (copy-directory source2 dest2) - (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) - (delete-directory dir 'recursive))) + (ert-with-temp-directory dir + (let* ((dirname (file-name-as-directory dir)) + (source (concat dirname "source")) + (dest (concat dirname "dest/new/directory/")) + (file (concat (file-name-as-directory source) "file")) + (source2 (concat dirname "source2")) + (dest2 (concat dirname "dest/new2"))) + (make-directory source) + (write-region "" nil file) + (copy-directory source dest t t t) + (should (file-exists-p (concat dest "file"))) + (make-directory (concat (file-name-as-directory source2) "a") t) + (copy-directory source2 dest2) + (should (file-directory-p (concat (file-name-as-directory dest2) "a"))) + (delete-directory dir 'recursive)))) + +(ert-deftest files-tests-abbreviate-file-name-homedir () + ;; Check homedir abbreviation. + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + (should (equal "~/foo/bar" + (abbreviate-file-name (concat homedir "foo/bar"))))) + ;; Check that homedir abbreviation doesn't occur when homedir is just /. + (let* ((homedir "/") + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil)) + (should (equal "/foo/bar" + (abbreviate-file-name (concat homedir "foo/bar")))))) + +(ert-deftest files-tests-abbreviate-file-name-directory-abbrev-alist () + ;; Check `directory-abbrev-alist' abbreviation. + (let ((directory-abbrev-alist '(("\\`/nowhere/special" . "/nw/sp")))) + (should (equal "/nw/sp/here" + (abbreviate-file-name "/nowhere/special/here")))) + ;; Check homedir and `directory-abbrev-alist' abbreviation. + (let* ((homedir temporary-file-directory) + (process-environment (cons (format "HOME=%s" homedir) + process-environment)) + (abbreviated-home-dir nil) + (directory-abbrev-alist + `((,(concat "\\`" (regexp-quote homedir) "nowhere/special") + . ,(concat homedir "nw/sp"))))) + (should (equal "~/nw/sp/here" + (abbreviate-file-name + (concat homedir "nowhere/special/here")))))) (ert-deftest files-tests-abbreviated-home-dir () "Test that changing HOME does not confuse `abbreviate-file-name'. @@ -1344,43 +1381,40 @@ See <https://debbugs.gnu.org/19657#20>." (ert-deftest files-tests-executable-find () "Test that `executable-find' works also with a relative or remote PATH. See <https://debbugs.gnu.org/35241>." - (let ((tmpfile (make-temp-file "files-test" nil (car exec-suffixes)))) - (unwind-protect - (progn - (set-file-modes tmpfile #o777) - (let ((exec-path `(,temporary-file-directory))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; An empty element of `exec-path' means `default-directory'. - (let ((default-directory temporary-file-directory) - (exec-path nil)) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile))))) - ;; The remote file name shall be quoted, and handled like a - ;; non-existing directory. - (let ((default-directory "/ssh::") - (exec-path (append exec-path `("." ,temporary-file-directory)))) - (should - (equal tmpfile - (executable-find (file-name-nondirectory tmpfile)))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix (car exec-suffixes) + (set-file-modes tmpfile #o755) + (let ((exec-path `(,temporary-file-directory))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; An empty element of `exec-path' means `default-directory'. + (let ((default-directory temporary-file-directory) + (exec-path nil)) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))) + ;; The remote file name shall be quoted, and handled like a + ;; non-existing directory. + (let ((default-directory "/ssh::") + (exec-path (append exec-path `("." ,temporary-file-directory)))) + (should + (equal tmpfile + (executable-find (file-name-nondirectory tmpfile))))))) (ert-deftest files-tests-dont-rewrite-precious-files () "Test that `file-precious-flag' forces files to be saved by renaming only, rather than modified in-place." - (let* ((temp-file-name (make-temp-file "files-tests")) - (advice (lambda (_start _end filename &rest _r) - (should-not (string= filename temp-file-name))))) - (unwind-protect - (with-current-buffer (find-file-noselect temp-file-name) - (advice-add #'write-region :before advice) - (setq-local file-precious-flag t) - (insert "foobar") - (should (null (save-buffer)))) - (ignore-errors (advice-remove #'write-region advice)) - (ignore-errors (delete-file temp-file-name))))) + (ert-with-temp-file temp-file-name + (let* ((advice (lambda (_start _end filename &rest _r) + (should-not (string= filename temp-file-name))))) + (unwind-protect + (with-current-buffer (find-file-noselect temp-file-name) + (advice-add #'write-region :before advice) + (setq-local file-precious-flag t) + (insert "foobar") + (should (null (save-buffer)))) + (ignore-errors (advice-remove #'write-region advice)))))) (ert-deftest files-test-file-size-human-readable () (should (equal (file-size-human-readable 13) "13")) @@ -1446,9 +1480,11 @@ See <https://debbugs.gnu.org/36401>." (ert-deftest files-colon-path () (if (memq system-type '(windows-nt ms-dos)) (should (equal (parse-colon-path "x:/foo//bar/baz") - '("x:/foo/bar/baz/"))) + '("x:/foo//bar/baz/"))) (should (equal (parse-colon-path "/foo//bar/baz") - '("/foo/bar/baz/"))))) + '("/foo//bar/baz/")))) + (should (equal (parse-colon-path (concat "." path-separator "/tmp")) + '("./" "/tmp/")))) (ert-deftest files-test-magic-mode-alist-doctype () "Test that DOCTYPE and variants put files in mhtml-mode." @@ -1492,7 +1528,7 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer () "Test that revert-buffer is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) (write-file temp-file-name) @@ -1505,7 +1541,7 @@ The door of all subtleties! (ert-deftest files-tests-revert-buffer-with-fine-grain () "Test that revert-buffer-with-fine-grain is successful." - (files-tests--with-temp-file temp-file-name + (ert-with-temp-file temp-file-name (with-temp-buffer (insert files-tests-lao) (write-file temp-file-name) @@ -1534,6 +1570,14 @@ The door of all subtleties! (should-error (file-name-with-extension "Jack" ".")) (should-error (file-name-with-extension "/is/a/directory/" "css"))) +(ert-deftest files-tests-file-name-base () + (should (equal (file-name-base "") "")) + (should (equal (file-name-base "/foo/") "")) + (should (equal (file-name-base "/foo") "foo")) + (should (equal (file-name-base "/foo/bar") "bar")) + (should (equal (file-name-base "foo") "foo")) + (should (equal (file-name-base "foo/bar") "bar"))) + (ert-deftest files-test-dir-locals-auto-mode-alist () "Test an `auto-mode-alist' entry in `.dir-locals.el'" (find-file (ert-resource-file "whatever.quux")) @@ -1545,5 +1589,223 @@ The door of all subtleties! (find-file (ert-resource-file "auto-test.zot3")) (should (eq major-mode 'fundamental-mode))) +(defun files-tests--save-some-buffers (pred def-pred-bind exp-1 exp-2) + "Helper function to test `save-some-buffers'. + +This function creates two file-visiting buffers, BUF-1, BUF-2 in +different directories at the same level, i.e., none of them is a +subdir of the other; then it modifies both buffers; finally, it +calls `save-some-buffers' from BUF-1 with first arg t, second +arg PRED and `save-some-buffers-default-predicate' let-bound to +DEF-PRED-BIND. + +EXP-1 and EXP-2 are the expected values of calling `buffer-modified-p' +on BUF-1 and BUF-2 after the `save-some-buffers' call. + +The test is repeated with `save-some-buffers-default-predicate' +let-bound to PRED and passing nil as second arg of +`save-some-buffers'." + (ert-with-temp-directory dir + (let* ((file-1 (expand-file-name "subdir-1/file.foo" dir)) + (file-2 (expand-file-name "subdir-2/file.bar" dir)) + (inhibit-message t) + buf-1 buf-2) + (unwind-protect + (progn + (make-empty-file file-1 'parens) + (make-empty-file file-2 'parens) + (setq buf-1 (find-file file-1) + buf-2 (find-file file-2)) + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (insert "foobar\n"))) + ;; Run the test. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate def-pred-bind)) + (save-some-buffers t pred)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2)))) + ;; Set both buffers as modified to run another test. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf (set-buffer-modified-p t))) + ;; The result of this test must be identical as the previous one. + (with-current-buffer buf-1 + (let ((save-some-buffers-default-predicate (or pred def-pred-bind))) + (save-some-buffers t nil)) + (should (eq exp-1 (buffer-modified-p buf-1))) + (should (eq exp-2 (buffer-modified-p buf-2))))) + ;; Clean up. + (dolist (buf (list buf-1 buf-2)) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))))))) + +(ert-deftest files-tests-save-some-buffers () + "Test `save-some-buffers'. +Test the 3 cases for the second argument PRED, i.e., nil, t, or +predicate. +The value of `save-some-buffers-default-predicate' is ignored unless +PRED is nil." + (let* ((foo-file-p (lambda () (string-suffix-p ".foo" buffer-file-name))) + (bar-file-p (lambda () (string-suffix-p ".bar" buffer-file-name))) + (args-results `((nil nil nil nil) + (nil ,foo-file-p nil t) + (nil ,bar-file-p t nil) + (,foo-file-p nil nil t) + (,bar-file-p nil t nil) + + (buffer-modified-p nil nil nil) + (t nil nil nil) + (t ,foo-file-p nil nil) + + (,foo-file-p save-some-buffers-root nil t) + (nil save-some-buffers-root nil t) + (,bar-file-p save-some-buffers-root t nil) + (t save-some-buffers-root nil nil)))) + (pcase-dolist (`(,pred ,def-pred-bind ,exp-1 ,exp-2) args-results) + (files-tests--save-some-buffers pred def-pred-bind exp-1 exp-2)))) + +(defmacro files-tests--with-buffer-offer-save (buffers-offer fn-test fn-binders args-results) + "Helper macro to test `save-some-buffers' and `save-buffers-kill-emacs'. + +This macro creates several non-file-visiting buffers in different +directories at the same level, i.e., none of them is a subdir of the +other. Then it modifies the buffers and sets their `buffer-offer-save' +as specified by BUFFERS-OFFER, a list of elements (BUFFER OFFER-SAVE). +Finally, it calls FN-TEST from the first buffer. + +FN-TEST is the function to test: either `save-some-buffers' or +`save-buffers-kill-emacs'. This function is called with +`save-some-buffers-default-predicate' let-bound to a value +specified inside ARGS-RESULTS. + +FN-BINDERS is a list of elements (FUNCTION . BINDING), where FUNCTION +is a function symbol that this macro temporary binds to BINDING during +the FN-TEST call. + +ARGS-RESULTS is a list of elements (FN-ARGS CALLERS-DIR EXPECTED), where +FN-ARGS are the arguments for FN-TEST; +CALLERS-DIR specifies the value to let-bind +\`save-some-buffers-default-predicate'; + EXPECTED is the expected result of the test." + (declare (debug (form symbol form form))) + (let ((dir (gensym "dir")) + (buffers (gensym "buffers"))) + `(let* ((,dir (make-temp-file "testdir" 'dir)) + (inhibit-message t) + (use-dialog-box nil) + ,buffers) + (pcase-dolist (`(,bufsym ,offer-save) ,buffers-offer) + (let* ((buf (generate-new-buffer (symbol-name bufsym))) + (subdir (expand-file-name + (format "subdir-%s" (buffer-name buf)) + ,dir))) + (make-directory subdir 'parens) + (push buf ,buffers) + (with-current-buffer buf + (cd subdir) + (setq buffer-offer-save offer-save) + (insert "foobar\n")))) + (setq ,buffers (nreverse ,buffers)) + (let ((nb-saved-buffers 0)) + (unwind-protect + (pcase-dolist (`(,fn-test-args ,callers-dir ,expected) + ,args-results) + (setq nb-saved-buffers 0) + (with-current-buffer (car ,buffers) + (cl-letf + (,@(mapcar (lambda (pair) `((symbol-function ,(car pair)) ,(cdr pair))) + fn-binders) + (save-some-buffers-default-predicate callers-dir)) + (apply #',fn-test fn-test-args) + (should (equal nb-saved-buffers expected))))) + ;; Clean up. + (dolist (buf ,buffers) + (with-current-buffer buf + (set-buffer-modified-p nil) + (kill-buffer buf))) + (delete-directory ,dir 'recursive)))))) + +(defmacro files-tests-with-all-permutations (permutation list &rest body) + "Execute BODY forms for all permutations of LIST. +Execute the forms with the symbol PERMUTATION bound to the current +permutation." + (declare (indent 2) (debug (symbol form body))) + (let ((vec (gensym "vec"))) + `(let ((,vec (vconcat ,list))) + (cl-labels ((swap (,vec i j) + (let ((tmp (aref ,vec j))) + (aset ,vec j (aref ,vec i)) + (aset ,vec i tmp))) + (permute (,vec l r) + (if (= l r) + (let ((,permutation (append ,vec nil))) + ,@body) + (cl-loop for idx from l below (1+ r) do + (swap ,vec idx l) + (permute ,vec (1+ l) r) + (swap ,vec idx l))))) + (permute ,vec 0 (1- (length ,vec))))))) + +(ert-deftest files-tests-buffer-offer-save () + "Test `save-some-buffers' for non-file-visiting buffers. +Check the behavior of `save-some-buffers' for non-file-visiting +buffers under several values of `buffer-offer-save'. +The value of `save-some-buffers-default-predicate' is ignored unless +PRED is nil." + (let* ((buffers-offer-init '((buf-1 t) (buf-2 always) (buf-3 nil))) + (nb-might-save + (length + (cl-remove-if (lambda (l) (null (cadr l))) buffers-offer-init))) + (nb-always-save + (length + (cl-remove-if-not (lambda (l) (eq 'always (cadr l))) buffers-offer-init)))) + (files-tests-with-all-permutations + buffers-offer + buffers-offer-init + (dolist (pred `(nil t save-some-buffers-root)) + (dolist (callers-dir `(nil save-some-buffers-root)) + (let* ((head-offer (cadar buffers-offer)) + (res (cond ((null pred) + (if (null callers-dir) nb-always-save (or (and head-offer 1) 0))) + (t + ;; Save any buffer with `buffer-offer-save' non-nil. + (if (eq pred t) nb-might-save + ;; Restrict to caller's dir. + (or (and head-offer 1) 0))))) + (args-res `(((nil ,pred) ,callers-dir ,res)))) + (files-tests--with-buffer-offer-save + buffers-offer + save-some-buffers + ;; Increase counter and answer 'n' when prompted to save a buffer. + (('read-event . (lambda (&rest _) (cl-incf nb-saved-buffers) ?n))) + args-res))))))) + +(ert-deftest files-tests-save-buffers-kill-emacs--asks-to-save-buffers () + "Test that `save-buffers-kill-emacs' asks to save buffers as expected. +Prompt users for any modified buffer with `buffer-offer-save' non-nil." + (let* ((buffers-offer-init '((buf-1 t) (buf-2 always) (buf-3 nil))) + (nb-might-save + (length + (cl-remove-if (lambda (l) (null (cadr l))) buffers-offer-init)))) + (files-tests-with-all-permutations + buffers-offer + buffers-offer-init + (files-tests--with-buffer-offer-save + buffers-offer + save-buffers-kill-emacs + ;; Increase counter and answer 'n' when prompted to save a buffer. + (('read-event . (lambda (&rest _) (cl-incf nb-saved-buffers) ?n)) + ('kill-emacs . #'ignore)) ; Do not kill Emacs. + `((nil nil ,nb-might-save) + ;; `save-some-buffers-default-predicate' (i.e. the 2nd element) is ignored. + (nil save-some-buffers-root ,nb-might-save)))))) + +(defun test-file-name-split () + (should (equal (file-name-split "foo/bar") '("foo" "bar"))) + (should (equal (file-name-split "/foo/bar") '("" "foo" "bar"))) + (should (equal (file-name-split "/foo/bar/zot") '("" "foo" "bar" "zot"))) + (should (equal (file-name-split "/foo/bar/") '("" "foo" "bar" ""))) + (should (equal (file-name-split "foo/bar/") '("foo" "bar" "")))) + (provide 'files-tests) ;;; files-tests.el ends here diff --git a/test/lisp/gnus/gnus-group-tests.el b/test/lisp/gnus/gnus-group-tests.el new file mode 100644 index 00000000000..ee1e01be4b2 --- /dev/null +++ b/test/lisp/gnus/gnus-group-tests.el @@ -0,0 +1,52 @@ +;;; gnus-group-tests.el --- Tests for gnus-group.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'gnus-group) +(require 'ert) + +(ert-deftest gnus-short-group-name () + (map-apply + (lambda (input expected) + (should (string-equal (gnus-short-group-name input) expected))) + '(("nnimap+email@example.com:archives/2020/03" . "email@example:a/2/03") + ("nndiary+diary:birthdays" . "diary:birthdays") + ("nnimap+email@example.com:test" . "email@example:test") + ("nnimap+email@example.com:234" . "email@example:234") + + ;; This is a very aggressive shortening of the left hand side. + ("nnimap+email@banana.salesman.example.com:234" . "email@banana:234") + ("nntp+some.where.edu:soc.motss" . "some:s.motss") + ("nntp+news.gmane.org:gmane.emacs.gnus.general" . "news:g.e.g.general") + ("nntp+news.gnus.org:gmane.text.docbook.apps" . "news:g.t.d.apps") + + ;; nnimap groups. + ("nnimap+email@example.com:[Invoices]/Bananas" . "email@example:I/Bananas") + ("nnimap+email@banana.salesman.example.com:[Invoices]/Bananas" + . "email@banana:I/Bananas") + + ;; The "n" from "nnspool" is perhaps not optimal. + ("nnspool+alt.binaries.pictures.furniture" . "n.b.p.furniture")))) + +;;; gnus-group-tests.el ends here diff --git a/test/lisp/gnus/gnus-icalendar-tests.el b/test/lisp/gnus/gnus-icalendar-tests.el index 90c3a34a5c0..1206a976f6e 100644 --- a/test/lisp/gnus/gnus-icalendar-tests.el +++ b/test/lisp/gnus/gnus-icalendar-tests.el @@ -216,7 +216,7 @@ RRULE:FREQ=WEEKLY;BYDAY=FR,MO,TH,TU,WE DTSTAMP:20200915T120627Z ORGANIZER;CN=anon@anoncompany.com:mailto:anon@anoncompany.com UID:7b6g3m7iftuo90ei4ul00feqn_R20200915T120000@google.com -ATTENDEE;CUTYPE=INDIVIDUAL;ROLE=REQ-PARTICIPANT;PARTSTAT=ACCEPTED;RSVP=TRUE +ATTENDEE;CUTYPE=INDIVIDUAL;PARTSTAT=ACCEPTED;RSVP=TRUE ;CN=participant@anoncompany.com;X-NUM-GUESTS=0:mailto:participant@anoncompany.com CREATED:20200325T095723Z DESCRIPTION:Coffee talk diff --git a/test/lisp/gnus/gnus-search-tests.el b/test/lisp/gnus/gnus-search-tests.el index 6148da65621..9f012d4e888 100644 --- a/test/lisp/gnus/gnus-search-tests.el +++ b/test/lisp/gnus/gnus-search-tests.el @@ -97,4 +97,4 @@ "more bits")))) (provide 'gnus-search-tests) -;;; search-tests.el ends here +;;; gnus-search-tests.el ends here diff --git a/test/lisp/gnus/gnus-util-tests.el b/test/lisp/gnus/gnus-util-tests.el index f8d30f6373e..60a9cde0e7f 100644 --- a/test/lisp/gnus/gnus-util-tests.el +++ b/test/lisp/gnus/gnus-util-tests.el @@ -132,4 +132,4 @@ (should (equal '("1") (gnus-setdiff '(2 "1" 2) '(2)))) (should (equal '("1" "1") (gnus-setdiff '(2 "1" 2 "1") '(2))))) -;;; gnustest-gnus-util.el ends here +;;; gnus-util-tests.el ends here diff --git a/test/lisp/gnus/message-tests.el b/test/lisp/gnus/message-tests.el index b4f2b7f675d..0f42f62f386 100644 --- a/test/lisp/gnus/message-tests.el +++ b/test/lisp/gnus/message-tests.el @@ -185,4 +185,4 @@ Hello. (provide 'message-mode-tests) -;;; message-mode-tests.el ends here +;;; message-tests.el ends here diff --git a/test/lisp/gnus/nnrss-tests.el b/test/lisp/gnus/nnrss-tests.el index 9821ec76fb4..92b7dacf180 100644 --- a/test/lisp/gnus/nnrss-tests.el +++ b/test/lisp/gnus/nnrss-tests.el @@ -26,4 +26,20 @@ (should (equal (nnrss-normalize-date "2004-09-17T05:09:49.001+00:00") "Fri, 17 Sep 2004 05:09:49 +0000"))) +(defconst test-nnrss-xml + '((rss + ((version . "2.0") + (xmlns:dc . "http://purl.org/dc/elements/1.1/")) + (channel + ((xmlns:content . "http://purl.org/rss/1.0/modules/content/")))))) + +(ert-deftest test-nnrss-namespace-top () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/dc/elements/1.1/") + "dc:"))) +(ert-deftest test-nnrss-namespace-inner () + (should (equal (nnrss-get-namespace-prefix + test-nnrss-xml "http://purl.org/rss/1.0/modules/content/") + "content:"))) + ;;; nnrss-tests.el ends here diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 513a0c2daea..24a42290a3f 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -148,7 +148,7 @@ Return first line of the output of (describe-function-1 FUNC)." (ert-deftest help-fns-test-describe-keymap/value () (describe-keymap minibuffer-local-must-match-map) (with-current-buffer "*Help*" - (should (looking-at "^key")))) + (should (looking-at "\nKey")))) (ert-deftest help-fns-test-describe-keymap/not-keymap () (should-error (describe-keymap nil)) @@ -158,7 +158,7 @@ Return first line of the output of (describe-function-1 FUNC)." (let ((foobar minibuffer-local-must-match-map)) (describe-keymap foobar) (with-current-buffer "*Help*" - (should (looking-at "^key"))))) + (should (looking-at "\nKey"))))) (ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) diff --git a/test/lisp/help-tests.el b/test/lisp/help-tests.el index 871417da3d2..a331ec440a8 100644 --- a/test/lisp/help-tests.el +++ b/test/lisp/help-tests.el @@ -65,7 +65,7 @@ result)))) (test-re (lambda (orig regexp) - (should (string-match (concat "^" regexp "$") + (should (string-match (concat "\\`" regexp "\\'") (substitute-command-keys orig)))))) ,@body)) @@ -90,18 +90,16 @@ (ert-deftest help-tests-substitute-command-keys/keymaps () (with-substitute-command-keys-test - (test "\\{minibuffer-local-must-match-map}" - "\ -key binding ---- ------- - + (test-re "\\{minibuffer-local-must-match-map}" + " +Key Binding +-+ C-g abort-minibuffers TAB minibuffer-complete C-j minibuffer-complete-and-exit RET minibuffer-complete-and-exit -ESC Prefix Command SPC minibuffer-complete-word -? minibuffer-completion-help +\\? minibuffer-completion-help C-<tab> file-cache-minibuffer-complete <XF86Back> previous-history-element <XF86Forward> next-history-element @@ -110,11 +108,8 @@ C-<tab> file-cache-minibuffer-complete <prior> switch-to-completions <up> previous-line-or-history-element -M-g Prefix Command M-v switch-to-completions -M-g ESC Prefix Command - M-< minibuffer-beginning-of-buffer M-n next-history-element M-p previous-history-element @@ -122,7 +117,6 @@ M-r previous-matching-history-element M-s next-matching-history-element M-g M-c switch-to-completions - "))) (ert-deftest help-tests-substitute-command-keys/keymap-change () @@ -249,11 +243,10 @@ M-g M-c switch-to-completions (with-substitute-command-keys-test (with-temp-buffer (help-tests-major-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -261,7 +254,6 @@ a .. c foo-other-range C-e foo-something x foo-original <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/shadow () @@ -269,11 +261,10 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (help-tests-minor-mode) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ ( .. ) short-range 1 .. 4 foo-range a .. c foo-other-range @@ -283,7 +274,6 @@ C-e foo-something x foo-original (this binding is currently shadowed) <F1> foo-function-key1 - ")))) (ert-deftest help-tests-substitute-command-keys/command-remap () @@ -292,15 +282,11 @@ x foo-original (with-temp-buffer (help-tests-major-mode) (define-key help-tests-major-mode-map [remap foo] 'bar) - (test "\\{help-tests-major-mode-map}" - "\ -key binding ---- ------- - -<remap> Prefix Command - + (test-re "\\{help-tests-major-mode-map}" + " +Key Binding +-+ <remap> <foo> bar - "))))) (ert-deftest help-tests-describe-map-tree/no-menu-t () @@ -312,12 +298,11 @@ key binding :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/no-menu-nil () (with-temp-buffer @@ -328,15 +313,13 @@ C-a foo :enable mark-active :help "Help text")))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -<menu-bar> Prefix Command -<menu-bar> <foo> foo - -"))))) +<menu-bar> <foo> foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-t () (with-temp-buffer @@ -345,14 +328,13 @@ C-a foo (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil t) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo (this binding is currently shadowed) -C-b bar - -"))))) +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/mention-shadow-nil () (with-temp-buffer @@ -361,12 +343,11 @@ C-b bar (2 . bar)))) (shadow-maps '((keymap . ((1 . baz)))))) (describe-map-tree map t shadow-maps nil nil t nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-b bar - -"))))) + (should (string-match " +Key Binding +-+ +C-b bar\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-t () (with-temp-buffer @@ -374,12 +355,11 @@ C-b bar (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map t nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - -C-a foo - -"))))) + (should (string-match " +Key Binding +-+ +C-a foo\n" + (buffer-string)))))) (ert-deftest help-tests-describe-map-tree/partial-nil () (with-temp-buffer @@ -387,13 +367,12 @@ C-a foo (map '(keymap . ((1 . foo) (2 . undefined))))) (describe-map-tree map nil nil nil nil nil nil nil nil) - (should (equal (buffer-string) "key binding ---- ------- - + (should (string-match " +Key Binding +-+ C-a foo -C-b undefined - -"))))) +C-b undefined\n" + (buffer-string)))))) (defvar help-tests--was-in-buffer nil) diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index 199512fe7de..200caa7e1ad 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -31,7 +31,8 @@ (with-temp-buffer (insert "a A b B\n") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (dotimes (_ 2) (let ((face (hi-lock-read-face-name))) @@ -43,7 +44,8 @@ (with-temp-buffer (insert "foo bar") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (hi-lock-set-pattern "9999" (hi-lock-read-face-name)) ; No match (hi-lock-set-pattern "foo" (hi-lock-read-face-name))) @@ -89,7 +91,8 @@ (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) (should (= (length (overlays-in (point-min) (point-max))) 1)) (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (call-interactively 'unhighlight-regexp)) (should (= (length (overlays-in (point-min) (point-max))) 0)) @@ -142,7 +145,8 @@ (font-lock-ensure) (should (memq 'hi-yellow (get-text-property 1 'face))) (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults))) (font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) @@ -155,7 +159,8 @@ (insert "aAbB\n") (cl-letf (((symbol-function 'completing-read) - (lambda (_prompt _coll _x _y _z _hist defaults) + (lambda (_prompt _coll + &optional _x _y _z _hist defaults _inherit) (car defaults)))) (highlight-regexp "a") diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el index 879131cae32..15798319a13 100644 --- a/test/lisp/htmlfontify-tests.el +++ b/test/lisp/htmlfontify-tests.el @@ -43,4 +43,4 @@ available (Bug#25468)." 0))) (provide 'htmlfontify-tests) -;; htmlfontify-tests.el ends here +;;; htmlfontify-tests.el ends here diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index a51079180a5..9b0327b0ef0 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -826,4 +826,4 @@ (should (equal (ibuffer-unary-operand '(not . a)) 'a))) (provide 'ibuffer-tests) -;; ibuffer-tests.el ends here +;;; ibuffer-tests.el ends here diff --git a/test/lisp/image-dired-tests.el b/test/lisp/image-dired-tests.el new file mode 100644 index 00000000000..3f0304ee405 --- /dev/null +++ b/test/lisp/image-dired-tests.el @@ -0,0 +1,37 @@ +;;; image-dired-tests.el --- Tests for image-dired.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'image-dired) + +(defun image-dired-test-image-file (name) + (expand-file-name + name (expand-file-name "data/image" + (or (getenv "EMACS_TEST_DIRECTORY") + "../")))) + +(ert-deftest image-dired-tests-get-exif-file-name () + (skip-unless (image-type-available-p 'jpeg)) + (let ((img (image-dired-test-image-file "black.jpg"))) + (should (equal (image-dired-get-exif-file-name img) + "2019_09_21_16_22_13_black.jpg")))) + +;;; image-dired-tests.el ends here diff --git a/test/lisp/image-tests.el b/test/lisp/image-tests.el index aa8600609c4..79b0014f60a 100644 --- a/test/lisp/image-tests.el +++ b/test/lisp/image-tests.el @@ -28,6 +28,27 @@ (expand-file-name "images" data-directory) "Directory containing Emacs images.") +(defconst image-tests--files + `((gif . ,(expand-file-name "test/data/image/black.gif" + source-directory)) + (jpeg . ,(expand-file-name "test/data/image/black.jpg" + source-directory)) + (pbm . ,(expand-file-name "splash.pbm" + image-tests--emacs-images-directory)) + (png . ,(expand-file-name "splash.png" + image-tests--emacs-images-directory)) + (svg . ,(expand-file-name "splash.svg" + image-tests--emacs-images-directory)) + (tiff . ,(expand-file-name + "nextstep/GNUstep/Emacs.base/Resources/emacs.tiff" + source-directory)) + (webp . ,(expand-file-name "test/data/image/black.webp" + source-directory)) + (xbm . ,(expand-file-name "gnus/gnus.xbm" + image-tests--emacs-images-directory)) + (xpm . ,(expand-file-name "splash.xpm" + image-tests--emacs-images-directory)))) + (ert-deftest image--set-property () "Test `image--set-property' behavior." (let ((image (list 'image))) @@ -49,12 +70,14 @@ (should (equal image '(image))))) (ert-deftest image-find-image () - (find-image '((:type xpm :file "undo.xpm"))) - (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))) + (should (listp (find-image '((:type xpm :file "undo.xpm"))))) + (should (listp (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center))))) + (should-not (find-image '((:type png :file "does-not-exist-foo-bar.png"))))) (ert-deftest image-type-from-file-name () (should (eq (image-type-from-file-name "foo.jpg") 'jpeg)) - (should (eq (image-type-from-file-name "foo.png") 'png))) + (should (eq (image-type-from-file-name "foo.png") 'png)) + (should (eq (image-type-from-file-name "foo.webp") 'webp))) (ert-deftest image-type/from-filename () ;; On emba, `image-types' and `image-load-path' do not exist. @@ -62,12 +85,37 @@ (bound-and-true-p image-load-path))) (should (eq (image-type "foo.jpg") 'jpeg))) -(ert-deftest image-type-from-file-header-test () +(defun image-tests--type-from-file-header (type) "Test image-type-from-file-header." - (should (eq (if (image-type-available-p 'svg) 'svg) - (image-type-from-file-header - (expand-file-name "splash.svg" - image-tests--emacs-images-directory))))) + (should (eq (if (image-type-available-p type) type) + (image-type-from-file-header (cdr (assq type image-tests--files)))))) + +(ert-deftest image-type-from-file-header-test/gif () + (image-tests--type-from-file-header 'gif)) + +(ert-deftest image-type-from-file-header-test/jpeg () + (image-tests--type-from-file-header 'jpeg)) + +(ert-deftest image-type-from-file-header-test/pbm () + (image-tests--type-from-file-header 'pbm)) + +(ert-deftest image-type-from-file-header-test/png () + (image-tests--type-from-file-header 'png)) + +(ert-deftest image-type-from-file-header-test/svg () + (image-tests--type-from-file-header 'svg)) + +(ert-deftest image-type-from-file-header-test/tiff () + (image-tests--type-from-file-header 'tiff)) + +(ert-deftest image-type-from-file-header-test/webp () + (image-tests--type-from-file-header 'webp)) + +(ert-deftest image-type-from-file-header-test/xbm () + (image-tests--type-from-file-header 'xbm)) + +(ert-deftest image-type-from-file-header-test/xpm () + (image-tests--type-from-file-header 'xpm)) (ert-deftest image-rotate () "Test `image-rotate'." diff --git a/test/lisp/image/exif-tests.el b/test/lisp/image/exif-tests.el index ddbee75467e..2357113f630 100644 --- a/test/lisp/image/exif-tests.el +++ b/test/lisp/image/exif-tests.el @@ -28,24 +28,19 @@ (or (getenv "EMACS_TEST_DIRECTORY") "../../")))) -(defun exif-elem (exif elem) - (plist-get (seq-find (lambda (e) - (eq elem (plist-get e :tag-name))) - exif) - :value)) - (ert-deftest test-exif-parse () (let ((exif (exif-parse-file (test-image-file "black.jpg")))) - (should (equal (exif-elem exif 'make) "Panasonic")) - (should (equal (exif-elem exif 'orientation) 1)) - (should (equal (exif-elem exif 'x-resolution) '(180 . 1))))) + (should (equal (exif-field 'make exif) "Panasonic")) + (should (equal (exif-field 'orientation exif) 1)) + (should (equal (exif-field 'x-resolution exif) '(180 . 1))) + (should (equal (exif-field 'date-time exif) "2019:09:21 16:22:13")))) (ert-deftest test-exif-parse-short () (let ((exif (exif-parse-file (test-image-file "black-short.jpg")))) - (should (equal (exif-elem exif 'make) "thr")) - (should (equal (exif-elem exif 'model) "four")) - (should (equal (exif-elem exif 'software) "em")) - (should (equal (exif-elem exif 'artist) "z")))) + (should (equal (exif-field 'make exif) "thr")) + (should (equal (exif-field 'model exif) "four")) + (should (equal (exif-field 'software exif) "em")) + (should (equal (exif-field 'artist exif) "z")))) (ert-deftest test-exit-direct-ascii-value () (should (equal (exif--direct-ascii-value 28005 2 t) (string ?e ?m 0))) diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index ecba86146f1..9379a53fe1d 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'info-xref) (defun info-xref-test-internal (body result) @@ -96,15 +97,17 @@ text. (ert-deftest info-xref-test-makeinfo () "Test that info-xref can parse basic makeinfo output." (skip-unless (executable-find "makeinfo")) - (let ((tempfile (make-temp-file "info-xref-test" nil ".texi")) - (tempfile2 (make-temp-file "info-xref-test2" nil ".texi")) - (errflag t)) - (unwind-protect - (progn - ;; tempfile contains xrefs to various things, including tempfile2. - (info-xref-test-write-file - tempfile - (concat "\ + (ert-with-temp-file tempfile + :suffix ".texi" + (ert-with-temp-file tempfile2 + :suffix ".texi" + (let ((errflag t)) + (unwind-protect + (progn + ;; tempfile contains xrefs to various things, including tempfile2. + (info-xref-test-write-file + tempfile + (concat "\ @xref{nodename,,,missing,Missing Manual}. @xref{nodename,crossref,title,missing,Missing Manual}. @@ -114,35 +117,36 @@ text. @xref{Chapter One,Something}. " - (format "@xref{Chapter One,,,%s,Present Manual}.\n" - (file-name-sans-extension (file-name-nondirectory - tempfile2))))) - ;; Something for tempfile to xref to. - (info-xref-test-write-file tempfile2 "") - (require 'info) - (save-window-excursion - (let ((Info-directory-list - (list - (or (file-name-directory tempfile) "."))) - Info-additional-directory-list) - (info-xref-check (format "%s.info" (file-name-sans-extension - tempfile)))) - (should (equal (list info-xref-bad info-xref-good - info-xref-unavail) - '(0 1 2))) - (setq errflag nil) - ;; If there was an error, we can leave this around. - (kill-buffer info-xref-output-buffer))) - ;; Useful diagnostic in case of problems. - (if errflag - (with-temp-buffer - (call-process "makeinfo" nil t nil "--version") - (message "%s" (buffer-string)))) - (mapc 'delete-file (list tempfile tempfile2 - (format "%s.info" (file-name-sans-extension - tempfile)) - (format "%s.info" (file-name-sans-extension - tempfile2))))))) + (format "@xref{Chapter One,,,%s,Present Manual}.\n" + (file-name-sans-extension (file-name-nondirectory + tempfile2))))) + ;; Something for tempfile to xref to. + (info-xref-test-write-file tempfile2 "") + (require 'info) + (save-window-excursion + (let ((Info-directory-list + (list + (or (file-name-directory tempfile) "."))) + Info-additional-directory-list) + (info-xref-check (format "%s.info" (file-name-sans-extension + tempfile)))) + (should (equal (list info-xref-bad info-xref-good + info-xref-unavail) + '(0 1 2))) + (setq errflag nil) + ;; If there was an error, we can leave this around. + (kill-buffer info-xref-output-buffer))) + ;; Useful diagnostic in case of problems. + (if errflag + (with-temp-buffer + (call-process "makeinfo" nil t nil "--version") + (message "%s" (buffer-string)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile)))) + (ignore-errors + (delete-file (format "%s.info" (file-name-sans-extension + tempfile2))))))))) (ert-deftest info-xref-test-emacs-manuals () "Test that all internal links in the Emacs manuals work." @@ -161,4 +165,4 @@ text. (line-end-position))))))) -;;; info-xref.el ends here +;;; info-xref-tests.el ends here diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index 0f765e4ff88..f3da2d88732 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -246,3 +246,5 @@ At EOF: (registers [17 0 0 0 0 0 0 0])) (ccl-execute compiled registers) (should (equal registers [2 16 0 0 0 0 0 1]))))) + +;;; ccl-tests.el ends here diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 7727c118b2c..8ca1ade771d 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -23,7 +23,7 @@ ;;; Code: -(require 'ert-x) ;For `ert-run-keys'. +(require 'ert-x) ;For `ert-simulate-keys'. (ert-deftest find-auto-coding--bug27391 () "Check that Bug#27391 is fixed." diff --git a/test/lisp/international/mule-util-resources/utf-8.txt b/test/lisp/international/mule-util-resources/utf-8.txt new file mode 100644 index 00000000000..385bbb4ba80 --- /dev/null +++ b/test/lisp/international/mule-util-resources/utf-8.txt @@ -0,0 +1,2 @@ +Thís is a test line 1. +Line 2. diff --git a/test/lisp/international/mule-util-tests.el b/test/lisp/international/mule-util-tests.el index 6518be66dbe..0fcff9d02dd 100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'mule-util) (defconst mule-util-test-truncate-data @@ -82,4 +83,43 @@ (dotimes (i (length mule-util-test-truncate-data)) (mule-util-test-truncate-create i)) +(ert-deftest filepos/bufferpos-tests-utf-8 () + (let ((coding-system-for-read 'utf-8-unix)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (should (eq buffer-file-coding-system 'utf-8-unix)) + ;; First line is "Thís is a test line 1.". + ;; Bytes start counting at 0; chars at 1. + (should (= (filepos-to-bufferpos 1 'exact) 2)) + (should (= (bufferpos-to-filepos 2 'exact) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'exact) 4)) + (should (= (bufferpos-to-filepos 4 'exact) 4))))) + +(ert-deftest filepos/bufferpos-tests-binary () + (let ((coding-system-for-read 'binary)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (should (eq buffer-file-coding-system 'no-conversion)) + ;; First line is "Thís is a test line 1.". + ;; Bytes start counting at 0; chars at 1. + (should (= (filepos-to-bufferpos 1 'exact) 2)) + (should (= (bufferpos-to-filepos 2 'exact) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'exact) 5)) + (should (= (bufferpos-to-filepos 5 'exact) 4))))) + +(ert-deftest filepos/bufferpos-tests-undecided () + (let ((coding-system-for-read 'binary)) + (with-temp-buffer + (insert-file-contents (ert-resource-file "utf-8.txt")) + (setq buffer-file-coding-system 'undecided) + (should-error (filepos-to-bufferpos 1 'exact)) + (should-error (bufferpos-to-filepos 2 'exact)) + (should (= (filepos-to-bufferpos 1 'approximate) 2)) + (should (= (bufferpos-to-filepos 2 'approximate) 1)) + ;; After non-ASCII. + (should (= (filepos-to-bufferpos 4 'approximate) 5)) + (should (= (bufferpos-to-filepos 5 'approximate) 4))))) + ;;; mule-util-tests.el ends here diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index 51f4ed3a80e..eb577b97dc4 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -123,9 +123,9 @@ The following invariants must be true for all conformant implementations..." (defsubst ucs-normalize-tests--rule2-holds-p (X) "Check 2nd conformance rule. -For every code point X assigned in this version of Unicode that is not specifically -listed in Part 1, the following invariants must be true for all conformant -implementations: +For every code point X assigned in this version of Unicode that +is not specifically listed in Part 1, the following invariants +must be true for all conformant implementations: X == toNFC(X) == toNFD(X) == toNFKC(X) == toNFKD(X)" (and (ucs-normalize-tests--normalization-chareq-p NFC X X) @@ -181,27 +181,34 @@ implementations: (should-not (ucs-normalize-tests--rule1-failing-for-partX 0))) (defconst ucs-normalize-tests--failing-lines-part1 - (list 2152 2418 15133 15134 15135 15136 15137 15138 - 15139 15140 15141 15142 16152 16153 16154 16155 - 16156 16157 16158 16159 16160 16161 16162 16163 - 16164 16165 16166 16167 16168 16169 16170 16171 - 16172 16173 16174 16175 16176 16177 16178 16179 - 16180 16181 16182 16183 16184 16185 16186 16187 - 16188 16189 16190 16191 16192 16193 16194 16195 - 16196 16197 16198 16199 16200 16201 16202 16203 - 16204 16205 16206 16207 16208 16209 16210 16211 - 16212 16213 16214 16215 16216 16217 16218 16219 - 16220 16221 16222 16223 16224 16225 16226 16227 - 16228 16229 16230 16231 16232 16233 16234 16235 - 16236 16237 16238 16239 16240 16241 16242 16243 - 16244 16245 16246 16247 16248 16249 16250 16251 - 16252 16253 16254 16255 16256 16257 16258 16259 - 16260 16261 16262 16263 16264 16265 16266 16267 - 16268 16269 16270 16271 16272 16273 16274 16275 - 16276 16277 16278 16279 16280 16281 16282 16283 - 16284 16285 16286 16287 16288 16289 16290 16291 - 16292 16429 16430 16431 16432 16433 16434 16435 - 16436 16437 16438)) + (list 2412 2413 2414 15133 15134 15135 15136 15137 + 15138 15139 15140 15141 15142 15143 15144 15145 + 15146 15147 15148 15149 15150 15151 15152 15153 + 15154 15155 15156 15157 15158 15159 15160 15161 + 15162 15163 15164 15165 15166 15167 15168 15169 + 15170 15171 15172 15173 15174 15175 15176 15177 + 15178 15179 15180 15181 15182 15183 15184 15185 + 15186 15187 15188 15192 15193 15194 15195 15196 + 15197 15198 15199 15200 15201 16211 16212 16213 + 16214 16215 16216 16217 16218 16219 16220 16221 + 16222 16223 16224 16225 16226 16227 16228 16229 + 16230 16231 16232 16233 16234 16235 16236 16237 + 16238 16239 16240 16241 16242 16243 16244 16245 + 16246 16247 16248 16249 16250 16251 16252 16253 + 16254 16255 16256 16257 16258 16259 16260 16261 + 16262 16263 16264 16265 16266 16267 16268 16269 + 16270 16271 16272 16273 16274 16275 16276 16277 + 16278 16279 16280 16281 16282 16283 16284 16285 + 16286 16287 16288 16289 16290 16291 16292 16293 + 16294 16295 16296 16297 16298 16299 16300 16301 + 16302 16303 16304 16305 16306 16307 16308 16309 + 16310 16311 16312 16313 16314 16315 16316 16317 + 16318 16319 16320 16321 16322 16323 16324 16325 + 16326 16327 16328 16329 16330 16331 16332 16333 + 16334 16335 16336 16337 16338 16339 16340 16341 + 16342 16343 16344 16345 16346 16347 16348 16349 + 16350 16351 16488 16489 16490 16491 16492 16493 + 16494 16495 16496 16497)) ;; Keep a record of failures, for consulting afterwards (the ert ;; backtrace only shows a truncated version of these lists). @@ -233,6 +240,7 @@ implementations: (ert-deftest ucs-normalize-part1 () :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 1800s ;; This takes a long time, so make sure we're compiled. (dolist (fun '(ucs-normalize-tests--part1-rule2 ucs-normalize-tests--rule1-failing-for-partX @@ -259,28 +267,76 @@ implementations: ucs-normalize-tests--failing-lines-part1))) (defconst ucs-normalize-tests--failing-lines-part2 - (list 17634 17635 17646 17647 17652 17653 17656 17657 - 17660 17661 17672 17673 17750 17751 17832 17834 - 17836 17837 17862 17863 17868 17869 18222 18270 - 18271 18368 18370 18400 18401 18402 18404 18406 - 18408 18410 18412 18413 18414 18416 18417 18418 - 18420 18421 18422 18423 18424 18426 18427 18428 - 18429 18430 18432 18434 18436 18438 18440 18442 - 18444 18446 18448 18450 18452 18454 18456 18458 - 18459 18460 18462 18464 18465 18466 18468 18469 - 18470 18472 18474 18475 18476 18478 18480 18481 - 18482 18484 18486 18487 18488 18490 18492 18494 - 18496 18498 18499 18500 18502 18504 18506 18508 - 18510 18512 18514 18516 18518 18520 18522 18524 - 18526 18528 18530 18531 18532 18533 18534 18602 - 18604 18606 18608 18610 18612 18614 18616 18618 - 18620 18622 18624 18626 18628 18630 18632 18634 - 18636 18638 18640 18642 18644 18646 18648 18650 - 18652 18654 18656 18658 18660 18662 18664 18666 - 18668 18670 18672 18674 18676 18678 18680 18682 - 18684 18686 18688 18690 18692 18694 18696 18698 - 18700 18702 18704 18706 18708 18710 18712 18714 - 18716 18718 18720 18722 18724 18726 18727)) + (list 17087 17088 17089 17090 17091 17092 17093 17094 + 17098 17099 17100 17101 17102 17103 17104 17105 + 17106 17107 17108 17113 17114 17115 17116 17117 + 17118 17119 17120 17125 17126 17127 17128 17129 + 17130 17131 17132 17133 17134 17135 17136 17137 + 17138 17139 17140 17141 17142 17143 17144 17145 + 17146 17157 17158 17159 17160 17161 17162 17163 + 17164 17185 17186 17187 17188 17189 17190 17197 + 17198 17199 17200 17207 17208 17209 17210 17211 + 17212 17213 17214 17219 17220 17221 17222 17275 + 17276 17285 17286 17295 17296 17309 17310 17311 + 17312 17313 17314 17315 17316 17317 17318 17319 + 17320 17325 17326 17373 17374 17419 17420 17421 + 17422 17433 17434 17439 17440 17465 17466 17473 + 17474 17479 17480 17485 17486 17491 17492 17497 + 17498 17499 17500 17501 17502 17505 17506 17507 + 17508 17511 17512 17519 17520 17523 17524 17527 + 17528 17531 17532 17551 17552 17555 17556 17599 + 17600 17601 17602 17603 17604 17605 17607 17608 + 17609 17610 17611 17612 17613 17615 17617 17619 + 17621 17623 17625 17627 17629 17631 17632 17633 + 17634 17635 17636 17637 17638 17639 17640 17669 + 17670 17675 17676 17681 17682 17689 17690 17691 + 17692 17693 17694 17707 17708 17713 17714 17715 + 17716 17727 17728 17733 17734 17739 17740 17745 + 17746 17749 17750 17753 17754 17759 17760 17767 + 17768 17807 17808 17809 17810 17811 17812 17813 + 17814 17816 17843 17844 17845 17846 17851 17852 + 17861 17875 17876 17879 17880 17899 17900 17911 + 17912 17913 17914 17915 17916 17917 17918 17919 + 17920 17921 17922 17927 17928 17929 17930 17931 + 17932 17933 17935 17937 17938 17939 17940 17941 + 17943 17945 17947 17949 17951 17952 17953 17955 + 17957 17959 17961 17962 17967 17968 17987 17988 + 17993 17994 18003 18004 18005 18006 18007 18008 + 18009 18010 18011 18012 18017 18018 18019 18020 + 18021 18022 18023 18024 18041 18042 18053 18054 + 18069 18070 18079 18080 18163 18164 18165 18166 + 18171 18172 18175 18176 18211 18212 18219 18220 + 18221 18222 18223 18224 18225 18226 18301 18302 + 18389 18390 18391 18392 18393 18394 18397 18398 + 18407 18408 18439 18440 18441 18442 18443 18444 + 18445 18446 18447 18448 18449 18450 18451 18452 + 18457 18458 18459 18460 18471 18472 18479 18480 + 18485 18486 18499 18500 18501 18502 18509 18510 + 18513 18514 18515 18516 18517 18518 18519 18520 + 18521 18523 18524 18525 18527 18528 18531 18537 + 18538 18539 18541 18543 18545 18547 18549 18550 + 18551 18553 18554 18555 18557 18558 18559 18560 + 18561 18563 18564 18565 18566 18567 18569 18571 + 18573 18575 18577 18579 18581 18583 18585 18587 + 18589 18591 18593 18595 18596 18597 18599 18601 + 18602 18603 18605 18606 18607 18609 18611 18612 + 18613 18615 18617 18618 18619 18621 18623 18624 + 18625 18627 18629 18631 18633 18635 18636 18637 + 18639 18641 18643 18645 18647 18649 18651 18653 + 18655 18657 18659 18661 18663 18665 18667 18668 + 18669 18670 18671 18674 18676 18686 18688 18690 + 18692 18694 18695 18696 18697 18698 18699 18700 + 18701 18702 18703 18704 18705 18706 18707 18708 + 18709 18710 18721 18722 18723 18724 18739 18741 + 18743 18745 18747 18749 18751 18753 18755 18757 + 18759 18761 18763 18765 18767 18769 18771 18773 + 18775 18777 18779 18781 18783 18785 18787 18789 + 18791 18793 18795 18797 18799 18801 18803 18805 + 18807 18809 18811 18813 18815 18817 18819 18821 + 18823 18825 18827 18829 18831 18833 18835 18837 + 18839 18840 18841 18842 18843 18844 18845 18846 + 18847 18848 18849 18850 18851 18852 18853 18855 + 18857 18859 18861 18863 18865 18866)) (ert-deftest ucs-normalize-part2 () :tags '(:expensive-test) diff --git a/test/lisp/jit-lock-tests.el b/test/lisp/jit-lock-tests.el index 121966b2b77..a54aad8165c 100644 --- a/test/lisp/jit-lock-tests.el +++ b/test/lisp/jit-lock-tests.el @@ -58,3 +58,5 @@ (with-silent-modifications (put-text-property (point-min) (point-max) 'fontified t)) (jit-lock-fontify-now (point-min) (point-max)))) + +;;; jit-lock-tests.el ends here diff --git a/test/lisp/kmacro-tests.el b/test/lisp/kmacro-tests.el index 8736f7fd2dc..ecd3d5fc22b 100644 --- a/test/lisp/kmacro-tests.el +++ b/test/lisp/kmacro-tests.el @@ -834,7 +834,7 @@ and `read-event' and `read-key-sequence' set up to return items from EVENTS and SEQUENCES respectively. SEQUENCES may be nil, but EVENTS should not be. EVENTS should be a list of symbols bound in `kmacro-step-edit-map' or `query-replace' map, and this function -will do the keymap lookup for you. SEQUENCES should contain +will do the keymap lookup for you. SEQUENCES should contain return values for `read-key-sequence'. Before running the macro, the current buffer will be erased. diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index e386398eea2..e3a75bed41d 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ls-lisp) (require 'dired) @@ -59,22 +60,22 @@ (ert-deftest ls-lisp-test-bug27631 () "Test for https://debbugs.gnu.org/27631 ." - (let* ((dir (make-temp-file "bug27631" 'dir)) - (dir1 (expand-file-name "dir1" dir)) - (dir2 (expand-file-name "dir2" dir)) - (default-directory dir) - ls-lisp-use-insert-directory-program buf) - (unwind-protect - (progn - (make-directory dir1) - (make-directory dir2) - (with-temp-file (expand-file-name "a.txt" dir1)) - (with-temp-file (expand-file-name "b.txt" dir2)) - (setq buf (dired (expand-file-name "dir*/*.txt" dir))) - (dired-toggle-marks) - (should (cdr (dired-get-marked-files)))) - (delete-directory dir 'recursive) - (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-with-temp-directory dir + :suffix "bug27631" + (let* ((dir1 (expand-file-name "dir1" dir)) + (dir2 (expand-file-name "dir2" dir)) + (default-directory dir) + ls-lisp-use-insert-directory-program buf) + (unwind-protect + (progn + (make-directory dir1) + (make-directory dir2) + (with-temp-file (expand-file-name "a.txt" dir1)) + (with-temp-file (expand-file-name "b.txt" dir2)) + (setq buf (dired (expand-file-name "dir*/*.txt" dir))) + (dired-toggle-marks) + (should (cdr (dired-get-marked-files)))) + (when (buffer-live-p buf) (kill-buffer buf)))))) (ert-deftest ls-lisp-test-bug27693 () "Test for https://debbugs.gnu.org/27693 ." diff --git a/test/lisp/mail/mail-parse-tests.el b/test/lisp/mail/mail-parse-tests.el new file mode 100644 index 00000000000..70de92df45a --- /dev/null +++ b/test/lisp/mail/mail-parse-tests.el @@ -0,0 +1,54 @@ +;;; mail-parse-tests.el --- tests for mail-parse.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'mail-parse) +(require 'subr-x) + +(ert-deftest test-mail-header-parse-address-lax () + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen <larsi@gnus.org>") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen larsi@gnus.org>") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "Lars Ingebrigtsen larsi@gnus.org") + '("larsi@gnus.org" . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax + "larsi@gnus.org (Lars Ingebrigtsen)") + '("larsi@gnus.org " . "Lars Ingebrigtsen"))) + (should (equal (mail-header-parse-address-lax "larsi@gnus.org") + '("larsi@gnus.org"))) + (should (equal (mail-header-parse-address-lax "foo") + nil))) + +(ert-deftest test-mail-header-parse-addresses-lax () + (should (equal (mail-header-parse-addresses-lax + "Bob Weiner <rsw@gnu.org>, Mats Lidell <matsl@gnu.org>") + '(("rsw@gnu.org" . "Bob Weiner") + ("matsl@gnu.org" . "Mats Lidell"))))) + +(provide 'mail-parse-tests) + +;;; mail-parse-tests.el ends here diff --git a/test/lisp/mail/rfc6068-tests.el b/test/lisp/mail/rfc6068-tests.el new file mode 100644 index 00000000000..caf8230cb1e --- /dev/null +++ b/test/lisp/mail/rfc6068-tests.el @@ -0,0 +1,52 @@ +;;; rfc6068-tests.el --- Tests for rfc6068.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'rfc6068) + +(ert-deftest rfc6068-unhexify-string () + (should (equal (rfc6068-unhexify-string "hello%20there") "hello there")) + (should (equal (rfc6068-unhexify-string "caf%C3%A9") "café"))) + +(ert-deftest rfc6068-parse-mailto-url () + (should + (equal + (rfc6068-parse-mailto-url "mailto:foo@example.org?subject=Foo&bar=baz") + '(("To" . "foo@example.org") ("Subject" . "Foo") ("Bar" . "baz")))) + (should + (equal + (rfc6068-parse-mailto-url "mailto:foo@bar.com?to=bar@example.org") + '(("To" . "foo@bar.com, bar@example.org")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz") + '(("To" . "foo@bar.com") ("Subject" . "bar baz")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz&to=other@bar.com") + '(("Subject" . "bar baz") ("To" . "foo@bar.com, other@bar.com")))) + (should + (equal (rfc6068-parse-mailto-url "mailto:user@example.org?subject=caf%C3%A9&body=caf%C3%A9") + '(("To" . "user@example.org") ("Subject" . "café") ("Body" . "café"))))) + +(provide 'rfc6068-tests) + +;;; rfc6068-tests.el ends here diff --git a/test/lisp/mail/rmail-tests.el b/test/lisp/mail/rmail-tests.el index f533401496b..826a90455fb 100644 --- a/test/lisp/mail/rmail-tests.el +++ b/test/lisp/mail/rmail-tests.el @@ -32,4 +32,4 @@ 'rmail-edit-current-message)))) (provide 'rmail-tests) -;; rmail-tests.el ends here +;;; rmail-tests.el ends here diff --git a/test/lisp/mail/rmailmm-tests.el b/test/lisp/mail/rmailmm-tests.el index a022008b534..d7b3775d6d0 100644 --- a/test/lisp/mail/rmailmm-tests.el +++ b/test/lisp/mail/rmailmm-tests.el @@ -114,4 +114,4 @@ This is the epilogue. It is also to be ignored.")) (provide 'rmailmm-tests) -;; rmailmm-tests.el ends here +;;; rmailmm-tests.el ends here diff --git a/test/lisp/mail/uudecode-tests.el b/test/lisp/mail/uudecode-tests.el index 6ff767562e3..1899ff50f69 100644 --- a/test/lisp/mail/uudecode-tests.el +++ b/test/lisp/mail/uudecode-tests.el @@ -35,11 +35,11 @@ (defvar uudecode-tests-encoded-str (uudecode-tests-read-file (ert-resource-file "uuencoded.txt")) - "Uuencoded data for bookmark-tests.el + "Uuencoded data for bookmark-tests.el. Same as `uudecode-tests-decoded-str' but uuencoded.") (defvar uudecode-tests-decoded-str (uudecode-tests-read-file (ert-resource-file "uudecoded.txt")) - "Plain text data for bookmark-tests.el + "Plain text data for bookmark-tests.el. Same as `uudecode-tests-encoded-str' but plain text.") (ert-deftest uudecode-tests-decode-region-internal () @@ -50,14 +50,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-internal (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-internal (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str))))) (ert-deftest uudecode-tests-decode-region-external () ;; Write to buffer @@ -68,14 +65,11 @@ Same as `uudecode-tests-encoded-str' but plain text.") (should (equal (buffer-string) uudecode-tests-decoded-str))) ;; Write to file (with-temp-buffer - (let ((tmpfile (make-temp-file "uudecode-tests-"))) - (unwind-protect - (progn - (insert uudecode-tests-encoded-str) - (uudecode-decode-region-external (point-min) (point-max) tmpfile) - (should (equal (uudecode-tests-read-file tmpfile) - uudecode-tests-decoded-str))) - (delete-file tmpfile)))))) + (ert-with-temp-file tmpfile + (insert uudecode-tests-encoded-str) + (uudecode-decode-region-external (point-min) (point-max) tmpfile) + (should (equal (uudecode-tests-read-file tmpfile) + uudecode-tests-decoded-str)))))) (provide 'uudecode-tests) ;;; uudecode-tests.el ends here diff --git a/test/lisp/mh-e/mh-limit-tests.el b/test/lisp/mh-e/mh-limit-tests.el new file mode 100644 index 00000000000..982573d9b49 --- /dev/null +++ b/test/lisp/mh-e/mh-limit-tests.el @@ -0,0 +1,35 @@ +;;; mh-limit-tests.el --- tests for mh-limit.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'mh-limit) + +(ert-deftest mh-pick-args-list () + "Test `mh-pick-args-list'." + (should (equal '() (mh-pick-args-list ""))) + (should (equal '("-subject" "a") (mh-pick-args-list "-subject a"))) + (should (equal '("-subject" "a") (mh-pick-args-list " -subject a "))) + (should (equal '("-subject" "a" "-from" "b") + (mh-pick-args-list "-subject a -from b"))) + (should (equal '("-subject" "a b" "-from" "c d") + (mh-pick-args-list "-subject a b -from c d")))) + +;;; mh-limit-tests.el ends here diff --git a/test/lisp/mh-e/mh-utils-tests.el b/test/lisp/mh-e/mh-utils-tests.el new file mode 100644 index 00000000000..ed979232a41 --- /dev/null +++ b/test/lisp/mh-e/mh-utils-tests.el @@ -0,0 +1,479 @@ +;;; mh-utils-tests.el --- tests for mh-utils.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This test suite runs tests that use and depend on MH programs +;; installed on the system. + +;; When running such tests, MH-E can use a particular MH variant +;; installed on the system, or it can use the mocks provided here. +;; (Setup is done by the `with-mh-test-env' macro.) + +;; By setting environment variable TEST_MH_PATH, you can select which of +;; the installed MH variants to use, or ignore them all and use mocks. +;; See also the script test-all-mh-variants.sh in this directory. + +;; 1. To run these tests against the default MH variant installed on +;; this system: +;; cd ../.. && make lisp/mh-e/mh-utils-tests + +;; 2. To run these tests against an MH variant installed in a +;; specific directory, set TEST_MH_PATH, as in this example: +;; cd ../.. && make lisp/mh-e/mh-utils-tests TEST_MH_PATH=/usr/local/nmh/bin + +;; 3. To search for and run these tests against all MH variants +;; installed on this system: +;; ./test-all-mh-variants.sh + +;; Setting the environment variable TEST_MH_DEBUG or the Lisp variable +;; mh-test-utils-debug-mocks logs access to the file system during the test. + +;;; Code: + +(require 'ert) +(eval-when-compile (require 'cl-lib)) +(require 'mh-utils) + +(ert-deftest mh-quote-pick-expr () + "Test `mh-quote-pick-expr'." + (should (equal nil (mh-quote-pick-expr nil))) + (should (equal '() (mh-quote-pick-expr '()))) + (should (equal '("foo") (mh-quote-pick-expr '("foo")))) + (should (equal '("^\\[foo]?\\*+\\.\\$") + (mh-quote-pick-expr '("^[foo]?*+.$")))) + (should (equal '("^\\[foo]?\\*+\\.\\$" "bar" "baz\\$") + (mh-quote-pick-expr '("^[foo]?*+.$" "bar" "baz$"))))) + +(ert-deftest mh-normalize-folder-name () + "Test `mh-normalize-folder-name'." + (should (equal nil (mh-normalize-folder-name nil))) + (should (equal "+" (mh-normalize-folder-name ""))) + (should (equal "" (mh-normalize-folder-name "" t))) + (should (equal nil (mh-normalize-folder-name "" nil nil t))) + (should (equal nil (mh-normalize-folder-name "+" nil nil t))) + (should (equal nil (mh-normalize-folder-name "+" t t t))) + (should (equal "+inbox" (mh-normalize-folder-name "inbox"))) + (should (equal "+inbox" (mh-normalize-folder-name "+inbox"))) + (should (equal "+inbox" (mh-normalize-folder-name "+inbox/"))) + (should (equal "+inbox/" (mh-normalize-folder-name "+inbox/" t t t))) + (should (equal "+inbox/" (mh-normalize-folder-name "+inbox/" nil t))) + (should (equal "+news" (mh-normalize-folder-name "+inbox////../news"))) + (should (equal "+news" (mh-normalize-folder-name "+inbox////../news/"))) + (should (equal "+news/" + (mh-normalize-folder-name "+inbox////../news/" nil t))) + (should (equal "+inbox/news" (mh-normalize-folder-name "+inbox////./news")))) + + +;; Folder names that are used by the following tests. +(defvar mh-test-rel-folder "rela-folder") +(defvar mh-test-abs-folder "/abso-folder") +(defvar mh-test-no-such-folder "/testdir/none" "A folder that does not exist.") + +(defvar mh-test-utils-variants nil + "The value of `mh-variants' used for these tests. +This variable allows setting `mh-variants' to a limited set for targeted +testing. Its value can be different from the normal value when +environment variable TEST_MH_PATH is set. By remembering the value, we +can log the choice only once, which makes the batch log easier to read.") + +(defvar mh-test-variant-logged-already nil + "Whether `with-mh-test-env' has written the MH variant to the log.") + +(defvar mh-test-utils-debug-mocks (> (length (getenv "TEST_MH_DEBUG")) 0) + "Whether to log detailed behavior of mock functions.") + +(defvar mh-test-call-process-real (symbol-function 'call-process)) +(defvar mh-test-file-directory-p-real (symbol-function 'file-directory-p)) + +;;; The macro with-mh-test-env wraps tests that touch the file system +;;; and/or run programs. + +(defmacro with-mh-test-env (&rest body) + "Evaluate BODY with a test mail environment. +Functions that touch the file system or run MH programs are either +mocked out or pointed at a test tree. Uses `mh-test-utils-setup' to +select which." + (declare (indent 0) (debug t)) + `(cl-letf ((temp-home-dir nil) + ;; make local bindings for things we will modify for test env + (mh-user-path) + (mh-test-abs-folder) + ((symbol-function 'call-process)) + ((symbol-function 'file-directory-p)) + ;; the test always gets its own sub-folders cache + (mh-sub-folders-cache (make-hash-table :test #'equal)) + ;; Allow envvar TEST_MH_PATH to control mh-variants. + (mh-variants mh-test-utils-variants) + ;; remember the original value + (original-mh-test-variant-logged mh-test-variant-logged-already) + (original-mh-path mh-path) + (original-mh-sys-path mh-sys-path) + (original-exec-path exec-path) + (original-mh-variant-in-use mh-variant-in-use) + (original-mh-progs mh-progs) + (original-mh-lib mh-lib) + (original-mh-lib-progs mh-lib-progs) + (original-mh-envvar (getenv "MH"))) + (unwind-protect + (progn + (setq temp-home-dir (mh-test-utils-setup)) + ,@body) + (unless noninteractive + ;; If interactive, forget that we logged the variant and + ;; restore any changes TEST_MH_PATH made. + (setq mh-test-variant-logged-already original-mh-test-variant-logged + mh-path original-mh-path + mh-sys-path original-mh-sys-path + exec-path original-exec-path + mh-variant-in-use original-mh-variant-in-use + mh-progs original-mh-progs + mh-lib original-mh-lib + mh-lib-progs original-mh-lib-progs)) + (if temp-home-dir (delete-directory temp-home-dir t)) + (setenv "MH" original-mh-envvar)))) + +(defun mh-test-utils-setup () + "Set dynamically bound variables needed by mock and/or variants. +Call `mh-variant-set' to look through the directories named by +envionment variable `TEST_MH_PATH' (default: `mh-path' and `mh-sys-path') +to find the MH variant to use, if any. +Return the name of the root of the created directory tree, if any." + (when (getenv "TEST_MH_PATH") + ;; force mh-variants to use only TEST_MH_PATH + (setq mh-path (split-string (getenv "TEST_MH_PATH") path-separator t) + mh-sys-path nil + exec-path '("/bin" "/usr/bin"))) + (unless mh-test-variant-logged-already + (mh-variant-set mh-variant) + (setq mh-test-utils-variants mh-variants) + (setq mh-test-variant-logged-already t)) + (when (native-comp-available-p) + ;; As `call-process'' and `file-directory-p' will be redefined, the + ;; native compiler will invoke `call-process' to compile the + ;; respective trampolines. To avoid interference with the + ;; `call-process' mocking, we build these ahead of time. + (mapc #'comp-subr-trampoline-install '(call-process file-directory-p))) + (if mh-variant-in-use + (mh-test-utils-setup-with-variant) + (mh-test-utils-setup-with-mocks))) + +(defun mh-test-utils-setup-with-mocks () + "Set dynamically bound variables so that MH programs are mocked out. +The tests use this method if no configured MH variant is found." + (setq mh-user-path "/testdir/Mail/") + (mh-populate-sub-folders-cache "+") + (mh-populate-sub-folders-cache "+rela-folder") + (mh-populate-sub-folders-cache "+rela-folder/bar") + (mh-populate-sub-folders-cache "+rela-folder/foo") + (mh-populate-sub-folders-cache "+rela-folder/food") + (fset 'call-process #'mh-test-utils-mock-call-process) + (fset 'file-directory-p #'mh-test-utils-mock-file-directory-p) + ;; no temp directory created + nil) + +(defun mh-test-utils-mock-call-process (program + &optional _infile _destination _display + &rest args) + "A mocked version of `call-process' that calls no processes." + (let ((argument-responses + ;; assoc list of program arguments and lines to output. + '((("folder" "-fast") . ("rela-folder")) + (("folders" "-noheader" "-norecurse" "-nototal") . + ("rela-folder has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+rela-folder") . + ("rela-folder+ has no messages." + "rela-folder/bar has no messages." + "rela-folder/foo has no messages." + "rela-folder/food has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+rela-folder/foo") . + ("rela-folder/foo+ has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+") . + ("+ has no messages.")) + (("folders" "-noheader" "-norecurse" "-nototal" "+/abso-folder") . + ("/abso-folder+ has no messages." + "/abso-folder/bar has no messages." + "/abso-folder/foo has no messages." + "/abso-folder/food has no messages.")) + )) + (arglist (cons (file-name-base program) args))) + (let ((response-list-cons (assoc arglist argument-responses))) + (cond (response-list-cons + (let ((response-list (cdr response-list-cons))) + (when mh-test-utils-debug-mocks + (message "call-process mock arglist %s" arglist) + (message " -> response %S" response-list)) + (while response-list + (insert (car response-list) "\n") + (setq response-list (cdr response-list)))) + 0) + (t + (message "call-process mock unexpected arglist %s" arglist) + 1))))) + +(defun mh-test-utils-mock-file-directory-p (filename) + "A mocked version of `file-directory-p' that does not access the file system." + (let ((directories '("" "/" "/tmp" "/abso-folder" "/abso-folder/foo" + "/testdir/Mail" "/testdir/Mail/rela-folder" + "/testdir/Mail/rela-folder/foo" + "rela-folder" "rela-folder/foo")) + (non-directories '("/abso-folder/fo" "rela-folder/fo" + "/testdir/Mail/rela-folder/fo" + "/testdir/Mail/nosuchfolder" + "/nosuchfolder" "nosuchfolder"))) + (cond ((member (directory-file-name filename) directories) + (when mh-test-utils-debug-mocks + (message "file-directory-p mock: %S -> t" filename)) + t) + ((member (directory-file-name filename) non-directories) + (when mh-test-utils-debug-mocks + (message "file-directory-p mock: %S -> nil" filename)) + nil) + (t + (message "file-directory-p mock unexpected filename: %S" filename) + nil)))) + +(defun mh-test-utils-setup-with-variant () + "Create a temporary directory structure for actual MH programs to read. +Return the name of the root of the created directory tree. +Set dynamically bound variables so that MH programs may log. +The tests use this method if a configured MH variant is found." + (let* ((temp-home-dir + (make-temp-file "emacs-mh-e-unit-test-" t)) + (profile (expand-file-name + ".mh_profile" temp-home-dir)) + (mail-dir (expand-file-name "Mail" temp-home-dir)) + (rela-folder (expand-file-name + "rela-folder" mail-dir)) + (abso-folder (expand-file-name + "abso-folder" temp-home-dir))) + (with-temp-file profile + (insert "Path: " mail-dir "\n" "Welcome: disable\n")) + (setenv "MH" profile) + (make-directory (expand-file-name "bar" rela-folder) t) + (make-directory (expand-file-name "foo" rela-folder) t) + (make-directory (expand-file-name "food" rela-folder) t) + (setq mh-user-path (file-name-as-directory mail-dir)) + (make-directory (expand-file-name "bar" abso-folder) t) + (make-directory (expand-file-name "foo" abso-folder) t) + (make-directory (expand-file-name "food" abso-folder) t) + (setq mh-test-abs-folder abso-folder) + (fset 'call-process #'mh-test-utils-log-call-process) + (fset 'file-directory-p #'mh-test-utils-log-file-directory-p) + temp-home-dir)) + +(defun mh-test-utils-log-call-process (program + &optional infile destination display + &rest args) + "A wrapper around `call-process' that can log the program args and output. +Both args and output are written with `message' if `mh-test-utils-debug-mocks' +is non-nil." + (let (process-output) + (when mh-test-utils-debug-mocks + (message "call-process arglist %s" (cons program args))) + (with-temp-buffer + (apply mh-test-call-process-real program infile destination display args) + (setq process-output (buffer-string))) + (when mh-test-utils-debug-mocks + (message " -> response:\n%s" process-output)) + (insert process-output))) + +(defun mh-test-utils-log-file-directory-p (filename) + "A wrapper around `file-directory-p' that can log calls. +Both FILENAME and the return value are written with `message' +if `mh-test-utils-debug-mocks' is non-nil." + (let ((result (funcall mh-test-file-directory-p-real filename))) + (when mh-test-utils-debug-mocks + (message "file-directory-p: %S -> %s" filename result)) + result)) + + +(ert-deftest mh-sub-folders-actual () + "Test `mh-sub-folders-actual'." + ;; Note that mh-sub-folders-actual expects the folder to have + ;; already been normalized with + ;; (mh-normalize-folder-name folder nil nil t) + (with-mh-test-env + (should (equal + mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders-actual nil))))) + ;; Empty string and "+" not tested since mh-normalize-folder-name + ;; would change them to nil. + (should (equal "foo" + (car (assoc "foo" (mh-sub-folders-actual + (format "+%s" mh-test-rel-folder)))))) + ;; Folder with trailing slash not tested since + ;; mh-normalize-folder-name would strip it. + (should (equal + nil + (mh-sub-folders-actual (format "+%s/foo" mh-test-rel-folder)))) + + (should (equal + (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders-actual (format "+%s" mh-test-abs-folder)))) + + ;; FIXME: mh-sub-folders-actual doesn't (yet) expect to be given a + ;; nonexistent folder. + ;; (should (equal nil + ;; (mh-sub-folders-actual "+nosuchfolder"))) + ;; (should (equal nil + ;; (mh-sub-folders-actual "+/nosuchfolder"))) + )) + +(ert-deftest mh-sub-folders () + "Test `mh-sub-folders'." + (with-mh-test-env + (should (equal mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders nil))))) + (should (equal mh-test-rel-folder + (car (assoc mh-test-rel-folder (mh-sub-folders ""))))) + (should (equal nil + (car (assoc mh-test-no-such-folder (mh-sub-folders + "+"))))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s" mh-test-rel-folder)))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s/" mh-test-rel-folder)))) + (should (equal nil + (mh-sub-folders (format "+%s/foo/" mh-test-rel-folder)))) + (should (equal nil + (mh-sub-folders (format "+%s/foo" mh-test-rel-folder)))) + (should (equal (list (list "bar") (list "foo") (list "food")) + (mh-sub-folders (format "+%s" mh-test-abs-folder)))) + + ;; FIXME: mh-sub-folders doesn't (yet) expect to be given a + ;; nonexistent folder. + ;; (should (equal nil + ;; (mh-sub-folders "+nosuchfolder"))) + ;; (should (equal nil + ;; (mh-sub-folders "+/nosuchfolder"))) + )) + + +(defmacro mh-test-folder-completion-1 (name + nil-expected t-expected lambda-expected) + "Helper for testing `mh-folder-completion-function'. +Ask for completion on NAME three times, with three different +values for the FLAG argument of `mh-folder-completion-function'. +NIL-EXPECTED is the expected value with FLAG nil. +T-EXPECTED is the expected value with FLAG t. +LAMBDA-EXPECTED is the expected value with FLAG lambda." + (declare (debug t)) + `(with-mh-test-env + (mh-test-folder-completion-2 ,nil-expected ;case "a" + (mh-folder-completion-function ,name nil nil)) + (mh-test-folder-completion-2 ,t-expected ;case "b" + (mh-folder-completion-function ,name nil t)) + (mh-test-folder-completion-2 ,lambda-expected ;case "c" + (mh-folder-completion-function ,name nil + 'lambda)))) + +(defmacro mh-test-folder-completion-2 (expected actual) + "Inner helper for testing `mh-folder-completion-function'. +ACTUAL should evaluate to either EXPECTED or to a list containing EXPECTED. +ACTUAL may be evaluated twice, but this gives a clearer error on failure, +and the `should' macro requires idempotent evaluation anyway." + (declare (debug t)) + `(if (and (not (consp ,expected)) (consp ,actual)) + (should (member ,expected ,actual)) + (should (equal ,expected ,actual)))) + + +(ert-deftest mh-folder-completion-function-02-empty () + "Test `mh-folder-completion-function' with empty name." + (mh-test-folder-completion-1 "" "+" (format "%s/" mh-test-rel-folder) nil)) + +(ert-deftest mh-folder-completion-function-03-plus () + "Test `mh-folder-completion-function' with `+'." + (mh-test-folder-completion-1 "+" "+" (format "%s/" mh-test-rel-folder) nil)) + +(ert-deftest mh-folder-completion-function-04-rel-folder () + "Test `mh-folder-completion-function' with `+rela-folder'." + (mh-test-folder-completion-1 (format "+%s" mh-test-rel-folder) + (format "+%s/" mh-test-rel-folder) + (list (format "%s/" mh-test-rel-folder)) + t)) + +(ert-deftest mh-folder-completion-function-05-rel-folder-slash () + "Test `mh-folder-completion-function' with `+rela-folder/'." + (mh-test-folder-completion-1 (format "+%s/" mh-test-rel-folder) + (format "+%s/" mh-test-rel-folder) + (list "bar" "foo" "food") + t)) + +(ert-deftest mh-folder-completion-function-06-rel-folder-slash-foo () + "Test `mh-folder-completion-function' with `+rela-folder/foo'." + (mh-test-folder-completion-1 (format "+%s/foo" mh-test-rel-folder) + (format "+%s/foo" mh-test-rel-folder) + (list "foo" "food") + t) + (with-mh-test-env + (should (equal nil + (mh-folder-completion-function + (format "+%s/fo" mh-test-rel-folder) nil 'lambda))))) + +(ert-deftest mh-folder-completion-function-07-rel-folder-slash-foo-slash () + "Test `mh-folder-completion-function' with `+rela-folder/foo/'." + (mh-test-folder-completion-1 (format "+%s/foo/" mh-test-rel-folder) + nil + nil + t)) + +(ert-deftest mh-folder-completion-function-08-plus-slash () + "Test `mh-folder-completion-function' with `+/'." + :expected-result :failed ;to be fixed in a patch by mkupfer + (mh-test-folder-completion-1 "+/" "+/" "tmp/" nil) + ;; case "bb" + (with-mh-test-env + (should (equal nil + (member (format "+%s/" mh-test-rel-folder) + (mh-folder-completion-function "+/" nil t)))))) + +(ert-deftest mh-folder-completion-function-09-plus-slash-tmp () + "Test `mh-folder-completion-function' with `+/tmp'." + :expected-result :failed ;to be fixed in a patch by mkupfer + (mh-test-folder-completion-1 "+/tmp" "+/tmp" "tmp/" t)) + +(ert-deftest mh-folder-completion-function-10-plus-slash-abs-folder () + "Test `mh-folder-completion-function' with `+/abso-folder'." + (mh-test-folder-completion-1 (format "+%s/" mh-test-abs-folder) + (format "+%s/" mh-test-abs-folder) + (list "bar" "foo" "food") + t)) + +(ert-deftest mh-folder-completion-function-11-plus-slash-abs-folder-slash-foo () + "Test `mh-folder-completion-function' with `+/abso-folder/foo'." + (mh-test-folder-completion-1 (format "+%s/foo" mh-test-abs-folder) + (format "+%s/foo" mh-test-abs-folder) + (list "foo" "food") + t) + (with-mh-test-env + (should (equal nil + (mh-folder-completion-function + (format "+%s/fo" mh-test-abs-folder) nil 'lambda))))) + +(ert-deftest mh-folder-completion-function-12-plus-nosuchfolder () + "Test `mh-folder-completion-function' with `+nosuchfolder'." + (mh-test-folder-completion-1 "+nosuchfolder" nil nil nil)) + +(ert-deftest mh-folder-completion-function-13-plus-slash-nosuchfolder () + "Test `mh-folder-completion-function' with `+/nosuchfolder'." + (mh-test-folder-completion-1 "+/nosuchfolder" nil nil nil)) + +;;; mh-utils-tests.el ends here diff --git a/test/lisp/mh-e/mh-xface-tests.el b/test/lisp/mh-e/mh-xface-tests.el new file mode 100644 index 00000000000..43355810abe --- /dev/null +++ b/test/lisp/mh-e/mh-xface-tests.el @@ -0,0 +1,50 @@ +;;; mh-xface-tests.el --- tests for mh-xface.el -*- lexical-binding: t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'mh-xface) + +(ert-deftest mh-x-image-url-sane-p () + "Test that `mh-x-image-url-sane-p' accepts a URL exactly if it is sane." + (should (equal (mh-x-image-url-sane-p (concat "http://" + (make-string 101 ?a))) + nil)) ;too long + (should (equal (mh-x-image-url-sane-p "http") nil)) ;too short + (should (equal (mh-x-image-url-sane-p "http:") t)) + (should (equal (mh-x-image-url-sane-p "https") nil)) ;too short + (should (equal (mh-x-image-url-sane-p "https:") t)) + (should (equal (mh-x-image-url-sane-p "https://www.example.com/me.png") t)) + (should (equal (mh-x-image-url-sane-p "abcde:") nil))) + +(ert-deftest mh-x-image-url-cache-canonicalize () + "Test `mh-x-image-url-cache-canonicalize'." + (should (equal (format "%s/%s" mh-x-image-cache-directory "%21foo%21bar.png") + (mh-x-image-url-cache-canonicalize "/foo/bar"))) + (should (equal (format "%s/%s" mh-x-image-cache-directory + "http%3A%21%21domain.com%21foo%21bar.png") + (mh-x-image-url-cache-canonicalize + "http://domain.com/foo/bar"))) + ;; All Windows invalid characters. + (should (equal (format "%s/%s" mh-x-image-cache-directory + "%21%3C%3E%3A%2A%3F%22%5C%7C%21bar.png") + (mh-x-image-url-cache-canonicalize "/<>:*?\"\\|/bar")))) + +;;; mh-xface-tests.el ends here diff --git a/test/lisp/mh-e/test-all-mh-variants.sh b/test/lisp/mh-e/test-all-mh-variants.sh new file mode 100755 index 00000000000..e917d8155bc --- /dev/null +++ b/test/lisp/mh-e/test-all-mh-variants.sh @@ -0,0 +1,104 @@ +#! /bin/bash +# Run the mh-utils-tests against all MH variants found on this system. + +# Copyright (C) 2021 Free Software Foundation, Inc. + +# This file is part of GNU Emacs. + +# GNU Emacs is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. + +# GNU Emacs is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. + +# You should have received a copy of the GNU General Public License +# along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +# Commentary: + +# By default runs all tests; test names or Emacs-style regexps may be +# given on the command line to run just those tests. +# +# Option -d turns on Emacs variable mh-test-utils-debug-mocks, which +# causes the tests to output all interactions with the file system. + +# If you want to run the tests for only one MH variant, you don't need +# to use this script, because "make" can do it. See the commentary at +# the top of ./mh-utils-tests.el for the recipe. + +debug= +if [[ "$1" = -* ]]; then + if [[ "$1" != -d ]]; then + echo "Usage: $(basename "$0") [-d] [test ...]" >&2 + exit 2 + fi + debug=t + shift +fi + +shopt -s extglob +ert_test_list=() +for tst; do + # Guess the type the test spec + case $tst in + *[\[\].*+\\]*) # Regexp: put in string quotes + ert_test_list+=("\"$tst\"") + ;; + *) # Lisp expression, keyword, or symbol: use as is + ert_test_list+=("$tst") + ;; + esac +done +if [[ ${#ert_test_list[@]} -eq 0 ]]; then + # t means true for all tests, runs everything + ert_test_list=(t) +fi + +# This script is 3 directories down in the Emacs source tree. +cd "$(dirname "$0")" +cd ../../.. +emacs=(src/emacs --batch -Q) + +# MH-E has a good list of directories where an MH variant might be installed, +# so we look in each of those. +read -r -a mh_sys_path \ + < <("${emacs[@]}" -l mh-e --eval "(princ mh-sys-path)" | sed 's/[()]//g') + +have_done_mocked_variant=false +declare -i tests_total=0 tests_passed=0 + +for path in "${mh_sys_path[@]}"; do + if [[ ! -x "$path/mhparam" ]]; then + if [[ "$have_done_mocked_variant" = false ]]; then + have_done_mocked_variant=true + else + continue + fi + fi + echo "Testing with PATH $path" + ((++tests_total)) + # The LD_LIBRARY_PATH setting is needed + # to run locally installed Mailutils. + TEST_MH_PATH=$path TEST_MH_DEBUG=$debug \ + LD_LIBRARY_PATH=/usr/local/lib HOME=/nonexistent \ + "${emacs[@]}" -l ert \ + --eval "(setq load-prefer-newer t)" \ + --eval "(load \"$PWD/test/lisp/mh-e/mh-utils-tests\" nil t)" \ + --eval "(ert-run-tests-batch-and-exit '(or ${ert_test_list[*]}))" \ + && ((++tests_passed)) +done + +if (( tests_total == 0 )); then + echo "NO tests run" + exit 1 +elif (( tests_total == tests_passed )); then + echo "All tested variants pass: $tests_passed/$tests_total" +else + echo "Tested variants passing: $tests_passed/$tests_total," \ + "FAILING: $((tests_total - tests_passed))/$tests_total" + exit 1 +fi diff --git a/test/lisp/net/browse-url-tests.el b/test/lisp/net/browse-url-tests.el index 898bef8513b..68c7c349013 100644 --- a/test/lisp/net/browse-url-tests.el +++ b/test/lisp/net/browse-url-tests.el @@ -28,6 +28,7 @@ (require 'browse-url) (require 'ert) +(require 'ert-x) (ert-deftest browse-url-tests-browser-kind () (should (eq (browse-url--browser-kind #'browse-url-w3 "gnu.org") @@ -68,11 +69,11 @@ (ert-deftest browse-url-tests-encode-url () (should (equal (browse-url-encode-url "") "")) - (should (equal (browse-url-encode-url "a b c") "a b c")) + (should (equal (browse-url-encode-url "a b c") "a%20b%20c")) (should (equal (browse-url-encode-url "\"a\" \"b\"") - "\"a%22\"b\"")) - (should (equal (browse-url-encode-url "(a) (b)") "(a%29(b)")) - (should (equal (browse-url-encode-url "a$ b$") "a%24b$"))) + "%22a%22%20%22b%22")) + (should (equal (browse-url-encode-url "(a) (b)") "%28a%29%20%28b%29")) + (should (equal (browse-url-encode-url "a$ b$") "a%24%20b%24"))) (ert-deftest browse-url-tests-url-at-point () (with-temp-buffer @@ -87,11 +88,10 @@ "ftp://foo/"))) (ert-deftest browse-url-tests-delete-temp-file () - (let ((browse-url-temp-file-name - (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file browse-url-temp-file-name (browse-url-delete-temp-file) (should-not (file-exists-p browse-url-temp-file-name))) - (let ((file (make-temp-file "browse-url-tests-"))) + (ert-with-temp-file file (browse-url-delete-temp-file file) (should-not (file-exists-p file)))) diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 53c786ada48..cfc380d3029 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -630,16 +630,19 @@ This includes initialization and closing the bus." :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar")) `(dbus-error ,dbus-error-invalid-args "Wrong arguments (foo bar)"))) - ;; Three arguments, D-Bus error activated by `dbus-error' signal. + ;; Three arguments, D-Bus error activated by `dbus-error' + ;; signal. On CentOS, it is not guaranteed which format the + ;; error message arises. (Bug#51369) (should - (equal + (member (should-error (dbus-call-method :session dbus--test-service dbus--test-path dbus--test-interface method1 "foo" "bar" "baz")) - `(dbus-error - ,dbus-error-failed - "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\""))) + `((dbus-error "D-Bus signal" "foo" "bar" "baz") + (dbus-error + ,dbus-error-failed + "D-Bus error: \"D-Bus signal\", \"foo\", \"bar\", \"baz\"")))) ;; Unregister method. (should (dbus-unregister-object registered)) diff --git a/test/lisp/net/netrc-resources/netrc-folding b/test/lisp/net/netrc-resources/netrc-folding new file mode 100644 index 00000000000..85e5e324cdf --- /dev/null +++ b/test/lisp/net/netrc-resources/netrc-folding @@ -0,0 +1,6 @@ +# Foo +machine XM login XL password XP + +machine YM + login YL + password YP diff --git a/test/lisp/net/netrc-tests.el b/test/lisp/net/netrc-tests.el index 1328b191494..f75328a59f7 100644 --- a/test/lisp/net/netrc-tests.el +++ b/test/lisp/net/netrc-tests.el @@ -48,6 +48,13 @@ (should (equal (netrc-credentials "ftp.example.org") '("jrh" "*baz*"))))) +(ert-deftest test-netrc-credentials () + (let ((netrc-file (ert-resource-file "netrc-folding"))) + (should + (equal (netrc-parse netrc-file) + '((("machine" . "XM") ("login" . "XL") ("password" . "XP")) + (("machine" . "YM")) (("login" . "YL")) (("password" . "YP"))))))) + (provide 'netrc-tests) ;;; netrc-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 1a4cc744f0c..8f5bddb71fa 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -128,7 +128,7 @@ (when prev (setq string (concat prev string)) (process-put proc 'previous-string nil))) - (if (and (not (string-match "\n" string)) + (if (and (not (string-search "\n" string)) (> (length string) 0)) (process-put proc 'previous-string string)) (let ((command (split-string string))) @@ -611,7 +611,7 @@ (skip-unless (gnutls-available-p)) (let ((server (make-tls-server 44667)) (times 0) - nowait + (nowait nil) ; Workaround Bug#47080 proc status) (unwind-protect (progn diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el index ed532af657a..bfb83f25184 100644 --- a/test/lisp/net/shr-tests.el +++ b/test/lisp/net/shr-tests.el @@ -67,4 +67,4 @@ (require 'shr) -;;; shr-stream-tests.el ends here +;;; shr-tests.el ends here diff --git a/test/lisp/net/socks-tests.el b/test/lisp/net/socks-tests.el index 71bdd74890a..7fb885235c0 100644 --- a/test/lisp/net/socks-tests.el +++ b/test/lisp/net/socks-tests.el @@ -95,7 +95,7 @@ ;; From fedora.org: 2605:bc80:3010:600:dead:beef:cafe:fed9 ;; 5004 ~~> Version Status (OK) NOOP Addr-Type (4 -> IPv6) (socks-filter proc "\5\0\0\4\x26\x05\xbc\x80\x30\x10\x00\x60") - (ert-info ("State still waiting and response emtpy") + (ert-info ("State still waiting and response empty") (should (eq (process-get proc 'socks-state) socks-state-waiting)) (should-not (process-get proc 'socks-response))) (ert-info ("Scratch field holds partial payload of pending msg") @@ -128,7 +128,7 @@ (defvar socks-tests-canned-server-patterns nil "Alist containing request/response cons pairs to be tried in order. -Vectors must match verbatim. Strings are considered regex patterns.") +Vectors must match verbatim. Strings are considered regex patterns.") (defun socks-tests-canned-server-create () "Create and return a fake SOCKS server." @@ -203,7 +203,7 @@ Vectors must match verbatim. Strings are considered regex patterns.") (should (equal host "example.com")) (list 93 184 216 34))) ((symbol-function 'user-full-name) - (lambda () "foo"))) + (lambda (&optional _) "foo"))) (socks-tests-perform-hello-world-http-request))))) ;; Replace first pattern below with ([5 3 0 1 2] . [5 2]) to validate diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index aac1b13bd0e..98012f4e909 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -923,9 +923,10 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "(progn \ (message \"tramp-archive loaded: %%s\" \ (featurep 'tramp-archive)) \ - (file-attributes %S \"/\") \ + (let ((inhibit-message t)) \ + (file-attributes %S \"/\")) \ (message \"tramp-archive loaded: %%s\" \ - (featurep 'tramp-archive)))")) + (featurep 'tramp-archive))))")) (dolist (default-directory `(,temporary-file-directory ;; Starting Emacs in a directory which has diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 052c03029fd..3d6ce963eef 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -52,6 +52,7 @@ (require 'vc-git) (require 'vc-hg) +(declare-function tramp-check-remote-uname "tramp-sh") (declare-function tramp-find-executable "tramp-sh") (declare-function tramp-get-remote-chmod-h "tramp-sh") (declare-function tramp-get-remote-gid "tramp-sh") @@ -61,6 +62,7 @@ (declare-function tramp-list-tramp-buffers "tramp-cmds") (declare-function tramp-method-out-of-band-p "tramp-sh") (declare-function tramp-smb-get-localname "tramp-smb") +(declare-function dired-compress "dired-aux") (defvar ange-ftp-make-backup-files) (defvar auto-save-file-name-transforms) (defvar lock-file-name-transforms) @@ -68,6 +70,7 @@ (defvar tramp-connection-properties) (defvar tramp-copy-size-limit) (defvar tramp-display-escape-sequence-regexp) +(defvar tramp-fuse-unmount-on-cleanup) (defvar tramp-inline-compress-start-size) (defvar tramp-persistency-file-name) (defvar tramp-remote-path) @@ -177,6 +180,19 @@ The temporary file is not created." (make-temp-name "tramp-test") (if local temporary-file-directory tramp-test-temporary-file-directory)))) +;; Method "smb" supports `make-symbolic-link' only if the remote host +;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el +;; and tramp-sshfs.el do not support symbolic links at all. +(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) + "Run BODY, ignoring \"make-symbolic-link not supported\" file error." + (declare (indent defun) (debug (body))) + `(condition-case err + (progn ,@body) + (file-error + (unless (string-equal (error-message-string err) + "make-symbolic-link not supported") + (signal (car err) (cdr err)))))) + ;; Don't print messages in nested `tramp--test-instrument-test-case' calls. (defvar tramp--test-instrument-test-case-p nil "Whether `tramp--test-instrument-test-case' run. @@ -2070,7 +2086,7 @@ Also see `ignore'." "/method:host:/:/path//foo")) ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 25, occasionally. No idea what's up. + ;; Emacs 25, occasionally. No idea what's up. (when (tramp--test-emacs26-p) (should (string-equal @@ -2759,21 +2775,31 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 (tramp--test-make-temp-name nil quoted)) - (tmp-name2 (expand-file-name "foo/bar" tmp-name1))) + (tmp-name2 (expand-file-name "foo/bar" tmp-name1)) + (unusual-file-mode-1 #o740) + (unusual-file-mode-2 #o710)) (unwind-protect (progn - (make-directory tmp-name1) + (with-file-modes unusual-file-mode-1 + (make-directory tmp-name1)) (should-error (make-directory tmp-name1) :type 'file-already-exists) (should (file-directory-p tmp-name1)) (should (file-accessible-directory-p tmp-name1)) + (when (tramp--test-supports-set-file-modes-p) + (should (equal (format "%#o" unusual-file-mode-1) + (format "%#o" (file-modes tmp-name1))))) (should-error (make-directory tmp-name2) :type 'file-error) - (make-directory tmp-name2 'parents) + (with-file-modes unusual-file-mode-2 + (make-directory tmp-name2 'parents)) (should (file-directory-p tmp-name2)) (should (file-accessible-directory-p tmp-name2)) + (when (tramp--test-supports-set-file-modes-p) + (should (equal (format "%#o" unusual-file-mode-2) + (format "%#o" (file-modes tmp-name2))))) ;; If PARENTS is non-nil, `make-directory' shall not ;; signal an error when DIR exists already. (make-directory tmp-name2 'parents)) @@ -2866,7 +2892,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (file-name-nondirectory tmp-name1) tmp-name2)) (tmp-name4 (expand-file-name "foo" tmp-name1)) (tmp-name5 (expand-file-name "foo" tmp-name2)) - (tmp-name6 (expand-file-name "foo" tmp-name3))) + (tmp-name6 (expand-file-name "foo" tmp-name3)) + (tmp-name7 (tramp--test-make-temp-name nil quoted))) ;; Copy complete directory. (unwind-protect @@ -2922,7 +2949,48 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive) - (delete-directory tmp-name2 'recursive)))))) + (delete-directory tmp-name2 'recursive))) + + ;; Copy symlink to directory. Implemented since Emacs 28.1. + (when (boundp 'copy-directory-create-symlink) + (dolist (copy-directory-create-symlink '(nil t)) + (unwind-protect + (tramp--test-ignore-make-symbolic-link-error + ;; Copy to file name. + (make-directory tmp-name1) + (write-region "foo" nil tmp-name4) + (make-symbolic-link tmp-name1 tmp-name7) + (should (file-directory-p tmp-name1)) + (should (file-exists-p tmp-name4)) + (should (file-symlink-p tmp-name7)) + (copy-directory tmp-name7 tmp-name2) + (if copy-directory-create-symlink + (should + (string-equal + (file-symlink-p tmp-name2) (file-symlink-p tmp-name7))) + (should (file-directory-p tmp-name2))) + ;; Copy to directory name. + (delete-directory tmp-name2 'recursive) + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-directory tmp-name7 (file-name-as-directory tmp-name2)) + (if copy-directory-create-symlink + (should + (string-equal + (file-symlink-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2)) + (file-symlink-p tmp-name7))) + (should + (file-directory-p + (expand-file-name + (file-name-nondirectory tmp-name7) tmp-name2))))) + + ;; Cleanup. + (ignore-errors + (delete-directory tmp-name1 'recursive) + (delete-directory tmp-name2 'recursive) + (delete-directory tmp-name7 'recursive)))))))) (ert-deftest tramp-test16-directory-files () "Check `directory-files'." @@ -3092,7 +3160,20 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (regexp-opt (directory-files tmp-name1)) (length (directory-files tmp-name1))))))) - ;; Check error case. + ;; Check error cases. + (when (and (tramp--test-supports-set-file-modes-p) + ;; With "sshfs", directories with zero file + ;; modes are still "accessible". + (not (tramp--test-sshfs-p)) + ;; A directory is always accessible for user "root". + (not (zerop (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1))))) + (set-file-modes tmp-name1 0) + (with-temp-buffer + (should-error + (insert-directory tmp-name1 nil) + :type 'file-error)) + (set-file-modes tmp-name1 #o777)) (delete-directory tmp-name1 'recursive) (with-temp-buffer (should-error @@ -3266,19 +3347,6 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ignore-errors (kill-buffer buffer)) (ignore-errors (delete-directory tmp-name1 'recursive)))))) -;; Method "smb" supports `make-symbolic-link' only if the remote host -;; has CIFS capabilities. tramp-adb.el, tramp-gvfs.el, tramp-rclone.el -;; and tramp-sshfs.el do not support symbolic links at all. -(defmacro tramp--test-ignore-make-symbolic-link-error (&rest body) - "Run BODY, ignoring \"make-symbolic-link not supported\" file error." - (declare (indent defun) (debug (body))) - `(condition-case err - (progn ,@body) - (file-error - (unless (string-equal (error-message-string err) - "make-symbolic-link not supported") - (signal (car err) (cdr err)))))) - (ert-deftest tramp-test18-file-attributes () "Check `file-attributes'. This tests also `access-file', `file-readable-p', @@ -3318,9 +3386,21 @@ This tests also `access-file', `file-readable-p', (tramp-get-remote-gid tramp-test-vec 'integer))) (delete-file tmp-name1)) + (when (tramp--test-supports-set-file-modes-p) + (write-region "foo" nil tmp-name1) + ;; A file is always accessible for user "root". + (when (not (zerop (tramp-compat-file-attribute-user-id + (file-attributes tmp-name1)))) + (set-file-modes tmp-name1 0) + (should-error + (access-file tmp-name1 "error") + :type 'file-error) + (set-file-modes tmp-name1 #o777)) + (delete-file tmp-name1)) (should-error (access-file tmp-name1 "error") :type tramp-file-missing) + ;; `file-ownership-preserved-p' should return t for ;; non-existing files. (when test-file-ownership-preserved-p @@ -3548,13 +3628,7 @@ They might differ only in time attributes or directory size." "Check `file-modes'. This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." (skip-unless (tramp--test-enabled)) - (skip-unless - (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) - ;; Not all tramp-gvfs.el methods support changing the file mode. - (and - (tramp--test-gvfs-p) - (string-match-p - "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) + (skip-unless (tramp--test-supports-set-file-modes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) @@ -3890,7 +3964,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) (if (tramp--test-smb-p) - ;; The symlink command of `smbclient' detects the + ;; The symlink command of "smbclient" detects the ;; cycle already. (should-error (make-symbolic-link tmp-name1 tmp-name2) @@ -4001,6 +4075,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (ert-deftest tramp-test24-file-acl () "Check that `file-acl' and `set-file-acl' work proper." (skip-unless (tramp--test-enabled)) + ;; The following test checks also whether `set-file-modes' will work. (skip-unless (file-acl tramp-test-temporary-file-directory)) (skip-unless (not (tramp--test-crypt-p))) @@ -4239,12 +4314,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; for completion. We must refill the cache. (tramp-set-connection-property tramp-test-vec "property" nil) - (let ;; This is needed for the `simplified' syntax. - ((method-marker - (if (zerop (length tramp-method-regexp)) - "" tramp-default-method-marker)) - ;; This is needed for the `separate' syntax. - (prefix-format (substring tramp-prefix-format 1)) + (let ;; This is needed for the `separate' syntax. + ((prefix-format (substring tramp-prefix-format 1)) ;; This is needed for the IPv6 host name syntax. (ipv6-prefix (and (string-match-p tramp-ipv6-regexp host) @@ -4260,22 +4331,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (concat prefix-format method tramp-postfix-method-format) (file-name-all-completions (concat prefix-format (substring method 0 1)) "/")))) - ;; Complete host name for default method. With gvfs - ;; based methods, host name will be determined as - ;; host.local, so we omit the test. - (let ((tramp-default-method (or method tramp-default-method))) - (unless (or (zerop (length host)) - (tramp--test-gvfs-p tramp-default-method)) - (should - (member - (concat - prefix-format method-marker tramp-postfix-method-format - ipv6-prefix host ipv6-postfix tramp-postfix-host-format) - (file-name-all-completions - (concat - prefix-format method-marker tramp-postfix-method-format - ipv6-prefix (substring host 0 1)) - "/"))))) ;; Complete host name. (unless (or (zerop (length method)) (zerop (length tramp-method-regexp)) @@ -4388,8 +4443,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `process-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4431,7 +4485,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) (should (zerop (process-file "ls" nil t nil fnnd))) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4439,10 +4493,10 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (string-equal (format "%s\n" fnnd) (buffer-string))) (should-not (get-buffer-window (current-buffer) t)) - ;; Second run. The output must be appended. + ;; Second run. The output must be appended. (goto-char (point-max)) (should (zerop (process-file "ls" nil t t fnnd))) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4455,7 +4509,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-file tmp-name)))))) -;; Must be a command, because used as `sigusr' handler. +;; Must be a command, because used as `sigusr1' handler. (defun tramp--test-timeout-handler (&rest _ignore) "Timeout handler, reporting a failed test." (interactive) @@ -4469,8 +4523,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `start-file-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) @@ -4535,16 +4588,75 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))) + ;; "telnet" and "sshfs" do not cooperate with disabled filter. + (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + (unwind-protect + (with-temp-buffer + (setq proc (start-file-process "test3" (current-buffer) "cat")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (set-process-filter proc t) + (process-send-string proc "foo\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) + ;; No output due to process filter. + (should (= (point-min) (point-max)))) + + ;; Cleanup. + (ignore-errors (delete-process proc)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + (not (tramp-direct-async-process-p)) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (process-connection-type '(nil pipe t pty)) + (unwind-protect + (with-temp-buffer + (setq proc + (start-file-process + (format "test4-%s" process-connection-type) + (current-buffer) "hexdump" "-v" "-e" "/1 \"%02X\n\"")) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (and (memq process-connection-type '(nil pipe)) + (not (tramp--test-macos-p))) + ;; On macOS, there is always newline conversion. + ;; "telnet" converts \r to <CR><NUL> if `crlf' + ;; flag is FALSE. See telnet(1) man page. + "66\n6F\n6F\n0D\\(\n00\\)?\n0A\n" + "66\n6F\n6F\n0A\\(\n00\\)?\n0A\n") + (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))) + ;; PTY. (unwind-protect (with-temp-buffer ;; It works only for tramp-sh.el, and not direct async processes. (if (or (not (tramp--test-sh-p)) (tramp-direct-async-process-p)) (should-error - (start-file-process "test4" (current-buffer) nil) + (start-file-process "test5" (current-buffer) nil) :type 'wrong-type-argument) - (setq proc (start-file-process "test4" (current-buffer) nil)) + (setq proc (start-file-process "test5" (current-buffer) nil)) (should (processp proc)) (should (equal (process-status proc) 'run)) ;; On MS Windows, `process-tty-name' returns nil. @@ -4559,8 +4671,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Define ert test `TEST-direct-async' for direct async processes. If UNSTABLE is non-nil, the test is tagged as `:unstable'." (declare (indent 1)) - ;; `make-process' supports file name handlers since Emacs 27. - (when (let ((file-name-handler-alist '(("" . #'tramp--test-always)))) + ;; `make-process' supports file name handlers since Emacs 27. We + ;; cannot use `tramp--test-always' during compilation of the macro. + (when (let ((file-name-handler-alist '(("" . (lambda (&rest _) t))))) (ignore-errors (make-process :file-handler t))) `(ert-deftest ,(intern (concat (symbol-name test) "-direct-async")) () ,docstring @@ -4589,8 +4702,7 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." "Check `make-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) @@ -4668,6 +4780,30 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) + ;; "telnet" and "sshfs" do not cooperate with disabled filter. + (unless (or (tramp--test-telnet-p) (tramp--test-sshfs-p)) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test3" :buffer (current-buffer) :command '("cat") + :filter t + :file-handler t))) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) + ;; No output due to process filter. + (should (= (point-min) (point-max)))) + + ;; Cleanup. + (ignore-errors (delete-process proc)))) + ;; Process sentinel. (unwind-protect (with-temp-buffer @@ -4693,8 +4829,9 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc))) - ;; Process with stderr buffer. - (unless (tramp-direct-async-process-p) + ;; Process with stderr buffer. "telnet" does not cooperate with + ;; three processes. + (unless (or (tramp--test-telnet-p) (tramp-direct-async-process-p)) (let ((stderr (generate-new-buffer "*stderr*"))) (unwind-protect (with-temp-buffer @@ -4749,7 +4886,57 @@ If UNSTABLE is non-nil, the test is tagged as `:unstable'." ;; Cleanup. (ignore-errors (delete-process proc)) - (ignore-errors (delete-file tmp-name))))))) + (ignore-errors (delete-file tmp-name)))) + + ;; Process connection type. + (when (and (tramp--test-sh-p) + (not (tramp-direct-async-process-p)) + ;; `executable-find' has changed the number of + ;; parameters in Emacs 27.1, so we use `apply' for + ;; older Emacsen. + (ignore-errors + (with-no-warnings + (apply #'executable-find '("hexdump" remote))))) + (dolist (connection-type '(nil pipe t pty)) + ;; `process-connection-type' is taken when + ;; `:connection-type' is nil. + (dolist (process-connection-type + (unless connection-type '(nil pipe t pty))) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name + (format "test7-%s-%s" + connection-type process-connection-type) + :buffer (current-buffer) + :connection-type connection-type + :command '("hexdump" "-v" "-e" "/1 \"%02X\n\"") + :file-handler t))) + (should (processp proc)) + (should (equal (process-status proc) 'run)) + (process-send-string proc "foo\r\n") + (process-send-eof proc) + ;; Read output. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (< (- (point-max) (point-min)) + (length "66\n6F\n6F\n0D\n0A\n")) + (while (accept-process-output proc 0 nil t)))) + (should + (string-match-p + (if (and (memq (or connection-type process-connection-type) + '(nil pipe)) + (not (tramp--test-macos-p))) + ;; On macOS, there is always newline conversion. + ;; "telnet" converts \r to <CR><NUL> if `crlf' + ;; flag is FALSE. See telnet(1) man page. + "66\n6F\n6F\n0D\\(\n00\\)?\n0A\n" + "66\n6F\n6F\n0A\\(\n00\\)?\n0A\n") + (buffer-string)))) + + ;; Cleanup. + (ignore-errors (delete-process proc))))))))) (tramp--test--deftest-direct-async-process tramp-test30-make-process "Check direct async `make-process'.") @@ -4818,11 +5005,11 @@ INPUT, if non-nil, is a string sent to the process." "Check `shell-command'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4846,7 +5033,7 @@ INPUT, if non-nil, is a string sent to the process." this-shell-command (format "ls %s" (file-name-nondirectory tmp-name)) (current-buffer)) - ;; `ls' could produce colorized output. + ;; "ls" could produce colorized output. (goto-char (point-min)) (while (re-search-forward tramp-display-escape-sequence-regexp nil t) @@ -4920,8 +5107,7 @@ INPUT, if non-nil, is a string sent to the process." :tags '(:expensive-test :unstable) (skip-unless (tramp--test-enabled)) (skip-unless nil) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. (skip-unless (tramp--test-emacs27-p)) @@ -5242,11 +5428,11 @@ Use direct async.") "Check that connection-local `explicit-shell-file-name' is set." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -5301,8 +5487,8 @@ Use direct async.") (ert-deftest tramp-test35-exec-path () "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) - (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p))) - (skip-unless (not (tramp--test-crypt-p))) + (skip-unless (tramp--test-supports-processes-p)) + (skip-unless (tramp--test-supports-set-file-modes-p)) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -5323,6 +5509,7 @@ Use direct async.") ;; found. (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) + (set-file-modes tmp-name #o777) (should (file-executable-p tmp-name)) (should @@ -5391,9 +5578,9 @@ Use direct async.") ;; Ignore trailing newline. (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) ;; The shell doesn't handle such long strings. - (unless (<= (length path) - (tramp-get-connection-property - tramp-test-vec "pipe-buf" 4096)) + (when (<= (length path) + (tramp-get-connection-property + tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. (should (string-equal @@ -5767,10 +5954,7 @@ Use direct async.") tramp-allow-unsafe-temporary-files (inhibit-message t) ;; tramp-rclone.el and tramp-sshfs.el cache the mounted files. - (tramp-cleanup-connection-hook - (append - (and (tramp--test-fuse-p) '(tramp-fuse-unmount)) - tramp-cleanup-connection-hook)) + (tramp-fuse-unmount-on-cleanup t) auto-save-default noninteractive) @@ -5950,7 +6134,7 @@ This requires restrictions of file name syntax." 'tramp-ftp-file-name-handler)) (defun tramp--test-crypt-p () - "Check, whether the remote directory is crypted" + "Check, whether the remote directory is crypted." (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) (defun tramp--test-docker-p () @@ -5987,8 +6171,7 @@ If optional METHOD is given, it is checked first." Several special characters do not work properly there." ;; We must refill the cache. `file-truename' does it. (file-truename tramp-test-temporary-file-directory) - (string-match-p - "^HP-UX" (tramp-get-connection-property tramp-test-vec "uname" ""))) + (tramp-check-remote-uname tramp-test-vec "^HP-UX")) (defun tramp--test-ksh-p () "Check, whether the remote shell is ksh. @@ -5999,12 +6182,22 @@ a $'' syntax." (string-match-p "ksh$" (tramp-get-connection-property tramp-test-vec "remote-shell" ""))) +(defun tramp--test-macos-p () + "Check, whether the remote host runs macOS." + ;; We must refill the cache. `file-truename' does it. + (file-truename tramp-test-temporary-file-directory) + (tramp-check-remote-uname tramp-test-vec "Darwin")) + (defun tramp--test-mock-p () "Check, whether the mock method is used. This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-out-of-band-p () + "Check, whether an out-of-band method is used." + (tramp-method-out-of-band-p tramp-test-vec 1)) + (defun tramp--test-rclone-p () "Check, whether the remote host is offered by rclone. This requires restrictions of file name syntax." @@ -6047,6 +6240,12 @@ This requires restrictions of file name syntax." "Check, whether the sudoedit method is used." (tramp-sudoedit-file-name-p tramp-test-temporary-file-directory)) +(defun tramp--test-telnet-p () + "Check, whether the telnet method is used. +This does not support special file names." + (string-equal + "telnet" (file-remote-p tramp-test-temporary-file-directory 'method))) + (defun tramp--test-windows-nt-p () "Check, whether the locale host runs MS Windows." (eq system-type 'windows-nt)) @@ -6054,13 +6253,13 @@ This requires restrictions of file name syntax." (defun tramp--test-windows-nt-and-out-of-band-p () "Check, whether the locale host runs MS Windows and an out-of-band method. This does not support utf8 based file transfer." - (and (eq system-type 'windows-nt) - (tramp-method-out-of-band-p tramp-test-vec 1))) + (and (tramp--test-windows-nt-p) + (tramp--test-out-of-band-p))) (defun tramp--test-windows-nt-or-smb-p () "Check, whether the locale or remote host runs MS Windows. This requires restrictions of file name syntax." - (or (eq system-type 'windows-nt) + (or (tramp--test-windows-nt-p) (tramp--test-smb-p))) (defun tramp--test-smb-p () @@ -6068,6 +6267,22 @@ This requires restrictions of file name syntax." This requires restrictions of file name syntax." (tramp-smb-file-name-p tramp-test-temporary-file-directory)) +(defun tramp--test-supports-processes-p () + "Return whether the method under test supports external processes." + (and (or (tramp--test-adb-p) (tramp--test-sh-p) (tramp--test-sshfs-p)) + (not (tramp--test-crypt-p)))) + +(defun tramp--test-supports-set-file-modes-p () + "Return whether the method under test supports setting file modes." + ;; "smb" does not unless the SMB server supports "posix" extensions. + ;; "adb" does not unless the Android device is rooted. + (or (tramp--test-sh-p) (tramp--test-sshfs-p) (tramp--test-sudoedit-p) + ;; Not all tramp-gvfs.el methods support changing the file mode. + (and + (tramp--test-gvfs-p) + (string-match-p + "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) + (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. @@ -6161,9 +6376,9 @@ This requires restrictions of file name syntax." (kill-buffer buffer) ;; `substitute-in-file-name' could return different - ;; values. For `adb', there could be strange file + ;; values. For "adb", there could be strange file ;; permissions preventing overwriting a file. We don't - ;; care in this testcase. + ;; care in this test case. (dolist (elt files) (let ((file1 (substitute-in-file-name (expand-file-name elt tmp-name1))) @@ -6320,6 +6535,7 @@ This requires restrictions of file name syntax." ;; These tests are inspired by Bug#17238. (ert-deftest tramp-test41-special-characters () "Check special characters in file names." + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 245s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-rsync-p))) (skip-unless (or (tramp--test-emacs26-p) (not (tramp--test-rclone-p)))) @@ -6328,8 +6544,9 @@ This requires restrictions of file name syntax." (ert-deftest tramp-test41-special-characters-with-stat () "Check special characters in file names. -Use the `stat' command." +Use the \"stat\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 287s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6346,8 +6563,9 @@ Use the `stat' command." (ert-deftest tramp-test41-special-characters-with-perl () "Check special characters in file names. -Use the `perl' command." +Use the \"perl\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 266s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6367,8 +6585,9 @@ Use the `perl' command." (ert-deftest tramp-test41-special-characters-with-ls () "Check special characters in file names. -Use the `ls' command." +Use the \"ls\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 287s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) @@ -6434,6 +6653,7 @@ Use the `ls' command." (ert-deftest tramp-test42-utf8 () "Check UTF8 encoding in file names and file contents." + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 620s (skip-unless (tramp--test-enabled)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) @@ -6447,13 +6667,14 @@ Use the `ls' command." (ert-deftest tramp-test42-utf8-with-stat () "Check UTF8 encoding in file names and file contents. -Use the `stat' command." +Use the \"stat\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 595s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6469,13 +6690,14 @@ Use the `stat' command." (ert-deftest tramp-test42-utf8-with-perl () "Check UTF8 encoding in file names and file contents. -Use the `perl' command." +Use the \"perl\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 620s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) ;; We cannot use `tramp-test-vec', because this fails during compilation. @@ -6494,13 +6716,14 @@ Use the `perl' command." (ert-deftest tramp-test42-utf8-with-ls () "Check UTF8 encoding in file names and file contents. -Use the `ls' command." +Use the \"ls\" command." :tags '(:expensive-test) + (skip-unless (not (getenv "EMACS_HYDRA_CI"))) ; SLOW ~ 690s (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-docker-p))) (skip-unless (not (tramp--test-rsync-p))) - (skip-unless (not (tramp--test-windows-nt-and-out-of-band-p))) + (skip-unless (not (tramp--test-out-of-band-p))) ; SLOW (skip-unless (not (tramp--test-ksh-p))) (skip-unless (not (tramp--test-crypt-p))) @@ -6580,12 +6803,14 @@ process sentinels. They shall not disturb each other." :tags (if (getenv "EMACS_EMBA_CI") '(:expensive-test :unstable) '(:expensive-test)) (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-supports-processes-p)) ;; Prior Emacs 27, `shell-file-name' was hard coded as "/bin/sh" for ;; remote processes in Emacs. That doesn't work for tramp-adb.el. - (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) - (tramp--test-sh-p))) - (skip-unless (not (tramp--test-crypt-p))) + (when (tramp--test-adb-p) + (skip-unless (tramp--test-emacs27-p))) (skip-unless (not (tramp--test-docker-p))) + (skip-unless (not (tramp--test-telnet-p))) + (skip-unless (not (tramp--test-sshfs-p))) (skip-unless (not (tramp--test-windows-nt-p))) (with-timeout @@ -6623,11 +6848,6 @@ process sentinels. They shall not disturb each other." (cond ((getenv "EMACS_HYDRA_CI") 10) (t 1))) - ;; We must distinguish due to performance reasons. - (timer-operation - (cond - ((tramp--test-mock-p) #'vc-registered) - (t #'file-attributes))) ;; This is when all timers start. We check inside the ;; timer function, that we don't exceed timeout. (timer-start (current-time)) @@ -6655,6 +6875,8 @@ process sentinels. They shall not disturb each other." (default-directory tmp-name) (file (buffer-name + ;; Use `seq-random-elt' once <26.1 support + ;; is dropped. (nth (random (length buffers)) buffers))) ;; A remote operation in a timer could ;; confuse Tramp heavily. So we ignore this @@ -6663,7 +6885,7 @@ process sentinels. They shall not disturb each other." (cons 'remote-file-error debug-ignored-errors))) (tramp--test-message "Start timer %s %s" file (current-time-string)) - (funcall timer-operation file) + (vc-registered file) (tramp--test-message "Stop timer %s %s" file (current-time-string)) ;; Adjust timer if it takes too much time. @@ -6720,6 +6942,7 @@ process sentinels. They shall not disturb each other." ;; the buffers. Mix with regular operation. (let ((buffers (copy-sequence buffers))) (while buffers + ;; Use `seq-random-elt' once <26.1 support is dropped. (let* ((buf (nth (random (length buffers)) buffers)) (proc (get-buffer-process buf)) (file (process-get proc 'foo)) @@ -6776,8 +6999,40 @@ process sentinels. They shall not disturb each other." ;; (tramp--test--deftest-direct-async-process tramp-test44-asynchronous-requests ;; "Check parallel direct asynchronous requests." 'unstable) +(ert-deftest tramp-test45-dired-compress-file () + "Check that Tramp (un)compresses normal files." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (write-region "foo" nil tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-file tmp-name))) + +(ert-deftest tramp-test45-dired-compress-dir () + "Check that Tramp (un)compresses directories." + (skip-unless (tramp--test-enabled)) + (skip-unless (tramp--test-sh-p)) + (let ((default-directory tramp-test-temporary-file-directory) + (tmp-name (tramp--test-make-temp-name))) + (make-directory tmp-name) + (dired default-directory) + (dired-revert) + (dired-goto-file tmp-name) + (should-not (dired-compress)) + (should (string= (concat tmp-name ".tar.gz") (dired-get-filename))) + (should-not (dired-compress)) + (should (string= tmp-name (dired-get-filename))) + (delete-directory tmp-name))) + ;; This test is inspired by Bug#29163. -(ert-deftest tramp-test45-auto-load () +(ert-deftest tramp-test46-auto-load () "Check that Tramp autoloads properly." ;; If we use another syntax but `default', Tramp is already loaded ;; due to the `tramp-change-syntax' call. @@ -6802,7 +7057,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test45-delay-load () +(ert-deftest tramp-test46-delay-load () "Check that Tramp is loaded lazily, only when needed." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6835,7 +7090,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) -(ert-deftest tramp-test45-recursive-load () +(ert-deftest tramp-test46-recursive-load () "Check that Tramp does not fail due to recursive load." (skip-unless (tramp--test-enabled)) @@ -6859,7 +7114,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) -(ert-deftest tramp-test45-remote-load-path () +(ert-deftest tramp-test46-remote-load-path () "Check that Tramp autoloads its packages with remote `load-path'." ;; The autoloaded Tramp objects are different since Emacs 26.1. We ;; cannot test older Emacsen, therefore. @@ -6888,7 +7143,7 @@ process sentinels. They shall not disturb each other." (mapconcat #'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) -(ert-deftest tramp-test46-unload () +(ert-deftest tramp-test47-unload () "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) @@ -6967,8 +7222,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Revisit expensive tests, once problems in `tramp-error' are solved. -;; * Fix `tramp-test06-directory-file-name' for `ftp'. -;; * Implement `tramp-test31-interrupt-process' for `adb', `sshfs' and +;; * Fix `tramp-test06-directory-file-name' for "ftp". +;; * Implement `tramp-test31-interrupt-process' for "adb", "sshfs" and ;; for direct async processes. ;; * Check, why direct async processes do not work for ;; `tramp-test44-asynchronous-requests'. diff --git a/test/lisp/newcomment-tests.el b/test/lisp/newcomment-tests.el new file mode 100644 index 00000000000..65690e593db --- /dev/null +++ b/test/lisp/newcomment-tests.el @@ -0,0 +1,39 @@ +;;; newcomment-tests.el --- Tests for newcomment.el -*- lexical-binding:t -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest test-uncomment-space-comment-continue () + (let ((comment-style 'multi-line) + (comment-continue " ") + (text " a\n b")) + (should + (equal text + (with-temp-buffer + (c-mode) + (insert text) + (comment-region (point-min) (point-max)) + (uncomment-region (point-min) (point-max)) + (buffer-string)))))) + +;;; newcomment-tests.el ends here diff --git a/test/lisp/mail/rfc2368-tests.el b/test/lisp/obsolete/rfc2368-tests.el index f997ea3ecb4..f997ea3ecb4 100644 --- a/test/lisp/mail/rfc2368-tests.el +++ b/test/lisp/obsolete/rfc2368-tests.el diff --git a/test/lisp/org/org-tests.el b/test/lisp/org/org-tests.el index c1985a46a40..e53b0384081 100644 --- a/test/lisp/org/org-tests.el +++ b/test/lisp/org/org-tests.el @@ -29,3 +29,5 @@ Ref <https://debbugs.gnu.org/30310>." (should (require 'org-version nil t)) (should (equal (version-to-list (org-release)) (cdr (assq 'org package--builtin-versions))))) + +;;; org-tests.el ends here diff --git a/test/lisp/paren-tests.el b/test/lisp/paren-tests.el index c4bec5d86de..11249ee9bc1 100644 --- a/test/lisp/paren-tests.el +++ b/test/lisp/paren-tests.el @@ -117,5 +117,36 @@ (- (point-max) 1) (point-max) nil))))) +(ert-deftest paren-tests-open-paren-line () + (cl-flet ((open-paren-line () + (let* ((data (show-paren--default)) + (here-beg (nth 0 data)) + (there-beg (nth 2 data))) + (blink-paren-open-paren-line-string + (min here-beg there-beg))))) + ;; Lisp-like + (with-temp-buffer + (insert "(defun foo () + (dummy))") + (goto-char (point-max)) + (should (string= "(defun foo ()" (open-paren-line)))) + + ;; C-like + (with-temp-buffer + (insert "int foo() { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo() {" (open-paren-line)))) + + ;; C-like with hanging { + (with-temp-buffer + (insert "int foo() + { + int blah; + }") + (goto-char (point-max)) + (should (string= "int foo()...{" (open-paren-line)))))) + (provide 'paren-tests) ;;; paren-tests.el ends here diff --git a/test/lisp/play/cookie1-tests.el b/test/lisp/play/cookie1-tests.el index 75dea4e5ef0..2dd73d18028 100644 --- a/test/lisp/play/cookie1-tests.el +++ b/test/lisp/play/cookie1-tests.el @@ -37,4 +37,4 @@ (should (= (length (cookie-apropos "false" fortune-file)) 1)))) (provide 'fortune-tests) -;;; fortune-tests.el ends here +;;; cookie1-tests.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el new file mode 100644 index 00000000000..7a3ab5fbda0 --- /dev/null +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -0,0 +1,128 @@ +;;; bug-reference-tests.el --- Tests for bug-reference.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'bug-reference) +(require 'ert) + +(defun test--get-github-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "github.com" 'github "https")) + url) + (match-string 1 url))) + +(defun test--get-gitlab-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitlab.com" 'gitlab "https")) + url) + (match-string 1 url))) + +(defun test--get-gitea-entry (url) + (and (string-match + (car (bug-reference--build-forge-setup-entry + "gitea.com" 'gitea "https")) + url) + (match-string 1 url))) + +(ert-deftest test-github-entry () + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "git@github.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-github-entry "https://github.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitlab-entry () + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "git@gitlab.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitlab-entry "https://gitlab.com/magit/magit/") + "magit/magit"))) + +(ert-deftest test-gitea-entry () + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid.git") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "git@gitea.com:larsmagne/csid") + "larsmagne/csid")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit.git/") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit") + "magit/magit")) + (should + (equal + (test--get-gitea-entry "https://gitea.com/magit/magit/") + "magit/magit"))) + +;;; bug-reference-tests.el ends here diff --git a/test/lisp/progmodes/cperl-mode-resources/grammar.pl b/test/lisp/progmodes/cperl-mode-resources/grammar.pl index c05fd7efc2a..96a86993082 100644 --- a/test/lisp/progmodes/cperl-mode-resources/grammar.pl +++ b/test/lisp/progmodes/cperl-mode-resources/grammar.pl @@ -1,6 +1,7 @@ use 5.024; use strict; use warnings; +use utf8; sub outside { say "Line @{[__LINE__]}: package '@{[__PACKAGE__]}'"; @@ -155,4 +156,17 @@ package :: { Shoved::elsewhere(); +# Finally, try unicode identifiers. +package Erdős::Number; + +sub erdős_number { + my $name = shift; + if ($name eq "Erdős Pál") { + return 0; + } + else { + die "No access to the database. Sorry."; + } +} + 1; diff --git a/test/lisp/progmodes/cperl-mode-resources/here-docs.pl b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl index 8af4625fff3..bb3d4871a91 100644 --- a/test/lisp/progmodes/cperl-mode-resources/here-docs.pl +++ b/test/lisp/progmodes/cperl-mode-resources/here-docs.pl @@ -17,7 +17,7 @@ For each of the HERE documents, the following checks will done: =item * -All occurrences of the string "look-here" are fontified correcty. +All occurrences of the string "look-here" are fontified correctly. Note that we deliberately test the face, not the syntax property: Users won't care for the syntax property, but they see the face. Different implementations with different syntax properties have been diff --git a/test/lisp/progmodes/cperl-mode-tests.el b/test/lisp/progmodes/cperl-mode-tests.el index 4d2bac6ee47..29b9e3f6fb9 100644 --- a/test/lisp/progmodes/cperl-mode-tests.el +++ b/test/lisp/progmodes/cperl-mode-tests.el @@ -154,16 +154,122 @@ point in the distant past, and is still broken in perl-mode. " (should (equal (get-text-property (match-beginning 0) 'face) 'font-lock-keyword-face)))) +(ert-deftest cperl-test-fontify-special-variables () + "Test fontification of variables like $^T or ${^ENCODING}. +These can occur as \"local\" aliases." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (insert "local ($^I, ${^UNICODE});\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (font-lock-ensure) + (search-forward "$") + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (search-forward "$") + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-identify-heredoc () + "Test whether a construct containing \"<<\" followed by a + bareword is properly identified for a here-document if + appropriate." + (let ((here-docs + '("$text .= <<DELIM;" ; mutator concatenating a here-doc + "func($arg) . <<DELIM;" ; concatenating a return value + "func 1, <<DELIM;" ; a function taking two arguments + )) + ;; There forms are currently mishandled in `perl-mode' :-( + (here-docs-cperl + '("print {a} <<DELIM;" ; printing to a file handle + "system $prog <<DELIM;" ; lie about the program's name + )) + (_undecidable + '("foo <<bar") ; could be either "foo() <<bar" + ; or "foo(<<bar)" + )) + (dolist (code (append here-docs (if (eq cperl-test-mode #'cperl-mode) + here-docs-cperl))) + (with-temp-buffer + (insert code "\n\nDELIM\n") + (funcall cperl-test-mode) + (goto-char (point-min)) + (forward-line 1) + ;; We should now be within a here-doc. + (let ((ppss (syntax-ppss))) + (should (and (nth 8 ppss) (nth 4 ppss)))) + )))) + +(ert-deftest cperl-test-identify-no-heredoc () + "Test whether a construct containing \"<<\" which is not a + here-document is properly rejected." + (let ( + (not-here-docs + '("while (<<>>) {" ; double angle bracket operator + "expr <<func();" ; left shift by a return value + "$var <<func;" ; left shift by a return value + "($var+1) <<func;" ; same for an expression + "$hash{key} <<func;" ; same for a hash element + "or $var <<func;" ; same for an expression + "sorted $by <<func" ; _not_ a call to sort + )) + (_undecidable + '("foo <<bar" ; could be either "foo() <<bar" + ; or "foo(<<bar)" + "$foo = <<;") ; empty delim forbidden since 5.28 + )) + (dolist (code not-here-docs) + (with-temp-buffer + (insert code "\n\n") + (funcall cperl-test-mode) + (goto-char (point-min)) + (forward-line 1) + ;; Point is not within a here-doc (nor string nor comment). + (let ((ppss (syntax-ppss))) + (should-not (nth 8 ppss))) + )))) + +(ert-deftest cperl-test-here-doc-missing-end () + "Verify that a missing here-document terminator gives a message. +This message prints the terminator which wasn't found and is only +issued by CPerl mode." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "my $foo = <<HERE\n") + (insert "some text here\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (cperl-find-pods-heres) + (should (string-match "End of here-document [‘'`]HERE[’']" + collected-messages)))) + (ert-with-message-capture collected-messages + (with-temp-buffer + (insert "my $foo = <<HERE . <<'THERE'\n") + (insert "some text here\n") + (insert "HERE\n") + (insert "more text here\n") + (goto-char (point-min)) + (funcall cperl-test-mode) + (cperl-find-pods-heres) + (should (string-match "End of here-document [‘'`]THERE[’']" + collected-messages))))) + (defvar perl-continued-statement-offset) (defvar perl-indent-level) +(defconst cperl--tests-heredoc-face + (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc + 'font-lock-string-face)) +(defconst cperl--tests-heredoc-delim-face + (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc + 'font-lock-constant-face)) + (ert-deftest cperl-test-heredocs () "Test that HERE-docs are fontified with the appropriate face." (require 'perl-mode) (let ((file (ert-resource-file "here-docs.pl")) (cperl-continued-statement-offset perl-continued-statement-offset) - (target-font (if (equal cperl-test-mode 'perl-mode) 'perl-heredoc - 'font-lock-string-face)) (case-fold-search nil)) (with-temp-buffer (insert-file-contents file) @@ -176,7 +282,7 @@ point in the distant past, and is still broken in perl-mode. " (while (search-forward "look-here" nil t) (should (equal (get-text-property (match-beginning 0) 'face) - target-font)) + cperl--tests-heredoc-face)) (beginning-of-line) (should (null (looking-at "[ \t]"))) (forward-line 1))) @@ -205,27 +311,30 @@ the whole string." (and (string-match regexp string) (string= (match-string 0 string) string)))))) -(ert-deftest cperl-test-ws-regexp () +(ert-deftest cperl-test-ws-rx () "Tests capture of very simple regular expressions (yawn)." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '(" " "\t" "\n")) (invalid '("a" " " ""))) - (cperl-test--validate-regexp cperl--ws-regexp + (cperl-test--validate-regexp (rx (eval cperl--ws-rx)) valid invalid))) -(ert-deftest cperl-test-ws-or-comment-regexp () +(ert-deftest cperl-test-ws+-rx () "Tests sequences of whitespace and comment lines." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid `(" " "\t#\n" "\n# \n" ,(concat "# comment\n" "# comment\n" "\n" "#comment\n"))) (invalid '("=head1 NAME\n" ))) - (cperl-test--validate-regexp cperl--ws-or-comment-regexp + (cperl-test--validate-regexp (rx (eval cperl--ws+-rx)) valid invalid))) (ert-deftest cperl-test-version-regexp () "Tests the regexp for recommended syntax of versions in Perl." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '("1" "1.1" "1.1_1" "5.032001" "v120.100.103")) @@ -241,6 +350,7 @@ the whole string." (ert-deftest cperl-test-package-regexp () "Tests the regular expression of Perl package names with versions. Also includes valid cases with whitespace in strange places." + (skip-unless (eq cperl-test-mode #'cperl-mode)) (let ((valid '("package Foo" "package Foo::Bar" @@ -253,9 +363,287 @@ Also includes valid cases with whitespace in strange places." "packageFoo" ; not a package declaration "package Foo1.1" ; invalid package name "class O3D::Sphere"))) ; class not yet supported - (cperl-test--validate-regexp cperl--package-regexp + (cperl-test--validate-regexp (rx (eval cperl--package-rx)) valid invalid))) +(ert-deftest cperl-test-identifier-rx () + "Test valid and invalid identifiers (no sigils)." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((valid + '("foo" "FOO" "f_oo" "a123" + "manĝis")) ; Unicode is allowed! + (invalid + '("$foo" ; no sigils allowed (yet) + "Foo::bar" ; no package qualifiers allowed + "lots_of_€"))) ; € is not alphabetic + (cperl-test--validate-regexp (rx (eval cperl--basic-identifier-rx)) + valid invalid))) + +;;; Test unicode identifier in various places + +(defun cperl--test-unicode-setup (code string) + "Insert CODE, prepare it for tests, and find STRING. +Invoke the appropriate major mode, ensure fontification, and set +point after the first occurrence of STRING (no regexp!)." + (insert code) + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (search-forward string)) + +(ert-deftest cperl-test-unicode-labels () + "Verify that non-ASCII labels are processed correctly." + (with-temp-buffer + (cperl--test-unicode-setup "LABEł: for ($manĝi) { say; }" "LAB") + (should (equal (get-text-property (point) 'face) + 'font-lock-constant-face)))) + +(ert-deftest cperl-test-unicode-sub () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "use strict;\n" ; distinguish bob from b-o-f + "sub ℏ {\n" + " 6.62607015e-34\n" + "};") + "sub ") ; point is before "ℏ" + + ;; Testing fontification + ;; FIXME 2021-09-10: This tests succeeds because cperl-mode + ;; accepts almost anything as a sub name for fontification. For + ;; example, it fontifies "sub @ {...;}" which is a syntax error in + ;; Perl. I let this pass for the moment. + (should (equal (get-text-property (point) 'face) + 'font-lock-function-name-face)) + + ;; Testing `beginning-of-defun'. Not available in perl-mode, + ;; where it jumps to the beginning of the buffer. + (when (eq cperl-test-mode #'cperl-mode) + (goto-char (point-min)) + (search-forward "-34") + (beginning-of-defun) + (should (looking-at "sub"))))) + +(ert-deftest cperl-test-unicode-varname () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "use strict;\n" + "my $π = 3.1415926535897932384626433832795028841971;\n" + "\n" + "my $manĝi = $π;\n" + "__END__\n") + "my $") ; perl-mode doesn't fontify the sigil, so include it here + + ;; Testing fontification + ;; FIXME 2021-09-10: This test succeeds in cperl-mode because the + ;; π character is "not ASCII alphabetic", so it treats $π as a + ;; punctuation variable. The following two `should' forms with a + ;; longer variable name were added for stronger verification. + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + ;; Test both ends of a longer variable name + (search-forward "my $") ; again skip the sigil + (should (equal (get-text-property (point) 'face) + 'font-lock-variable-name-face)) + (search-forward "manĝi") + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-varname-list () + "Verify that all elements of a variable list are fontified." + + (let ((hash-face (if (eq cperl-test-mode #'perl-mode) + 'perl-non-scalar-variable + 'cperl-hash-face)) + (array-face (if (eq cperl-test-mode #'perl-mode) + 'perl-non-scalar-variable + 'cperl-array-face))) + (with-temp-buffer + (cperl--test-unicode-setup + "my (%äsh,@ärräy,$scâlâr);" "%") + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "@") + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "scâlâr") + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face))) + + ;; Now with package-qualified variables + (with-temp-buffer + (cperl--test-unicode-setup + "local (%Søme::äsh,@Søme::ärräy,$Søme::scâlâr);" "%") + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "Søme::") ; test basic identifier + (should (equal (get-text-property (point) 'face) + hash-face)) + (search-forward "@") ; test package name + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "Søme::") ; test basic identifier + (should (equal (get-text-property (point) 'face) + array-face)) + (search-forward "Søme") ; test package name + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face)) + (search-forward "scâlâr") ; test basic identifier + (should (equal (get-text-property (match-beginning 0) 'face) + 'font-lock-variable-name-face)) + (should (equal (get-text-property (1- (match-end 0)) 'face) + 'font-lock-variable-name-face))))) + +(ert-deftest cperl-test-unicode-arrays () + "Test fontification of array access." + ;; Perl mode just looks at the sigil, for element access + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; simple array element + (with-temp-buffer + (cperl--test-unicode-setup + "$ärräy[1] = 7;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array slice + (with-temp-buffer + (cperl--test-unicode-setup + "@ärräy[(1..3)] = (4..6);" "@") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array max index + (with-temp-buffer + (cperl--test-unicode-setup + "$#ärräy = 1;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-array-face))) + ;; array dereference + (with-temp-buffer + (cperl--test-unicode-setup + "@$ärräy = (1,2,3)" "@") + (should (equal (get-text-property (1- (point)) 'face) + 'cperl-array-face)) + (should (equal (get-text-property (1+ (point)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-hashes () + "Test fontification of hash access." + ;; Perl mode just looks at the sigil, for element access + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; simple hash element + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh{'a'} = 7;" "$") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash array slice + (with-temp-buffer + (cperl--test-unicode-setup + "@häsh{(1..3)} = (4..6);" "@") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash subset + (with-temp-buffer + (cperl--test-unicode-setup + "my %hash = %häsh{'a',2,3};" "= %") + (should (equal (get-text-property (point) 'face) + 'cperl-hash-face))) + ;; hash dereference + (with-temp-buffer + (cperl--test-unicode-setup + "%$äsh = (key => 'value');" "%") + (should (equal (get-text-property (1- (point)) 'face) + 'cperl-hash-face)) + (should (equal (get-text-property (1+ (point)) 'face) + 'font-lock-variable-name-face)))) + +(ert-deftest cperl-test-unicode-hashref () + "Verify that a hashref access disambiguates {s}. +CPerl mode takes the token \"s\" as a substitution unless +detected otherwise. Not for perl-mode: it doesn't stringify +bareword hash keys and doesn't recognize a substitution +\"s}foo}bar}\"" + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (cperl--test-unicode-setup "$häshref->{s} # }}" "{") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)) + (should (equal (get-text-property (1+ (point)) 'face) + nil)))) + +(ert-deftest cperl-test-unicode-proto () + ;; perl-mode doesn't fontify prototypes at all + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (with-temp-buffer + (cperl--test-unicode-setup + (concat "sub prötötyped ($) {\n" + " ...;" + "}\n") + "prötötyped (") + + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)))) + +(ert-deftest cperl-test-unicode-fhs () + (with-temp-buffer + (cperl--test-unicode-setup + (concat "while (<BAREWÖRD>) {\n" + " ...;)\n" + "}\n") + "while (<") ; point is before the first char of the handle + ;; Testing fontification + ;; FIXME 2021-09-10: perl-mode.el and cperl-mode.el handle these + ;; completely differently. perl-mode interprets barewords as + ;; constants, cperl-mode does not fontify them. Both treat + ;; non-barewords as globs, which are not fontified by perl-mode, + ;; but fontified as strings in cperl-mode. We keep (and test) + ;; that behavior "as is" because both bareword filehandles and + ;; <glob> syntax are no longer recommended. + (let ((bareword-face + (if (equal cperl-test-mode 'perl-mode) 'font-lock-constant-face + nil))) + (should (equal (get-text-property (point) 'face) + bareword-face))))) + +(ert-deftest cperl-test-unicode-hashkeys () + "Test stringification of bareword hash keys. Not in perl-mode. +perl-mode generally does not stringify bareword hash keys." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + ;; Plain hash key + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh { kéy }" "{ ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face))) + ;; Nested hash key + (with-temp-buffer + (cperl--test-unicode-setup + "$häsh { kéy } { kèy }" "} { ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face))) + ;; Key => value + (with-temp-buffer + (cperl--test-unicode-setup + "( kéy => 'value'," "( ") + (should (equal (get-text-property (point) 'face) + 'font-lock-string-face)))) + +(ert-deftest cperl-test-word-at-point () + "Test whether the function captures non-ASCII words." + (skip-unless (eq cperl-test-mode #'cperl-mode)) + (let ((words '("rôle" "café" "ångström" + "Data::Dump::dump" + "_underscore"))) + (dolist (word words) + (with-temp-buffer + (insert " + ") ; this will be the suffix + (beginning-of-line) + (insert ")") ; A non-word char + (insert word) + (should (string= word (cperl-word-at-point-hard))))))) + ;;; Function test: Building an index for imenu (ert-deftest cperl-test-imenu-index () @@ -279,7 +667,8 @@ created by CPerl mode, so skip it for Perl mode." "Versioned::Package::outer" "lexical" "Versioned::Block::signatured" - "Package::in_package_again"))) + "Package::in_package_again" + "Erdős::Number::erdős_number"))) (dolist (sub expected) (should (assoc-string sub index))))))) @@ -339,6 +728,72 @@ under timeout control." (should (string-match "poop ('foo', \n 'bar')" (buffer-string)))))) +(ert-deftest cperl-test-bug-14343 () + "Verify that inserting text into a HERE-doc string with Elisp +does not break fontification." + (with-temp-buffer + (insert "my $string = <<HERE;\n" + "One line of text.\n" + "Last line of this string.\n" + "HERE\n") + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (search-forward "One line") + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (beginning-of-line) + (insert "Another line if text.\n") + (font-lock-ensure) + (forward-line -1) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face))) + ;; insert into an empty here-document + (with-temp-buffer + (insert "print <<HERE;\n" + "HERE\n") + (funcall cperl-test-mode) + (font-lock-ensure) + (goto-char (point-min)) + (forward-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert a newline into the empty here-document + (goto-char (point-min)) + (forward-line) + (insert "\n") + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert text at the beginning of the here-doc + (goto-char (point-min)) + (forward-line) + (insert "text") + (font-lock-ensure) + (search-backward "text") + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)) + (search-forward "HERE") + (beginning-of-line) + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + ;; Insert a new line immediately before the delimiter + ;; (That's where the point is anyway) + (insert "A new line\n") + (font-lock-ensure) + ;; The delimiter is still the delimiter + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-delim-face)) + (forward-line -1) + ;; The new line has been "added" to the here-document + (should (equal (get-text-property (point) 'face) + cperl--tests-heredoc-face)))) + (ert-deftest cperl-test-bug-16368 () "Verify that `cperl-forward-group-in-re' doesn't hide errors." (skip-unless (eq cperl-test-mode #'cperl-mode)) diff --git a/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts new file mode 100644 index 00000000000..2c0d51edae8 --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/elisp-indents.erts @@ -0,0 +1,88 @@ +Code: + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))) + +Name: defun + +=-= +(defun foo () +"doc" +(+ 1 2)) +=-= +(defun foo () + "doc" + (+ 1 2)) +=-=-= + +Name: function call + +=-= +(foo zot +bar +(zot bar)) +=-= +(foo zot + bar + (zot bar)) +=-=-= + +Name: lisp data + +=-= +( foo zot +bar +(zot bar)) +=-= +( foo zot + bar + (zot bar)) +=-=-= + +Name: defun-space + +=-= +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) +=-=-= + +Name: defvar-keymap + +=-= +(defvar-keymap eww-link-keymap + :copy shr-map + :foo bar + "\r" #'eww-follow-link) +=-=-= + +Name: def-indent1 + +=-= +(defzot-does-not-exist 1 + 2 3) +=-=-= + +Name: def-indent2 + +=-= +(define-keymap 1 + 2 3) +=-=-= + +Name: elisp-indents1 + +=-= +(defvar foo + () + "bar") +=-=-= + +Name: elisp-indents2 + +=-= +(defvar foo () + "bar") +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/flet.erts b/test/lisp/progmodes/elisp-mode-resources/flet.erts new file mode 100644 index 00000000000..da3dcb6ec3e --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/flet.erts @@ -0,0 +1,353 @@ +Name: flet1 + +=-= +(cl-flet () + (a (dangerous-position + b))) +=-=-= + +Name: flet2 + +=-= +(cl-flet wrong-syntax-but-should-not-obstruct-indentation + (a (dangerous-position + b))) +=-=-= + +Name: flet3 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c))) +=-=-= + +Name: flet4 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet5 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet6 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (irregular-local-def (form returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet7 + +=-= +(cl-flet ((a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + wrong-syntax-but-should-not-osbtruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet8 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +;; (setf _) not yet supported but looks like it will be +Name: flet9 + +=-= +(cl-flet (((setf a) (new value) + stuff) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet10 + +=-= +(cl-flet ( (a (arg-of-flet-a) + b + c + (if d + e + f)) + (irregular-local-def (form + returning + lambda)) + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet11 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet12 + +=-= +(cl-flet ( wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i)) + (let ((j k)) + (if dangerous-position + l + m))) +=-=-= + +Name: flet13 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet14 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i) + wrong-syntax-but-should-not-obstruct-indentation)) +=-=-= + +Name: flet15 + +=-= +(cl-flet (wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + wrong-syntax-but-should-not-obstruct-indentation + (g (arg-of--flet-g) + h + i))) +=-=-= + +Name: flet16 + +=-= +(cl-flet ((f (x) + (g x))) + (pcase e + ((dangerous-expression) + (form)))) +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-1 +Code: (lambda () (emacs-lisp-mode) (setq indent-tabs-mode nil) (newline nil t)) +Point-Char: | + +=-= +(let ((x (and y| +=-= +(let ((x (and y + | +=-=-= + +Name: flet-indentation-incomplete-sexp-no-side-effects-2 + +=-= +(let ((x| +=-= +(let ((x + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-1 +Point-Char: | + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-2 +Point-Char: | + +=-= +(cl-flet((f(x)| +=-= +(cl-flet((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-3 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-whitespace-5 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-1 + +=-= +(cl-flet((f (x)| +=-= +(cl-flet((f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-2 + +=-= +(cl-flet ((f(x)| +=-= +(cl-flet ((f(x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-3 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-4 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-5 + +=-= +(cl-flet( (f (x)| +=-= +(cl-flet( (f (x) + | +=-=-= + +Name: flet-indentation-incomplete-sexp-missing-and-excessive-whitespace-6 + +=-= +(cl-flet( (f(x)| +=-= +(cl-flet( (f(x) + | +=-=-= diff --git a/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el new file mode 100644 index 00000000000..9b41fb5426c --- /dev/null +++ b/test/lisp/progmodes/elisp-mode-resources/simple-shorthand-test.el @@ -0,0 +1,40 @@ +;;; simple-shorthand-test.el --- -*- lexical-binding: t; -*- + +(defun f-test () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (with-temp-buffer + (insert "(foo-bar)") + (goto-char (point-min)) + (read (current-buffer))))) + +(defun f-test2 () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (read-from-string "(foo-bar)"))) + + +(defun f-test3 () + (let ((read-symbol-shorthands '(("foo-" . "bar-")))) + (intern "foo-bar"))) + +(defvar f-test-complete-me 42) + +(elisp--foo-test3) + +(defun #_f-test4--- () 84) + +(defmacro f-define-test-5 ()) + +;; should be font locked with both shorthand +;; highlighting _and_ macro highlighting. +(f-define-test-5) + +(when nil + (f-test3) + (f-test2) + (f-test) + (#_f-test4---)) + + +;; Local Variables: +;; read-symbol-shorthands: (("f-" . "elisp--foo-")) +;; End: diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index f47d54e59c0..7f1cd6795ef 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -23,8 +23,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'xref) (eval-when-compile (require 'cl-lib)) +(require 'ert-x) ;;; Completion @@ -300,12 +302,9 @@ ;; tmp may be on a different filesystem to the tests, but, ehh. (defvar xref--case-insensitive - (let ((dir (make-temp-file "xref-test" t))) - (unwind-protect - (progn - (with-temp-file (expand-file-name "hElLo" dir) "hello") - (file-exists-p (expand-file-name "HELLO" dir))) - (delete-directory dir t))) + (ert-with-temp-directory dir + (with-temp-file (expand-file-name "hElLo" dir) "hello") + (file-exists-p (expand-file-name "HELLO" dir))) "Non-nil if file system seems to be case-insensitive.") (defun xref-elisp-test-run (xrefs expected-xrefs) @@ -315,27 +314,27 @@ (expected (pop expected-xrefs)) (expected-xref (or (when (consp expected) (car expected)) expected)) (expected-source (when (consp expected) (cdr expected))) - (xref-file (xref-elisp-location-file (oref xref location))) + (xref-file (xref-elisp-location-file (xref-item-location xref))) (expected-file (xref-elisp-location-file - (oref expected-xref location)))) + (xref-item-location expected-xref)))) ;; Make sure file names compare as strings. (when (file-name-absolute-p xref-file) - (setf (xref-elisp-location-file (oref xref location)) - (file-truename (xref-elisp-location-file (oref xref location))))) + (setf (xref-elisp-location-file (xref-item-location xref)) + (file-truename (xref-elisp-location-file (xref-item-location xref))))) (when (file-name-absolute-p expected-file) - (setf (xref-elisp-location-file (oref expected-xref location)) + (setf (xref-elisp-location-file (xref-item-location expected-xref)) (file-truename (xref-elisp-location-file - (oref expected-xref location))))) + (xref-item-location expected-xref))))) ;; Downcase the filenames for case-insensitive file systems. (when xref--case-insensitive - (setf (xref-elisp-location-file (oref xref location)) - (downcase (xref-elisp-location-file (oref xref location)))) + (setf (xref-elisp-location-file (xref-item-location xref)) + (downcase (xref-elisp-location-file (xref-item-location xref)))) - (setf (xref-elisp-location-file (oref expected-xref location)) + (setf (xref-elisp-location-file (xref-item-location expected-xref)) (downcase (xref-elisp-location-file - (oref expected-xref location))))) + (xref-item-location expected-xref))))) (should (equal xref expected-xref)) @@ -416,8 +415,6 @@ to (xref-elisp-test-descr-to-target xref)." ;; FIXME: defconst -;; FIXME: eieio defclass - ;; Possible ways of defining the default method implementation for a ;; generic function. We declare these here, so we know we cover all ;; cases, and we don't rely on other code not changing. @@ -429,7 +426,7 @@ to (xref-elisp-test-descr-to-target xref)." slot-1) (cl-defgeneric xref-elisp-generic-no-methods (arg1 arg2) - "doc string generic no-methods" + "Doc string generic no-methods." ;; No default implementation, no methods, but fboundp is true for ;; this symbol; it calls cl-no-applicable-method ) @@ -440,44 +437,44 @@ to (xref-elisp-test-descr-to-target xref)." ;; ‘this’. It passes in interactive tests, so I haven't been able to ;; track down the problem. (cl-defmethod xref-elisp-generic-no-default ((this xref-elisp-root-type) arg2) - "doc string generic no-default xref-elisp-root-type" + "Doc string generic no-default xref-elisp-root-type." "non-default for no-default") ;; defgeneric after defmethod in file to ensure the fallback search ;; method of just looking for the function name will fail. (cl-defgeneric xref-elisp-generic-no-default (arg1 arg2) - "doc string generic no-default generic" + "Doc string generic no-default generic." ;; No default implementation; this function calls the cl-generic ;; dispatching code. ) (cl-defgeneric xref-elisp-generic-co-located-default (arg1 arg2) - "doc string generic co-located-default" + "Doc string generic co-located-default." "co-located default") (cl-defmethod xref-elisp-generic-co-located-default ((this xref-elisp-root-type) arg2) - "doc string generic co-located-default xref-elisp-root-type" + "Doc string generic co-located-default xref-elisp-root-type." "non-default for co-located-default") (cl-defgeneric xref-elisp-generic-separate-default (arg1 arg2) - "doc string generic separate-default" + "Doc string generic separate-default." ;; default implementation provided separately ) (cl-defmethod xref-elisp-generic-separate-default (arg1 arg2) - "doc string generic separate-default default" + "Doc string generic separate-default default." "separate default") (cl-defmethod xref-elisp-generic-separate-default ((this xref-elisp-root-type) arg2) - "doc string generic separate-default xref-elisp-root-type" + "Doc string generic separate-default xref-elisp-root-type." "non-default for separate-default") (cl-defmethod xref-elisp-generic-implicit-generic (arg1 arg2) - "doc string generic implicit-generic default" + "Doc string generic implicit-generic default." "default for implicit generic") (cl-defmethod xref-elisp-generic-implicit-generic ((this xref-elisp-root-type) arg2) - "doc string generic implicit-generic xref-elisp-root-type" + "Doc string generic implicit-generic xref-elisp-root-type." "non-default for implicit generic") @@ -604,6 +601,12 @@ to (xref-elisp-test-descr-to-target xref)." 'xref-location-marker nil '(xref-etags-location)) 'cl-defmethod (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) + (xref-make "(cl-defmethod xref-location-marker ((l xref-etags-apropos-location)))" + (xref-make-elisp-location + (cl--generic-load-hist-format + 'xref-location-marker nil '(xref-etags-apropos-location)) + 'cl-defmethod + (expand-file-name "../../../lisp/progmodes/etags.el" emacs-test-dir))) )) (xref-elisp-deftest find-defs-defgeneric-eval @@ -617,35 +620,35 @@ to (xref-elisp-test-descr-to-target xref)." (declare-function xref-elisp-overloadable-no-default-default "elisp-mode-tests") (define-overloadable-function xref-elisp-overloadable-no-methods () - "doc string overloadable no-methods") + "Doc string overloadable no-methods.") (define-overloadable-function xref-elisp-overloadable-no-default () - "doc string overloadable no-default") + "Doc string overloadable no-default.") (define-mode-local-override xref-elisp-overloadable-no-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable no-default c-mode." + "Doc string overloadable no-default c-mode." "result overloadable no-default c-mode.") (define-overloadable-function xref-elisp-overloadable-co-located-default () - "doc string overloadable co-located-default" + "Doc string overloadable co-located-default." "result overloadable co-located-default.") (define-mode-local-override xref-elisp-overloadable-co-located-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable co-located-default c-mode." + "Doc string overloadable co-located-default c-mode." "result overloadable co-located-default c-mode.") (define-overloadable-function xref-elisp-overloadable-separate-default () - "doc string overloadable separate-default.") + "Doc string overloadable separate-default.") (defun xref-elisp-overloadable-separate-default-default () - "doc string overloadable separate-default default" + "Doc string overloadable separate-default default." "result overloadable separate-default.") (define-mode-local-override xref-elisp-overloadable-separate-default c-mode (_start _end &optional _nonterminal _depth _returnonerror) - "doc string overloadable separate-default c-mode." + "Doc string overloadable separate-default c-mode." "result overloadable separate-default c-mode.") (xref-elisp-deftest find-defs-define-overload-no-methods @@ -746,15 +749,11 @@ to (xref-elisp-test-descr-to-target xref)." ;; Source for both variable and defun is "(define-minor-mode ;; compilation-minor-mode". There is no way to tell that directly from ;; the symbol, but we can use (memq sym minor-mode-list) to detect -;; that the symbol is a minor mode. See `elisp--xref-find-definitions' -;; for more comments. -;; -;; IMPROVEME: return defvar instead of defun if source near starting -;; point indicates the user is searching for a variable, not a -;; function. +;; that the symbol is a minor mode. In non-filtering mode we only +;; return the function. (require 'compile) ;; not loaded by default at test time (xref-elisp-deftest find-defs-defun-defvar-el - (elisp--xref-find-definitions 'compilation-minor-mode) + (xref-backend-definitions 'elisp "compilation-minor-mode") (list (cons (xref-make "(defun compilation-minor-mode)" @@ -764,12 +763,27 @@ to (xref-elisp-test-descr-to-target xref)." "(define-minor-mode compilation-minor-mode") )) +;; Returning only defvar because source near point indicates the user +;; is searching for a variable, not a function. +(xref-elisp-deftest find-defs-minor-defvar-c + (with-temp-buffer + (emacs-lisp-mode) + (insert "(foo overwrite-mode") + (xref-backend-definitions 'elisp + (xref-backend-identifier-at-point 'elisp))) + (list + (cons + (xref-make "(defvar overwrite-mode)" + (xref-make-elisp-location 'overwrite-mode 'defvar "src/buffer.c")) + "DEFVAR_PER_BUFFER (\"overwrite-mode\"") + )) + (xref-elisp-deftest find-defs-defvar-el - (elisp--xref-find-definitions 'xref--marker-ring) + (elisp--xref-find-definitions 'xref--history) (list - (xref-make "(defvar xref--marker-ring)" + (xref-make "(defvar xref--history)" (xref-make-elisp-location - 'xref--marker-ring 'defvar + 'xref--history 'defvar (expand-file-name "../../../lisp/progmodes/xref.el" emacs-test-dir))) )) @@ -825,18 +839,6 @@ to (xref-elisp-test-descr-to-target xref)." (insert "?\\N{HEAVY CHECK MARK}") (should (equal (elisp--preceding-sexp) ?\N{HEAVY CHECK MARK})))) -(ert-deftest elisp-indent-basic () - (with-temp-buffer - (emacs-lisp-mode) - (let ((orig "(defun x () - (print (quote ( thingy great - stuff))) - (print (quote (thingy great - stuff))))")) - (insert orig) - (indent-region (point-min) (point-max)) - (should (equal (buffer-string) orig))))) - (defun test--font (form search) (with-temp-buffer (emacs-lisp-mode) @@ -893,5 +895,218 @@ to (xref-elisp-test-descr-to-target xref)." "(\\(when\\)") nil))) +(defmacro elisp-mode-test--with-buffer (text-with-pos &rest body) + "Eval BODY with buffer and variables from TEXT-WITH-POS. +All occurrences of {NAME} are removed from TEXT-WITH-POS and +the remaining text put in a buffer in `elisp-mode'. +Each NAME is then bound to its position in the text during the +evaluation of BODY." + (declare (indent 1)) + (let* ((annot-text (eval text-with-pos t)) + (pieces nil) + (positions nil) + (tlen (length annot-text)) + (ofs 0) + (text-ofs 0)) + (while + (and (< ofs tlen) + (let ((m (string-match (rx "{" (group (+ (not "}"))) "}") + annot-text ofs))) + (and m + (let ((var (intern (match-string 1 annot-text)))) + (push (substring annot-text ofs m) pieces) + (setq text-ofs (+ text-ofs (- m ofs))) + (push (list var (1+ text-ofs)) positions) + (setq ofs (match-end 0)) + t))))) + (push (substring annot-text ofs tlen) pieces) + (let ((text (apply #'concat (nreverse pieces))) + (bindings (nreverse positions))) + `(with-temp-buffer + (ert-info (,text :prefix "text: ") + (emacs-lisp-mode) + (insert ,text) + (let ,bindings . ,body)))))) + +(ert-deftest elisp-mode-with-buffer () + ;; Sanity test of macro, also demonstrating how it works. + (elisp-mode-test--with-buffer + "{a}123{b}45{c}6" + (should (equal a 1)) + (should (equal b 4)) + (should (equal c 6)) + (should (equal (buffer-string) "123456")))) + +(ert-deftest elisp-mode-infer-namespace () + (elisp-mode-test--with-buffer + (concat " ({p1}alphaX {p2}beta {p3}gamma '{p4}delta\n" + " #'{p5}epsilon `{p6}zeta `(,{p7}eta ,@{p8}theta))\n") + (should (equal (elisp--xref-infer-namespace p1) 'function)) + (should (equal (elisp--xref-infer-namespace p2) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p3) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p4) 'any)) + (should (equal (elisp--xref-infer-namespace p5) 'function)) + (should (equal (elisp--xref-infer-namespace p6) 'any)) + (should (equal (elisp--xref-infer-namespace p7) 'variable)) + (should (equal (elisp--xref-infer-namespace p8) 'variable))) + + (elisp-mode-test--with-buffer + (concat "(let ({p1}alpha {p2}beta ({p3}gamma {p4}delta))\n" + " ({p5}epsilon {p6}zeta)\n" + " {p7}eta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'function)) + (should (equal (elisp--xref-infer-namespace p6) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p7) 'variable))) + + (elisp-mode-test--with-buffer + (concat "(let (({p1}alpha {p2}beta)\n" + " ({p3}gamma ({p4}delta {p5}epsilon)))\n" + " ({p6}zeta))\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'function)) + (should (equal (elisp--xref-infer-namespace p5) 'maybe-variable)) + (should (equal (elisp--xref-infer-namespace p6) 'function))) + + (elisp-mode-test--with-buffer + (concat "(defun {p1}alpha () {p2}beta)\n" + "(defface {p3}gamma ...)\n" + "(defvar {p4}delta {p5}epsilon)\n" + "(function {p6}zeta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'function)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'face)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'variable)) + (should (equal (elisp--xref-infer-namespace p6) 'function))) + + (elisp-mode-test--with-buffer + (concat "(require '{p1}alpha)\n" + "(fboundp '{p2}beta)\n" + "(boundp '{p3}gamma)\n" + "(facep '{p4}delta)\n" + "(define-key map [f1] '{p5}epsilon)\n") + (should (equal (elisp--xref-infer-namespace p1) 'feature)) + (should (equal (elisp--xref-infer-namespace p2) 'function)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'face)) + (should (equal (elisp--xref-infer-namespace p5) 'function))) + + (elisp-mode-test--with-buffer + (concat "(list {p1}alpha {p2}beta)\n" + "(progn {p3}gamma {p4}delta)\n" + "(lambda ({p5}epsilon {p6}zeta) {p7}eta)\n") + (should (equal (elisp--xref-infer-namespace p1) 'variable)) + (should (equal (elisp--xref-infer-namespace p2) 'variable)) + (should (equal (elisp--xref-infer-namespace p3) 'variable)) + (should (equal (elisp--xref-infer-namespace p4) 'variable)) + (should (equal (elisp--xref-infer-namespace p5) 'variable)) + (should (equal (elisp--xref-infer-namespace p6) 'variable)) + (should (equal (elisp--xref-infer-namespace p7) 'variable))) + + (elisp-mode-test--with-buffer + (concat "'({p1}alpha {p2}beta\n" + " ({p3}gamma ({p4}delta)))\n") + (should (equal (elisp--xref-infer-namespace p1) 'any)) + (should (equal (elisp--xref-infer-namespace p2) 'any)) + (should (equal (elisp--xref-infer-namespace p3) 'any)) + (should (equal (elisp--xref-infer-namespace p4) 'any)))) + + +(ert-deftest elisp-shorthand-read-buffer () + (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (shorthand-sname (format "s-%s" gsym)) + (expected (intern (format "shorthand-longhand-%s" gsym)))) + (cl-assert (not (intern-soft shorthand-sname))) + (should (equal (let ((read-symbol-shorthands + '(("s-" . "shorthand-longhand-")))) + (with-temp-buffer + (insert shorthand-sname) + (goto-char (point-min)) + (read (current-buffer)))) + expected)) + (should (not (intern-soft shorthand-sname))))) + +(ert-deftest elisp-shorthand-read-from-string () + (let* ((gsym (downcase (symbol-name (cl-gensym "sh-")))) + (shorthand-sname (format "s-%s" gsym)) + (expected (intern (format "shorthand-longhand-%s" gsym)))) + (cl-assert (not (intern-soft shorthand-sname))) + (should (equal (let ((read-symbol-shorthands + '(("s-" . "shorthand-longhand-")))) + (car (read-from-string shorthand-sname))) + expected)) + (should (not (intern-soft shorthand-sname))))) + +(ert-deftest elisp-shorthand-load-a-file () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (mapatoms (lambda (s) + (when (string-match "^elisp--foo-" (symbol-name s)) + (unintern s obarray)))) + (load test-file) + (should (intern-soft "elisp--foo-test")) + (should-not (intern-soft "f-test")))) + +(ert-deftest elisp-shorthand-byte-compile-a-file () + + (let ((test-file (ert-resource-file "simple-shorthand-test.el")) + (byte-compiled (ert-resource-file "simple-shorthand-test.elc"))) + (mapatoms (lambda (s) + (when (string-match "^elisp--foo-" (symbol-name s)) + (unintern s obarray)))) + (byte-compile-file test-file) + (should-not (intern-soft "f-test")) + (should (intern-soft "elisp--foo-test")) + (should-not (fboundp (intern-soft "elisp--foo-test"))) + (load byte-compiled) + (should (intern-soft "elisp--foo-test")) + (should-not (intern-soft "f-test")))) + +(ert-deftest elisp-shorthand-completion-at-point () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (load test-file) + (with-current-buffer (find-file-noselect test-file) + (revert-buffer t t) + (goto-char (point-min)) + (insert "f-test-compl") + (completion-at-point) + (goto-char (point-min)) + (should (search-forward "f-test-complete-me" (line-end-position) t)) + (goto-char (point-min)) + (should (string= (symbol-name (read (current-buffer))) + "elisp--foo-test-complete-me")) + (revert-buffer t t)))) + +(ert-deftest elisp-shorthand-escape () + (let ((test-file (ert-resource-file "simple-shorthand-test.el"))) + (load test-file) + (should (intern-soft "f-test4---")) + (should-not (intern-soft "elisp--foo-test4---")) + (should (= 84 (funcall (intern-soft "f-test4---")))) + (should (unintern "f-test4---")))) + +(ert-deftest elisp-dont-shadow-punctuation-only-symbols () + (let* ((shorthanded-form '(/= 42 (-foo 42))) + (expected-longhand-form '(/= 42 (fooey-foo 42))) + (observed (let ((read-symbol-shorthands + '(("-" . "fooey-")))) + (car (read-from-string + (with-temp-buffer + (print shorthanded-form (current-buffer)) + (buffer-string))))))) + (should (equal observed expected-longhand-form)))) + +(ert-deftest test-indentation () + (ert-test-erts-file (ert-resource-file "elisp-indents.erts")) + (ert-test-erts-file (ert-resource-file "flet.erts") + (lambda () + (emacs-lisp-mode) + (indent-region (point-min) (point-max))))) + (provide 'elisp-mode-tests) ;;; elisp-mode-tests.el ends here diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index 35a2592e76f..32b73f101e1 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'etags) (eval-when-compile (require 'cl-lib)) @@ -95,19 +96,19 @@ (ert-deftest etags-buffer-local-tags-table-list () "Test that a buffer-local value of `tags-table-list' is used." - (let ((file (make-temp-file "etag-test-tmpfile"))) - (unwind-protect - (progn - (set-buffer (find-file-noselect file)) - (fundamental-mode) - (setq-local tags-table-list - (list (expand-file-name "manual/etags/ETAGS.good_3" - etags-tests--test-dir))) - (cl-letf ((tag-tables tags-table-list) - (tags-file-name nil) - ((symbol-function 'read-file-name) - (lambda (&rest _) - (error "We should not prompt the user")))) - (should (visit-tags-table-buffer)) - (should (equal tags-file-name (car tag-tables))))) - (delete-file file)))) + (ert-with-temp-file file + :suffix "etag-test-tmpfile" + (set-buffer (find-file-noselect file)) + (fundamental-mode) + (setq-local tags-table-list + (list (expand-file-name "manual/etags/ETAGS.good_3" + etags-tests--test-dir))) + (cl-letf ((tag-tables tags-table-list) + (tags-file-name nil) + ((symbol-function 'read-file-name) + (lambda (&rest _) + (error "We should not prompt the user")))) + (should (visit-tags-table-buffer)) + (should (equal tags-file-name (car tag-tables)))))) + +;;; etags-tests.el ends here diff --git a/test/lisp/progmodes/flymake-resources/another-problematic-file.c b/test/lisp/progmodes/flymake-resources/another-problematic-file.c new file mode 100644 index 00000000000..03eacdd8011 --- /dev/null +++ b/test/lisp/progmodes/flymake-resources/another-problematic-file.c @@ -0,0 +1,5 @@ +#include "some-problems.h" + +int frob(char* freb) { + return 42; +} diff --git a/test/lisp/progmodes/flymake-resources/some-problems.h b/test/lisp/progmodes/flymake-resources/some-problems.h index 165d8dd525e..86ea2de3b0d 100644 --- a/test/lisp/progmodes/flymake-resources/some-problems.h +++ b/test/lisp/progmodes/flymake-resources/some-problems.h @@ -2,4 +2,6 @@ strange; +int frob(char); + sint main(); diff --git a/test/lisp/progmodes/flymake-tests.el b/test/lisp/progmodes/flymake-tests.el index bda1b663c22..4840018236a 100644 --- a/test/lisp/progmodes/flymake-tests.el +++ b/test/lisp/progmodes/flymake-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'flymake) (eval-when-compile (require 'subr-x)) ; string-trim @@ -60,7 +61,7 @@ (cl-defun flymake-tests--call-with-fixture (fn file &key (severity-predicate nil sev-pred-supplied-p)) - "Call FN after flymake setup in FILE, using `flymake-proc`. + "Call FN after flymake setup in FILE, using `flymake-proc'. SEVERITY-PREDICATE is used to setup `flymake-proc-diagnostic-type-pred'" (let* ((file (expand-file-name file flymake-tests-data-directory)) @@ -109,7 +110,7 @@ SEVERITY-PREDICATE is used to setup (face-at-point))))) (ert-deftest perl-backend () - "Test the perl backend" + "Test the perl backend." (skip-unless (executable-find "perl")) (flymake-tests--with-flymake ("test.pl") (flymake-goto-next-error) @@ -120,25 +121,24 @@ SEVERITY-PREDICATE is used to setup (defvar ruby-mode-hook) (ert-deftest ruby-backend () - "Test the ruby backend" + "Test the ruby backend." (skip-unless (executable-find "ruby")) ;; Some versions of ruby fail if HOME doesn't exist (bug#29187). - (let* ((tempdir (make-temp-file "flymake-tests-ruby" t)) - (process-environment (cons (format "HOME=%s" tempdir) - process-environment)) - ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 - ;; for this particular yuckiness - (abbreviated-home-dir nil)) - (unwind-protect - (let ((ruby-mode-hook - (lambda () - (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) - (flymake-tests--with-flymake ("test.rb") - (flymake-goto-next-error) - (should (eq 'flymake-warning (face-at-point))) - (flymake-goto-next-error) - (should (eq 'flymake-error (face-at-point))))) - (delete-directory tempdir t)))) + (ert-with-temp-directory tempdir + :suffix "flymake-tests-ruby" + (let* ((process-environment (cons (format "HOME=%s" tempdir) + process-environment)) + ;; And see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19657#20 + ;; for this particular yuckiness + (abbreviated-home-dir nil) + (ruby-mode-hook + (lambda () + (setq flymake-diagnostic-functions '(ruby-flymake-simple))))) + (flymake-tests--with-flymake ("test.rb") + (flymake-goto-next-error) + (should (eq 'flymake-warning (face-at-point))) + (flymake-goto-next-error) + (should (eq 'flymake-error (face-at-point))))))) (ert-deftest different-diagnostic-types () "Test GCC warning via function predicate." @@ -193,7 +193,7 @@ SEVERITY-PREDICATE is used to setup (defun flymake-tests--diagnose-words (report-fn type words) - "Helper. Call REPORT-FN with diagnostics for WORDS in buffer." + "Helper. Call REPORT-FN with diagnostics for WORDS in buffer." (funcall report-fn (cl-loop for word in words @@ -234,7 +234,7 @@ SEVERITY-PREDICATE is used to setup (lambda (_report-fn) ;; HACK: Shoosh log during tests (setq-local warning-minimum-log-level :emergency) - (error "crashed")))) + (error "Crashed")))) (insert "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore manha aliqua. Ut enim ad minim veniam, quis nostrud @@ -291,7 +291,7 @@ SEVERITY-PREDICATE is used to setup (should-error (flymake-goto-next-error nil nil t)))))) (ert-deftest recurrent-backend () - "Test a backend that calls REPORT-FN multiple times" + "Test a backend that calls REPORT-FN multiple times." (with-temp-buffer (let (tick) (cl-letf @@ -374,4 +374,4 @@ SEVERITY-PREDICATE is used to setup (provide 'flymake-tests) -;;; flymake.el ends here +;;; flymake-tests.el ends here diff --git a/test/lisp/progmodes/gdb-mi-tests.el b/test/lisp/progmodes/gdb-mi-tests.el index ab482214afb..d66df961b63 100644 --- a/test/lisp/progmodes/gdb-mi-tests.el +++ b/test/lisp/progmodes/gdb-mi-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'gdb-mi) @@ -44,3 +46,5 @@ ) (provide 'gdb-mi-tests) + +;;; gdb-mi-tests.el ends here diff --git a/test/lisp/progmodes/opascal-tests.el b/test/lisp/progmodes/opascal-tests.el index 682f2c6cb6b..ea91479362d 100644 --- a/test/lisp/progmodes/opascal-tests.el +++ b/test/lisp/progmodes/opascal-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'opascal) diff --git a/test/lisp/progmodes/pascal-tests.el b/test/lisp/progmodes/pascal-tests.el index e9c705806b3..f5202143e20 100644 --- a/test/lisp/progmodes/pascal-tests.el +++ b/test/lisp/progmodes/pascal-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (require 'pascal) @@ -61,3 +63,5 @@ (should (equal (point) 15)))) (provide 'pascal-tests) + +;;; pascal-tests.el ends here diff --git a/test/lisp/progmodes/perl-mode-tests.el b/test/lisp/progmodes/perl-mode-tests.el index f63f8ad7253..3f4af5e1f61 100644 --- a/test/lisp/progmodes/perl-mode-tests.el +++ b/test/lisp/progmodes/perl-mode-tests.el @@ -21,6 +21,13 @@ (require 'perl-mode) +(ert-deftest perl-test-lock () + (with-temp-buffer + (perl-mode) + (insert "$package = foo;") + (font-lock-ensure (point-min) (point-max)) + (should (equal (get-text-property 4 'face) 'font-lock-variable-name-face)))) + ;;;; Re-use cperl-mode tests (defvar cperl-test-mode) diff --git a/test/lisp/progmodes/project-tests.el b/test/lisp/progmodes/project-tests.el index 68460a9fa5b..a469414a743 100644 --- a/test/lisp/progmodes/project-tests.el +++ b/test/lisp/progmodes/project-tests.el @@ -29,29 +29,17 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'grep) (require 'xref) -(defmacro project-tests--with-temporary-directory (var &rest body) - "Create a new temporary directory. -Bind VAR to the name of the directory, and evaluate BODY. Delete -the directory after BODY exits." - (declare (debug (symbolp body)) (indent 1)) - (cl-check-type var symbol) - (let ((directory (make-symbol "directory"))) - `(let ((,directory (make-temp-file "project-tests-" :directory))) - (unwind-protect - (let ((,var ,directory)) - ,@body) - (delete-directory ,directory :recursive))))) - (ert-deftest project/quoted-directory () "Check that `project-files' and `project-find-regexp' deal with quoted directory names (Bug#47799)." (skip-unless (executable-find find-program)) (skip-unless (executable-find "xargs")) (skip-unless (executable-find "grep")) - (project-tests--with-temporary-directory directory + (ert-with-temp-directory directory (let ((default-directory directory) (project-current-inhibit-prompt t) (project-find-functions nil) @@ -95,7 +83,7 @@ quoted directory names (Bug#47799)." returned by `project-ignores' if the root directory is a directory name (Bug#48471)." (skip-unless (executable-find find-program)) - (project-tests--with-temporary-directory dir + (ert-with-temp-directory dir (make-empty-file (expand-file-name "some-file" dir)) (make-empty-file (expand-file-name "ignored-file" dir)) (let* ((project (make-project-tests--trivial @@ -107,4 +95,19 @@ directory name (Bug#48471)." collect (file-relative-name file dir)))) (should (equal relative-files '("some-file")))))) +(ert-deftest project-ignores-bug-50240 () + "Check that `project-files' does not ignore all files. +When `project-ignores' includes a name matching project dir." + (skip-unless (executable-find find-program)) + (ert-with-temp-directory dir + (make-empty-file (expand-file-name "some-file" dir)) + (let* ((project (make-project-tests--trivial + :root (file-name-as-directory dir) + :ignores (list (file-name-nondirectory + (directory-file-name dir))))) + (files (project-files project))) + (should (equal files + (list + (expand-file-name "some-file" dir))))))) + ;;; project-tests.el ends here diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index 1af579bb7a4..15bda5c197a 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'python) ;; Dependencies for testing: @@ -48,17 +49,17 @@ BODY is code to be executed within the temp buffer. Point is always located at the beginning of buffer." (declare (indent 1) (debug t)) ;; temp-file never actually used for anything? - `(let* ((temp-file (make-temp-file "python-tests" nil ".py")) - (buffer (find-file-noselect temp-file)) - (python-indent-guess-indent-offset nil)) - (unwind-protect - (with-current-buffer buffer - (python-mode) - (insert ,contents) - (goto-char (point-min)) - ,@body) - (and buffer (kill-buffer buffer)) - (delete-file temp-file)))) + `(ert-with-temp-file temp-file + :suffix "-python.py" + (let ((buffer (find-file-noselect temp-file)) + (python-indent-guess-indent-offset nil)) + (unwind-protect + (with-current-buffer buffer + (python-mode) + (insert ,contents) + (goto-char (point-min)) + ,@body) + (and buffer (kill-buffer buffer)))))) (defun python-tests-look-at (string &optional num restore-point) "Move point at beginning of STRING in the current buffer. @@ -193,7 +194,6 @@ aliqua." (ert-deftest python-syntax-after-python-backspace () ;; `python-indent-dedent-line-backspace' garbles syntax - :expected-result :failed (python-tests-with-temp-buffer "\"\"\"" (goto-char (point-max)) @@ -5283,7 +5283,7 @@ urlpatterns = patterns('', (should (= (current-indentation) 23)))) (or eim (electric-indent-mode -1))))) -(ert-deftest python-triple-quote-pairing () +(ert-deftest python-triple-double-quote-pairing () (let ((epm electric-pair-mode)) (unwind-protect (progn @@ -5310,6 +5310,33 @@ urlpatterns = patterns('', "\"\n\"\"\"\n")))) (or epm (electric-pair-mode -1))))) +(ert-deftest python-triple-single-quote-pairing () + (let ((epm electric-pair-mode)) + (unwind-protect + (progn + (python-tests-with-temp-buffer + "''\n" + (or epm (electric-pair-mode 1)) + (goto-char (1- (point-max))) + (python-tests-self-insert ?') + (should (string= (buffer-string) + "''''''\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "\n" + (python-tests-self-insert (list ?' ?' ?')) + (should (string= (buffer-string) + "''''''\n")) + (should (= (point) 4))) + (python-tests-with-temp-buffer + "'\n''\n" + (goto-char (1- (point-max))) + (python-tests-self-insert ?') + (should (= (point) (1- (point-max)))) + (should (string= (buffer-string) + "'\n'''\n")))) + (or epm (electric-pair-mode -1))))) + ;;; Hideshow support diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index e2ea0d91370..2168b38484e 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -357,7 +357,7 @@ VALUES-PLIST is a list with alternating index and value elements." (let ((ruby-align-chained-calls t)) (ruby-should-indent-buffer "one.two.three - | .four + | .four | |my_array.select { |str| str.size > 5 } | .map { |str| str.downcase }" @@ -875,6 +875,28 @@ VALUES-PLIST is a list with alternating index and value elements." (ruby-mode-set-encoding) (should (string= "# coding: iso-8859-15\nⓇ" (buffer-string)))))) +(ert-deftest ruby-imenu-with-private-modifier () + (ruby-with-temp-buffer + (ruby-test-string + "class Blub + | def hi + | 'Hi!' + | end + | + | def bye + | 'Bye!' + | end + | + | private def hiding + | 'You can't see me' + | end + |end") + (should (equal (mapcar #'car (ruby-imenu-create-index)) + '("Blub" + "Blub#hi" + "Blub#bye" + "Blub#hiding"))))) + (ert-deftest ruby--indent/converted-from-manual-test () :tags '(:expensive-test) ;; Converted from manual test. @@ -886,6 +908,33 @@ VALUES-PLIST is a list with alternating index and value elements." (should (equal (buffer-string) orig)))) (kill-buffer buf)))) +(ert-deftest ruby--test-chained-indentation () + (with-temp-buffer + (ruby-mode) + (setq-local ruby-align-chained-calls t) + (insert "some_variable.where +.not(x: nil) +.where(y: 2) +") + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "some_variable.where + .not(x: nil) + .where(y: 2) +"))) + + (with-temp-buffer + (ruby-mode) + (setq-local ruby-align-chained-calls t) + (insert "some_variable.where.not(x: nil) +.where(y: 2) +") + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "some_variable.where.not(x: nil) + .where(y: 2) +")))) + (provide 'ruby-mode-tests) ;;; ruby-mode-tests.el ends here diff --git a/test/lisp/progmodes/sh-script-tests.el b/test/lisp/progmodes/sh-script-tests.el new file mode 100644 index 00000000000..c21010c8b43 --- /dev/null +++ b/test/lisp/progmodes/sh-script-tests.el @@ -0,0 +1,51 @@ +;;; sh-script-tests.el --- Tests for sh-script.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'sh-script) +(require 'ert) + +(ert-deftest test-sh-script-indentation () + (with-temp-buffer + (insert "relative-path/to/configure --prefix=$prefix\\ + --with-x") + (shell-script-mode) + (goto-char (point-min)) + (forward-line 1) + (indent-for-tab-command) + (should (equal + (buffer-substring-no-properties (point-min) (point-max)) + "relative-path/to/configure --prefix=$prefix\\ + --with-x")))) + +(ert-deftest test-basic-sh-indentation () + (with-temp-buffer + (insert "myecho () {\necho foo\n}\n") + (shell-script-mode) + (indent-region (point-min) (point-max)) + (should (equal (buffer-string) + "myecho () { + echo foo +} +")))) + +;;; sh-script-tests.el ends here diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 21dd0649529..1bbe3a95e90 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -28,6 +28,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) (require 'sql) (ert-deftest sql-tests-postgres-list-databases () @@ -50,7 +51,7 @@ (lambda (_command) t)) ((symbol-function 'process-lines) (lambda (_program &rest _args) - (error "some error")))) + (error "Some error")))) (should-not (sql-postgres-list-databases)))) ;;; Check Connection Password Handling/Wallet @@ -63,52 +64,49 @@ Identify tests by ID. Set :sql-login dialect attribute to LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED string of values passed to the comint function for validation." (declare (indent 2)) - `(cl-letf - ((sql-test-login-params ' ,login-params) - ((symbol-function 'sql-comint-test) - (lambda (product options &optional buf-name) - (with-current-buffer (get-buffer-create buf-name) - (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) - ((symbol-function 'sql-run-test) - (lambda (&optional buffer) - (interactive "P") - (sql-product-interactive 'sqltest buffer))) - (sql-user nil) - (sql-server nil) - (sql-database nil) - (sql-product-alist - '((ansi) - (sqltest - :name "SqlTest" - :sqli-login sql-test-login-params - :sqli-comint-func sql-comint-test))) - (sql-connection-alist - '((,(format "test-%s" id) - ,@connection))) - (sql-password-wallet - (list - (make-temp-file - "sql-test-netrc" nil nil - (mapconcat #'identity - '("machine aMachine user aUserName password \"netrc-A aPassword\"" - "machine aServer user aUserName password \"netrc-B aPassword\"" - "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" - "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" - "machine aDatabase user aUserName password \"netrc-E aPassword\"" - "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" - "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" - ) "\n"))))) - - (let* ((connection ,(format "test-%s" id)) - (buffername (format "*SQL: ERT TEST <%s>*" connection))) - (when (get-buffer buffername) - (kill-buffer buffername)) - (sql-connect connection buffername) - (should (get-buffer buffername)) - (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) - (when (get-buffer buffername) - (kill-buffer buffername)) - (delete-file (car sql-password-wallet))))) + `(ert-with-temp-file tempfile + :suffix "sql-test-netrc" + :text (concat + "machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + "\n") + (cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet (list tempfile))) + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)))))) (ert-deftest sql-test-connect () "Test of basic `sql-connect'." @@ -416,6 +414,16 @@ The ACTION will be tested after set-up of PRODUCT." (kill-buffer "*SQL: exist*"))) +(ert-deftest sql-tests-comint-automatic-password () + (let ((sql-password nil)) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "")) + (should-not (sql-comint-automatic-password "Password: "))) + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password "Password: ")))) + ;; Also, we shouldn't care what the password is - we rely on comint for that. + (let ((sql-password "password")) + (should (equal "password" (sql-comint-automatic-password ""))))) (provide 'sql-tests) ;;; sql-tests.el ends here diff --git a/test/lisp/progmodes/xref-tests.el b/test/lisp/progmodes/xref-tests.el index d29452243b2..b1de1a4df5a 100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@ -52,6 +52,14 @@ (should (string-match-p "file1\\.txt\\'" (xref-location-group (nth 0 locs)))) (should (string-match-p "file2\\.txt\\'" (xref-location-group (nth 1 locs)))))) +(ert-deftest xref-matches-in-directory-filters-with-ignores () + (let ((locs (xref-matches-in-directory "bar" "*" xref-tests--data-dir + '("./file1.*")))) + (should (= 1 (length locs))) + (should (string-match-p "file2\\.txt\\'" (xref-location-group + (xref-item-location + (nth 0 locs))))))) + (ert-deftest xref-matches-in-directory-finds-two-matches-on-the-same-line () (let ((locs (xref-tests--locations-in-data-dir "foo"))) (should (= 2 (length locs))) @@ -120,8 +128,12 @@ (let ((xref-file-name-display 'abs)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + nil)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list (concat xref-tests--data-dir "file1.txt") (concat xref-tests--data-dir "file2.txt")))))) @@ -129,8 +141,12 @@ (ert-deftest xref--xref-file-name-display-is-nondirectory () (let ((xref-file-name-display 'nondirectory)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + nil)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list "file1.txt" "file2.txt"))))) @@ -138,13 +154,15 @@ (ert-deftest xref--xref-file-name-display-is-relative-to-project-root () (let* ((data-parent-dir (file-name-directory (directory-file-name xref-tests--data-dir))) - (project-find-functions - (lambda (_) (cons 'transient data-parent-dir))) (xref-file-name-display 'project-relative)) (should (equal (delete-dups - (mapcar 'xref-location-group - (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) + (mapcar + (lambda (loc) + (xref--group-name-for-display + (xref-location-group loc) + data-parent-dir)) + (xref-tests--locations-in-data-dir "\\(bar\\|foo\\)"))) (list "xref-resources/file1.txt" "xref-resources/file2.txt"))))) diff --git a/test/lisp/ps-print-tests.el b/test/lisp/ps-print-tests.el index b25e88622d8..d468911dd3d 100644 --- a/test/lisp/ps-print-tests.el +++ b/test/lisp/ps-print-tests.el @@ -34,3 +34,5 @@ (autoloadp (symbol-function 'ps-mule-initialize)))) + +;;; ps-print-tests.el ends here diff --git a/test/lisp/repeat-tests.el b/test/lisp/repeat-tests.el new file mode 100644 index 00000000000..a1f9bbb1739 --- /dev/null +++ b/test/lisp/repeat-tests.el @@ -0,0 +1,111 @@ +;;; repeat-tests.el --- Tests for repeat.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; Author: Juri Linkov <juri@linkov.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'repeat) + +(defvar repeat-tests-calls nil) + +(defun repeat-tests-call-a (&optional arg) + (interactive "p") + (push `(,arg a) repeat-tests-calls)) + +(defun repeat-tests-call-b (&optional arg) + (interactive "p") + (push `(,arg b) repeat-tests-calls)) + +(defvar repeat-tests-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-x w a") 'repeat-tests-call-a) + map) + "Keymap for keys that initiate repeating sequences.") + +(defvar repeat-tests-repeat-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'repeat-tests-call-a) + (define-key map "b" 'repeat-tests-call-b) + map) + "Keymap for repeating sequences.") +(put 'repeat-tests-call-a 'repeat-map 'repeat-tests-repeat-map) +(put 'repeat-tests-call-b 'repeat-map 'repeat-tests-repeat-map) + +(defmacro with-repeat-mode (&rest body) + "Create environment for testing `repeat-mode'." + `(unwind-protect + (progn + (repeat-mode +1) + (with-temp-buffer + (save-window-excursion + ;; `execute-kbd-macro' applied to window only + (set-window-buffer nil (current-buffer)) + (use-local-map repeat-tests-map) + ,@body))) + (repeat-mode -1))) + +(defun repeat-tests--check (keys calls inserted) + (setq repeat-tests-calls nil) + (delete-region (point-min) (point-max)) + (execute-kbd-macro (kbd keys)) + (should (equal (nreverse repeat-tests-calls) calls)) + ;; Check for self-inserting keys + (should (equal (buffer-string) inserted))) + +(ert-deftest repeat-tests-exit-key () + (with-repeat-mode + (let ((repeat-echo-function 'ignore)) + (let ((repeat-exit-key nil)) + (repeat-tests--check + "C-x w a b a b RET c" + '((1 a) (1 b) (1 a) (1 b)) "\nc")) + (let ((repeat-exit-key [return])) + (repeat-tests--check + "C-x w a b a b <return> c" + '((1 a) (1 b) (1 a) (1 b)) "c"))))) + +(ert-deftest repeat-tests-keep-prefix () + (with-repeat-mode + (let ((repeat-echo-function 'ignore)) + (repeat-tests--check + "C-x w a b a b c" + '((1 a) (1 b) (1 a) (1 b)) "c") + (let ((repeat-keep-prefix nil)) + (repeat-tests--check + "C-2 C-x w a b a b c" + '((2 a) (1 b) (1 a) (1 b)) "c") + (repeat-tests--check + "C-2 C-x w a C-3 c" + '((2 a)) "ccc")) + ;; TODO: fix and uncomment + ;; (let ((repeat-keep-prefix t)) + ;; (repeat-tests--check + ;; "C-2 C-x w a b a b c" + ;; '((2 a) (2 b) (2 a) (2 b)) "c") + ;; (repeat-tests--check + ;; "C-2 C-x w a C-1 C-2 b a C-3 C-4 b c" + ;; '((2 a) (12 b) (12 a) (34 b)) "c")) + ))) + +;; TODO: :tags '(:expensive-test) for repeat-exit-timeout + +(provide 'repeat-tests) +;;; repeat-tests.el ends here diff --git a/test/lisp/saveplace-tests.el b/test/lisp/saveplace-tests.el index 17199ed443a..190ffb78288 100644 --- a/test/lisp/saveplace-tests.el +++ b/test/lisp/saveplace-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'ert-x) (require 'saveplace) @@ -39,49 +41,42 @@ (ert-deftest saveplace-test-save-place-to-alist/file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile (file-truename tmpfile)) - (save-place-alist nil) - (save-place-loaded t) - (loc tmpfile) - (pos 4)) - (unwind-protect - (save-window-excursion - (find-file loc) - (insert "abc") ; must insert something - (save-place-to-alist) - (should (equal save-place-alist (list (cons tmpfile pos))))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + (let* ((tmpfile (file-truename tmpfile)) + (save-place-alist nil) + (save-place-loaded t) + (loc tmpfile) + (pos 4)) + (save-window-excursion + (find-file loc) + (insert "abc") ; must insert something + (save-place-to-alist) + (should (equal save-place-alist (list (cons tmpfile pos)))))))) (ert-deftest saveplace-test-forget-unreadable-files () (save-place-mode) - (let* ((save-place-loaded t) - (tmpfile (make-temp-file "emacs-test-saveplace-")) - (alist-orig (list (cons "/this/file/does/not/exist" 10) - (cons tmpfile 1917))) - (save-place-alist alist-orig)) - (unwind-protect - (progn - (save-place-forget-unreadable-files) - (should (equal save-place-alist (cdr alist-orig)))) - (delete-file tmpfile)))) + (ert-with-temp-file tmpfile + :suffix "-saveplace" + (let* ((save-place-loaded t) + (alist-orig (list (cons "/this/file/does/not/exist" 10) + (cons tmpfile 1917))) + (save-place-alist alist-orig)) + (save-place-forget-unreadable-files) + (should (equal save-place-alist (cdr alist-orig)))))) (ert-deftest saveplace-test-place-alist-to-file () (save-place-mode) - (let* ((tmpfile (make-temp-file "emacs-test-saveplace-")) - (tmpfile2 (make-temp-file "emacs-test-saveplace-")) - (save-place-file tmpfile) - (save-place-alist (list (cons tmpfile2 99)))) - (unwind-protect - (progn (save-place-alist-to-file) - (setq save-place-alist nil) - (save-window-excursion - (find-file save-place-file) - (unwind-protect - (should (string-match tmpfile2 (buffer-string))) - (kill-buffer)))) - (delete-file tmpfile) - (delete-file tmpfile2)))) + (ert-with-temp-file tmpfile + (ert-with-temp-file tmpfile2 + (let* ((save-place-file tmpfile) + (save-place-alist (list (cons tmpfile2 99)))) + (save-place-alist-to-file) + (setq save-place-alist nil) + (save-window-excursion + (find-file save-place-file) + (unwind-protect + (should (string-match tmpfile2 (buffer-string))) + (kill-buffer))))))) (ert-deftest saveplace-test-load-alist-from-file () (save-place-mode) diff --git a/test/lisp/ses-tests.el b/test/lisp/ses-tests.el index 04f255dcd4c..9a7fb502d7c 100644 --- a/test/lisp/ses-tests.el +++ b/test/lisp/ses-tests.el @@ -175,3 +175,5 @@ to `ses--bar' and inserting a row, makes A2 value empty, and `ses--bar' equal to (provide 'ses-tests) + +;;; ses-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index c571dc3e14b..1ab539f3e42 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -664,7 +664,29 @@ guaranteed by the originator of a cluster definition." (should (member (format "/%s:%s" cluster2 (file-local-name file2)) (car shadow-literal-groups))) ;; Bug#49596. - (should (member (concat primary file1) (car shadow-literal-groups)))) + (should (member (concat primary file1) (car shadow-literal-groups))) + + ;; Error handling. + (setq shadow-literal-groups nil) + ;; There's no `buffer-file-name'. + (with-temp-buffer + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups) + ;; Define an empty literal group. + (setq mocked-input `(,(kbd "RET"))) + (with-temp-buffer + (set-visited-file-name file1) + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups) + ;; Use a non-existing site name. + (setq mocked-input `("foo" ,(kbd "RET"))) + (with-temp-buffer + (set-visited-file-name file1) + (call-interactively #'shadow-define-literal-group) + (set-buffer-modified-p nil)) + (should-not shadow-literal-groups)) ;; Cleanup. (shadow--tests-cleanup)))) diff --git a/test/lisp/shell-tests.el b/test/lisp/shell-tests.el index 223a18590b1..342b421911f 100644 --- a/test/lisp/shell-tests.el +++ b/test/lisp/shell-tests.el @@ -1,4 +1,4 @@ -;;; shell-tests.el -*- lexical-binding:t -*- +;;; shell-tests.el --- Tests for shell.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2021 Free Software Foundation, Inc. diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index 4b153d117f0..742da0bde59 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -959,6 +959,17 @@ See Bug#21722." (with-shell-command-dont-erase-buffer str output-buffer-is-current (should (= (point) (alist-get shell-command-dont-erase-buffer expected-point))))))) +(ert-deftest test-undo-region () + (with-temp-buffer + (insert "This is a test\n") + (goto-char (point-min)) + (setq buffer-undo-list nil) + (downcase-word 1) + (should (= (length (delq nil (undo-make-selective-list 1 9))) 2)) + (should (= (length (delq nil (undo-make-selective-list 4 9))) 1)) + ;; FIXME this is the off-by-one error case. + ;;(should (= (length (delq nil (undo-make-selective-list 5 9))) 0)) + (should (= (length (delq nil (undo-make-selective-list 6 9))) 0)))) (provide 'simple-test) -;;; simple-test.el ends here +;;; simple-tests.el ends here diff --git a/test/lisp/so-long-tests/so-long-tests-helpers.el b/test/lisp/so-long-tests/so-long-tests-helpers.el index ab4d9c6c137..f542806ac16 100644 --- a/test/lisp/so-long-tests/so-long-tests-helpers.el +++ b/test/lisp/so-long-tests/so-long-tests-helpers.el @@ -43,7 +43,8 @@ (cl-case action ('so-long-mode (should (eq major-mode 'so-long-mode)) - (so-long-tests-assert-overrides)) + (so-long-tests-assert-overrides) + (so-long-tests-assert-preserved)) ('so-long-minor-mode (should (eq so-long-minor-mode t)) (so-long-tests-assert-overrides)) @@ -62,7 +63,8 @@ (cl-case action ('so-long-mode (should-not (eq major-mode 'so-long-mode)) - (so-long-tests-assert-overrides-reverted)) + (so-long-tests-assert-overrides-reverted) + (so-long-tests-assert-preserved)) ('so-long-minor-mode (should-not (eq so-long-minor-mode t)) (so-long-tests-assert-overrides-reverted)) @@ -90,11 +92,22 @@ (when (boundp (car ovar)) (should (equal (symbol-value (car ovar)) (cdr ovar)))))) +(defun so-long-tests-assert-preserved () + "Assert that preserved modes and variables have their expected values." + (dolist (var so-long-mode-preserved-variables) + (when (boundp var) + (should (equal (symbol-value var) + (alist-get var so-long-tests-memory))))) + (dolist (mode so-long-mode-preserved-minor-modes) + (when (boundp mode) + (should (equal (symbol-value mode) + (alist-get mode so-long-tests-memory)))))) + (defun so-long-tests-remember () "Remember the original states of modes and variables. -Call this after setting up a buffer in the normal (not so-long) -state for its major mode, so that after triggering a so-long +Call this after setting up a buffer in the normal (not `so-long') +state for its major mode, so that after triggering a `so-long' action we can call `so-long-revert' and compare the reverted state against this remembered state." (setq so-long-tests-memory nil) @@ -107,7 +120,22 @@ state against this remembered state." (dolist (mode so-long-minor-modes) (when (boundp mode) (push (cons mode (symbol-value mode)) + so-long-tests-memory))) + (dolist (var so-long-mode-preserved-variables) + (when (boundp var) + (push (cons var (symbol-value var)) + so-long-tests-memory))) + (dolist (mode so-long-mode-preserved-minor-modes) + (when (boundp mode) + (push (cons mode (symbol-value mode)) so-long-tests-memory)))) +(defun so-long-tests-predicates () + "Return the list of testable predicate functions." + (if (fboundp 'buffer-line-statistics) + '(so-long-statistics-excessive-p + so-long-detected-long-line-p) + '(so-long-detected-long-line-p))) + (provide 'so-long-tests-helpers) ;;; so-long-tests-helpers.el ends here diff --git a/test/lisp/so-long-tests/so-long-tests.el b/test/lisp/so-long-tests/so-long-tests.el index a6d8721ffc8..7eee345aadd 100644 --- a/test/lisp/so-long-tests/so-long-tests.el +++ b/test/lisp/so-long-tests/so-long-tests.el @@ -57,101 +57,131 @@ (declare-function so-long-tests-assert-active "so-long-tests-helpers") (declare-function so-long-tests-assert-reverted "so-long-tests-helpers") (declare-function so-long-tests-assert-and-revert "so-long-tests-helpers") +(declare-function so-long-tests-predicates "so-long-tests-helpers") -;; Enable the automated behavior for all tests. +;; Enable the automated behaviour for all tests. (global-so-long-mode 1) (ert-deftest so-long-tests-threshold-under () "Under line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1- so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1- so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-threshold-at () "At line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1- so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1- so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-threshold-over () "Over line length threshold." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (normal-mode) - (so-long-tests-remember) - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (so-long-tests-assert-and-revert 'so-long-mode))) + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + (so-long-tests-remember) + (insert (make-string (1+ so-long-threshold) ?x)) + (normal-mode) + (so-long-tests-assert-and-revert 'so-long-mode)))) (ert-deftest so-long-tests-skip-comments () "Skip leading shebang, whitespace, and comments." - ;; Long comment, no newline. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with newline. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with short text following. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (insert (make-string so-long-threshold ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Long comment, with long text following. - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - (insert (make-string (1+ so-long-threshold) ?\;)) - (insert "\n") - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'so-long-mode)))) + ;; Only for `so-long-detected-long-line-p' -- comments are not + ;; treated differently when using `so-long-statistics-excessive-p'. + (dolist (so-long-predicate (so-long-tests-predicates)) + ;; Long comment, no newline. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with newline. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with short text following. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (insert (make-string so-long-threshold ?x)) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode))))) + ;; Long comment, with long text following. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?\;)) + (insert "\n") + (insert (make-string (1+ so-long-threshold) ?x)) + (normal-mode) + (should (eq major-mode 'so-long-mode))))) (ert-deftest so-long-tests-max-lines () "Give up after `so-long-max-lines'." - (with-temp-buffer - (display-buffer (current-buffer)) - (insert "#!emacs\n") - ;; Insert exactly `so-long-max-lines' non-comment lines, followed - ;; by a long line. - (dotimes (_ so-long-max-lines) - (insert "x\n")) - (insert (make-string (1+ so-long-threshold) ?x)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)) - ;; If `so-long-max-lines' is nil, don't give up the search. - (let ((so-long-max-lines nil)) - (normal-mode) - (should (eq major-mode 'so-long-mode))) - ;; If `so-long-skip-leading-comments' is nil, all lines are - ;; counted, and so the shebang line counts, which makes the - ;; long line one line further away. - (let ((so-long-skip-leading-comments nil) - (so-long-max-lines (1+ so-long-max-lines))) + ;; Only for `so-long-detected-long-line-p' -- the whole buffer is + ;; 'seen' when using `so-long-statistics-excessive-p'. + (dolist (so-long-predicate (so-long-tests-predicates)) + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + ;; Insert exactly `so-long-max-lines' non-comment lines, followed + ;; by a long line. + (dotimes (_ so-long-max-lines) + (insert "x\n")) + (insert (make-string (1+ so-long-threshold) ?x)) (normal-mode) - (should (eq major-mode 'emacs-lisp-mode)) - (let ((so-long-max-lines (1+ so-long-max-lines))) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode)))) + ;; If `so-long-max-lines' is nil, don't give up the search. + (let ((so-long-max-lines nil)) (normal-mode) - (should (eq major-mode 'so-long-mode)))))) + (should (eq major-mode 'so-long-mode))) + ;; If `so-long-skip-leading-comments' is nil, all lines are + ;; counted, and so the shebang line counts, which makes the + ;; long line one line further away. + (let ((so-long-skip-leading-comments nil) + (so-long-max-lines (1+ so-long-max-lines))) + (normal-mode) + (should (eq major-mode + (cond ((eq so-long-predicate #'so-long-detected-long-line-p) + 'emacs-lisp-mode) + ((eq so-long-predicate #'so-long-statistics-excessive-p) + 'so-long-mode)))) + (let ((so-long-max-lines (1+ so-long-max-lines))) + (normal-mode) + (should (eq major-mode 'so-long-mode))))))) (ert-deftest so-long-tests-invisible-buffer-function () "Call `so-long-invisible-buffer-function' in invisible buffers." @@ -180,7 +210,7 @@ ;; From Emacs 27 the `display-buffer' call is insufficient. ;; The various 'window change functions' are now invoked by the ;; redisplay, and redisplay does nothing at all in batch mode, - ;; so we cannot test under this revised behavior. Refer to: + ;; so we cannot test under this revised behaviour. Refer to: ;; https://lists.gnu.org/r/emacs-devel/2019-10/msg00971.html ;; For interactive (non-batch) test runs, calling `redisplay' ;; does do the trick; so do that first. @@ -195,9 +225,11 @@ ;; Emacs adds the framework necessary to make `redisplay' work ;; in batch mode. (unless (eq so-long--active t) - (run-window-configuration-change-hook)))) + (with-suppressed-warnings + ((obsolete run-window-configuration-change-hook)) + (run-window-configuration-change-hook))))) (so-long-tests-assert-and-revert 'so-long-mode)) - ;; `so-long-invisible-buffer-function' is `nil'. + ;; `so-long-invisible-buffer-function' is nil. (with-temp-buffer (insert "#!emacs\n") (normal-mode) @@ -230,7 +262,9 @@ (redisplay) (when noninteractive (unless (eq so-long--active t) - (run-window-configuration-change-hook)))) + (with-suppressed-warnings + ((obsolete run-window-configuration-change-hook)) + (run-window-configuration-change-hook))))) (should (eq major-mode 'emacs-lisp-mode)))) (ert-deftest so-long-tests-actions () @@ -323,20 +357,76 @@ (normal-mode) (should (eq major-mode 'so-long-mode))))) +(ert-deftest so-long-tests-preserved-variables-and-modes () + "Preserved variables and minor modes when using `so-long-mode'." + ;; Test the user options `so-long-mode-preserved-variables' and + ;; `so-long-mode-preserved-minor-modes'. The minor mode `view-mode' + ;; is 'preserved' by default (using both options). + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + ;; We enable `view-mode' before triggering `so-long'. + (insert (make-string (1+ so-long-threshold) ?x)) + (view-mode 1) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + (so-long-tests-remember) + (let ((so-long-action 'so-long-mode) + (menu (so-long-menu))) + (so-long) + (so-long-tests-assert-active 'so-long-mode) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + ;; Revert. + (funcall (lookup-key menu [so-long-revert])) + (so-long-tests-assert-reverted 'so-long-mode) + (should (eq view-mode t)) + (should (eq buffer-read-only t)) + ;; Disable `view-mode'. Note that without the preserved + ;; variables, the conflict between how `view-mode' and `so-long' + ;; each deal with the buffer's original `buffer-read-only' value + ;; would lead to a situation whereby the buffer would still be + ;; read-only after `view-mode' had been disabled. + (view-mode 0) + (should (eq view-mode nil)) + (should (eq buffer-read-only nil)))) + ;; Without `view-mode'. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (normal-mode) + (insert (make-string (1+ so-long-threshold) ?x)) + (should (eq view-mode nil)) + (so-long-tests-remember) + (let ((so-long-action 'so-long-mode) + (menu (so-long-menu))) + (so-long) + (so-long-tests-assert-active 'so-long-mode) + (should (eq view-mode nil)) + ;; Revert. + (funcall (lookup-key menu [so-long-revert])) + (so-long-tests-assert-reverted 'so-long-mode) + (should (eq view-mode nil))))) + (ert-deftest so-long-tests-predicate () "Custom predicate function." ;; Test the `so-long-predicate' user option. + ;; Always true. Trigger when we normally wouldn't. (with-temp-buffer (display-buffer (current-buffer)) (insert "#!emacs\n") - ;; Always false. - (let ((so-long-predicate #'ignore)) - (normal-mode) - (should (eq major-mode 'emacs-lisp-mode))) - ;; Always true. (let ((so-long-predicate (lambda () t))) (normal-mode) - (should (eq major-mode 'so-long-mode))))) + (should (eq major-mode 'so-long-mode)))) + ;; Always false. Don't trigger when we normally would. + (with-temp-buffer + (display-buffer (current-buffer)) + (insert "#!emacs\n") + (insert (make-string (1+ so-long-threshold) ?x)) + (let ((so-long-predicate #'ignore)) + (normal-mode) + (should (eq major-mode 'emacs-lisp-mode))))) (ert-deftest so-long-tests-file-local-action () "File-local action." @@ -405,7 +495,10 @@ (insert ,local-vars) (normal-mode) ;; Remember the `emacs-lisp-mode' state. The other cases - ;; will validate the 'reverted' state against this. + ;; will validate the 'reverted' state against this. (Note + ;; that we haven't displayed the buffer, and therefore only + ;; `so-long-invisible-buffer-function' has acted, so we are + ;; still remembering the 'before' state.) (so-long-tests-remember) (should (eq major-mode 'emacs-lisp-mode))) ;; Downgrade the action from major mode to minor mode. diff --git a/test/lisp/so-long-tests/spelling-tests.el b/test/lisp/so-long-tests/spelling-tests.el index 0be8555bdd2..b598366ba7a 100644 --- a/test/lisp/so-long-tests/spelling-tests.el +++ b/test/lisp/so-long-tests/spelling-tests.el @@ -23,6 +23,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ispell) (require 'cl-lib) @@ -50,20 +51,19 @@ ;; The Emacs test Makefile's use of HOME=/nonexistent triggers an error ;; when starting the inferior ispell process, so we set HOME to a valid ;; (but empty) temporary directory for this test. - (let* ((tmpdir (make-temp-file "so-long." :dir ".ispell")) - (process-environment (cons (format "HOME=%s" tmpdir) - process-environment)) - (find-spelling-mistake - (unwind-protect - (cl-letf (((symbol-function 'ispell-command-loop) - (lambda (_miss _guess word _start _end) - (message "Unrecognized word: %s." word) - (throw 'mistake t)))) - (catch 'mistake - (find-library "so-long") - (ispell-buffer) - nil)) - (delete-directory tmpdir)))) - (should (not find-spelling-mistake))))) + (ert-with-temp-file tmpdir + :suffix "so-long.ispell" + (let* ((process-environment (cons (format "HOME=%s" tmpdir) + process-environment)) + (find-spelling-mistake + (cl-letf (((symbol-function 'ispell-command-loop) + (lambda (_miss _guess word _start _end) + (message "Unrecognised word: %s." word) + (throw 'mistake t)))) + (catch 'mistake + (find-library "so-long") + (ispell-buffer) + nil)))) + (should (not find-spelling-mistake)))))) ;;; spelling-tests.el ends here diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index b57982a7055..238c9be1ab0 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -62,19 +62,259 @@ (0 font-lock-keyword-face)))))))) +;;;; List functions. + +(ert-deftest subr-test-caaar () + (should (null (caaar '()))) + (should (null (caaar '(() (2))))) + (should (null (caaar '((() (2)) (a b))))) + (should-error (caaar '(1 2)) :type 'wrong-type-argument) + (should-error (caaar '((1 2))) :type 'wrong-type-argument) + (should (= 1 (caaar '(((1 2) (3 4)))))) + (should (null (caaar '((() (3 4))))))) + +(ert-deftest subr-test-caadr () + (should (null (caadr '()))) + (should (null (caadr '(1)))) + (should-error (caadr '(1 2)) :type 'wrong-type-argument) + (should (= 2 (caadr '(1 (2 3))))) + (should (equal '((2) (3)) (caadr '((1) (((2) (3))) (4)))))) + + ;;;; Keymap support. (ert-deftest subr-test-kbd () + (should (equal (kbd "") "")) (should (equal (kbd "f") "f")) + (should (equal (kbd "X") "X")) + (should (equal (kbd "foobar") "foobar")) ; 6 characters + (should (equal (kbd "return") "return")) ; 6 characters + + (should (equal (kbd "<F2>") [F2])) + (should (equal (kbd "<f1> <f2> TAB") [f1 f2 ?\t])) + (should (equal (kbd "<f1> RET") [f1 ?\r])) + (should (equal (kbd "<f1> SPC") [f1 ? ])) (should (equal (kbd "<f1>") [f1])) - (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "<f1>") [f1])) + (should (equal (kbd "[f1]") "[f1]")) + (should (equal (kbd "<return>") [return])) + (should (equal (kbd "< right >") "<right>")) ; 7 characters + + ;; Modifiers: + (should (equal (kbd "C-x") "\C-x")) (should (equal (kbd "C-x a") "\C-xa")) - ;; Check that kbd handles both new and old style key descriptions - ;; (bug#45536). + (should (equal (kbd "C-;") [?\C-\;])) + (should (equal (kbd "C-a") "\C-a")) + (should (equal (kbd "C-c SPC") "\C-c ")) + (should (equal (kbd "C-c TAB") "\C-c\t")) + (should (equal (kbd "C-c c") "\C-cc")) + (should (equal (kbd "C-x 4 C-f") "\C-x4\C-f")) + (should (equal (kbd "C-x C-f") "\C-x\C-f")) + (should (equal (kbd "C-M-<down>") [C-M-down])) + (should (equal (kbd "<C-M-down>") [C-M-down])) + (should (equal (kbd "C-RET") [?\C-\C-m])) + (should (equal (kbd "C-SPC") [?\C- ])) + (should (equal (kbd "C-TAB") [?\C-\t])) + (should (equal (kbd "C-<down>") [C-down])) + (should (equal (kbd "C-c C-c C-c") "\C-c\C-c\C-c")) + + (should (equal (kbd "M-a") [?\M-a])) + (should (equal (kbd "M-<DEL>") [?\M-\d])) + (should (equal (kbd "M-C-a") [?\M-\C-a])) + (should (equal (kbd "M-ESC") [?\M-\e])) + (should (equal (kbd "M-RET") [?\M-\r])) + (should (equal (kbd "M-SPC") [?\M- ])) + (should (equal (kbd "M-TAB") [?\M-\t])) + (should (equal (kbd "M-x a") [?\M-x ?a])) + (should (equal (kbd "M-<up>") [M-up])) + (should (equal (kbd "M-c M-c M-c") [?\M-c ?\M-c ?\M-c])) + + (should (equal (kbd "s-SPC") [?\s- ])) + (should (equal (kbd "s-a") [?\s-a])) + (should (equal (kbd "s-x a") [?\s-x ?a])) + (should (equal (kbd "s-c s-c s-c") [?\s-c ?\s-c ?\s-c])) + + (should (equal (kbd "S-H-a") [?\S-\H-a])) + (should (equal (kbd "S-a") [?\S-a])) + (should (equal (kbd "S-x a") [?\S-x ?a])) + (should (equal (kbd "S-c S-c S-c") [?\S-c ?\S-c ?\S-c])) + + (should (equal (kbd "H-<RET>") [?\H-\r])) + (should (equal (kbd "H-DEL") [?\H-\d])) + (should (equal (kbd "H-a") [?\H-a])) + (should (equal (kbd "H-x a") [?\H-x ?a])) + (should (equal (kbd "H-c H-c H-c") [?\H-c ?\H-c ?\H-c])) + + (should (equal (kbd "A-H-a") [?\A-\H-a])) + (should (equal (kbd "A-SPC") [?\A- ])) + (should (equal (kbd "A-TAB") [?\A-\t])) + (should (equal (kbd "A-a") [?\A-a])) + (should (equal (kbd "A-c A-c A-c") [?\A-c ?\A-c ?\A-c])) + + (should (equal (kbd "C-M-a") [?\C-\M-a])) + (should (equal (kbd "C-M-<up>") [C-M-up])) + + ;; Special characters. + (should (equal (kbd "DEL") "\d")) + (should (equal (kbd "ESC C-a") "\e\C-a")) + (should (equal (kbd "ESC") "\e")) + (should (equal (kbd "LFD") "\n")) + (should (equal (kbd "NUL") "\0")) + (should (equal (kbd "RET") "\C-m")) + (should (equal (kbd "SPC") "\s")) + (should (equal (kbd "TAB") "\t")) + (should (equal (kbd "\^i") "")) + (should (equal (kbd "^M") "\^M")) + + ;; With numbers. + (should (equal (kbd "\177") "\^?")) + (should (equal (kbd "\000") "\0")) + (should (equal (kbd "\\177") "\^?")) + (should (equal (kbd "\\000") "\0")) + (should (equal (kbd "C-x \\150") "\C-xh")) + + ;; Multibyte + (should (equal (kbd "ñ") [?ñ])) + (should (equal (kbd "ü") [?ü])) + (should (equal (kbd "ö") [?ö])) + (should (equal (kbd "ğ") [?ğ])) + (should (equal (kbd "ա") [?ա])) + (should (equal (kbd "üüöö") [?ü ?ü ?ö ?ö])) + (should (equal (kbd "C-ü") [?\C-ü])) + (should (equal (kbd "M-ü") [?\M-ü])) + (should (equal (kbd "H-ü") [?\H-ü])) + + ;; Handle both new and old style key descriptions (bug#45536). (should (equal (kbd "s-<return>") [s-return])) (should (equal (kbd "<s-return>") [s-return])) (should (equal (kbd "C-M-<return>") [C-M-return])) - (should (equal (kbd "<C-M-return>") [C-M-return]))) + (should (equal (kbd "<C-M-return>") [C-M-return])) + + ;; Error. + (should-error (kbd "C-xx")) + (should-error (kbd "M-xx")) + (should-error (kbd "M-x<TAB>")) + + ;; These should be equivalent: + (should (equal (kbd "\C-xf") (kbd "C-x f")))) + +(ert-deftest subr-test-kbd-valid-p () + (should (not (kbd-valid-p ""))) + (should (kbd-valid-p "f")) + (should (kbd-valid-p "X")) + (should (not (kbd-valid-p " X"))) + (should (kbd-valid-p "X f")) + (should (not (kbd-valid-p "a b"))) + (should (not (kbd-valid-p "foobar"))) + (should (not (kbd-valid-p "return"))) + + (should (kbd-valid-p "<F2>")) + (should (kbd-valid-p "<f1> <f2> TAB")) + (should (kbd-valid-p "<f1> RET")) + (should (kbd-valid-p "<f1> SPC")) + (should (kbd-valid-p "<f1>")) + (should (not (kbd-valid-p "[f1]"))) + (should (kbd-valid-p "<return>")) + (should (not (kbd-valid-p "< right >"))) + + ;; Modifiers: + (should (kbd-valid-p "C-x")) + (should (kbd-valid-p "C-x a")) + (should (kbd-valid-p "C-;")) + (should (kbd-valid-p "C-a")) + (should (kbd-valid-p "C-c SPC")) + (should (kbd-valid-p "C-c TAB")) + (should (kbd-valid-p "C-c c")) + (should (kbd-valid-p "C-x 4 C-f")) + (should (kbd-valid-p "C-x C-f")) + (should (kbd-valid-p "C-M-<down>")) + (should (not (kbd-valid-p "<C-M-down>"))) + (should (kbd-valid-p "C-RET")) + (should (kbd-valid-p "C-SPC")) + (should (kbd-valid-p "C-TAB")) + (should (kbd-valid-p "C-<down>")) + (should (kbd-valid-p "C-c C-c C-c")) + + (should (kbd-valid-p "M-a")) + (should (kbd-valid-p "M-<DEL>")) + (should (not (kbd-valid-p "M-C-a"))) + (should (kbd-valid-p "C-M-a")) + (should (kbd-valid-p "M-ESC")) + (should (kbd-valid-p "M-RET")) + (should (kbd-valid-p "M-SPC")) + (should (kbd-valid-p "M-TAB")) + (should (kbd-valid-p "M-x a")) + (should (kbd-valid-p "M-<up>")) + (should (kbd-valid-p "M-c M-c M-c")) + + (should (kbd-valid-p "s-SPC")) + (should (kbd-valid-p "s-a")) + (should (kbd-valid-p "s-x a")) + (should (kbd-valid-p "s-c s-c s-c")) + + (should (not (kbd-valid-p "S-H-a"))) + (should (kbd-valid-p "S-a")) + (should (kbd-valid-p "S-x a")) + (should (kbd-valid-p "S-c S-c S-c")) + + (should (kbd-valid-p "H-<RET>")) + (should (kbd-valid-p "H-DEL")) + (should (kbd-valid-p "H-a")) + (should (kbd-valid-p "H-x a")) + (should (kbd-valid-p "H-c H-c H-c")) + + (should (kbd-valid-p "A-H-a")) + (should (kbd-valid-p "A-SPC")) + (should (kbd-valid-p "A-TAB")) + (should (kbd-valid-p "A-a")) + (should (kbd-valid-p "A-c A-c A-c")) + + (should (kbd-valid-p "C-M-a")) + (should (kbd-valid-p "C-M-<up>")) + + ;; Special characters. + (should (kbd-valid-p "DEL")) + (should (kbd-valid-p "ESC C-a")) + (should (kbd-valid-p "ESC")) + (should (kbd-valid-p "LFD")) + (should (kbd-valid-p "NUL")) + (should (kbd-valid-p "RET")) + (should (kbd-valid-p "SPC")) + (should (kbd-valid-p "TAB")) + (should (not (kbd-valid-p "\^i"))) + (should (not (kbd-valid-p "^M"))) + + ;; With numbers. + (should (not (kbd-valid-p "\177"))) + (should (not (kbd-valid-p "\000"))) + (should (not (kbd-valid-p "\\177"))) + (should (not (kbd-valid-p "\\000"))) + (should (not (kbd-valid-p "C-x \\150"))) + + ;; Multibyte + (should (kbd-valid-p "ñ")) + (should (kbd-valid-p "ü")) + (should (kbd-valid-p "ö")) + (should (kbd-valid-p "ğ")) + (should (kbd-valid-p "ա")) + (should (not (kbd-valid-p "üüöö"))) + (should (kbd-valid-p "C-ü")) + (should (kbd-valid-p "M-ü")) + (should (kbd-valid-p "H-ü")) + + ;; Handle both new and old style key descriptions (bug#45536). + (should (kbd-valid-p "s-<return>")) + (should (not (kbd-valid-p "<s-return>"))) + (should (kbd-valid-p "C-M-<return>")) + (should (not (kbd-valid-p "<C-M-return>"))) + + (should (kbd-valid-p "<mouse-1>")) + (should (kbd-valid-p "<Scroll_Lock>")) + + (should (not (kbd-valid-p "c-x"))) + (should (not (kbd-valid-p "C-xx"))) + (should (not (kbd-valid-p "M-xx"))) + (should (not (kbd-valid-p "M-x<TAB>")))) (ert-deftest subr-test-define-prefix-command () (define-prefix-command 'foo-prefix-map) @@ -473,11 +713,11 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should (equal subr-tests--hook '(f5 f2 f1 f4 f3))) (add-hook 'subr-tests--hook 'f6) (should (equal subr-tests--hook '(f5 f6 f2 f1 f4 f3))) - ;; Make sure `t' is equivalent to 90. + ;; Make sure t is equivalent to 90. (add-hook 'subr-tests--hook 'f7 90) (add-hook 'subr-tests--hook 'f8 t) (should (equal subr-tests--hook '(f5 f6 f2 f1 f4 f3 f7 f8))) - ;; Make sure `nil' is equivalent to 0. + ;; Make sure nil is equivalent to 0. (add-hook 'subr-tests--hook 'f9 0) (add-hook 'subr-tests--hook 'f10) (should (equal subr-tests--hook '(f5 f10 f9 f6 f2 f1 f4 f3 f7 f8))) @@ -694,5 +934,76 @@ See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=19350." (should-not (buffer-local-boundp 'test-not-boundp buf)) (should (buffer-local-boundp 'test-global-boundp buf)))) +(ert-deftest test-replace-string-in-region () + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-string-in-region "foo" "new" (point-min) (point-max)) + 2)) + (should (equal (buffer-string) "new bar zot newbar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-string-in-region "foo" "new" (point-min) 14) + 1)) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should-error (replace-string-in-region "foo" "new" (point-min) 30))) + + (with-temp-buffer + (insert "Foo bar zot foobar") + (should (= (replace-string-in-region "Foo" "new" (point-min)) + 1)) + (should (equal (buffer-string) "new bar zot foobar")))) + +(ert-deftest test-replace-regexp-in-region () + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-regexp-in-region "fo+" "new" (point-min) (point-max)) + 2)) + (should (equal (buffer-string) "new bar zot newbar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should (= (replace-regexp-in-region "fo+" "new" (point-min) 14) + 1)) + (should (equal (buffer-string) "new bar zot foobar"))) + + (with-temp-buffer + (insert "foo bar zot foobar") + (should-error (replace-regexp-in-region "fo+" "new" (point-min) 30))) + + (with-temp-buffer + (insert "Foo bar zot foobar") + (should (= (replace-regexp-in-region "Fo+" "new" (point-min)) + 1)) + (should (equal (buffer-string) "new bar zot foobar")))) + +(ert-deftest test-with-existing-directory () + (let ((dir (make-temp-name "/tmp/not-exist-"))) + (let ((default-directory dir)) + (should-not (file-exists-p default-directory))) + (with-existing-directory + (should-not (equal dir default-directory)) + (should (file-exists-p default-directory))))) + +(ert-deftest subr-test-internal--format-docstring-line () + (should + (string= (let ((fill-column 70)) + (internal--format-docstring-line + "In addition to any hooks its parent mode might have run, this \ +mode runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the final \ +or penultimate step during initialization.")) + "In addition to any hooks its parent mode might have run, this mode +runs the hook ‘foo-bar-baz-very-long-name-indeed-mode-hook’, as the +final or penultimate step during initialization.")) + (should-error (internal--format-docstring-line "foo\nbar"))) + +(ert-deftest test-ensure-list () + (should (equal (ensure-list nil) nil)) + (should (equal (ensure-list :foo) '(:foo))) + (should (equal (ensure-list '(1 2 3)) '(1 2 3)))) + (provide 'subr-tests) ;;; subr-tests.el ends here diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index 48a127157dd..6964d423185 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -47,4 +47,4 @@ (provide 'tar-mode-tests) -;; tar-mode-tests.el ends here +;;; tar-mode-tests.el ends here diff --git a/test/lisp/term-tests.el b/test/lisp/term-tests.el index 503cb5d7aab..73d39cf3b66 100644 --- a/test/lisp/term-tests.el +++ b/test/lisp/term-tests.el @@ -28,6 +28,65 @@ (defvar term-height) ; Number of lines in window. (defvar term-width) ; Number of columns in window. +(defvar yellow-fg-props + `( :foreground ,(face-foreground 'term-color-yellow nil 'default) + :background "unspecified-bg" :inverse-video nil)) +(defvar yellow-bg-props + `( :foreground "unspecified-fg" + :background ,(face-background 'term-color-yellow nil 'default) + :inverse-video nil)) +(defvar bright-yellow-fg-props + `( :foreground ,(face-foreground 'term-color-bright-yellow nil 'default) + :background "unspecified-bg" :inverse-video nil)) +(defvar bright-yellow-bg-props + `( :foreground "unspecified-fg" + :background ,(face-background 'term-color-bright-yellow nil 'default) + :inverse-video nil)) +(defvar custom-color-fg-props + `( :foreground "#87FFFF" + :background "unspecified-bg" :inverse-video nil)) + +(defvar ansi-test-strings + `(("\e[33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,yellow-fg-props))) + ("\e[43mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,yellow-bg-props))) + ("\e[93mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-fg-props))) + ("\e[103mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face `(,bright-yellow-bg-props))) + ("\e[1;33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[33;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[1m\e[33mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[33m\e[1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;3;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,yellow-fg-props term-bold)) + ,(propertize "Hello World" 'font-lock-face + `(,bright-yellow-fg-props term-bold))) + ("\e[38;5;123;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))) + ("\e[38;2;135;255;255;1mHello World\e[0m" + ,(propertize "Hello World" 'font-lock-face + `(,custom-color-fg-props term-bold))))) + (defun term-test-screen-from-input (width height input &optional return-var) (with-temp-buffer (term-mode) @@ -48,7 +107,7 @@ (mapc (lambda (input) (term-emulate-terminal proc input)) input) (term-emulate-terminal proc input)) (if return-var (buffer-local-value return-var (current-buffer)) - (buffer-substring-no-properties (point-min) (point-max)))))) + (buffer-substring (point-min) (point-max)))))) (ert-deftest term-simple-lines () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) @@ -56,7 +115,7 @@ first line\r next line\r\n")) (should (equal (term-test-screen-from-input 40 12 str) - (replace-regexp-in-string "\r" "" str))))) + (string-replace "\r" "" str))))) (ert-deftest term-carriage-return () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) @@ -77,6 +136,24 @@ first line\r_next line\r\n")) (term-test-screen-from-input 40 12 (let ((str (make-string 30 ?a))) (list str str)))))) +(ert-deftest term-colors () + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (pcase-dolist (`(,str ,expected) ansi-test-strings) + (let ((result (term-test-screen-from-input 40 12 str))) + (should (equal result expected)) + (should (equal (text-properties-at 0 result) + (text-properties-at 0 expected)))))) + +(ert-deftest term-colors-bold-is-bright () + (skip-unless (not (memq system-type '(windows-nt ms-dos)))) + (let ((ansi-color-bold-is-bright t)) + (pcase-dolist (`(,str ,expected ,bright-expected) ansi-test-strings) + (let ((expected (or bright-expected expected)) + (result (term-test-screen-from-input 40 12 str))) + (should (equal result expected)) + (should (equal (text-properties-at 0 result) + (text-properties-at 0 expected))))))) + (ert-deftest term-cursor-movement () (skip-unless (not (memq system-type '(windows-nt ms-dos)))) ;; Absolute positioning. diff --git a/test/lisp/term/tty-colors-tests.el b/test/lisp/term/tty-colors-tests.el index ba29a9c376e..d0e739b5ec9 100644 --- a/test/lisp/term/tty-colors-tests.el +++ b/test/lisp/term/tty-colors-tests.el @@ -35,4 +35,4 @@ (provide 'term-tests) -;;; term-tests.el ends here +;;; tty-colors-tests.el ends here diff --git a/test/lisp/textmodes/dns-mode-tests.el b/test/lisp/textmodes/dns-mode-tests.el index 8bc48732c62..1be5291509f 100644 --- a/test/lisp/textmodes/dns-mode-tests.el +++ b/test/lisp/textmodes/dns-mode-tests.el @@ -77,3 +77,5 @@ (insert " ") (dns-mode-ipv6-to-nibbles nil) (should (equal (buffer-string) "8.b.d.0.1.0.0.2.ip6.arpa. "))))) + +;;; dns-mode-tests.el ends here diff --git a/test/lisp/textmodes/fill-tests.el b/test/lisp/textmodes/fill-tests.el index a4c7f447b59..2a1195b87ea 100644 --- a/test/lisp/textmodes/fill-tests.el +++ b/test/lisp/textmodes/fill-tests.el @@ -54,7 +54,7 @@ (beg (line-beginning-position)) (end (line-end-position)) (fill-prefix (make-string (- pos beg) ?\s)) - ;; `fill-column' is too small to accomodate the current line + ;; `fill-column' is too small to accommodate the current line (fill-column (- end beg 10))) (fill-region-as-paragraph beg end nil nil pos)) (should (equal (buffer-string) string))))) @@ -69,13 +69,35 @@ (beg (line-beginning-position)) (end (line-end-position)) (fill-prefix (make-string (- pos beg) ?\s)) - ;; `fill-column' is too small to accomodate the current line + ;; `fill-column' is too small to accommodate the current line (fill-column (- end beg 10))) (fill-region-as-paragraph beg end nil nil pos)) (should (equal (buffer-string) "aaa = baaaaaaaa aaaaaaaaaa\n aaaaaaaaaa\n"))))) +(ert-deftest test-fill-end-period () + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.") + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius. ")) + (should + (equal + (with-temp-buffer + (text-mode) + (auto-fill-mode) + (insert "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eius.Foo") + (forward-char -3) + (self-insert-command 1 ?\s) + (buffer-string)) + "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do +eius. Foo"))) + (provide 'fill-tests) ;;; fill-tests.el ends here diff --git a/test/lisp/textmodes/reftex-tests.el b/test/lisp/textmodes/reftex-tests.el index b824e05f6d5..cc5b23e1c9c 100644 --- a/test/lisp/textmodes/reftex-tests.el +++ b/test/lisp/textmodes/reftex-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) ;;; reftex (require 'reftex) @@ -33,32 +34,31 @@ (ert-deftest reftex-locate-bibliography-files () "Test `reftex-locate-bibliography-files'." - (let ((temp-dir (make-temp-file "reftex-bib" 'dir)) - (files '("ref1.bib" "ref2.bib")) - (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) - ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) - ("\\begin{document}\n\\bibliographystyle{plain}\n + (ert-with-temp-directory temp-dir + (let ((files '("ref1.bib" "ref2.bib")) + (test '(("\\addbibresource{ref1.bib}\n" . ("ref1.bib")) + ("\\\\addbibresource[label=x]{ref2.bib}\\n" . ("ref2.bib")) + ("\\begin{document}\n\\bibliographystyle{plain}\n \\bibliography{ref1,ref2}\n\\end{document}" . ("ref1.bib" "ref2.bib")))) - (reftex-bibliography-commands - ;; Default value: See reftex-vars.el `reftex-bibliography-commands' - '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" - "addbibresource"))) - (with-temp-buffer - (insert "test\n") + (reftex-bibliography-commands + ;; Default value: See reftex-vars.el `reftex-bibliography-commands' + '("bibliography" "nobibliography" "setupbibtex\\[.*?database=" + "addbibresource"))) + (with-temp-buffer + (insert "test\n") + (mapc + (lambda (file) + (write-region (point-min) (point-max) (expand-file-name file + temp-dir))) + files)) (mapc - (lambda (file) - (write-region (point-min) (point-max) (expand-file-name file - temp-dir))) - files)) - (mapc - (lambda (data) - (with-temp-buffer - (insert (car data)) - (let ((res (mapcar #'file-name-nondirectory - (reftex-locate-bibliography-files temp-dir)))) - (should (equal res (cdr data)))))) - test) - (delete-directory temp-dir 'recursive))) + (lambda (data) + (with-temp-buffer + (insert (car data)) + (let ((res (mapcar #'file-name-nondirectory + (reftex-locate-bibliography-files temp-dir)))) + (should (equal res (cdr data)))))) + test)))) (ert-deftest reftex-what-environment-test () "Test `reftex-what-environment'." @@ -102,12 +102,12 @@ ;; reason. (An alternative solution would be to use file-equal-p, ;; but I'm too lazy to do that, as one of the tests compares a ;; list.) - (let* ((temp-dir (file-truename (make-temp-file "reftex-parse" 'dir))) - (tex-file (expand-file-name "test.tex" temp-dir)) - (bib-file (expand-file-name "ref.bib" temp-dir))) - (with-temp-buffer - (insert -"\\begin{document} + (ert-with-temp-directory temp-dir + (let* ((tex-file (expand-file-name "test.tex" temp-dir)) + (bib-file (expand-file-name "ref.bib" temp-dir))) + (with-temp-buffer + (insert + "\\begin{document} \\section{test}\\label{sec:test} \\subsection{subtest} @@ -118,27 +118,26 @@ \\bibliographystyle{plain} \\bibliography{ref} \\end{document}") - (write-region (point-min) (point-max) tex-file)) - (with-temp-buffer - (insert "test\n") - (write-region (point-min) (point-max) bib-file)) - (reftex-ensure-compiled-variables) - (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) - (should (equal (car parsed) `(eof ,tex-file))) - (pop parsed) - (while parsed - (let ((entry (pop parsed))) - (cond - ((eq (car entry) 'bib) - (should (string= (cadr entry) bib-file))) - ((eq (car entry) 'toc)) ;; ... - ((string= (car entry) "eq:foo")) - ((string= (car entry) "sec:test")) - ((eq (car entry) 'bof) - (should (string= (cadr entry) tex-file)) - (should (null parsed))) - (t (should-not t))))) - (delete-directory temp-dir 'recursive)))) + (write-region (point-min) (point-max) tex-file)) + (with-temp-buffer + (insert "test\n") + (write-region (point-min) (point-max) bib-file)) + (reftex-ensure-compiled-variables) + (let ((parsed (reftex-parse-from-file tex-file nil temp-dir))) + (should (equal (car parsed) `(eof ,tex-file))) + (pop parsed) + (while parsed + (let ((entry (pop parsed))) + (cond + ((eq (car entry) 'bib) + (should (string= (cadr entry) bib-file))) + ((eq (car entry) 'toc)) ;; ... + ((string= (car entry) "eq:foo")) + ((string= (car entry) "sec:test")) + ((eq (car entry) 'bof) + (should (string= (cadr entry) tex-file)) + (should (null parsed))) + (t (should-not t))))))))) ;;; reftex-cite (require 'reftex-cite) diff --git a/test/lisp/textmodes/texinfo-resources/fill.erts b/test/lisp/textmodes/texinfo-resources/fill.erts new file mode 100644 index 00000000000..95f3b09eba8 --- /dev/null +++ b/test/lisp/textmodes/texinfo-resources/fill.erts @@ -0,0 +1,70 @@ +Code: + (lambda () + (texinfo-mode) + (fill-paragraph)) + +Name: fill1 +Point-Char: | + +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. +=-= +@noindent Everyone is permitted to copy and distribute verbatim copies +of this license document, but changing it is not allowed. +=-=-= + +Name: fill2 +Point-Char: | + +=-= +@cindex relative| remapping, faces +@cindex base remapping, faces + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + + +Name: fill3 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces| + The following functions implement a higher-level interface to @code{face-remapping-alist}. +=-=-= + +Name: fill4 +Point-Char: | + +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to @code{face-remapping-alist}. +=-= +@cindex relative remapping, faces +@cindex base remapping, faces + The following functions| implement a higher-level interface to +@code{face-remapping-alist}. +=-=-= + +Name: fill5 +Point-Char: | + +=-= +@defun face-remap-add-relative face &rest specs +|This function adds the face spec in @var{specs} as relative +remappings for face @var{face} in the current buffer. The remaining +arguments, @var{specs}, should form either a list of face names, or a +property list of attribute/value pairs. +=-= +@defun face-remap-add-relative face &rest specs +This function adds the face spec in @var{specs} as relative remappings +for face @var{face} in the current buffer. The remaining arguments, +@var{specs}, should form either a list of face names, or a property +list of attribute/value pairs. +=-=-= + +Name: fill6 + +=-= +@subsection This is a very very very very very very very very very very long subsection name +=-=-= diff --git a/test/lisp/textmodes/texinfo-tests.el b/test/lisp/textmodes/texinfo-tests.el new file mode 100644 index 00000000000..fa0c4de005e --- /dev/null +++ b/test/lisp/textmodes/texinfo-tests.el @@ -0,0 +1,33 @@ +;;; texinfo-tests.el --- Tests for texinfo.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'texinfo) +(require 'ert) +(require 'ert-x) + +(ert-deftest test-filling () + (ert-test-erts-file (ert-resource-file "fill.erts"))) + +;;; texinfo-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index fba6f21d5dc..2a32dc57b1c 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -70,7 +70,7 @@ ;; UUID, only hex is allowed ("01234567-89ab-cdef-ABCD-EF0123456789" 1 uuid "01234567-89ab-cdef-ABCD-EF0123456789") ("01234567-89ab-cdef-ABCD-EF012345678G" 1 uuid nil)) - "List of thing-at-point tests. + "List of `thing-at-point' tests. Each list element should have the form (STRING POS THING RESULT) @@ -223,4 +223,12 @@ position to retrieve THING.") (should (equal (test--number "0xf00" 2) 3840)) (should (equal (test--number "0xf00" 3) 3840))) -;;; thingatpt.el ends here +(ert-deftest test-fields () + (with-temp-buffer + (insert (propertize "foo" 'field 1) "bar" (propertize "zot" 'field 2)) + (goto-char 1) + (should (eq (symbol-at-point) 'foo)) + (goto-char 5) + (should (eq (symbol-at-point) 'bar)))) + +;;; thingatpt-tests.el ends here diff --git a/test/lisp/thumbs-tests.el b/test/lisp/thumbs-tests.el index ee096138453..a9b41d7c00f 100644 --- a/test/lisp/thumbs-tests.el +++ b/test/lisp/thumbs-tests.el @@ -20,15 +20,13 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'thumbs) (ert-deftest thumbs-tests-thumbsdir/create-if-missing () - (let ((thumbs-thumbsdir (make-temp-file "thumbs-test" t))) - (unwind-protect - (progn - (delete-directory thumbs-thumbsdir) - (should (file-directory-p (thumbs-thumbsdir)))) - (delete-directory thumbs-thumbsdir)))) + (ert-with-temp-directory thumbs-thumbsdir + (delete-directory thumbs-thumbsdir) + (should (file-directory-p (thumbs-thumbsdir))))) (provide 'thumbs-tests) ;;; thumbs-tests.el ends here diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index 0d64320496d..cb446eb486e 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -26,7 +26,7 @@ (defmacro with-time-stamp-test-env (&rest body) "Evaluate BODY with some standard time-stamp test variables bound." - (declare (indent defun)) + (declare (indent 0) (debug t)) `(let ((user-login-name "test-logname") (user-full-name "100%d Tester") ;verify "%" passed unchanged (buffer-file-name "/emacs/test/time-stamped-file") @@ -46,7 +46,7 @@ (defmacro with-time-stamp-test-time (reference-time &rest body) "Force any contained time-stamp call to use time REFERENCE-TIME." - (declare (indent defun)) + (declare (indent 1) (debug t)) `(cl-letf* ((orig-time-stamp-string-fn (symbol-function 'time-stamp-string)) ((symbol-function 'time-stamp-string) @@ -56,13 +56,14 @@ (defmacro with-time-stamp-system-name (name &rest body) "Force (system-name) to return NAME while evaluating BODY." - (declare (indent defun)) + (declare (indent 1) (debug t)) `(cl-letf (((symbol-function 'system-name) (lambda () ,name))) ,@body)) (defmacro time-stamp-should-warn (form) "Similar to `should' but verifies that a format warning is generated." + (declare (debug t)) `(let ((warning-count 0)) (cl-letf (((symbol-function 'time-stamp-conv-warn) (lambda (_old _new) @@ -86,7 +87,7 @@ (should (equal (time-stamp-string "%H %Z" ref-time1) "15 GMT"))))) (iter-defun time-stamp-test-pattern-sequential () - "Iterate through each possibility for a part of time-stamp-pattern." + "Iterate through each possibility for a part of `time-stamp-pattern'." (let ((pattern-value-parts '(("4/" "10/" "-4/" "0/" "") ;0: line limit ("stamp<" "") ;1: start @@ -115,7 +116,7 @@ (extract-part 5)))))))))) (iter-defun time-stamp-test-pattern-multiply () - "Iterate through every combination of parts of time-stamp-pattern." + "Iterate through every combination of parts of `time-stamp-pattern'." (let ((line-limit-values '("" "4/")) (start-values '("" "stamp<")) (format-values '("%%" "%m")) @@ -141,9 +142,9 @@ ts-format _format-lines _end-lines) ;; Verify that time-stamp parsed time-stamp-pattern and ;; called us with the correct pieces. - (let ((limit-number (string-to-number line-limit1))) - (if (equal line-limit1 "") - (setq limit-number time-stamp-line-limit)) + (let ((limit-number (if (equal line-limit1 "") + time-stamp-line-limit + (string-to-number line-limit1)))) (goto-char (point-min)) (if (> limit-number 0) (should (= search-limit (line-beginning-position @@ -703,9 +704,10 @@ ;;;; Setup for tests of time offset formatting with %z (defun formatz (format zone) - "Uses time FORMAT string to format the offset of ZONE, returning the result. -FORMAT is \"%z\" or a variation. -ZONE is as the ZONE argument of the `format-time-string' function." + "Uses FORMAT to format the offset of ZONE, returning the result. +FORMAT must be time format \"%z\" or some variation thereof. +ZONE is as the ZONE argument of the `format-time-string' function. +This function is called by 99% of the `time-stamp' \"%z\" unit tests." (with-time-stamp-test-env (let ((time-stamp-time-zone zone)) ;; Call your favorite time formatter here. @@ -717,9 +719,9 @@ ZONE is as the ZONE argument of the `format-time-string' function." (defun format-time-offset (format offset-secs) "Uses FORMAT to format the time zone represented by OFFSET-SECS. -FORMAT must be \"%z\", possibly with a flag and padding. +FORMAT must be time format \"%z\" or some variation thereof. This function is a wrapper around `time-stamp-formatz-from-parsed-options' -and is used for testing." +and is called by some low-level `time-stamp' \"%z\" unit tests." ;; This wrapper adds a simple regexp-based parser that handles only ;; %z and variants. In normal use, time-stamp-formatz-from-parsed-options ;; is called from a parser that handles all time string formats. @@ -761,6 +763,7 @@ and is used for testing." "Formats ZONE and compares it to EXPECT. Uses the free variables `form-string' and `pattern-mod'. The functions in `pattern-mod' are composed left to right." + (declare (debug t)) `(let ((result ,expect)) (dolist (fn pattern-mod) (setq result (funcall fn result))) @@ -849,7 +852,7 @@ The functions in `pattern-mod' are composed left to right." (defun formatz-mod-del-colons (string) "Returns STRING with any colons removed." - (replace-regexp-in-string ":" "" string)) + (string-replace ":" "" string)) (defun formatz-mod-add-00 (string) "Returns STRING with \"00\" appended." @@ -871,7 +874,7 @@ The functions in `pattern-mod' are composed left to right." (defmacro formatz-generate-tests (form-strings hour-mod mins-mod secs-mod big-mod secbig-mod) - "Defines ert-deftest tests for time formats FORM-STRINGS. + "Defines tests for time formats FORM-STRINGS. FORM-STRINGS is a list of formats, each \"%z\" or some variation thereof. Each of the remaining arguments is an unquoted list of the form @@ -895,10 +898,11 @@ BIG-MOD is the result for offset +100 hours and modifiers for the other expected results for hours greater than 99 with a whole number of minutes. SECBIG-MOD is the result for offset +100 hours 30 seconds and modifiers for the other expected results for hours greater than 99 with non-zero seconds." - (declare (indent 1)) + (declare (indent 1) (debug (&rest sexp))) ;; Generate a form to create a list of tests to define. When this ;; macro is called, the form is evaluated, thus defining the tests. - (let ((ert-test-list '(list))) + ;; We will modify this list, so start with a list consed at runtime. + (let ((ert-test-list (list 'list))) (dolist (form-string form-strings ert-test-list) (nconc ert-test-list diff --git a/test/lisp/time-tests.el b/test/lisp/time-tests.el index 88b7638d91d..89e6985b842 100644 --- a/test/lisp/time-tests.el +++ b/test/lisp/time-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'ert-x) (require 'time) diff --git a/test/lisp/timezone-tests.el b/test/lisp/timezone-tests.el index 9f6961409e6..9bbe36cfe8a 100644 --- a/test/lisp/timezone-tests.el +++ b/test/lisp/timezone-tests.el @@ -21,6 +21,8 @@ ;;; Commentary: +;;; Code: + (require 'ert) (require 'timezone) diff --git a/test/lisp/url/url-auth-tests.el b/test/lisp/url/url-auth-tests.el index ff30f100250..05ccfc0d12a 100644 --- a/test/lisp/url/url-auth-tests.el +++ b/test/lisp/url/url-auth-tests.el @@ -154,7 +154,7 @@ Essential is how realms and paths are matched." auth) (dolist (row (list - ;; If :expected-user is `nil' it indicates + ;; If :expected-user is nil it indicates ;; authentication information shouldn't be found. ;; non-existent server diff --git a/test/lisp/url/url-handlers-test.el b/test/lisp/url/url-handlers-tests.el index 7e5a60363da..71e054b1287 100644 --- a/test/lisp/url/url-handlers-test.el +++ b/test/lisp/url/url-handlers-tests.el @@ -1,4 +1,4 @@ -;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- +;;; url-handlers-tests.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*- ;; Copyright (C) 2018-2021 Free Software Foundation, Inc. @@ -73,5 +73,4 @@ (should (equal (file-name-directory "https://foo.org/") "https://foo.org/")))) -(provide 'url-handlers-test) -;;; url-handlers-test.el ends here +;;; url-handlers-tests.el ends here diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el index 2418af40aca..a7f81eba8f5 100644 --- a/test/lisp/url/url-parse-tests.el +++ b/test/lisp/url/url-parse-tests.el @@ -23,7 +23,7 @@ ;;; Commentary: ;; Test cases covering generic URI syntax as described in RFC3986, -;; section 3. Syntax Components and 4. Usage. See also appendix +;; section 3. Syntax Components and 4. Usage. See also appendix ;; A. Collected ABNF for URI, as the example given here are all ;; productions of this grammar. diff --git a/test/lisp/vc/add-log-tests.el b/test/lisp/vc/add-log-tests.el index dc2b9961c6c..70e49fe57fe 100644 --- a/test/lisp/vc/add-log-tests.el +++ b/test/lisp/vc/add-log-tests.el @@ -29,8 +29,8 @@ content marker expected-defun) "Generate an ert test for mode-own `add-log-current-defun-function'. Run `add-log-current-defun' at the point where MARKER specifies -in a buffer which content is CONTENT under major mode MODE. Then -it compares the result with EXPECTED-DEFUN." +in a buffer which content is CONTENT under major mode MODE. +Then it compares the result with EXPECTED-DEFUN." (let ((xname (intern (concat "add-log-current-defun-test-" (symbol-name name) )))) diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 5bc4ad6dace..909d5620de6 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -173,35 +173,33 @@ wristwatches wrongheadedly wrongheadedness youthfulness -") - (temp-dir (make-temp-file "diff-mode-test" 'dir))) - - (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) - (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) - (unwind-protect - (progn - (with-current-buffer buf (insert fil_before) (save-buffer)) - (with-current-buffer buf2 (insert fil2_before) (save-buffer)) - - (with-temp-buffer - (cd temp-dir) - (insert patch) - (goto-char (point-min)) - (diff-apply-hunk) - (diff-apply-hunk) - (diff-apply-hunk)) - - (should (equal (with-current-buffer buf (buffer-string)) - fil_after)) - (should (equal (with-current-buffer buf2 (buffer-string)) - fil2_after))) - - (ignore-errors - (with-current-buffer buf (set-buffer-modified-p nil)) - (kill-buffer buf) - (with-current-buffer buf2 (set-buffer-modified-p nil)) - (kill-buffer buf2) - (delete-directory temp-dir 'recursive)))))) +")) + (ert-with-temp-directory temp-dir + (let ((buf (find-file-noselect (format "%s/%s" temp-dir "fil" ))) + (buf2 (find-file-noselect (format "%s/%s" temp-dir "fil2")))) + (unwind-protect + (progn + (with-current-buffer buf (insert fil_before) (save-buffer)) + (with-current-buffer buf2 (insert fil2_before) (save-buffer)) + + (with-temp-buffer + (cd temp-dir) + (insert patch) + (goto-char (point-min)) + (diff-apply-hunk) + (diff-apply-hunk) + (diff-apply-hunk)) + + (should (equal (with-current-buffer buf (buffer-string)) + fil_after)) + (should (equal (with-current-buffer buf2 (buffer-string)) + fil2_after))) + + (ignore-errors + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf) + (with-current-buffer buf2 (set-buffer-modified-p nil)) + (kill-buffer buf2))))))) (ert-deftest diff-mode-test-hunk-text-no-newline () "Check output of `diff-hunk-text' with no newline at end of file." @@ -468,4 +466,17 @@ baz")))) (114 131 (diff-mode syntax face font-lock-string-face)) (134 140 (diff-mode syntax face font-lock-keyword-face)))))))) +(ert-deftest test-hunk-file-names () + (with-temp-buffer + (insert "diff -c /tmp/ange-ftp13518wvE.el /tmp/ange-ftp1351895K.el\n") + (goto-char (point-min)) + (should (equal (diff-hunk-file-names) + '("/tmp/ange-ftp1351895K.el" "/tmp/ange-ftp13518wvE.el")))) + (with-temp-buffer + (insert "diff -c -L /ftp:slbhao:/home/albinus/src/tramp/lisp/tramp.el -L /ftp:slbhao:/home/albinus/src/emacs/lisp/net/tramp.el /tmp/ange-ftp13518wvE.el /tmp/ange-ftp1351895K.el\n") + (goto-char (point-min)) + (should (equal (diff-hunk-file-names) + '("/tmp/ange-ftp1351895K.el" "/tmp/ange-ftp13518wvE.el"))))) + (provide 'diff-mode-tests) +;;; diff-mode-tests.el ends here diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index a464db2349d..0f09616a816 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -22,6 +22,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'ediff-ptch) (ert-deftest ediff-ptch-test-bug25010 () @@ -45,34 +46,33 @@ index 6a07f80..6e8e947 100644 "Test for https://debbugs.gnu.org/26084 ." (skip-unless (executable-find "git")) (skip-unless (executable-find ediff-patch-program)) - (let* ((tmpdir (make-temp-file "ediff-ptch-test" t)) - (default-directory (file-name-as-directory tmpdir)) - (patch (make-temp-file "ediff-ptch-test")) - (qux (expand-file-name "qux.txt" tmpdir)) - (bar (expand-file-name "bar.txt" tmpdir)) - (git-program (executable-find "git"))) - ;; Create repository. - (with-temp-buffer - (insert "qux here\n") - (write-region nil nil qux nil 'silent) - (erase-buffer) - (insert "bar here\n") - (write-region nil nil bar nil 'silent)) - (call-process git-program nil nil nil "init") - (call-process git-program nil nil nil "add" ".") - (call-process git-program nil nil nil "commit" "-m" "Test repository.") - ;; Update repo., save the diff and reset to initial state. - (with-temp-buffer - (insert "foo here\n") - (write-region nil nil qux nil 'silent) - (write-region nil nil bar nil 'silent)) - (call-process git-program nil `(:file ,patch) nil "diff") - (call-process git-program nil nil nil "reset" "--hard" "HEAD") - ;; Visit the diff file i.e., patch; extract from it the parts - ;; affecting just each of the files: store in patch-bar the part - ;; affecting 'bar', and in patch-qux the part affecting 'qux'. - (find-file patch) - (unwind-protect + (ert-with-temp-directory tmpdir + (ert-with-temp-file patch + (let* ((default-directory (file-name-as-directory tmpdir)) + (qux (expand-file-name "qux.txt" tmpdir)) + (bar (expand-file-name "bar.txt" tmpdir)) + (git-program (executable-find "git"))) + ;; Create repository. + (with-temp-buffer + (insert "qux here\n") + (write-region nil nil qux nil 'silent) + (erase-buffer) + (insert "bar here\n") + (write-region nil nil bar nil 'silent)) + (call-process git-program nil nil nil "init") + (call-process git-program nil nil nil "add" ".") + (call-process git-program nil nil nil "commit" "-m" "Test repository.") + ;; Update repo., save the diff and reset to initial state. + (with-temp-buffer + (insert "foo here\n") + (write-region nil nil qux nil 'silent) + (write-region nil nil bar nil 'silent)) + (call-process git-program nil `(:file ,patch) nil "diff") + (call-process git-program nil nil nil "reset" "--hard" "HEAD") + ;; Visit the diff file i.e., patch; extract from it the parts + ;; affecting just each of the files: store in patch-bar the part + ;; affecting 'bar', and in patch-qux the part affecting 'qux'. + (find-file patch) (let* ((info (progn (ediff-map-patch-buffer (current-buffer)) ediff-patch-map)) (patch-bar @@ -116,9 +116,7 @@ index 6a07f80..6e8e947 100644 (buffer-string)) (with-temp-buffer (insert-file-contents backup) - (buffer-string))))))) - (delete-directory tmpdir 'recursive) - (delete-file patch))))) + (buffer-string)))))))))))) (provide 'ediff-ptch-tests) diff --git a/test/lisp/vc/smerge-mode-tests.el b/test/lisp/vc/smerge-mode-tests.el index 2c8f48618e5..d7827c7a8cb 100644 --- a/test/lisp/vc/smerge-mode-tests.el +++ b/test/lisp/vc/smerge-mode-tests.el @@ -34,3 +34,5 @@ (should (equal (buffer-substring (point-min) (point-max)) "")))) (provide 'smerge-mode-tests) + +;;; smerge-mode-tests.el ends here diff --git a/test/lisp/vc/vc-bzr-tests.el b/test/lisp/vc/vc-bzr-tests.el index b02dce8f707..afced819fbc 100644 --- a/test/lisp/vc/vc-bzr-tests.el +++ b/test/lisp/vc/vc-bzr-tests.el @@ -25,6 +25,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc-bzr) (require 'vc-dir) @@ -51,106 +52,97 @@ ;; temporary directory. ;; TODO does this means tests should be setting XDG_ variables (not ;; just HOME) to temporary values too? - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (ignored-dir (progn - (make-directory bzrdir) - (expand-file-name "ignored-dir" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (make-directory ignored-dir) - (with-temp-buffer - (insert (file-name-nondirectory ignored-dir)) - (write-region nil nil (expand-file-name ".bzrignore" bzrdir) - nil 'silent)) - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (with-temp-buffer - (insert "unregistered file") - (write-region nil nil (expand-file-name "testfile2" ignored-dir) - nil 'silent)) - (vc-dir ignored-dir) - (while (vc-dir-busy) - (sit-for 0.1)) - ;; FIXME better to explicitly test for error from process sentinel. - (with-current-buffer "*vc-dir*" - (goto-char (point-min)) - (should (search-forward "unregistered" nil t)))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (ignored-dir (progn + (make-directory bzrdir) + (expand-file-name "ignored-dir" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (make-directory ignored-dir) + (with-temp-buffer + (insert (file-name-nondirectory ignored-dir)) + (write-region nil nil (expand-file-name ".bzrignore" bzrdir) + nil 'silent)) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (with-temp-buffer + (insert "unregistered file") + (write-region nil nil (expand-file-name "testfile2" ignored-dir) + nil 'silent)) + (vc-dir ignored-dir) + (while (vc-dir-busy) + (sit-for 0.1)) + ;; FIXME better to explicitly test for error from process sentinel. + (with-current-buffer "*vc-dir*" + (goto-char (point-min)) + (should (search-forward "unregistered" nil t)))))) ;; Not specific to bzr. (ert-deftest vc-bzr-test-bug9781 () "Test for https://debbugs.gnu.org/9781 ." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (subdir (progn - (make-directory bzrdir) - (expand-file-name "subdir" bzrdir))) - (file (expand-file-name "file" bzrdir)) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (skip-unless (eq 0 ; some internal bzr error - (call-process vc-bzr-program nil nil nil "init"))) - (make-directory subdir) - (with-temp-buffer - (insert "text") - (write-region nil nil file nil 'silent) - (write-region nil nil (expand-file-name "subfile" subdir) - nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - (call-process vc-bzr-program nil nil nil "remove" subdir) - (with-temp-buffer - (insert "different text") - (write-region nil nil file nil 'silent)) - (vc-dir bzrdir) - (while (vc-dir-busy) - (sit-for 0.1)) - (vc-dir-mark-all-files t) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) - (vc-next-action nil)) - (should (get-buffer "*vc-log*"))) - (delete-directory homedir t)))) + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (subdir (progn + (make-directory bzrdir) + (expand-file-name "subdir" bzrdir))) + (file (expand-file-name "file" bzrdir)) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (skip-unless (eq 0 ; some internal bzr error + (call-process vc-bzr-program nil nil nil "init"))) + (make-directory subdir) + (with-temp-buffer + (insert "text") + (write-region nil nil file nil 'silent) + (write-region nil nil (expand-file-name "subfile" subdir) + nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + (call-process vc-bzr-program nil nil nil "remove" subdir) + (with-temp-buffer + (insert "different text") + (write-region nil nil file nil 'silent)) + (vc-dir bzrdir) + (while (vc-dir-busy) + (sit-for 0.1)) + (vc-dir-mark-all-files t) + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) t))) + (vc-next-action nil)) + (should (get-buffer "*vc-log*"))))) ;; https://lists.gnu.org/r/help-gnu-emacs/2012-04/msg00145.html (ert-deftest vc-bzr-test-faulty-bzr-autoloads () "Test we can generate autoloads in a bzr directory when bzr is faulty." (skip-unless (executable-find vc-bzr-program)) - (let* ((homedir (make-temp-file "vc-bzr-test" t)) - (bzrdir (expand-file-name "bzr" homedir)) - (file (progn - (make-directory bzrdir) - (expand-file-name "foo.el" bzrdir))) - (default-directory (file-name-as-directory bzrdir)) - (process-environment (cons (format "HOME=%s" homedir) - process-environment))) - (unwind-protect - (progn - (call-process vc-bzr-program nil nil nil "init") - (with-temp-buffer - (insert ";;;###autoload + (ert-with-temp-directory homedir + (let* ((bzrdir (expand-file-name "bzr" homedir)) + (file (progn + (make-directory bzrdir) + (expand-file-name "foo.el" bzrdir))) + (default-directory (file-name-as-directory bzrdir)) + (process-environment (cons (format "HOME=%s" homedir) + process-environment))) + (call-process vc-bzr-program nil nil nil "init") + (with-temp-buffer + (insert ";;;###autoload \(defun foo () \"foo\" (interactive) (message \"foo!\"))") - (write-region nil nil file nil 'silent)) - (call-process vc-bzr-program nil nil nil "add") - (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") - ;; Deleting dirstate ensures both that vc-bzr's status heuristic - ;; fails, so it has to call the external bzr status, and - ;; causes bzr status to fail. This simulates a broken bzr - ;; installation. - (delete-file ".bzr/checkout/dirstate") - (should (progn (make-directory-autoloads - default-directory - (expand-file-name "loaddefs.el" bzrdir)) - t))) - (delete-directory homedir t)))) + (write-region nil nil file nil 'silent)) + (call-process vc-bzr-program nil nil nil "add") + (call-process vc-bzr-program nil nil nil "commit" "-m" "Commit 1") + ;; Deleting dirstate ensures both that vc-bzr's status heuristic + ;; fails, so it has to call the external bzr status, and + ;; causes bzr status to fail. This simulates a broken bzr + ;; installation. + (delete-file ".bzr/checkout/dirstate") + (should (progn (make-directory-autoloads + default-directory + (expand-file-name "loaddefs.el" bzrdir)) + t))))) -;;; vc-bzr.el ends here +;;; vc-bzr-tests.el ends here diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 5430535c5ed..578d7ebb418 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -52,7 +52,7 @@ ;; - responsible-p (file) ;; - receive-file (file rev) ;; - unregister (file) DONE -;; * checkin (files comment) +;; * checkin (files comment) DONE ;; * find-revision (file rev buffer) ;; * checkout (file &optional rev) ;; * revert (file &optional contents-done) @@ -75,7 +75,7 @@ ;; - show-log-entry (revision) ;; - comment-history (file) ;; - update-changelog (files) -;; * diff (files &optional async rev1 rev2 buffer) +;; * diff (files &optional async rev1 rev2 buffer) DONE ;; - revision-completion-table (files) ;; - annotate-command (file buf &optional rev) ;; - annotate-time () @@ -100,7 +100,7 @@ ;; - log-edit-mode () ;; - check-headers () ;; - delete-file (file) -;; - rename-file (old new) +;; - rename-file (old new) DONE ;; - find-file-hook () ;; - extra-menu () ;; - extra-dir-menu () @@ -109,7 +109,9 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'vc) +(require 'log-edit) (declare-function w32-application-type "w32proc.c") @@ -177,41 +179,38 @@ For backends which dont support it, it is emulated." (defun vc-test--create-repo (backend) "Create a test repository in `default-directory', a temporary directory." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--create-repo" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Check the revision granularity. - (should (memq (vc-test--revision-granularity-function backend) - '(file repository))) - - ;; Create empty repository. - (make-directory default-directory) - (should (file-directory-p default-directory)) - (vc-test--create-repo-function backend) - (should (eq (vc-responsible-backend default-directory) backend))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Check the revision granularity. + (should (memq (vc-test--revision-granularity-function backend) + '(file repository))) + + ;; Create empty repository. + (make-directory default-directory) + (should (file-directory-p default-directory)) + (vc-test--create-repo-function backend) + (should (eq (vc-responsible-backend default-directory) backend))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; FIXME: Why isn't there `vc-unregister'? (defun vc-test--unregister-function (backend file) @@ -234,318 +233,429 @@ Catch the `vc-not-supported' error." (defun vc-test--register (backend) "Register and unregister a file. This checks also `vc-backend' and `vc-responsible-backend'." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--register" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - ;; For file oriented backends CVS, RCS and SVN the backend is - ;; returned, and the directory is registered already. - (should (if (vc-backend default-directory) - (vc-registered default-directory) - (not (vc-registered default-directory)))) - (should (eq (vc-responsible-backend default-directory) backend)) - - (let ((tmp-name1 (expand-file-name "foo" default-directory)) - (tmp-name2 "bla")) - ;; Register files. Check for it. - (write-region "foo" nil tmp-name1 nil 'nomessage) - (should (file-exists-p tmp-name1)) - (should-not (vc-backend tmp-name1)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should-not (vc-registered tmp-name1)) - - (write-region "bla" nil tmp-name2 nil 'nomessage) - (should (file-exists-p tmp-name2)) - (should-not (vc-backend tmp-name2)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should-not (vc-registered tmp-name2)) - - (vc-register (list backend (list tmp-name1 tmp-name2))) - (should (file-exists-p tmp-name1)) - (should (eq (vc-backend tmp-name1) backend)) - (should (eq (vc-responsible-backend tmp-name1) backend)) - (should (vc-registered tmp-name1)) - - (should (file-exists-p tmp-name2)) - (should (eq (vc-backend tmp-name2) backend)) - (should (eq (vc-responsible-backend tmp-name2) backend)) - (should (vc-registered tmp-name2)) - - ;; `vc-backend' accepts also a list of files, - ;; `vc-responsible-backend' doesn't. - (should (vc-backend (list tmp-name1 tmp-name2))) - - ;; Unregister the files. - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name1) - 'vc-not-supported) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + ;; For file oriented backends CVS, RCS and SVN the backend is + ;; returned, and the directory is registered already. + (should (if (vc-backend default-directory) + (vc-registered default-directory) + (not (vc-registered default-directory)))) + (should (eq (vc-responsible-backend default-directory) backend)) + + (let ((tmp-name1 (expand-file-name "foo" default-directory)) + (tmp-name2 "bla")) + ;; Register files. Check for it. + (write-region "foo" nil tmp-name1 nil 'nomessage) + (should (file-exists-p tmp-name1)) (should-not (vc-backend tmp-name1)) - (should-not (vc-registered tmp-name1))) - (unless (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name2) - 'vc-not-supported) - (should-not (vc-backend tmp-name2)) - (should-not (vc-registered tmp-name2))) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should-not (vc-registered tmp-name1)) - ;; The files should still exist. - (should (file-exists-p tmp-name1)) - (should (file-exists-p tmp-name2)))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (write-region "bla" nil tmp-name2 nil 'nomessage) + (should (file-exists-p tmp-name2)) + (should-not (vc-backend tmp-name2)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should-not (vc-registered tmp-name2)) + + (vc-register (list backend (list tmp-name1 tmp-name2))) + (should (file-exists-p tmp-name1)) + (should (eq (vc-backend tmp-name1) backend)) + (should (eq (vc-responsible-backend tmp-name1) backend)) + (should (vc-registered tmp-name1)) + + (should (file-exists-p tmp-name2)) + (should (eq (vc-backend tmp-name2) backend)) + (should (eq (vc-responsible-backend tmp-name2) backend)) + (should (vc-registered tmp-name2)) + + ;; `vc-backend' accepts also a list of files, + ;; `vc-responsible-backend' doesn't. + (should (vc-backend (list tmp-name1 tmp-name2))) + + ;; Unregister the files. + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name1) + 'vc-not-supported) + (should-not (vc-backend tmp-name1)) + (should-not (vc-registered tmp-name1))) + (unless (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name2) + 'vc-not-supported) + (should-not (vc-backend tmp-name2)) + (should-not (vc-registered tmp-name2))) + + ;; The files should still exist. + (should (file-exists-p tmp-name1)) + (should (file-exists-p tmp-name2)))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--state (backend) "Check the different states of a file." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--state" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check state of a nonexistent file. - - (message "vc-state2 %s" (vc-state tmp-name)) - (should (null (vc-state tmp-name))) - - ;; Write a new file. Check state. - (write-region "foo" nil tmp-name nil 'nomessage) - - ;; nil: Mtn - ;; unregistered: Bzr CVS Git Hg SVN RCS - (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) '(nil unregistered))) - - ;; Register a file. Check state. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; FIXME: nil is definitely wrong. - ;; nil: SRC - ;; added: Bzr CVS Git Hg Mtn SVN - ;; up-to-date: RCS SCCS - (message "vc-state4 %s" (vc-state tmp-name)) - (should (memq (vc-state tmp-name) '(nil added up-to-date))) - - ;; Unregister the file. Check state. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-state5 unsupported") - ;; unregistered: Bzr Git RCS Hg - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) - (should (memq (vc-state tmp-name backend) - '(nil unregistered)))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check state of a nonexistent file. + + (message "vc-state2 %s" (vc-state tmp-name)) + (should (null (vc-state tmp-name))) + + ;; Write a new file. Check state. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; nil: Mtn + ;; unregistered: Bzr CVS Git Hg SVN RCS + (message "vc-state3 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) '(nil unregistered))) + + ;; Register a file. Check state. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; FIXME: nil is definitely wrong. + ;; nil: SRC + ;; added: Bzr CVS Git Hg Mtn SVN + ;; up-to-date: RCS SCCS + (message "vc-state4 %s" (vc-state tmp-name)) + (should (memq (vc-state tmp-name) '(nil added up-to-date))) + + ;; Unregister the file. Check state. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-state5 unsupported") + ;; unregistered: Bzr Git RCS Hg + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-state5 %s %s" backend (vc-state tmp-name backend)) + (should (memq (vc-state tmp-name backend) + '(nil unregistered)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--working-revision (backend) "Check the working revision of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--working-revision" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check working revision of - ;; repository, should be nil. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; FIXME: Is the value for SVN correct? - ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC - ;; "0": SVN - (message - "vc-working-revision1 %s" (vc-working-revision default-directory)) - (should (member (vc-working-revision default-directory) '(nil "0"))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check initial working revision, should be nil until - ;; it's registered. - - (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Write a new file. Check working revision. - (write-region "foo" nil tmp-name nil 'nomessage) - - (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name)) - - ;; Register a file. Check working revision. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) - - ;; XXX: nil is fine, at least in Git's case, because - ;; `vc-register' only makes the file `added' in this case. - ;; nil: Git Mtn - ;; "0": Bzr CVS Hg SRC SVN - ;; "1.1": RCS SCCS - ;; "-1": Hg versions before 5 (probably) - (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) - (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) - - ;; TODO: Call `vc-checkin', and check the resulting - ;; working revision. None of the return values should be - ;; nil then. - - ;; Unregister the file. Check working revision. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-working-revision5 unsupported") - ;; nil: Bzr Git Hg RCS - ;; unsupported: CVS Mtn SCCS SRC SVN - (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) - (should-not (vc-working-revision tmp-name))))) - - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check working revision of + ;; repository, should be nil. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; FIXME: Is the value for SVN correct? + ;; nil: Bzr CVS Git Hg Mtn RCS SCCS SRC + ;; "0": SVN + (message + "vc-working-revision1 %s" (vc-working-revision default-directory)) + (should (member (vc-working-revision default-directory) '(nil "0"))) + + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check initial working revision, should be nil until + ;; it's registered. + + (message "vc-working-revision2 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Write a new file. Check working revision. + (write-region "foo" nil tmp-name nil 'nomessage) + + (message "vc-working-revision3 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name)) + + ;; Register a file. Check working revision. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; XXX: nil is fine, at least in Git's case, because + ;; `vc-register' only makes the file `added' in this case. + ;; nil: Git Mtn + ;; "0": Bzr CVS Hg SRC SVN + ;; "1.1": RCS SCCS + ;; "-1": Hg versions before 5 (probably) + (message "vc-working-revision4 %s" (vc-working-revision tmp-name)) + (should (member (vc-working-revision tmp-name) '(nil "0" "1.1" "-1"))) + + ;; TODO: Call `vc-checkin', and check the resulting + ;; working revision. None of the return values should be + ;; nil then. + + ;; Unregister the file. Check working revision. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-working-revision5 unsupported") + ;; nil: Bzr Git Hg RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message "vc-working-revision5 %s" (vc-working-revision tmp-name)) + (should-not (vc-working-revision tmp-name))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) (defun vc-test--checkout-model (backend) "Check the checkout model of a repository." - - (let ((vc-handled-backends `(,backend)) - (default-directory - (file-name-as-directory - (expand-file-name - (make-temp-name "vc-test") temporary-file-directory))) - (process-environment process-environment) - tempdir - vc-test--cleanup-hook) - (when (eq backend 'Bzr) - (setq tempdir (make-temp-file "vc-test--checkout-model" t) - process-environment (cons (format "BZR_HOME=%s" tempdir) - process-environment))) - - (unwind-protect - (progn - ;; Cleanup. - (add-hook - 'vc-test--cleanup-hook - `(lambda () (delete-directory ,default-directory 'recursive))) - - ;; Create empty repository. Check repository checkout model. - (make-directory default-directory) - (vc-test--create-repo-function backend) - - ;; Surprisingly, none of the backends returns 'announce. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model1 %s" - (vc-checkout-model backend default-directory)) - (should (memq (vc-checkout-model backend default-directory) - '(announce implicit locking))) - - (let ((tmp-name (expand-file-name "foo" default-directory))) - ;; Check checkout model of a nonexistent file. - - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + ;; Surprisingly, none of the backends returns 'announce. + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + "vc-checkout-model1 %s" + (vc-checkout-model backend default-directory)) + (should (memq (vc-checkout-model backend default-directory) + '(announce implicit locking))) - ;; Write a new file. Check checkout model. - (write-region "foo" nil tmp-name nil 'nomessage) + (let ((tmp-name (expand-file-name "foo" default-directory))) + ;; Check checkout model of a nonexistent file. - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model2 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) - ;; Register a file. Check checkout model. - (vc-register - (list backend (list (file-name-nondirectory tmp-name)))) + ;; Write a new file. Check checkout model. + (write-region "foo" nil tmp-name nil 'nomessage) - ;; implicit: Bzr CVS Git Hg Mtn SRC SVN - ;; locking: RCS SCCS - (message - "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) - (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking))) - - ;; Unregister the file. Check checkout model. - (if (eq (vc-test--run-maybe-unsupported-function - 'vc-test--unregister-function backend tmp-name) - 'vc-not-supported) - (message "vc-checkout-model5 unsupported") - ;; implicit: Bzr Git Hg - ;; locking: RCS - ;; unsupported: CVS Mtn SCCS SRC SVN + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS (message - "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + "vc-checkout-model3 %s" (vc-checkout-model backend tmp-name)) (should (memq (vc-checkout-model backend tmp-name) - '(announce implicit locking)))))) + '(announce implicit locking))) - ;; Save exit. - (ignore-errors - (if tempdir (delete-directory tempdir t)) - (run-hooks 'vc-test--cleanup-hook))))) + ;; Register a file. Check checkout model. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + ;; implicit: Bzr CVS Git Hg Mtn SRC SVN + ;; locking: RCS SCCS + (message + "vc-checkout-model4 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking))) + + ;; Unregister the file. Check checkout model. + (if (eq (vc-test--run-maybe-unsupported-function + 'vc-test--unregister-function backend tmp-name) + 'vc-not-supported) + (message "vc-checkout-model5 unsupported") + ;; implicit: Bzr Git Hg + ;; locking: RCS + ;; unsupported: CVS Mtn SCCS SRC SVN + (message + "vc-checkout-model5 %s" (vc-checkout-model backend tmp-name)) + (should (memq (vc-checkout-model backend tmp-name) + '(announce implicit locking)))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(defun vc-test--rename-file (backend) + "Check the rename-file action." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let ((tmp-name (expand-file-name "foo" default-directory)) + (new-name (expand-file-name "bar" default-directory))) + ;; Write a new file. + (write-region "foo" nil tmp-name nil 'nomessage) + + ;; Register it. Renaming can fail otherwise. + (vc-register + (list backend (list (file-name-nondirectory tmp-name)))) + + (vc-rename-file tmp-name new-name) + + (should (not (file-exists-p tmp-name))) + (should (file-exists-p new-name)) + + (should (equal (vc-state new-name) + (if (memq backend '(RCS SCCS)) + 'up-to-date + 'added))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) + +(declare-function log-edit-done "vc/log-edit") + +(defun vc-test--version-diff (backend) + "Check the diff version of a repository." + (ert-with-temp-directory tempdir + (let ((vc-handled-backends `(,backend)) + (default-directory + (file-name-as-directory + (expand-file-name + (make-temp-name "vc-test") temporary-file-directory))) + (process-environment process-environment) + vc-test--cleanup-hook) + (when (eq backend 'Bzr) + (setq process-environment (cons (format "BZR_HOME=%s" tempdir) + process-environment))) + ;; git tries various approaches to guess a user name and email, + ;; which can fail depending on how the system is configured. + ;; Eg if the user account has no GECOS, git commit can fail with + ;; status 128 "fatal: empty ident name". + (when (memq backend '(Bzr Git)) + (setq process-environment (cons "EMAIL=john@doe.ee" + process-environment))) + (if (eq backend 'Git) + (setq process-environment (append '("GIT_AUTHOR_NAME=A" + "GIT_COMMITTER_NAME=C") + process-environment))) + (unwind-protect + (progn + ;; Cleanup. + (add-hook + 'vc-test--cleanup-hook + `(lambda () (delete-directory ,default-directory 'recursive))) + + ;; Create empty repository. Check repository checkout model. + (make-directory default-directory) + (vc-test--create-repo-function backend) + + (let* ((tmp-name (expand-file-name "foo" default-directory)) + (files (list (file-name-nondirectory tmp-name)))) + ;; Write and register a new file. + (write-region "originaltext" nil tmp-name nil 'nomessage) + (vc-register (list backend files)) + + (let ((buff (find-file tmp-name))) + (with-current-buffer buff + (progn + ;; Optionally checkout file. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + + ;; Checkin file. + (vc-checkin files backend) + (insert "Testing vc-version-diff") + (log-edit-done)))) + + ;; Modify file content. + (when (memq backend '(RCS CVS SCCS)) + (vc-checkout tmp-name)) + (write-region "updatedtext" nil tmp-name nil 'nomessage) + + ;; Check version diff. + (vc-version-diff files nil nil) + (should (bufferp (get-buffer "*vc-diff*"))) + + (with-current-buffer "*vc-diff*" + (progn + (let ((rawtext (buffer-substring-no-properties (point-min) + (point-max)))) + (should (string-search "-originaltext" rawtext)) + (should (string-search "+updatedtext" rawtext))))))) + + ;; Save exit. + (ignore-errors + (run-hooks 'vc-test--cleanup-hook)))))) ;; Create the test cases. @@ -648,7 +758,35 @@ This checks also `vc-backend' and `vc-responsible-backend'." (ert-get-test ',(intern (format "vc-test-%s01-register" backend-string)))))) - (vc-test--checkout-model ',backend)))))) + (vc-test--checkout-model ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s05-rename-file" backend-string)) () + ,(format "Check `vc-rename-file' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + ;; CVS calls vc-delete-file, which insists on prompting + ;; "Really want to delete ...?" + (skip-unless (not (eq 'CVS ',backend))) + (vc-test--rename-file ',backend)) + + (ert-deftest + ,(intern (format "vc-test-%s06-version-diff" backend-string)) () + ,(format "Check `vc-version-diff' for the %s backend." + backend-string) + (skip-unless + (ert-test-passed-p + (ert-test-most-recent-result + (ert-get-test + ',(intern + (format "vc-test-%s01-register" backend-string)))))) + (vc-test--version-diff ',backend)) + )))) (provide 'vc-tests) ;;; vc-tests.el ends here diff --git a/test/lisp/wdired-tests.el b/test/lisp/wdired-tests.el index ba276e24d96..e768a165529 100644 --- a/test/lisp/wdired-tests.el +++ b/test/lisp/wdired-tests.el @@ -20,6 +20,7 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'dired) (require 'wdired) @@ -28,104 +29,100 @@ (ert-deftest wdired-test-bug32173-01 () "Test using non-nil wdired-use-interactive-rename. Partially modifying a file name should succeed." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (replace-regexp-in-string "foo" replace test-file)) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. - :override - (lambda (_sym _prompt &rest _args) (setq dired-query t)) - '((name . "advice-dired-query"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (wdired-finish-edit) - (should (equal (dired-file-name-at-point) new-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file)) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + (advice-add 'dired-query ; Don't ask confirmation to overwrite a file. + :override + (lambda (_sym _prompt &rest _args) (setq dired-query t)) + '((name . "advice-dired-query"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (wdired-finish-edit) + (should (equal (dired-file-name-at-point) new-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-bug32173-02 () "Test using non-nil wdired-use-interactive-rename. Aborting an edit should leaving original file name unchanged." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (wdired-use-interactive-rename t)) - (write-region "" nil test-file nil 'silent) - ;; Make dired-do-create-files-regexp a noop to mimic typing C-g - ;; at its prompt before wdired-finish-edit returns. - (advice-add 'dired-do-create-files-regexp - :override - (lambda (&rest _) (ignore)) - '((name . "advice-dired-do-create-files-regexp"))) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert "bar") - (wdired-finish-edit) - (should (equal (dired-get-filename) test-file))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (wdired-use-interactive-rename t)) + (write-region "" nil test-file nil 'silent) + ;; Make dired-do-create-files-regexp a noop to mimic typing C-g + ;; at its prompt before wdired-finish-edit returns. + (advice-add 'dired-do-create-files-regexp + :override + (lambda (&rest _) (ignore)) + '((name . "advice-dired-do-create-files-regexp"))) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert "bar") + (wdired-finish-edit) + (should (equal (dired-get-filename) test-file))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-symlink-name () "Test the file name of a symbolic link. The Dired and WDired functions returning the name should include only the name before the link arrow." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (link-name "foo")) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (skip-unless - ;; This check is for wdired, not symbolic links, so skip - ;; it when make-symbolic-link fails for any reason (like - ;; insufficient privileges). - (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) - (revert-buffer) - (let* ((file-name (dired-get-filename)) - (dir-part (file-name-directory file-name)) - (lf-name (concat dir-part link-name))) - (should (equal file-name lf-name)) - (dired-toggle-read-only) - (should (equal (wdired-get-filename) lf-name)) - (dired-toggle-read-only))) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((link-name "foo")) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (skip-unless + ;; This check is for wdired, not symbolic links, so skip + ;; it when make-symbolic-link fails for any reason (like + ;; insufficient privileges). + (ignore-errors (make-symbolic-link "./bar/baz" link-name) t)) + (revert-buffer) + (let* ((file-name (dired-get-filename)) + (dir-part (file-name-directory file-name)) + (lf-name (concat dir-part link-name))) + (should (equal file-name lf-name)) + (dired-toggle-read-only) + (should (equal (wdired-get-filename) lf-name)) + (dired-toggle-read-only))) + (if buf (kill-buffer buf))))))) (ert-deftest wdired-test-unfinished-edit-01 () "Test editing a file name without saving the change. Finding the new name should be possible while still in wdired-mode." - (let* ((test-dir (make-temp-file "test-dir-" t)) - (test-file (concat (file-name-as-directory test-dir) "foo.c")) - (replace "bar") - (new-file (replace-regexp-in-string "foo" replace test-file))) - (write-region "" nil test-file nil 'silent) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (should (equal (dired-file-name-at-point) test-file)) - (dired-toggle-read-only) - (kill-region (point) (progn (search-forward ".") - (forward-char -1) (point))) - (insert replace) - (should (equal (dired-get-filename) new-file))) - (when buf - (with-current-buffer buf - ;; Prevent kill-buffer-query-functions from chiming in. - (set-buffer-modified-p nil) - (kill-buffer buf))) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((test-file (concat (file-name-as-directory test-dir) "foo.c")) + (replace "bar") + (new-file (string-replace "foo" replace test-file))) + (write-region "" nil test-file nil 'silent) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (should (equal (dired-file-name-at-point) test-file)) + (dired-toggle-read-only) + (kill-region (point) (progn (search-forward ".") + (forward-char -1) (point))) + (insert replace) + (should (equal (dired-get-filename) new-file))) + (when buf + (with-current-buffer buf + ;; Prevent kill-buffer-query-functions from chiming in. + (set-buffer-modified-p nil) + (kill-buffer buf)))))))) (defvar server-socket-dir) (declare-function dired-smart-shell-command "dired-x" @@ -139,61 +136,59 @@ dired-move-to-end-of-filename handles indicator characters, it suffices to compare the return values of dired-get-filename and wdired-get-filename before and after editing." ;; FIXME: Add a test for a door (indicator ">") only under Solaris? - (let* ((test-dir (make-temp-file "test-dir-" t)) - (server-socket-dir test-dir) - (dired-listing-switches "-Fl") - (dired-ls-F-marks-symlinks (eq system-type 'darwin)) - (buf (find-file-noselect test-dir))) - (unwind-protect - (progn - (with-current-buffer buf - (dired-create-empty-file "foo") - (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) - (make-symbolic-link "foo" "bar") - (make-directory "foodir") - (require 'dired-x) - (dired-smart-shell-command "mkfifo foopipe") - (server-force-delete) - ;; FIXME? This seems a heavy-handed way of making a socket. - (server-start) ; Add a socket file. - (kill-buffer buf)) - (dired test-dir) - (dired-toggle-read-only) - (let (names) - ;; Test that the file names are the same in Dired and WDired. - (while (not (eobp)) - (should (equal (dired-get-filename 'no-dir t) - (wdired-get-filename t))) - (insert "w") - (push (wdired-get-filename t) names) - (dired-next-line 1)) - (wdired-finish-edit) - ;; Test that editing the file names ignores the indicator - ;; character. - (let (dir) - (while (and (dired-previous-line 1) - (setq dir (dired-get-filename 'no-dir t))) - (should (equal dir (pop names))))))) - (kill-buffer (get-buffer test-dir)) - (server-force-delete) - (delete-directory test-dir t)))) + (ert-with-temp-directory test-dir + (let* ((server-socket-dir test-dir) + (dired-listing-switches "-Fl") + (dired-ls-F-marks-symlinks (eq system-type 'darwin)) + (buf (find-file-noselect test-dir))) + (unwind-protect + (progn + (with-current-buffer buf + (dired-create-empty-file "foo") + (set-file-modes "foo" (file-modes-symbolic-to-number "+x")) + (make-symbolic-link "foo" "bar") + (make-directory "foodir") + (require 'dired-x) + (dired-smart-shell-command "mkfifo foopipe") + (server-force-delete) + ;; FIXME? This seems a heavy-handed way of making a socket. + (server-start) ; Add a socket file. + (kill-buffer buf)) + (dired test-dir) + (dired-toggle-read-only) + (let (names) + ;; Test that the file names are the same in Dired and WDired. + (while (not (eobp)) + (should (equal (dired-get-filename 'no-dir t) + (wdired-get-filename t))) + (insert "w") + (push (wdired-get-filename t) names) + (dired-next-line 1)) + (wdired-finish-edit) + ;; Test that editing the file names ignores the indicator + ;; character. + (let (dir) + (while (and (dired-previous-line 1) + (setq dir (dired-get-filename 'no-dir t))) + (should (equal dir (pop names))))))) + (kill-buffer (get-buffer test-dir)) + (server-force-delete))))) (ert-deftest wdired-test-bug39280 () "Test for https://debbugs.gnu.org/39280." - (let* ((test-dir (make-temp-file "test-dir" 'dir)) - (fname "foo") - (full-fname (expand-file-name fname test-dir))) - (make-empty-file full-fname) - (let ((buf (find-file-noselect test-dir))) - (unwind-protect - (with-current-buffer buf - (dired-toggle-read-only) - (dolist (old '(t nil)) - (should (equal fname (wdired-get-filename 'nodir old))) - (should (equal full-fname (wdired-get-filename nil old)))) - (wdired-finish-edit)) - (if buf (kill-buffer buf)) - (delete-directory test-dir t))))) + (ert-with-temp-directory test-dir + (let* ((fname "foo") + (full-fname (expand-file-name fname test-dir))) + (make-empty-file full-fname) + (let ((buf (find-file-noselect test-dir))) + (unwind-protect + (with-current-buffer buf + (dired-toggle-read-only) + (dolist (old '(t nil)) + (should (equal fname (wdired-get-filename 'nodir old))) + (should (equal full-fname (wdired-get-filename nil old)))) + (wdired-finish-edit)) + (if buf (kill-buffer buf))))))) (provide 'wdired-tests) ;;; wdired-tests.el ends here diff --git a/test/lisp/whitespace-tests.el b/test/lisp/whitespace-tests.el index 9f54a4fd340..1001476a286 100644 --- a/test/lisp/whitespace-tests.el +++ b/test/lisp/whitespace-tests.el @@ -51,7 +51,7 @@ ;; We cannot call whitespace-mode because it will do nothing in batch ;; mode. So we call its innards instead. (defun whitespace-tests-whitespace-mode-on () - "Turn whitespace-mode on even in batch mode." + "Turn `whitespace-mode' on even in batch mode." (whitespace-turn-on) (whitespace-action-when-on) (setq whitespace-mode t)) diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index b00b58acfc5..7c64ef39f8d 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -78,7 +78,7 @@ ;; Bug#16344 "<!----><x>< /x>" "<a>< b/></a>") - "List of XML strings that should signal an error in the parser") + "List of XML strings that should signal an error in the parser.") (defvar xml-parse-tests--qnames '( ;; Test data for name expansion @@ -199,4 +199,4 @@ Parser is called with and without 'symbol-qnames argument.") ;; no-byte-compile: t ;; End: -;;; xml-parse-tests.el ends here. +;;; xml-tests.el ends here diff --git a/test/manual/BidiCharacterTest.txt b/test/manual/BidiCharacterTest.txt index 02e2083ee66..c30d0778612 100644 --- a/test/manual/BidiCharacterTest.txt +++ b/test/manual/BidiCharacterTest.txt @@ -1,6 +1,6 @@ -# BidiCharacterTest-13.0.0.txt -# Date: 2019-09-09, 19:32:00 GMT [LI] -# © 2019 Unicode®, Inc. +# BidiCharacterTest-14.0.0.txt +# Date: 2020-03-30, 23:56:00 GMT [LI] +# © 2020 Unicode®, Inc. # For terms of use, see http://www.unicode.org/terms_of_use.html # # Unicode Character Database @@ -87,6 +87,32 @@ 0661 0028 0662 0029 0331;0;0;2 1 2 1 1;4 3 2 1 0 0661 0028 0332 0662 0029 0333;0;0;2 1 1 2 1 1;5 4 3 2 1 0 +# Nonspacing marks applied to paired brackets [added to test cases for Unicode 14.0] +# These cases exercise the ignoring of bc=BN characters (such as ZWJ or ZWSP) +# that appear between the base bracket character and the nonspacing mark, +# in a context where the brackets have been forced to a strong R direction. +# +# Note that due to an implementation error in the N0 rule in the Bidi Reference C +# test code for UBA 8.0, versions of that reference test code through UBA 12.0 will fail for +# precisely these newly added tests. The bug in the implementation of the N0 rule in the Bidi Reference C +# test code was fixed for Unicode 13.0, and that updated test code now performs correctly +# for all versions of UBA. +# +# These test cases first test a combining mark following a ZWJ after the trailing bracket of a pair: +0041 200F 005B 05D0 005D 200D 20D6;0;0;0 1 1 1 1 x 1;0 6 4 3 2 1 +0041 200F 005B 05D0 005D 200D 20D6;1;1;2 1 1 1 1 x 1;6 4 3 2 1 0 +# Then a combining mark following a ZWJ after the leading bracket of a pair: +0041 200F 005B 200D 20D6 05D0 005D;0;0;0 1 1 x 1 1 1;0 6 5 4 2 1 +0041 200F 005B 200D 20D6 05D0 005D;1;1;2 1 1 x 1 1 1;6 5 4 2 1 0 +# Then a combining mark following a ZWJ after both brackets of a pair: +0041 200F 005B 200D 20D6 05D0 005D 200D 20D6;0;0;0 1 1 x 1 1 1 x 1;0 8 6 5 4 2 1 +0041 200F 005B 200D 20D6 05D0 005D 200D 20D6;1;1;2 1 1 x 1 1 1 x 1;8 6 5 4 2 1 0 +# Then the intervention of a ZWSP in these same sequences. +# (The ZWSP formally breaks the combining character sequence, but should +# not block the identification of the combining mark for the application of rule N0.) +0041 200F 005B 200D 200B 20D6 05D0 005D 200B 200D 20D6;0;0;0 1 1 x x 1 1 1 x x 1;0 10 7 6 5 2 1 +0041 200F 005B 200D 200B 20D6 05D0 005D 200B 200D 20D6;1;1;2 1 1 x x 1 1 1 x x 1;10 7 6 5 2 1 0 + # Nested bracket pairs that reach and exceed the fixed capacity of the bracket stack # a ( ( ... ( b ) ) ... ) with 62, 63, and 64 nested bracket pairs 0061 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0028 0062 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029 0029;1;1;2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2;0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 diff --git a/test/manual/biditest.el b/test/manual/biditest.el index a77fc158807..c84e7ed7310 100644 --- a/test/manual/biditest.el +++ b/test/manual/biditest.el @@ -121,3 +121,5 @@ BidiCharacterTest.txt file." (message "%s" (bidi-resolved-levels))) (define-key global-map [f8] #'bidi-levels) + +;;; biditest.el ends here diff --git a/test/manual/cedet/ede-tests.el b/test/manual/cedet/ede-tests.el index 2af50860c60..17618381ef2 100644 --- a/test/manual/cedet/ede-tests.el +++ b/test/manual/cedet/ede-tests.el @@ -80,4 +80,4 @@ The search is done with the current EDE root." (ede-locate-file-in-project loc file) (data-debug-insert-object-slots loc "]"))) -;;; ede-test.el ends here +;;; ede-tests.el ends here diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index 1561c18dd68..3e416cc6b20 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -24,6 +24,8 @@ ;; Originally, there are many test functions scattered among the ;; Semantic source files. This file consolidates them. +;;; Code: + (require 'data-debug) ;;; From semantic-complete @@ -46,7 +48,7 @@ All systems are different. Ask questions along the way." (interactive) (let ((doload nil)) - (when (y-or-n-p "Create a system database to test with? ") + (when (y-or-n-p "Create a system database to test with?") (call-interactively 'semanticdb-create-ebrowse-database) (setq doload t)) ;; Should we load in caches @@ -269,3 +271,5 @@ tag that contains point, and return that." Lcount (semantic-tag-name target) (semantic-elapsed-time start nil))) Lcount))) + +;;; semantic-tests.el ends here diff --git a/test/manual/cedet/tests/test.el b/test/manual/cedet/tests/test.el index d1d0d1602f4..34c03619f88 100644 --- a/test/manual/cedet/tests/test.el +++ b/test/manual/cedet/tests/test.el @@ -19,31 +19,29 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;; Require -;; +;;; Code: + (require 'semantic) (require 'eieio "../eieio") ;; tags encapsulated in eval-when-compile and eval-and-compile ;; should be expanded out into the outer environment. (eval-when-compile - (require 'semantic-imenu) - ) + (require 'semantic-imenu)) (eval-and-compile (defconst const-1 nil) (defun function-1 (arg) - nil) - ) + nil)) ;;; Functions ;; (defun a-defun (arg1 arg2 &optional arg3) - "doc a" + "Doc a." nil) (defun a-defun-interactive (arg1 arg2 &optional arg3) - "doc a that is a command" + "Doc a that is a command." (interactive "R") nil) @@ -52,15 +50,15 @@ nil) (defsubst a-defsubst (arg1 arg2 &optional arg3) - "doc a-subst" + "Doc a-subst." nil) (defmacro a-defmacro (arg1 arg2 &optional arg3) - "doc a-macro" + "Doc a-macro." nil) (define-overload a-overload (arg) - "doc a-overload" + "Doc a-overload." nil) ;;; Methods @@ -81,16 +79,16 @@ ;;; Variables ;; (defvar a-defvar (cons 1 2) - "Variable a") + "Variable a.") ;; FIXME: This practice is not recommended in recent Emacs. Remove? (defvar a-defvar-star (cons 1 2) - "*User visible var a") + "*User visible var a.") -(defconst a-defconst 'a "var doc const") +(defconst a-defconst 'a "Var doc const.") (defcustom a-defcustom nil - "doc custom" + "Doc custom." :group 'a-defgroup :type 'boolean) @@ -111,7 +109,7 @@ (defgroup a-defgroup nil - "Group for `emacs-lisp' regression-test") + "Group for `emacs-lisp' regression-test.") ;;; Classes ;; @@ -154,3 +152,5 @@ "some value") (provide 'test) + +;;; test.el ends here diff --git a/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el b/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el index 36f6624472d..86cc8825466 100644 --- a/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el +++ b/test/manual/etags/el-src/emacs/lisp/progmodes/etags.el @@ -732,7 +732,7 @@ Returns t if it visits a tags table, or nil if there are no more in the list." "Return the file name of the file whose tags point is within. Assumes the tags table is the current buffer. If RELATIVE is non-nil, file name returned is relative to tags -table file's directory. If RELATIVE is nil, file name returned +table file's directory. If RELATIVE is nil, file name returned is complete." (funcall file-of-tag-function relative)) diff --git a/test/manual/image-size-tests.el b/test/manual/image-size-tests.el index 44846a7a67a..067a0bfc8e2 100644 --- a/test/manual/image-size-tests.el +++ b/test/manual/image-size-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Commentary: + ;; To test: Load the file and eval (image-size-tests). ;; A non-erroring result is a success. diff --git a/test/manual/image-transforms-tests.el b/test/manual/image-transforms-tests.el index debb74f2edb..acbaed5c0b6 100644 --- a/test/manual/image-transforms-tests.el +++ b/test/manual/image-transforms-tests.el @@ -174,3 +174,5 @@ (test-scaling) (test-scaling-rotation) (goto-char (point-min)))) + +;;; image-transforms-tests.el ends here diff --git a/test/manual/redisplay-testsuite.el b/test/manual/redisplay-testsuite.el index 8e90f2d7a5c..8a4828417c8 100644 --- a/test/manual/redisplay-testsuite.el +++ b/test/manual/redisplay-testsuite.el @@ -350,3 +350,5 @@ static unsigned char x_bits[] = {0xff, 0x81, 0xbd, 0xa5, 0xa5, 0xbd, 0x81, 0xff (test-redisplay-4) (test-redisplay-5) (goto-char (point-min)))) + +;;; redisplay-testsuite.el ends here diff --git a/test/misc/test-custom-libs.el b/test/misc/test-custom-libs.el index cc2be99dea8..d826dfbcab4 100644 --- a/test/misc/test-custom-libs.el +++ b/test/misc/test-custom-libs.el @@ -19,7 +19,7 @@ ;;; Commentary: -;; This file runs for all libraries with autoloads separate emacs +;; This file runs for all libraries with autoloads separate Emacs ;; processes of the form "emacs -batch -l LIB". ;;; Code: @@ -45,4 +45,4 @@ (cus-test-libs t) (should-not cus-test-libs-errors)) -;;; test-custom-deps.el ends here +;;; test-custom-libs.el ends here diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 1324c2d3b4d..5383c436035 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -58,3 +58,5 @@ (dolist (c (list 10003 ?b 128 ?c ?d (max-char) ?e)) (aset s 0 c) (should (equal s (make-string 1 c)))))) + +;;; alloc-tests.el ends here diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 11f842e8fe0..7943ac2ec26 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 () @@ -754,7 +756,7 @@ with parameters from the *Messages* buffer modification." (should-length 2 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max))) (narrow-to-region 1 50) - (should-length 0 (overlays-in 1 (point-max))) + (should-length 1 (overlays-in 1 (point-max))) (should-length 1 (overlays-in (point-max) (point-max)))))) @@ -1399,4 +1401,85 @@ with parameters from the *Messages* buffer modification." (should (memq long-overlay (overlays-in 3 3))) (should (memq zero-overlay (overlays-in 3 3)))))) +(ert-deftest test-remove-overlays () + (with-temp-buffer + (insert "foo") + (make-overlay (point) (point)) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0))) + + (with-temp-buffer + (insert "foo") + (goto-char 2) + (make-overlay (point) (point)) + ;; We only count zero-length overlays at the end of the buffer. + (should (= (length (overlays-in 1 2)) 0)) + (narrow-to-region 1 2) + ;; We've now narrowed, so the zero-length overlay is at the end of + ;; the (accessible part of the) buffer. + (should (= (length (overlays-in 1 2)) 1)) + (remove-overlays) + (should (= (length (overlays-in (point-min) (point-max))) 0)))) + +(ert-deftest test-kill-buffer-auto-save-default () + (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 () + (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 9fa54dcaf43..dbbe9f30925 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/character-tests.el b/test/src/character-tests.el index f630b32a5ee..ba24d49039c 100644 --- a/test/src/character-tests.el +++ b/test/src/character-tests.el @@ -43,3 +43,5 @@ (should (= (string-width "áëòç" nil 4) 2)) (should (= (string-width "הַרְבֵּה אַהֲבָה") 9)) (should (= (string-width "הַרְבֵּה אַהֲבָה" nil 8) 4))) + +;;; character-tests.el ends here diff --git a/test/src/charset-tests.el b/test/src/charset-tests.el index 5c46627c163..23e201ad453 100644 --- a/test/src/charset-tests.el +++ b/test/src/charset-tests.el @@ -22,7 +22,9 @@ (require 'ert) (ert-deftest charset-decode-char () - "Test decode-char." + "Test `decode-char'." (should-error (decode-char 'ascii 0.5))) (provide 'charset-tests) + +;;; charset-tests.el ends here diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index 0309b2b1ad6..1c585ea5377 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -56,7 +56,7 @@ (set-buffer-multibyte nil) (insert (encode-coding-string "あ" 'euc-jp) "\xd" "\n") (decode-coding-region (point-min) (point-max) 'euc-jp-dos) - (should-not (string-match-p "\^M" (buffer-string))))) + (should-not (string-search "\^M" (buffer-string))))) ;; Return the contents (specified by CONTENT-TYPE; ascii, latin, or ;; binary) of a test file. @@ -434,4 +434,4 @@ ;; End: (provide 'coding-tests) -;; coding-tests.el ends here +;;; coding-tests.el ends here diff --git a/test/src/comp-resources/comp-test-funcs.el b/test/src/comp-resources/comp-test-funcs.el index f2a246320ac..6352a7c7e94 100644 --- a/test/src/comp-resources/comp-test-funcs.el +++ b/test/src/comp-resources/comp-test-funcs.el @@ -202,7 +202,7 @@ (defun comp-tests-err-arith-f () (/ 1 0)) (defun comp-tests-err-foo-f () - (error "foo")) + (error "Foo")) (defun comp-tests-condition-case-0-f () ;; Bpushhandler Bpophandler @@ -264,7 +264,7 @@ (% a b))) (defun comp-tests-doc-f () - "A nice docstring" + "A nice docstring." t) (defun comp-test-interactive-form0-f (dir) @@ -478,6 +478,7 @@ (eq family 'unspecified)) family))) +;; This function doesn't have a doc string on purpose. (defun comp-test-46670-1-f (_) "foo") @@ -647,7 +648,7 @@ (?> 2)))) (defun comp-test-big-interactive (filename &optional force arg load) - ;; Check non trivial interactive form using `byte-recompile-file'. + "Check non trivial interactive form using `byte-recompile-file'." (interactive (let ((file buffer-file-name) (file-name nil) @@ -683,17 +684,17 @@ (defun comp-test-no-return-1 (x) (while x - (error "foo"))) + (error "Foo"))) (defun comp-test-no-return-2 (x) (cond ((eql x '2) t) - ((error "bar") nil))) + ((error "Bar") nil))) (defun comp-test-no-return-3 ()) (defun comp-test-no-return-4 (x) (when x - (error "foo") + (error "Foo") (while (comp-test-no-return-3) (comp-test-no-return-3)))) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index fb9441eb66e..025bc2058ec 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -53,30 +53,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." @@ -285,7 +287,7 @@ Check that the resulting binaries do not differ." (should (string= (comp-tests-condition-case-0-f) "arith-error Arithmetic error catched")) (should (string= (comp-tests-condition-case-1-f) - "error foo catched")) + "error Foo catched")) (should (= (comp-tests-catch-f (lambda () (throw 'foo 3))) 3)) @@ -333,7 +335,7 @@ Check that the resulting binaries do not differ." (comp-deftest doc () (should (string= (documentation #'comp-tests-doc-f) - "A nice docstring")) + "A nice docstring.")) ;; Check a preloaded function, we can't use `comp-tests-doc-f' now ;; as this is loaded manually with no .elc. (should (string-match "\\.*.elc\\'" (symbol-file #'error)))) @@ -1167,7 +1169,7 @@ Return a list of results." ;; 49 ((defun comp-tests-ret-type-spec-f () - (error "foo")) + (error "Foo")) nil) ;; 50 @@ -1373,7 +1375,7 @@ Return a list of results." (defun comp-tests-pure-checker-1 (_) "Check that inside `comp-tests-pure-caller-f' `comp-tests-pure-callee-f' is - folded." +folded." (should (cl-notany #'identity diff --git a/test/src/data-tests.el b/test/src/data-tests.el index b1e5fa0767c..756c41b6ff3 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -26,10 +26,10 @@ (defconst data-tests--float-greater-than-fixnums (+ 1.0 most-positive-fixnum) "A floating-point value that is greater than all fixnums. It is also as small as conveniently possible, to make the tests sharper. -Adding 1.0 to most-positive-fixnum should suffice on all +Adding 1.0 to `most-positive-fixnum' should suffice on all practical Emacs platforms, since the result is a power of 2 and this is exactly representable and is greater than -most-positive-fixnum, which is just less than a power of 2.") +`most-positive-fixnum', which is just less than a power of 2.") (ert-deftest data-tests-= () (should-error (=)) @@ -204,11 +204,11 @@ most-positive-fixnum, which is just less than a power of 2.") ""))) (defun test-bool-vector-count-consecutive-tc (desc) - "Run a test case for bool-vector-count-consecutive. + "Run a test case for `bool-vector-count-consecutive'. DESC is a string describing the test. It is a sequence of hexadecimal digits describing the bool vector. We exhaustively test all counts at all possible positions in the vector by -comparing the subr with a much slower lisp implementation." +comparing the subr with a much slower Lisp implementation." (let ((bv (test-bool-vector-bv-from-hex-string desc))) (cl-loop for lf in '(nil t) @@ -338,7 +338,7 @@ comparing the subr with a much slower lisp implementation." (should (eq binding-test-some-local 'local)))) (ert-deftest binding-test-setq-default () - "Test that a setq-default has no effect when there is a local binding." + "Test that a `setq-default' has no effect when there is a local binding." (with-current-buffer binding-test-buffer-B ;; This variable is not local in this buffer. (let ((binding-test-some-local 'something-else)) @@ -399,28 +399,28 @@ comparing the subr with a much slower lisp implementation." (eq binding-test-some-local 'outer)))))) (ert-deftest binding-test-defvar-bool () - "Test DEFVAR_BOOL" + "Test DEFVAR_BOOL." (let ((display-hourglass 5)) (should (eq display-hourglass t)))) (ert-deftest binding-test-defvar-int () - "Test DEFVAR_INT" + "Test DEFVAR_INT." (should-error (setq gc-cons-threshold 5.0) :type 'wrong-type-argument)) (ert-deftest binding-test-set-constant-t () - "Test setting the constant t" + "Test setting the constant t." (with-no-warnings (should-error (setq t 'bob) :type 'setting-constant))) (ert-deftest binding-test-set-constant-nil () - "Test setting the constant nil" + "Test setting the constant nil." (with-no-warnings (should-error (setq nil 'bob) :type 'setting-constant))) (ert-deftest binding-test-set-constant-keyword () - "Test setting a keyword constant" + "Test setting a keyword constant." (with-no-warnings (should-error (setq :keyword 'bob) :type 'setting-constant))) (ert-deftest binding-test-set-constant-nil () - "Test setting a keyword to itself" + "Test setting a keyword to itself." (with-no-warnings (should (setq :keyword :keyword)))) (ert-deftest data-tests--set-default-per-buffer () @@ -757,7 +757,7 @@ comparing the subr with a much slower lisp implementation." ;; forwarding, but this needs to happen before the var is accessed ;; from the Lisp side and before we switch to another buffer. ;; The trigger in bug#34318 doesn't exist any more because the C code has - ;; changes. Instead I found the trigger below. + ;; changed. Instead I found the trigger below. (with-temp-buffer (setq last-coding-system-used 'bug34318) (make-local-variable 'last-coding-system-used) diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index 520445cca5a..1d25cf2f66b 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -42,4 +42,4 @@ (provide 'decompress-tests) -;;; decompress-tests.el ends here. +;;; decompress-tests.el ends here diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index a731a95ccf0..e83dd7c857b 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")))))) diff --git a/test/src/emacs-module-resources/mod-test.c b/test/src/emacs-module-resources/mod-test.c index 5720af8c605..4c0b168e34d 100644 --- a/test/src/emacs-module-resources/mod-test.c +++ b/test/src/emacs-module-resources/mod-test.c @@ -298,7 +298,10 @@ Fmod_test_userptr_make (emacs_env *env, ptrdiff_t nargs, emacs_value args[], { struct super_struct *p = calloc (1, sizeof *p); if (!p) - signal_errno (env, "calloc"); + { + signal_errno (env, "calloc"); + return NULL; + } p->amazing_int = env->extract_integer (env, args[0]); return env->make_user_ptr (env, free, p); } diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index a4d858113ed..442bca5facb 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 @@ -324,7 +315,9 @@ local reference." (mod-test-sum a b) -Return A + B" +Return A + B + +" module-file-suffix)))))) (ert-deftest module/load-history () diff --git a/test/src/emacs-tests.el b/test/src/emacs-tests.el index ac08e055b55..a1a412423cb 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 b2b7dfefda5..3c3e7033419 100644 --- a/test/src/eval-tests.el +++ b/test/src/eval-tests.el @@ -39,31 +39,40 @@ (ert-deftest eval-tests--bugs-24912-and-24913 () "Check that Emacs doesn't accept weird argument lists. Bug#24912 and Bug#24913." - (dolist (args '((&rest &optional) - (&rest a &optional) (&rest &optional a) - (&optional &optional) (&optional &optional a) - (&optional a &optional b) - (&rest &rest) (&rest &rest a) - (&rest a &rest b))) - (should-error (eval `(funcall (lambda ,args)) t) :type 'invalid-function) - (should-error (byte-compile-check-lambda-list args)) - (let ((byte-compile-debug t)) - (ert-info ((format "bytecomp: args = %S" args)) - (should-error (eval `(byte-compile (lambda ,args)) t)))))) - -(ert-deftest eval-tests-accept-empty-optional-rest () - "Check that Emacs accepts empty &optional and &rest arglists. + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&rest &optional) + (&rest a &optional) (&rest &optional a) + (&optional &optional) (&optional &optional a) + (&optional a &optional b) + (&rest &rest) (&rest &rest a) + (&rest a &rest b) + (&rest) (&optional &rest) + )) + (ert-info ((prin1-to-string args) :prefix "args: ") + (should-error + (eval `(funcall (lambda ,args)) lb) :type 'invalid-function) + (should-error (byte-compile-check-lambda-list args)) + (let ((byte-compile-debug t)) + (should-error (eval `(byte-compile (lambda ,args)) lb))))))))) + +(ert-deftest eval-tests-accept-empty-optional () + "Check that Emacs accepts empty &optional arglists. Bug#24912." - (dolist (args '((&optional) (&rest) (&optional &rest) - (&optional &rest a) (&optional a &rest))) - (let ((fun `(lambda ,args 'ok))) - (ert-info ("eval") - (should (eq (funcall (eval fun t)) 'ok))) - (ert-info ("byte comp check") - (byte-compile-check-lambda-list args)) - (ert-info ("bytecomp") - (let ((byte-compile-debug t)) - (should (eq (funcall (byte-compile fun)) 'ok))))))) + (dolist (lb '(t false)) + (ert-info ((prin1-to-string lb) :prefix "lexical-binding: ") + (let ((lexical-binding lb)) + (dolist (args '((&optional) (&optional &rest a))) + (ert-info ((prin1-to-string args) :prefix "args: ") + (let ((fun `(lambda ,args 'ok))) + (ert-info ("eval") + (should (eq (funcall (eval fun lb)) 'ok))) + (ert-info ("byte comp check") + (byte-compile-check-lambda-list args)) + (ert-info ("bytecomp") + (let ((byte-compile-debug t)) + (should (eq (funcall (byte-compile fun)) 'ok))))))))))) (dolist (form '(let let*)) diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index f4d123b4261..4143503aa18 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (defun try-link (target link) @@ -97,7 +99,7 @@ Also check that an encoding error can appear in a symlink." (should (equal (file-name-as-directory "D:/abc//") "d:/abc//"))) (ert-deftest fileio-tests--relative-HOME () - "Test that expand-file-name works even when HOME is relative." + "Test that `expand-file-name' works even when HOME is relative." (let ((process-environment (copy-sequence process-environment))) (setenv "HOME" "a/b/c") (should (equal (expand-file-name "~/foo") @@ -128,7 +130,7 @@ Also check that an encoding error can appear in a symlink." (if f (delete-file f))))) (ert-deftest fileio-tests--relative-default-directory () - "Test expand-file-name when default-directory is relative." + "Test `expand-file-name' when `default-directory' is relative." (let ((default-directory "some/relative/name")) (should (file-name-absolute-p (expand-file-name "foo")))) (let* ((default-directory "~foo") @@ -136,8 +138,17 @@ Also check that an encoding error can appear in a symlink." (should (and (file-name-absolute-p name) (not (eq (aref name 0) ?~)))))) +(ert-deftest fileio-test--expand-file-name-null-bytes () + "Test that `expand-file-name' checks for null bytes in filenames." + (should-error (expand-file-name (concat "file" (char-to-string ?\0) ".txt")) + :type 'wrong-type-argument) + (should-error (expand-file-name "file.txt" (concat "dir" (char-to-string ?\0))) + :type 'wrong-type-argument) + (let ((default-directory (concat "dir" (char-to-string ?\0)))) + (should-error (expand-file-name "file.txt") :type 'wrong-type-argument))) + (ert-deftest fileio-tests--file-name-absolute-p () - "Test file-name-absolute-p." + "Test `file-name-absolute-p'." (dolist (suffix '("" "/" "//" "/foo" "/foo/" "/foo//" "/foo/bar")) (unless (string-equal suffix "") (should (file-name-absolute-p suffix))) @@ -148,7 +159,7 @@ Also check that an encoding error can appear in a symlink." (should (not (file-name-absolute-p (concat "~nosuchuser" suffix))))))) (ert-deftest fileio-tests--circular-after-insert-file-functions () - "Test after-insert-file-functions as a circular list." + "Test `after-insert-file-functions' as a circular list." (let ((f (make-temp-file "fileio")) (after-insert-file-functions (list 'identity))) (setcdr after-insert-file-functions after-insert-file-functions) diff --git a/test/src/filelock-tests.el b/test/src/filelock-tests.el index a96d6d67289..ba001679639 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. diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index 4a3c03d833e..a066d2e15e2 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -17,8 +17,72 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) +(ert-deftest 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))) @@ -125,3 +189,5 @@ (ash (1- (ash 1 53)) 2045)))) (provide 'floatfns-tests) + +;;; floatfns-tests.el ends here diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 9f6593a177c..bec5c03f9e7 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)) @@ -430,6 +480,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)) @@ -786,7 +853,15 @@ ;; string containing hanzi character, compare by character (should (equal 2 (string-distance "ab" "ab我她"))) (should (equal 1 (string-distance "ab" "a我b"))) - (should (equal 1 (string-distance "我" "她")))) + (should (equal 1 (string-distance "我" "她"))) + + ;; correct behaviour with empty strings + (should (equal 0 (string-distance "" ""))) + (should (equal 0 (string-distance "" "" t))) + (should (equal 1 (string-distance "x" ""))) + (should (equal 1 (string-distance "x" "" t))) + (should (equal 1 (string-distance "" "x"))) + (should (equal 1 (string-distance "" "x" t)))) (ert-deftest test-bignum-eql () "Test that `eql' works for bignums." @@ -1106,3 +1181,5 @@ (should (= (line-number-at-pos nil) 11)) (should-error (line-number-at-pos -1)) (should-error (line-number-at-pos 100)))) + +;;; fns-tests.el ends here diff --git a/test/src/font-tests.el b/test/src/font-tests.el index de153b8de9b..ea57b122f4f 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -159,6 +159,31 @@ expected font properties from parsing NAME.") (insert "\n")))) (goto-char (point-min))) +(ert-deftest font-parse-xlfd-test () + ;; Normal number of segments. + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'FreeSans)) + (should (equal (font-get + (font-spec :name "-GNU -FreeSans-semibold-italic-normal-*-*-*-*-*-*-0-iso10646-1") + :foundry) + 'GNU\ )) + ;; Dash in the family name. + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'mikachan-PS)) + (should (equal (font-get + (font-spec :name "-Take-mikachan-PS-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :weight) + 'normal)) + ;; Synthetic test. + (should (equal (font-get + (font-spec :name "-foundry-name-with-lots-of-dashes-normal-normal-normal-*-*-*-*-*-*-0-iso10646-1") + :family) + 'name-with-lots-of-dashes))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/src/image-tests.el b/test/src/image-tests.el new file mode 100644 index 00000000000..2b236086b6f --- /dev/null +++ b/test/src/image-tests.el @@ -0,0 +1,245 @@ +;;; 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 (init-image-library 'xpm)) ; built-in + (should-not (init-image-library 'invalid-image-type))) + +;;; image-tests.el ends here diff --git a/test/src/indent-tests.el b/test/src/indent-tests.el index 6a3f1a5c95f..6cfe64c07e4 100644 --- a/test/src/indent-tests.el +++ b/test/src/indent-tests.el @@ -57,3 +57,5 @@ (move-to-column 12 t) (buffer-substring-no-properties 1 14)) "\txxx \tLine"))) + +;;; indent-tests.el ends here diff --git a/test/src/inotify-tests.el b/test/src/inotify-tests.el index 5572c7d7a0f..70330ac8657 100644 --- a/test/src/inotify-tests.el +++ b/test/src/inotify-tests.el @@ -24,6 +24,7 @@ ;;; 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)) @@ -37,8 +38,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,24 +50,22 @@ (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) -;;; inotify-tests.el ends here. +;;; inotify-tests.el ends here diff --git a/test/src/json-tests.el b/test/src/json-tests.el index 908945fcb08..8dc0a744aa0 100644 --- a/test/src/json-tests.el +++ b/test/src/json-tests.el @@ -252,7 +252,7 @@ Test with both unibyte and multibyte strings." (let* ((input "{ \"abc\" : [9, false] , \"def\" : null }") (output - (replace-regexp-in-string " " "" input))) + (string-replace " " "" input))) (should (equal (json-parse-string input :object-type 'plist :null-object :json-null diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index a9b0cb502d3..8e28faf2b26 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -124,6 +124,55 @@ ;; (ert-deftest keymap-lookup-key/accept-default () ;; ...) +(ert-deftest keymap-lookup-key/mixed-case () + "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)) + (should (eq (lookup-key map [menu-bar Foo Bar]) 'foo))) + (let ((map (make-keymap))) + (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" @@ -269,16 +318,17 @@ commit 86c19714b097aa477d339ed99ffb5136c755a046." (shadow-map (let ((map (make-keymap))) (define-key map "f" 'bar) map)) - (text-quoting-style 'grave)) + (text-quoting-style 'grave) + (describe-bindings-check-shadowing-in-ranges 'ignore-self-insert)) (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." @@ -299,10 +349,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]) @@ -316,6 +366,13 @@ 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))) + (provide 'keymap-tests) ;;; keymap-tests.el ends here diff --git a/test/src/lcms-tests.el b/test/src/lcms-tests.el index 40a48f1e9bb..d2d137e9bd5 100644 --- a/test/src/lcms-tests.el +++ b/test/src/lcms-tests.el @@ -95,7 +95,7 @@ B is considered the exact value." '(0.29902 0.31485 1.0)))) (ert-deftest lcms-roundtrip () - "Test accuracy of converting to and from different color spaces" + "Test accuracy of converting to and from different color spaces." (skip-unless (featurep 'lcms2)) (should (let ((color '(.5 .3 .7))) @@ -109,7 +109,7 @@ B is considered the exact value." 0.0001)))) (ert-deftest lcms-ciecam02-gold () - "Test CIE CAM02 JCh gold values" + "Test CIE CAM02 JCh gold values." (skip-unless (featurep 'lcms2)) (should (lcms-triple-approx-p diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index dac8f95bc4d..be685fe999f 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -119,14 +119,6 @@ (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 +129,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/marker-tests.el b/test/src/marker-tests.el index 234a0b35ea7..cf8e82cd560 100644 --- a/test/src/marker-tests.el +++ b/test/src/marker-tests.el @@ -57,4 +57,4 @@ (set-marker marker-2 marker-1) (should (goto-char marker-2)))) -;;; marker-tests.el ends here. +;;; marker-tests.el ends here diff --git a/test/src/minibuf-tests.el b/test/src/minibuf-tests.el index c55611eb84b..51d9c67453e 100644 --- a/test/src/minibuf-tests.el +++ b/test/src/minibuf-tests.el @@ -406,7 +406,7 @@ (should (equal (try-completion "bar" '("bArfoo" "barbaz")) (try-completion "bar" '("barbaz" "bArfoo")))) ;; bug#11339 - (should (equal (try-completion "baz" '("baz" "bAz")) "baz")) ;And not `t'! + (should (equal (try-completion "baz" '("baz" "bAz")) "baz")) ;And not t! (should (equal (try-completion "baz" '("bAz" "baz")) (try-completion "baz" '("baz" "bAz")))))) @@ -414,8 +414,8 @@ (let ((inhibit-interaction t)) (should-error (read-from-minibuffer "foo: ") :type 'inhibited-interaction) - (should-error (y-or-n-p "foo: ") :type 'inhibited-interaction) - (should-error (yes-or-no-p "foo: ") :type 'inhibited-interaction) + (should-error (y-or-n-p "Foo?") :type 'inhibited-interaction) + (should-error (yes-or-no-p "Foo?") :type 'inhibited-interaction) (should-error (read-no-blanks-input "foo: ") :type 'inhibited-interaction) ;; See that we get the expected error. diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 9bab523708e..b831ca3bdaa 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -25,6 +25,7 @@ (require 'cl-lib) (require 'ert) +(require 'ert-x) ; ert-with-temp-directory (require 'puny) (require 'subr-x) (require 'dns) @@ -64,24 +65,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 +530,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 +617,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)) @@ -745,7 +732,7 @@ Return nil if that can't be determined." process-tests--EMFILE-message) (ert-deftest process-tests/sentinel-called () - "Check that sentinels are called after processes finish" + "Check that sentinels are called after processes finish." (let ((command (process-tests--emacs-command))) (skip-unless command) (dolist (conn-type '(pipe pty)) @@ -946,5 +933,11 @@ Return nil if FILENAME doesn't exist." (when buf (kill-buffer buf))))) +(ert-deftest process-num-processors () + "Sanity checks for num-processors." + (should (equal (num-processors) (num-processors))) + (should (integerp (num-processors))) + (should (< 0 (num-processors)))) + (provide 'process-tests) ;;; process-tests.el ends here diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el index 0607eacf397..71e3189443e 100644 --- a/test/src/regex-emacs-tests.el +++ b/test/src/regex-emacs-tests.el @@ -279,11 +279,11 @@ on success" (defconst regex-tests-re-even-escapes "\\(?:^\\|[^\\]\\)\\(?:\\\\\\\\\\)*" - "Regex that matches an even number of \\ characters") + "Regex that matches an even number of \\ characters.") (defconst regex-tests-re-odd-escapes (concat regex-tests-re-even-escapes "\\\\") - "Regex that matches an odd number of \\ characters") + "Regex that matches an odd number of \\ characters.") (defun regex-tests-unextend (pattern) @@ -396,9 +396,9 @@ pattern)" ;; emacs matches non-greedy regex ab.*? non-greedily 639 677 712 ] - "Line numbers in the boost test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the boost test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - Comments are lines starting with ; @@ -480,9 +480,9 @@ differences in behavior.") ;; ambiguous groupings are ambiguous 610 611 1154 1157 1160 1168 1171 1176 1179 1182 1185 1188 1193 1196 1203 ] - "Line numbers in the PCRE test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the PCRE test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; @@ -562,9 +562,9 @@ differences in behavior.") ;; fails to match 168 ] - "Line numbers in the PTESTS test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the PTESTS test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - fields separated by ¦ (note: this is not a |) @@ -621,9 +621,9 @@ differences in behavior.") ;; emacs is more stringent with regexes involving unbalanced ) 67 ] - "Line numbers in the TESTS test that should be skipped. These -are false-positive test failures that represent known/benign -differences in behavior.") + "Line numbers in the TESTS test that should be skipped. +These are false-positive test failures that represent +known/benign differences in behavior.") ;; - Format ;; - fields separated by :. Watch for [\[:xxx:]] diff --git a/test/src/search-tests.el b/test/src/search-tests.el new file mode 100644 index 00000000000..b7b4ab9a8ff --- /dev/null +++ b/test/src/search-tests.el @@ -0,0 +1,42 @@ +;;; search-tests.el --- tests for search.c functions -*- lexical-binding: t -*- + +;; Copyright (C) 2015-2016, 2018-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) + +(ert-deftest test-replace-match-modification-hooks () + (let ((ov-set nil)) + (with-temp-buffer + (insert "1 abc") + (setq ov-set (make-overlay 3 5)) + (overlay-put + ov-set 'modification-hooks + (list (lambda (o after &rest _args) + (when after + (let ((inhibit-modification-hooks t)) + (save-excursion + (goto-char 2) + (insert "234"))))))) + (goto-char 3) + (if (search-forward "bc") + (replace-match "bcd")) + (should (= (point) 10))))) + +;;; search-tests.el ends here diff --git a/test/src/syntax-tests.el b/test/src/syntax-tests.el index e4e3054d37a..bd89283dd14 100644 --- a/test/src/syntax-tests.el +++ b/test/src/syntax-tests.el @@ -500,4 +500,10 @@ the `parse-partial-sexp's are expected to stop. See (syntax-pps-comments /* 56 76 77 58) (syntax-pps-comments /* 60 78 79) +(ert-deftest test-from-to-parse-partial-sexp () + (with-temp-buffer + (insert "foo") + (should (parse-partial-sexp 1 1)) + (should-error (parse-partial-sexp 2 1)))) + ;;; syntax-tests.el ends here diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index b083588e645..c001579c474 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -69,4 +69,4 @@ (null stack))))) (provide 'textprop-tests) -;; textprop-tests.el ends here. +;;; textprop-tests.el ends here diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index fc7bc7441b7..52eace7e9d2 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -70,12 +70,12 @@ (thread-live-p (make-thread #'ignore)))) (ert-deftest threads-all-threads () - "Simple test for all-threads." + "Simple test for `all-threads'." (skip-unless (featurep 'threads)) (should (listp (all-threads)))) (ert-deftest threads-main-thread () - "Simple test for all-threads." + "Simple test for `all-threads'." (skip-unless (featurep 'threads)) (should (eq main-thread (car (all-threads))))) @@ -155,7 +155,7 @@ (should (eq (type-of (make-mutex)) 'mutex))) (ert-deftest threads-mutex-lock-unlock () - "Test mutex-lock and unlock." + "Test `mutex-lock' and unlock." (skip-unless (featurep 'threads)) (should (let ((mx (make-mutex))) @@ -392,4 +392,4 @@ (let ((th (make-thread 'ignore))) (should-not (equal th main-thread)))) -;;; threads.el ends here +;;; thread-tests.el ends here diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 0a450a7573f..bba9b3fcd8c 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -241,3 +241,5 @@ a fixed place on the right and are padded on the left." (let ((xdiv (/ x divisor))) (should (= xdiv (float-time (time-convert xdiv t)))))) (setq x (* x 2))))) + +;;; timefns-tests.el ends here diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index a658bccf6dc..88fcfad14cc 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 4e7d2ad8ab2..cc67aef8e15 100644 --- a/test/src/xdisp-tests.el +++ b/test/src/xdisp-tests.el @@ -99,4 +99,59 @@ (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)))) + ;;; xdisp-tests.el ends here diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el index 0a7ef55b2b6..cba706f4535 100644 --- a/test/src/xfaces-tests.el +++ b/test/src/xfaces-tests.el @@ -17,6 +17,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. +;;; Code: + (require 'ert) (ert-deftest xfaces-color-distance () @@ -48,3 +50,5 @@ (should (equal (color-values-from-color-spec "rgbi:0/0.5/10") nil))) (provide 'xfaces-tests) + +;;; xfaces-tests.el ends here diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index a35b4d2ccc8..7c4ca396f70 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -52,4 +52,4 @@ (should (equal (cdr test) (libxml-parse-xml-region (point-min) (point-max))))))) -;;; libxml-tests.el ends here +;;; xml-tests.el ends here |
