diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
110 files changed, 3083 insertions, 448 deletions
diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index b45cd69467b..72883fc2ec7 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -1,4 +1,4 @@ -;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; -*- +;;; bindat-tests.el --- tests for bindat.el -*- lexical-binding: t; coding: utf-8; -*- ;; Copyright (C) 2019-2021 Free Software Foundation, Inc. @@ -24,13 +24,15 @@ (require 'cl-lib) (defvar header-bindat-spec - '((dest-ip ip) + (bindat-spec + (dest-ip ip) (src-ip ip) (dest-port u16) (src-port u16))) (defvar data-bindat-spec - '((type u8) + (bindat-spec + (type u8) (opcode u8) (length u16r) ;; little endian order (id strz 8) @@ -38,7 +40,8 @@ (align 4))) (defvar packet-bindat-spec - '((header struct header-bindat-spec) + (bindat-spec + (header struct header-bindat-spec) (items u8) (fill 3) (item repeat (items) @@ -94,6 +97,28 @@ (src-ip . [192 168 1 101]) (dest-ip . - [192 168 1 100])))))) + [192 168 1 100])))))) + +(ert-deftest bindat-test-pack/multibyte-string-fails () + (should-error (bindat-pack nil nil "ö"))) + +(ert-deftest bindat-test-unpack/multibyte-string-fails () + (should-error (bindat-unpack nil "ö"))) + +(ert-deftest bindat-test-format-vector () + (should (equal (bindat-format-vector [1 2 3] "%d" "x" 2) "1x2")) + (should (equal (bindat-format-vector [1 2 3] "%d" "x") "1x2x3"))) + +(ert-deftest bindat-test-vector-to-dec () + (should (equal (bindat-vector-to-dec [1 2 3]) "1.2.3")) + (should (equal (bindat-vector-to-dec [2048 1024 512] ".") "2048.1024.512"))) + +(ert-deftest bindat-test-vector-to-hex () + (should (equal (bindat-vector-to-hex [1 2 3]) "01:02:03")) + (should (equal (bindat-vector-to-hex [2048 1024 512] ".") "800.400.200"))) + +(ert-deftest bindat-test-ip-to-string () + (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) + (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) ;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el new file mode 100644 index 00000000000..5f390898e6a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-add-hook.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (add-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el new file mode 100644 index 00000000000..eaa625eba1c --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-remove-hook.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (remove-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el new file mode 100644 index 00000000000..7a116ad464b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-failure.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args-until-failure 'foo)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el new file mode 100644 index 00000000000..96d10a343df --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args-until-success.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args-until-success 'foo #'next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el new file mode 100644 index 00000000000..bb9101bd070 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-run-hook-with-args.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (run-hook-with-args 'foo)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el new file mode 100644 index 00000000000..5f390898e6a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/error-lexical-var-with-symbol-value.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t; -*- +(let ((foo nil)) + (add-hook 'foo #'next-line) + foo) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el new file mode 100644 index 00000000000..47481574ea8 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/foo-inlinable.el @@ -0,0 +1,6 @@ +;; -*- lexical-binding: t; -*- + +(defsubst foo-inlineable (foo-var) + (+ foo-var 2)) + +(provide 'foo-inlinable) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el new file mode 100644 index 00000000000..5582b2ab0ea --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/nowarn-inline-after-defvar.el @@ -0,0 +1,17 @@ +;; -*- lexical-binding: t; -*- + +;; In this test, we try and make sure that inlined functions's code isn't +;; mistakenly re-interpreted in the caller's context: we import an +;; inlinable function from another file where `foo-var' is a normal +;; lexical variable, and then call(inline) it in a function where +;; `foo-var' is a dynamically-scoped variable. + +(require 'foo-inlinable + (expand-file-name "foo-inlinable.el" + (file-name-directory + (or byte-compile-current-file load-file-name)))) + +(defvar foo-var) + +(defun foo-fun () + (+ (foo-inlineable 5) 1)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el new file mode 100644 index 00000000000..f193130c6ca --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-autoload-not-on-top-level.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (autoload 'bar "baz" nil nil 'macro)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el new file mode 100644 index 00000000000..687add380b9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-callargs.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defun foo (_x) + nil) +(defun bar () + (foo 1 2)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el new file mode 100644 index 00000000000..a67d4f041f3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-nogroup.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defcustom foo nil + :type 'boolean) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el new file mode 100644 index 00000000000..c15ab9b192a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defcustom-notype.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defcustom foo nil + :group 'emacs) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el new file mode 100644 index 00000000000..9f3cbb98900 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-defvar-lacks-prefix.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(defvar foo nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el new file mode 100644 index 00000000000..a1902bc03b0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-format.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(message "%s" 1 2) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el new file mode 100644 index 00000000000..6e187129c9b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-setq.el @@ -0,0 +1,2 @@ +;;; -*- lexical-binding: t -*- +(setq foo 'bar) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el new file mode 100644 index 00000000000..50a95272874 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-free-variable-reference.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defvar xxx-test) +(defun foo () + (setq xxx-test bar)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el new file mode 100644 index 00000000000..9e0c99bd30b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-interactive-only.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el new file mode 100644 index 00000000000..6bd902705ed --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-lambda-malformed-interactive-spec.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (interactive "foo" "bar") + nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el new file mode 100644 index 00000000000..aa1e6c0463b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-make-variable-buffer-local.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(defvar foobar) +(defun foo () + (make-variable-buffer-local 'foobar)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el new file mode 100644 index 00000000000..2a7af617ac9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-defun.el @@ -0,0 +1,8 @@ +;;; -*- lexical-binding: t -*- + +(defun foo-obsolete () + (declare (obsolete nil "99.99")) + nil) + +(defun foo () + (foo-obsolete)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el new file mode 100644 index 00000000000..078e6e4a3a9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-hook.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (add-hook 'bytecomp--tests-obsolete-var #'next-line)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el new file mode 100644 index 00000000000..e65a541e6e3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-bound.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- + +(make-obsolete-variable 'bytecomp--tests-obsolete-var-2 nil "99.99") + +(defun foo () + (let ((bytecomp--tests-obsolete-var-2 2)) + bytecomp--tests-obsolete-var-2)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el new file mode 100644 index 00000000000..31deb6155ba --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable-same-file.el @@ -0,0 +1,13 @@ +;;; -*- lexical-binding: t -*- + +(defvar foo-obsolete nil) +(make-obsolete-variable 'foo-obsolete nil "99.99") + +;; From bytecomp.el: +;; If foo.el declares `toto' as obsolete, it is likely that foo.el will +;; actually use `toto' in order for this obsolete variable to still work +;; correctly, so paradoxically, while byte-compiling foo.el, the presence +;; of a make-obsolete-variable call for `toto' is an indication that `toto' +;; should not trigger obsolete-warnings in foo.el. +(defun foo () + foo-obsolete) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el new file mode 100644 index 00000000000..9a517cc6767 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-obsolete-variable.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- + +(defun foo () + bytecomp--tests-obsolete-var) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el new file mode 100644 index 00000000000..6bd239b6598 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun-as-macro.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () nil) +(defmacro foo () t) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el new file mode 100644 index 00000000000..53e4c0ac8de --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () nil) +(defun foo () t) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el new file mode 100644 index 00000000000..f71ae445615 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-redefine-macro-as-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defmacro foo () t) +(defun foo () nil) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el new file mode 100644 index 00000000000..38185457192 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-save-excursion.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (save-excursion + (set-buffer (current-buffer)) + nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el new file mode 100644 index 00000000000..cc1fb572577 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-constant.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (let ((t 1)) t)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el new file mode 100644 index 00000000000..dde2dcee6e7 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-let-bind-nonvariable.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (let (('t 1)) t)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el new file mode 100644 index 00000000000..2fc0680cfab --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-constant.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (setq t nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-nonvariable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-nonvariable.el new file mode 100644 index 00000000000..0c76c4d388b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-variable-set-nonvariable.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + (set '(a) nil)) diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el new file mode 100644 index 00000000000..96deb1bbb0a --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-autoload.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(autoload 'foox "foo" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el new file mode 100644 index 00000000000..2a4700bfda5 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-custom-declare-variable.el @@ -0,0 +1,4 @@ +;;; -*- lexical-binding: t -*- +(custom-declare-variable + 'foo t + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el new file mode 100644 index 00000000000..a4235d22bd3 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defalias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defalias 'foo #'ignore + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el new file mode 100644 index 00000000000..946f01989a0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defconst.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defconst foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el new file mode 100644 index 00000000000..3da9ccd48c6 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-abbrev-table.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-abbrev-table 'foo () + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el new file mode 100644 index 00000000000..fea841b12ec --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-function-alias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-obsolete-function-alias 'foo #'ignore "99.1" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el new file mode 100644 index 00000000000..2d5f201cb65 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-define-obsolete-variable-alias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(define-obsolete-variable-alias 'foo 'ignore "99.1" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el new file mode 100644 index 00000000000..94b0e80c979 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defun.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defun foo () + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el new file mode 100644 index 00000000000..99aacd09cbd --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvar.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "multiline +foo +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +bar") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el new file mode 100644 index 00000000000..52fdc17f5bf --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-defvaralias.el @@ -0,0 +1,3 @@ +;;; -*- lexical-binding: t -*- +(defvaralias 'foo-bar #'ignore + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el new file mode 100644 index 00000000000..1ff554f3704 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-fill-column.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") + +;; Local Variables: +;; fill-column: 100 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el new file mode 100644 index 00000000000..0bcf7b1d63b --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore-override.el @@ -0,0 +1,8 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "123456789012345") + +;; Local Variables: +;; byte-compile-docstring-max-column: 10 +;; fill-column: 20 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el new file mode 100644 index 00000000000..c80ddd180d9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-ignore.el @@ -0,0 +1,7 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx") + +;; Local Variables: +;; byte-compile-docstring-max-column: 100 +;; End: diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el new file mode 100644 index 00000000000..2563dbbb3b9 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline-first.el @@ -0,0 +1,5 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +This is a multiline docstring where the first line is long. +foobar") diff --git a/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el new file mode 100644 index 00000000000..9ae7bc9b9f0 --- /dev/null +++ b/test/lisp/emacs-lisp/bytecomp-resources/warn-wide-docstring-multiline.el @@ -0,0 +1,6 @@ +;;; -*- lexical-binding: t -*- +(defvar foo-bar nil + "This is a multiline docstring. +But it's not the first line that is long. +xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +foobar") diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 14ca149f06a..0b70c11b298 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-tests.el +;;; bytecomp-tests.el -*- lexical-binding:t -*- ;; Copyright (C) 2008-2021 Free Software Foundation, Inc. @@ -26,11 +26,21 @@ ;;; Commentary: (require 'ert) +(require 'ert-x) (require 'cl-lib) (require 'subr-x) (require 'bytecomp) ;;; Code: +(defvar bytecomp-test-var nil) + +(defun bytecomp-test-get-var () + bytecomp-test-var) + +(defun bytecomp-test-identity (x) + "Identity, but hidden from some optimisations." + x) + (defconst byte-opt-testsuite-arith-data '( ;; some functional tests @@ -47,6 +57,11 @@ (let ((a 1.0)) (/ 3 a 2)) (let ((a most-positive-fixnum) (b 2.0)) (* a 2 b)) (let ((a 3) (b 2)) (/ a b 1.0)) + (let ((a -0.0)) (+ a)) + (let ((a -0.0)) (- a)) + (let ((a -0.0)) (* a)) + (let ((a -0.0)) (min a)) + (let ((a -0.0)) (max a)) (/ 3 -1) (+ 4 3 2 1) (+ 4 3 2.0 1) @@ -360,7 +375,62 @@ '(((a b)) a b (c) (d))) (mapcar (lambda (x) (cond ((memq '(a b) x) 1) ((equal x '(c)) 2))) - '(((a b)) a b (c) (d)))) + '(((a b)) a b (c) (d))) + + (assoc 'b '((a 1) (b 2) (c 3))) + (assoc "b" '(("a" 1) ("b" 2) ("c" 3))) + (let ((x '((a 1) (b 2) (c 3)))) (assoc 'c x)) + (assoc 'a '((a 1) (b 2) (c 3)) (lambda (u v) (not (equal u v)))) + + ;; Constprop test cases + (let ((a 'alpha) (b (concat "be" "ta")) (c nil) (d t) (e :gamma) + (f '(delta epsilon))) + (list a b c d e f)) + + (let ((x 1) (y (+ 3 4))) + (list + (let (q (y x) (z y)) + (if q x (list x y z))))) + + (let* ((x 3) (y (* x 2)) (x (1+ y))) + x) + + (let ((x 1) (bytecomp-test-var 2) (y 3)) + (list x bytecomp-test-var (bytecomp-get-test-var) y)) + + (progn + (defvar d) + (let ((x 'a) (y 'b)) (list x y))) + + (let ((x 2)) + (list x (setq x 13) (setq x (* x 2)) x)) + + (let ((x 'a) (y 'b)) + (setq y x + x (cons 'c y) + y x) + (list x y)) + + (let ((x 3)) + (let ((y x) z) + (setq x 5) + (setq y (+ y 8)) + (setq z (if (bytecomp-test-identity t) + (progn + (setq x (+ x 1)) + (list x y)) + (setq x (+ x 2)) + (list x y))) + (list x y z))) + + (let ((i 1) (s 0) (x 13)) + (while (< i 5) + (setq s (+ s i)) + (setq i (1+ i))) + (list s x i)) + + (let ((x 2)) + (list (or (bytecomp-identity 'a) (setq x 3)) x))) "List of expression for test. Each element will be executed by interpreter and with bytecompiled code, and their results compared.") @@ -368,24 +438,24 @@ bytecompiled code, and their results compared.") (defun bytecomp-check-1 (pat) "Return non-nil if PAT is the same whether directly evalled or compiled." (let ((warning-minimum-log-level :emergency) - (byte-compile-warnings nil) - (v0 (condition-case nil + (byte-compile-warnings nil) + (v0 (condition-case err (eval pat) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (equal v0 v1))) (put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) (defun bytecomp-explain-1 (pat) - (let ((v0 (condition-case nil + (let ((v0 (condition-case err (eval pat) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -408,12 +478,12 @@ Subtests signal errors if something goes wrong." (print-quoted t) v0 v1) (dolist (pat byte-opt-testsuite-arith-data) - (condition-case nil + (condition-case err (setq v0 (eval pat)) - (error (setq v0 nil))) - (condition-case nil + (error (setq v0 (list 'bytecomp-check-error (car err))))) + (condition-case err (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 nil))) + (error (setq v1 (list 'bytecomp-check-error (car err))))) (insert (format "%s" pat)) (indent-to-column 65) (if (equal v0 v1) @@ -439,8 +509,8 @@ Subtests signal errors if something goes wrong." (if compile (let ((byte-compile-dest-file-function (lambda (e) elcfile))) - (byte-compile-file elfile t)) - (load elfile nil 'nomessage))) + (byte-compile-file elfile))) + (load elfile nil 'nomessage)) (when elfile (delete-file elfile)) (when elcfile (delete-file elcfile))))) (put 'test-byte-comp-compile-and-load 'lisp-indent-function 1) @@ -479,9 +549,13 @@ Subtests signal errors if something goes wrong." (defun def () (m)))) (should (equal (funcall 'def) 4))) + +;;;; Warnings. + (ert-deftest bytecomp-tests--warnings () (with-current-buffer (get-buffer-create "*Compile-Log*") (let ((inhibit-read-only t)) (erase-buffer))) + (mapc #'fmakunbound '(my-test0 my--test11 my--test12 my--test2)) (test-byte-comp-compile-and-load t '(progn (defun my-test0 () @@ -505,19 +579,205 @@ Subtests signal errors if something goes wrong." ;; Should not warn that mt--test2 is not known to be defined. (should-not (re-search-forward "my--test2" nil t)))) +(defmacro bytecomp--with-warning-test (re-warning &rest form) + (declare (indent 1)) + `(with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer)) + (byte-compile ,@form) + (ert-info ((buffer-string) :prefix "buffer: ") + (should (re-search-forward ,re-warning))))) + (ert-deftest bytecomp-warn-wrong-args () - (with-current-buffer (get-buffer-create "*Compile-Log*") - (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile '(remq 1 2 3)) - (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward "remq.*3.*2"))))) + (bytecomp--with-warning-test "remq.*3.*2" + '(remq 1 2 3))) (ert-deftest bytecomp-warn-wrong-args-subr () - (with-current-buffer (get-buffer-create "*Compile-Log*") - (let ((inhibit-read-only t)) (erase-buffer)) - (byte-compile '(safe-length 1 2 3)) - (ert-info ((buffer-string) :prefix "buffer: ") - (should (re-search-forward "safe-length.*3.*1"))))) + (bytecomp--with-warning-test "safe-length.*3.*1" + '(safe-length 1 2 3))) + +(ert-deftest bytecomp-warn-variable-lacks-prefix () + (bytecomp--with-warning-test "foo.*lacks a prefix" + '(defvar foo nil))) + +(defvar bytecomp-tests--docstring (make-string 100 ?x)) + +(ert-deftest bytecomp-warn-wide-docstring/defconst () + (bytecomp--with-warning-test "defconst.*foo.*wider than.*characters" + `(defconst foo t ,bytecomp-tests--docstring))) + +(ert-deftest bytecomp-warn-wide-docstring/defvar () + (bytecomp--with-warning-test "defvar.*foo.*wider than.*characters" + `(defvar foo t ,bytecomp-tests--docstring))) + +(defmacro bytecomp--define-warning-file-test (file re-warning &optional reverse) + `(ert-deftest ,(intern (format "bytecomp/%s" file)) () + :expected-result ,(if reverse :failed :passed) + (with-current-buffer (get-buffer-create "*Compile-Log*") + (let ((inhibit-read-only t)) (erase-buffer)) + (byte-compile-file ,(ert-resource-file file)) + (ert-info ((buffer-string) :prefix "buffer: ") + (should (re-search-forward ,re-warning)))))) + +(bytecomp--define-warning-file-test "error-lexical-var-with-add-hook.el" + "add-hook.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-remove-hook.el" + "remove-hook.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args-until-failure.el" + "args-until-failure.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args-until-success.el" + "args-until-success.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-run-hook-with-args.el" + "args.*lexical var") + +(bytecomp--define-warning-file-test "error-lexical-var-with-symbol-value.el" + "symbol-value.*lexical var") + +(bytecomp--define-warning-file-test "warn-autoload-not-on-top-level.el" + "compiler ignores.*autoload.*") + +(bytecomp--define-warning-file-test "warn-callargs.el" + "with 2 arguments, but accepts only 1") + +(bytecomp--define-warning-file-test "warn-defcustom-nogroup.el" + "fails to specify containing group") + +(bytecomp--define-warning-file-test "warn-defcustom-notype.el" + "fails to specify type") + +(bytecomp--define-warning-file-test "warn-defvar-lacks-prefix.el" + "var.*foo.*lacks a prefix") + +(bytecomp--define-warning-file-test "warn-format.el" + "called with 2 args to fill 1 format field") + +(bytecomp--define-warning-file-test "warn-free-setq.el" + "free.*foo") + +(bytecomp--define-warning-file-test "warn-free-variable-reference.el" + "free.*bar") + +(bytecomp--define-warning-file-test "warn-make-variable-buffer-local.el" + "make-variable-buffer-local.*not called at toplevel") + +(bytecomp--define-warning-file-test "warn-interactive-only.el" + "next-line.*interactive use only.*forward-line") + +(bytecomp--define-warning-file-test "warn-lambda-malformed-interactive-spec.el" + "malformed interactive spec") + +(bytecomp--define-warning-file-test "warn-obsolete-defun.el" + "foo-obsolete.*obsolete function.*99.99") + +(defvar bytecomp--tests-obsolete-var nil) +(make-obsolete-variable 'bytecomp--tests-obsolete-var nil "99.99") + +(bytecomp--define-warning-file-test "warn-obsolete-hook.el" + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") + +(bytecomp--define-warning-file-test "warn-obsolete-variable-same-file.el" + "foo-obs.*obsolete.*99.99" t) + +(bytecomp--define-warning-file-test "warn-obsolete-variable.el" + "bytecomp--tests-obs.*obsolete[^z-a]*99.99") + +(bytecomp--define-warning-file-test "warn-obsolete-variable-bound.el" + "bytecomp--tests-obs.*obsolete.*99.99" t) + +(bytecomp--define-warning-file-test "warn-redefine-defun-as-macro.el" + "as both function and macro") + +(bytecomp--define-warning-file-test "warn-redefine-macro-as-defun.el" + "as both function and macro") + +(bytecomp--define-warning-file-test "warn-redefine-defun.el" + "defined multiple") + +(bytecomp--define-warning-file-test "warn-save-excursion.el" + "with-current.*rather than save-excursion") + +(bytecomp--define-warning-file-test "warn-variable-let-bind-constant.el" + "let-bind constant") + +(bytecomp--define-warning-file-test "warn-variable-let-bind-nonvariable.el" + "let-bind nonvariable") + +(bytecomp--define-warning-file-test "warn-variable-set-constant.el" + "variable reference to constant") + +(bytecomp--define-warning-file-test "warn-variable-set-nonvariable.el" + "variable reference to nonvariable") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-autoload.el" + "autoload.*foox.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-custom-declare-variable.el" + "custom-declare-variable.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defalias.el" + "defalias.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defconst.el" + "defconst.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-abbrev-table.el" + "define-abbrev.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-obsolete-function-alias.el" + "defalias.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-define-obsolete-variable-alias.el" + "defvaralias.*foo.*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) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defvar.el" + "defvar.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-defvaralias.el" + "defvaralias.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-fill-column.el" + "defvar.*foo.*wider than.*characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore-override.el" + "defvar.*foo.*wider than.*characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-ignore.el" + "defvar.*foo.*wider than.*characters" 'reverse) + +(bytecomp--define-warning-file-test + "warn-wide-docstring-multiline-first.el" + "defvar.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "warn-wide-docstring-multiline.el" + "defvar.*foo.*wider than.*characters") + +(bytecomp--define-warning-file-test + "nowarn-inline-after-defvar.el" + "Lexical argument shadows" 'reverse) + + +;;;; Macro expansion. (ert-deftest test-eager-load-macro-expansion () (test-byte-comp-compile-and-load nil @@ -567,25 +827,25 @@ bytecompiled code, and their results compared.") "Return non-nil if PAT is the same whether directly evalled or compiled." (let ((warning-minimum-log-level :emergency) (byte-compile-warnings nil) - (v0 (condition-case nil + (v0 (condition-case err (eval pat t) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (let ((lexical-binding t)) (byte-compile `(lambda nil ,pat)))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (equal v0 v1))) (put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) (defun bytecomp-lexbind-explain-1 (pat) - (let ((v0 (condition-case nil + (let ((v0 (condition-case err (eval pat t) - (error nil))) - (v1 (condition-case nil + (error (list 'bytecomp-check-error (car err))))) + (v1 (condition-case err (funcall (let ((lexical-binding t)) (byte-compile (list 'lambda nil pat)))) - (error nil)))) + (error (list 'bytecomp-check-error (car err)))))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -628,17 +888,6 @@ literals (Bug#20852)." (let ((byte-compile-dest-file-function (lambda (_) destination))) (should (byte-compile-file source))))))) -(ert-deftest bytecomp-tests--old-style-backquotes () - "Check that byte compiling warns about old-style backquotes." - (bytecomp-tests--with-temp-file source - (write-region "(` (a b))" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) '("Old-style backquotes detected!"))))))) - - (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." (bytecomp-tests--with-temp-file source @@ -651,7 +900,8 @@ literals (Bug#20852)." (setq bytecomp-tests--foobar (bytecomp-tests--foobar)))) (print form (current-buffer))) (write-region (point-min) (point-max) source nil 'silent) - (byte-compile-file source t) + (byte-compile-file source) + (load source) (should (equal bytecomp-tests--foobar (cons 1 2))))) (ert-deftest bytecomp-tests--test-no-warnings-with-advice () @@ -809,6 +1059,12 @@ literals (Bug#20852)." (test-suppression '(defun zot () + (next-line)) + '((interactive-only next-line)) + "interactive use only") + + (test-suppression + '(defun zot () (mapcar #'list '(1 2 3)) nil) '((mapcar mapcar)) @@ -828,6 +1084,121 @@ literals (Bug#20852)." '((suspicious set-buffer)) "Warning: Use .with-current-buffer. rather than")) +(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-deftest bytecomp-tests--dest-mountpoint () + "Test that byte compilation works if the destination file is a +mountpoint (Bug#44631)." + (let ((bwrap (executable-find "bwrap")) + (emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless bwrap) + (skip-unless (file-executable-p bwrap)) + (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-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))))) + +(defun bytecomp-tests--get-vars () + (list (ignore-errors (symbol-value 'bytecomp-tests--var1)) + (ignore-errors (symbol-value 'bytecomp-tests--var2)))) + +(ert-deftest bytecomp-local-defvar () + "Check that local `defvar' declarations work correctly, both +interpreted and compiled." + (let ((lexical-binding t)) + (let ((fun '(lambda () + (defvar bytecomp-tests--var1) + (let ((bytecomp-tests--var1 'a) ; dynamic + (bytecomp-tests--var2 'b)) ; still lexical + (ignore bytecomp-tests--var2) ; avoid warning + (bytecomp-tests--get-vars))))) + (should (listp fun)) ; Guard against overzealous refactoring! + (should (equal (funcall (eval fun t)) '(a nil))) + (should (equal (funcall (byte-compile fun)) '(a nil))) + ) + + ;; `progn' does not constitute a lexical scope for `defvar' (bug#46387). + (let ((fun '(lambda () + (progn + (defvar bytecomp-tests--var1) + (defvar bytecomp-tests--var2)) + (let ((bytecomp-tests--var1 'c) + (bytecomp-tests--var2 'd)) + (bytecomp-tests--get-vars))))) + (should (listp fun)) + (should (equal (funcall (eval fun t)) '(c d))) + (should (equal (funcall (byte-compile fun)) '(c d)))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index 30a3869b33e..517373386e3 100644 --- a/test/lisp/emacs-lisp/cconv-tests.el +++ b/test/lisp/emacs-lisp/cconv-tests.el @@ -20,6 +20,166 @@ ;;; Commentary: (require 'ert) +(require 'cl-lib) + +(ert-deftest cconv-tests-lambda-:documentation () + "Docstring for lambda can be specified with :documentation." + (let ((fun (lambda () + (:documentation (concat "lambda" " documentation")) + 'lambda-result))) + (should (string= (documentation fun) "lambda documentation")) + (should (eq (funcall fun) 'lambda-result)))) + +(ert-deftest cconv-tests-pcase-lambda-:documentation () + "Docstring for pcase-lambda can be specified with :documentation." + (let ((fun (pcase-lambda (`(,a ,b)) + (:documentation (concat "pcase-lambda" " documentation")) + (list b a)))) + (should (string= (documentation fun) "pcase-lambda documentation")) + (should (equal '(2 1) (funcall fun '(1 2)))))) + +(defun cconv-tests-defun () + (:documentation (concat "defun" " documentation")) + 'defun-result) +(ert-deftest cconv-tests-defun-:documentation () + "Docstring for defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defun) + "defun documentation")) + (should (eq (cconv-tests-defun) 'defun-result))) + +(cl-defun cconv-tests-cl-defun () + (:documentation (concat "cl-defun" " documentation")) + 'cl-defun-result) +(ert-deftest cconv-tests-cl-defun-:documentation () + "Docstring for cl-defun can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defun) + "cl-defun documentation")) + (should (eq (cconv-tests-cl-defun) 'cl-defun-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (defmacro cconv-tests-defmacro () +;; (:documentation (concat "defmacro" " documentation")) +;; '(quote defmacro-result)) +;; (ert-deftest cconv-tests-defmacro-:documentation () +;; "Docstring for defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-defmacro) +;; "defmacro documentation")) +;; (should (eq (cconv-tests-defmacro) 'defmacro-result))) + +;; FIXME: The byte-complier croaks on this. See Bug#28557. +;; (cl-defmacro cconv-tests-cl-defmacro () +;; (:documentation (concat "cl-defmacro" " documentation")) +;; '(quote cl-defmacro-result)) +;; (ert-deftest cconv-tests-cl-defmacro-:documentation () +;; "Docstring for cl-defmacro can be specified with :documentation." +;; (should (string= (documentation 'cconv-tests-cl-defmacro) +;; "cl-defmacro documentation")) +;; (should (eq (cconv-tests-cl-defmacro) 'cl-defmacro-result))) + +(cl-iter-defun cconv-tests-cl-iter-defun () + (:documentation (concat "cl-iter-defun" " documentation")) + (iter-yield 'cl-iter-defun-result)) +(ert-deftest cconv-tests-cl-iter-defun-:documentation () + "Docstring for cl-iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :tags '(:unstable) + :expected-result :failed + (should (string= (documentation 'cconv-tests-cl-iter-defun) + "cl-iter-defun documentation")) + (should (eq (iter-next (cconv-tests-cl-iter-defun)) + 'cl-iter-defun-result))) + +(iter-defun cconv-tests-iter-defun () + (:documentation (concat "iter-defun" " documentation")) + (iter-yield 'iter-defun-result)) +(ert-deftest cconv-tests-iter-defun-:documentation () + "Docstring for iter-defun can be specified with :documentation." + ;; FIXME: See Bug#28557. + :tags '(:unstable) + :expected-result :failed + (should (string= (documentation 'cconv-tests-iter-defun) + "iter-defun documentation")) + (should (eq (iter-next (cconv-tests-iter-defun)) 'iter-defun-result))) + +(ert-deftest cconv-tests-iter-lambda-:documentation () + "Docstring for iter-lambda can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((iter-fun + (iter-lambda () + (:documentation (concat "iter-lambda" " documentation")) + (iter-yield 'iter-lambda-result)))) + (should (string= (documentation iter-fun) "iter-lambda documentation")) + (should (eq (iter-next (funcall iter-fun)) 'iter-lambda-result)))) + +(ert-deftest cconv-tests-cl-function-:documentation () + "Docstring for cl-function can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((fun (cl-function (lambda (&key arg) + (:documentation (concat "cl-function" + " documentation")) + (list arg 'cl-function-result))))) + (should (string= (documentation fun) "cl-function documentation")) + (should (equal (funcall fun :arg t) '(t cl-function-result))))) + +(ert-deftest cconv-tests-function-:documentation () + "Docstring for lambda inside function can be specified with :documentation." + (let ((fun #'(lambda (arg) + (:documentation (concat "function" " documentation")) + (list arg 'function-result)))) + (should (string= (documentation fun) "function documentation")) + (should (equal (funcall fun t) '(t function-result))))) + +(fmakunbound 'cconv-tests-cl-defgeneric) +(setplist 'cconv-tests-cl-defgeneric nil) +(cl-defgeneric cconv-tests-cl-defgeneric (n) + (:documentation (concat "cl-defgeneric" " documentation"))) +(cl-defmethod cconv-tests-cl-defgeneric ((n integer)) + (:documentation (concat "cl-defmethod" " documentation")) + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + ;; FIXME: See Bug#28557. + :expected-result :failed + (let ((descr (describe-function 'cconv-tests-cl-defgeneric))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric documentation" descr)) + (should (string-match-p "cl-defmethod documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric 10)))) + +(fmakunbound 'cconv-tests-cl-defgeneric-literal) +(setplist 'cconv-tests-cl-defgeneric-literal nil) +(cl-defgeneric cconv-tests-cl-defgeneric-literal (n) + (:documentation "cl-defgeneric-literal documentation")) +(cl-defmethod cconv-tests-cl-defgeneric-literal ((n integer)) + (:documentation "cl-defmethod-literal documentation") + (+ 1 n)) +(ert-deftest cconv-tests-cl-defgeneric-literal-:documentation () + "Docstring for cl-defgeneric can be specified with :documentation." + (let ((descr (describe-function 'cconv-tests-cl-defgeneric-literal))) + (set-text-properties 0 (length descr) nil descr) + (should (string-match-p "cl-defgeneric-literal documentation" descr)) + (should (string-match-p "cl-defmethod-literal documentation" descr))) + (should (= 11 (cconv-tests-cl-defgeneric-literal 10)))) + +(defsubst cconv-tests-defsubst () + (:documentation (concat "defsubst" " documentation")) + 'defsubst-result) +(ert-deftest cconv-tests-defsubst-:documentation () + "Docstring for defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-defsubst) + "defsubst documentation")) + (should (eq (cconv-tests-defsubst) 'defsubst-result))) + +(cl-defsubst cconv-tests-cl-defsubst () + (:documentation (concat "cl-defsubst" " documentation")) + 'cl-defsubst-result) +(ert-deftest cconv-tests-cl-defsubst-:documentation () + "Docstring for cl-defsubst can be specified with :documentation." + (should (string= (documentation 'cconv-tests-cl-defsubst) + "cl-defsubst documentation")) + (should (eq (cconv-tests-cl-defsubst) 'cl-defsubst-result))) (ert-deftest cconv-convert-lambda-lifted () "Bug#30872." diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el new file mode 100644 index 00000000000..9552bf0e397 --- /dev/null +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -0,0 +1,116 @@ +;;; check-declare-tests.el --- Tests for check-declare.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; 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 'check-declare) +(require 'ert) +(eval-when-compile (require 'subr-x)) + +(ert-deftest check-declare-tests-locate () + (should (file-exists-p (check-declare-locate "check-declare" ""))) + (should + (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-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-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-deftest check-declare-tests-sort () + (should-not (check-declare-sort '())) + (should (equal (check-declare-sort '((a (1 a)) (b (2)) (d (1 d)))) + '((2 (b)) (1 (a a) (d d)))))) + +(ert-deftest check-declare-tests-warn () + (with-temp-buffer + (let ((check-declare-warning-buffer (buffer-name))) + (check-declare-warn + "foo-file" "foo-fun" "bar-file" "it wasn't" 999) + (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)))))) + +(provide 'check-declare-tests) +;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index f3c308725ac..91f0a1e2014 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Code: diff --git a/test/lisp/emacs-lisp/cl-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 0648a0f8b43..9312fb44a1e 100644 --- a/test/lisp/emacs-lisp/cl-generic-tests.el +++ b/test/lisp/emacs-lisp/cl-generic-tests.el @@ -24,6 +24,7 @@ ;;; Code: (require 'cl-generic) +(require 'edebug) ;; Don't indirectly require `cl-lib' at run-time. (eval-when-compile (require 'ert)) @@ -239,7 +240,7 @@ (let ((retval (cl--generic-method-files 'cl-generic-tests--generic))) (should (equal (length retval) 2)) (mapc (lambda (x) - (should (equal (car x) cl-generic-tests--this-file)) + (should (equal (file-truename (car x)) cl-generic-tests--this-file)) (should (equal (cadr x) 'cl-generic-tests--generic))) retval) (should-not (equal (nth 0 retval) (nth 1 retval))))) @@ -249,5 +250,40 @@ (should-not (cl--generic-method-files 'cl-generic-tests--undefined-generic)) (should-not (cl--generic-method-files 'cl-generic-tests--generic-without-methods))) +(ert-deftest cl-defgeneric/edebug/method () + "Check that `:method' forms in `cl-defgeneric' create unique +Edebug symbols (Bug#42672)." + (with-temp-buffer + (dolist (form '((cl-defgeneric cl-defgeneric/edebug/method/1 (_) + (:method ((_ number)) 1) + (:method ((_ string)) 2) + (:method :around ((_ number)) 3)) + (cl-defgeneric cl-defgeneric/edebug/method/2 (_) + (:method ((_ number)) 3)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name)))) + (eval-buffer) + (should (equal + (reverse instrumented-names) + ;; The generic function definitions come after the + ;; method definitions because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `cl-defgeneric/edebug/method/1 ((_ number))', but + ;; that requires further changes to Edebug. + (list (intern "cl-defgeneric/edebug/method/1 (number)") + (intern "cl-defgeneric/edebug/method/1 (string)") + (intern "cl-defgeneric/edebug/method/1 :around (number)") + 'cl-defgeneric/edebug/method/1 + (intern "cl-defgeneric/edebug/method/2 (number)") + 'cl-defgeneric/edebug/method/2)))))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index b7b1e22b93e..a5ec62b9c42 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -242,6 +242,22 @@ (should (= (cl-the integer (cl-incf side-effect)) 1)) (should (= side-effect 1)))) +(ert-deftest cl-lib-test-incf () + (let ((var 0)) + (should (= (cl-incf var) 1)) + (should (= var 1))) + (let ((alist)) + (should (= (cl-incf (alist-get 'a alist 0)) 1)) + (should (= (alist-get 'a alist 0) 1)))) + +(ert-deftest cl-lib-test-decf () + (let ((var 1)) + (should (= (cl-decf var) 0)) + (should (= var 0))) + (let ((alist)) + (should (= (cl-decf (alist-get 'a alist 0)) -1)) + (should (= (alist-get 'a alist 0) -1)))) + (ert-deftest cl-lib-test-plusp () (should-not (cl-plusp -1.0e+INF)) (should-not (cl-plusp -1.5e2)) @@ -527,15 +543,7 @@ (apply (lambda (x) (+ x 1)) (list 8))))) '(5 (6 5) (6 6) 9)))) -(defun cl-lib-tests--dummy-function () - ;; Dummy function to see if the file is compiled. - t) - (ert-deftest cl-lib-defstruct-record () - ;; This test fails when compiled, see Bug#24402/27718. - :expected-result (if (byte-code-function-p - (symbol-function 'cl-lib-tests--dummy-function)) - :failed :passed) (cl-defstruct foo x) (let ((x (make-foo :x 42))) (should (recordp x)) @@ -550,6 +558,7 @@ (should (eq (type-of x) 'vector)) (cl-old-struct-compat-mode 1) + (defvar cl-struct-foo) (let ((cl-struct-foo (cl--struct-get-class 'foo))) (setf (symbol-function 'cl-struct-foo) :quick-object-witness-check) (should (eq (type-of x) 'foo)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index c0f1a109e88..2e5f3020b41 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -4,18 +4,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -39,6 +39,15 @@ collect (list c b a)) '((4.0 2 1) (8.3 6 5) (10.4 9 8))))) +(ert-deftest cl-macs-loop-and-arrays () + "Bug#40727" + (should (equal (cl-loop for y = (- (or x 0)) and x across [1 2] + collect (cons x y)) + '((1 . 0) (2 . -1)))) + (should (equal (cl-loop for x across [1 2] and y = (- (or x 0)) + collect (cons x y)) + '((1 . 0) (2 . -1))))) + (ert-deftest cl-macs-loop-destructure () (should (equal (cl-loop for (a b c) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) @@ -416,7 +425,9 @@ collection clause." '(2 3 4 5 6)))) (ert-deftest cl-macs-loop-across-ref () - (should (equal (cl-loop with my-vec = ["one" "two" "three"] + (should (equal (cl-loop with my-vec = (vector (cl-copy-seq "one") + (cl-copy-seq "two") + (cl-copy-seq "three")) for x across-ref my-vec do (setf (aref x 0) (upcase (aref x 0))) finally return my-vec) @@ -498,7 +509,6 @@ collection clause." (ert-deftest cl-macs-loop-for-as-equals-and () "Test for https://debbugs.gnu.org/29799 ." - :expected-result :failed (let ((arr (make-vector 3 0))) (should (equal '((0 0) (1 1) (2 2)) (cl-loop for k below 3 for x = k and z = (elt arr k) @@ -532,7 +542,6 @@ collection clause." (ert-deftest cl-macs-loop-conditional-step-clauses () "These tests failed under the initial fixes in #bug#29799." - :expected-result :failed (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) if (not (= i j)) return nil @@ -592,4 +601,36 @@ collection clause." collect y into result1 finally return (equal (nreverse result) result1)))) +(ert-deftest cl-macs-aux-edebug () + "Check that Bug#40431 is fixed." + (with-temp-buffer + (prin1 '(cl-defun cl-macs-aux-edebug-test-fun (&aux ((a . b) '(1 . 2))) + (list a b)) + (current-buffer)) + ;; Just make sure the function can be instrumented. + (edebug-defun))) + +;;; cl-labels + +(ert-deftest cl-macs--labels () + ;; Simple recursive function. + (cl-labels ((len (xs) (if xs (1+ (len (cdr xs))) 0))) + (should (equal (len (make-list 42 t)) 42))) + + ;; Simple tail-recursive function. + (cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) + (should (equal (len (make-list 42 t) 0) 42)) + ;; Should not bump into stack depth limits. + (should (equal (len (make-list 42000 t) 0) 42000))) + + ;; Check that non-recursive functions are handled more efficiently. + (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) + (`(let* ,_ (funcall ,_ 5)) t))) + + ;; Case of "tail-recursive lambdas". + (should (pcase (macroexpand + '(cl-labels ((len (xs n) (if xs (len (cdr xs) (1+ n)) n))) + #'len)) + (`(function (lambda (,_ ,_) . ,_)) t)))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-seq-tests.el b/test/lisp/emacs-lisp/cl-seq-tests.el index 6893eb8ada8..d0fad8907d5 100644 --- a/test/lisp/emacs-lisp/cl-seq-tests.el +++ b/test/lisp/emacs-lisp/cl-seq-tests.el @@ -294,6 +294,7 @@ Body are forms defining the test." (ert-deftest cl-seq-test-bug24264 () "Test for https://debbugs.gnu.org/24264 ." + :tags '(:expensive-test) (let ((list (append (make-list 8000005 1) '(8))) (list2 (make-list 8000005 2))) (should (cl-position 8 list)) diff --git a/test/lisp/emacs-lisp/copyright-tests.el b/test/lisp/emacs-lisp/copyright-tests.el new file mode 100644 index 00000000000..7deb8b53a2e --- /dev/null +++ b/test/lisp/emacs-lisp/copyright-tests.el @@ -0,0 +1,50 @@ +;;; copyright-tests.el --- tests for copyright.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/>. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'copyright) + +(defmacro with-copyright-test (orig result) + `(cl-letf (((symbol-function 'format-time-string) (lambda (&rest _) "2019"))) + (let ((copyright-query nil) + (copyright-current-year 2019)) + (with-temp-buffer + (insert ,orig) + (copyright-update) + (should (equal (buffer-string) ,result)))))) + +(defvar copyright-tests--data + '((";; Copyright (C) 2017 Free Software Foundation, Inc." + . ";; Copyright (C) 2017, 2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2017-2019 Free Software Foundation, Inc.") + (";; Copyright (C) 2005-2006, 2015, 2017-2018 Free Software Foundation, Inc." + . ";; Copyright (C) 2005-2006, 2015, 2017-2019 Free Software Foundation, Inc.") + (";; copyright '18 FSF" + . ";; copyright '18, '19 FSF"))) + +(ert-deftest test-copyright-update () + (dolist (test copyright-tests--data) + (with-copyright-test (car test) (cdr test)))) + +(provide 'copyright-tests) +;;; copyright-tests.el ends here diff --git a/test/lisp/emacs-lisp/easy-mmode-tests.el b/test/lisp/emacs-lisp/easy-mmode-tests.el new file mode 100644 index 00000000000..77eaed62579 --- /dev/null +++ b/test/lisp/emacs-lisp/easy-mmode-tests.el @@ -0,0 +1,65 @@ +;;; easy-mmode-tests.el --- tests for easy-mmode.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/>. + +;;; Code: + +(require 'ert) +(require 'easy-mmode) +(require 'message) + +(ert-deftest easy-mmode--globalized-predicate () + (with-temp-buffer + (emacs-lisp-mode) + (should (eq (easy-mmode--globalized-predicate-p nil) nil)) + (should (eq (easy-mmode--globalized-predicate-p t) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '(not text-mode)) t)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode))) nil)) + (should (eq (easy-mmode--globalized-predicate-p '((not text-mode) t)) t)) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode emacs-lisp-mode)) + t)) + (mail-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + nil)) + (text-mode) + (should (eq (easy-mmode--globalized-predicate-p + '(c-mode (not message-mode mail-mode) text-mode)) + t)))) + +(define-minor-mode easy-mmode-test-mode "A test.") + +(ert-deftest easy-mmode--minor-mode () + (with-temp-buffer + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode nil) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode -33) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 33) + (should (eq easy-mmode-test-mode t)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode nil)) + (easy-mmode-test-mode 'toggle) + (should (eq easy-mmode-test-mode t)))) + +(provide 'easy-mmode-tests) + +;;; easy-mmode-tests.el ends here diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index 5ea36121748..9257f167d67 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -1,4 +1,4 @@ -;;; edebug-test-code.el --- Sample code for the Edebug test suite +;;; edebug-test-code.el --- Sample code for the Edebug test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2021 Free Software Foundation, Inc. @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -62,12 +62,12 @@ (defun edebug-test-code-format-vector-node (node) !start!(concat "[" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "]")) (defun edebug-test-code-format-list-node (node) !start!(concat "{" - (apply 'concat (mapcar 'edebug-test-code-format-node node))!apply! + (apply #'concat (mapcar #'edebug-test-code-format-node node))!apply! "}")) (defun edebug-test-code-format-node (node) @@ -137,5 +137,21 @@ ,(cons func args)))) (wrap + 1 x))) +(defun edebug-test-code-cl-flet1 () + (cl-flet + ;; This `&rest' sexp head should not collide with + ;; the Edebug spec elem of the same name. + ((f (&rest x) x) + (gate (x) (+ x 5))) + ;; This call to `gate' shouldn't collide with the Edebug spec elem + ;; of the same name. + (message "Hi %s" (gate 7)))) + +(defun edebug-test-code-use-gv-expander (x) + (declare (gv-expander + (lambda (do) + (funcall do `(car ,x) (lambda (v) `(setcar ,x ,v)))))) + (car x)) + (provide 'edebug-test-code) ;;; edebug-test-code.el ends here diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 73d0919904b..daac43372ac 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -36,17 +36,6 @@ (require 'edebug) (require 'kmacro) -;; Use `eval-and-compile' because this is used by the macro -;; `edebug-tests-deftest'. -(eval-and-compile - (defvar edebug-tests-sample-code-file - (expand-file-name - "edebug-resources/edebug-test-code.el" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Name of file containing code samples for Edebug tests.")) - (defvar edebug-tests-temp-file nil "Name of temp file containing sample code stripped of stop point symbols.") (defvar edebug-tests-stop-points nil @@ -108,7 +97,10 @@ back to the top level.") ;; sit-on interferes with keyboard macros. (edebug-sit-on-break nil) - (edebug-continue-kbd-macro t)) + (edebug-continue-kbd-macro t) + + ;; don't print backtraces, otherwise error messages don't match + (backtrace-on-error-noninteractive nil)) ,@body)) (defmacro edebug-tests-with-normal-env (&rest body) @@ -116,7 +108,8 @@ back to the top level.") (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"))) + (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 @@ -221,6 +214,7 @@ be the same as every keystroke) execute the thunk at the same index." (let* ((edebug-tests-thunks thunks) (edebug-tests-kbd-macro-index 0) + (find-file-suppress-same-file-warnings t) saved-local-map) (with-current-buffer (find-file-noselect edebug-tests-temp-file) (setq saved-local-map overriding-local-map) @@ -344,7 +338,7 @@ evaluate to \"symbol\", \"symbol-1\", \"symbol-2\", etc." Write the loadable code to a buffer for TMPFILE, and set `edebug-tests-stop-points' to a map from defined symbols to stop point names to positions in the file." - (with-current-buffer (find-file-noselect edebug-tests-sample-code-file) + (with-current-buffer (find-file-noselect (ert-resource-file "edebug-test-code.el")) (let ((marked-up-code (buffer-string))) (with-temp-file tmpfile (insert marked-up-code)))) @@ -938,5 +932,128 @@ test and possibly others should be updated." "g" (should (equal edebug-tests-@-result '(0 1)))))) +(ert-deftest edebug-cl-defmethod-qualifier () + "Check that secondary `cl-defmethod' forms don't stomp over +primary ones (Bug#42671)." + (with-temp-buffer + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (defined-symbols ()) + (edebug-new-definition-function + (lambda (def-name) + (push def-name defined-symbols) + (edebug-new-definition def-name)))) + (dolist (form '((cl-defmethod edebug-cl-defmethod-qualifier ((_ number))) + (cl-defmethod edebug-cl-defmethod-qualifier + :around ((_ number))))) + (print form (current-buffer))) + (eval-buffer) + (should + (equal + defined-symbols + (list (intern "edebug-cl-defmethod-qualifier :around (number)") + (intern "edebug-cl-defmethod-qualifier (number)"))))))) + +(ert-deftest edebug-tests--conflicting-internal-names () + "Check conflicts between form's head symbols and Edebug spec elements." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "cl-flet1" '(10) t))) + +(ert-deftest edebug-tests-gv-expander () + "Edebug can instrument `gv-expander' expressions." + (edebug-tests-with-normal-env + (edebug-tests-setup-@ "use-gv-expander" nil t) + (should (equal + (catch 'text + (run-at-time 0 nil + (lambda () (throw 'text (buffer-substring (point) (+ (point) 5))))) + (eval '(setf (edebug-test-code-use-gv-expander (cons 'a 'b)) 3) t)) + "(func")))) + +(defun edebug-tests--read (form spec) + (with-temp-buffer + (print form (current-buffer)) + (goto-char (point-min)) + (cl-letf ((edebug-all-forms t) + ((get (car form) 'edebug-form-spec) spec)) + (edebug--read nil (current-buffer))))) + +(ert-deftest edebug-tests--&rest-behavior () + ;; `&rest' is documented to allow the last "repetition" to be aborted early. + (should (edebug-tests--read '(dummy x 1 y 2 z) + '(&rest symbolp integerp))) + ;; `&rest' should notice here that the "symbolp integerp" sequence + ;; is not respected. + (should-error (edebug-tests--read '(dummy x 1 2 y) + '(&rest symbolp integerp)))) + +(ert-deftest edebug-tests-cl-flet () + "Check that Edebug can instrument `cl-flet' forms without name +clashes (Bug#41853)." + (with-temp-buffer + (dolist (form '((defun edebug-tests-cl-flet-1 () + (cl-flet ((inner () 0)) (message "Hi")) + (cl-flet ((inner () 1)) (inner))) + (defun edebug-tests-cl-flet-2 () + (cl-flet ((inner () 2)) (inner))))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; Use `format' so as to throw away differences due to + ;; interned/uninterned symbols. + (should (equal (format "%s" (reverse instrumented-names)) + ;; The outer definitions come after the inner + ;; ones because their body ends later. + ;; FIXME: We'd rather have names such as + ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', + ;; but that requires further changes to Edebug. + (format "%s" '(inner@cl-flet@10000 + inner@cl-flet@10001 + edebug-tests-cl-flet-1 + inner@cl-flet@10002 + edebug-tests-cl-flet-2))))))) + +(ert-deftest edebug-tests-duplicate-symbol-backtrack () + "Check that Edebug doesn't create duplicate symbols when +backtracking (Bug#42701)." + (with-temp-buffer + (dolist (form '((require 'subr-x) + (defun edebug-tests-duplicate-symbol-backtrack () + (if-let (x (funcall (lambda (y) 1) 2)) 3 4)))) + (print form (current-buffer))) + (let* ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop) + (instrumented-names ()) + (edebug-new-definition-function + (lambda (name) + (when (memq name instrumented-names) + (error "Duplicate definition of `%s'" name)) + (push name instrumented-names) + (edebug-new-definition name))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (eval-buffer) + ;; The anonymous symbols are uninterned. Use their names so we + ;; can perform the assertion. The names should still be unique. + (should (equal (mapcar #'symbol-name (reverse instrumented-names)) + ;; The outer definition comes after the inner + ;; ones because its body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#42701. + ;; Once that bug is fixed, remove the duplicates. + '("edebug-anon10000" + "edebug-anon10001" + "edebug-tests-duplicate-symbol-backtrack")))))) + (provide 'edebug-tests) ;;; edebug-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index cd1efd1c787..285616a7806 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -1,4 +1,4 @@ -;;; eieio-testsinvoke.el -- eieio tests for method invocation +;;; eieio-testsinvoke.el -- eieio tests for method invocation -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008, 2010, 2013-2021 Free Software Foundation, ;; Inc. @@ -83,36 +83,36 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((p eitest-B-base1)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((p eitest-B-base2)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((p eitest-B)) +(defmethod eitest-F :BEFORE ((_p eitest-B)) (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((p eitest-B)) +(defmethod eitest-F ((_p eitest-B)) (eieio-test-method-store :PRIMARY 'eitest-B) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base1)) +(defmethod eitest-F ((_p eitest-B-base1)) (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base2)) +(defmethod eitest-F ((_p eitest-B-base2)) (eieio-test-method-store :PRIMARY 'eitest-B-base2) (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F :AFTER ((p eitest-B-base1)) +(defmethod eitest-F :AFTER ((_p eitest-B-base1)) (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((p eitest-B-base2)) +(defmethod eitest-F :AFTER ((_p eitest-B-base2)) (eieio-test-method-store :AFTER 'eitest-B-base2)) -(defmethod eitest-F :AFTER ((p eitest-B)) +(defmethod eitest-F :AFTER ((_p eitest-B)) (eieio-test-method-store :AFTER 'eitest-B)) (ert-deftest eieio-test-method-order-list-3 () @@ -136,7 +136,7 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((class eitest-A)) +(defmethod eitest-H :STATIC ((_class eitest-A)) "No need to do work in here." 'moose) @@ -147,15 +147,15 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((a eitest-A)) +(defmethod eitest-I :BEFORE ((_a eitest-A)) (eieio-test-method-store :BEFORE 'eitest-A) ":before") -(defmethod eitest-I :PRIMARY ((a eitest-A)) +(defmethod eitest-I :PRIMARY ((_a eitest-A)) (eieio-test-method-store :PRIMARY 'eitest-A) ":primary") -(defmethod eitest-I :AFTER ((a eitest-A)) +(defmethod eitest-I :AFTER ((_a eitest-A)) (eieio-test-method-store :AFTER 'eitest-A) ":after") @@ -174,17 +174,17 @@ (defclass C (C-base1 C-base2) ()) ;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((p C-base1) &rest args) +(defmethod constructor :STATIC ((_p C-base1) &rest _args) (eieio-test-method-store :STATIC 'C-base1) (if (next-method-p) (call-next-method)) ) -(defmethod make-instance :STATIC ((p C-base2) &rest args) +(defmethod make-instance :STATIC ((_p C-base2) &rest _args) (eieio-test-method-store :STATIC 'C-base2) (if (next-method-p) (call-next-method)) ) -(cl-defmethod make-instance ((p (subclass C)) &rest args) +(cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) (cl-call-next-method) ) @@ -213,24 +213,24 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((p D)) +(defmethod eitest-F ((_p D)) "D" (eieio-test-method-store :PRIMARY 'D) (call-next-method)) -(defmethod eitest-F ((p D-base0)) +(defmethod eitest-F ((_p D-base0)) "D-base0" (eieio-test-method-store :PRIMARY 'D-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p D-base1)) +(defmethod eitest-F ((_p D-base1)) "D-base1" (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) -(defmethod eitest-F ((p D-base2)) +(defmethod eitest-F ((_p D-base2)) "D-base2" (eieio-test-method-store :PRIMARY 'D-base2) (when (next-method-p) @@ -256,21 +256,21 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((p E)) +(defmethod eitest-F ((_p E)) (eieio-test-method-store :PRIMARY 'E) (call-next-method)) -(defmethod eitest-F ((p E-base0)) +(defmethod eitest-F ((_p E-base0)) (eieio-test-method-store :PRIMARY 'E-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p E-base1)) +(defmethod eitest-F ((_p E-base1)) (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) -(defmethod eitest-F ((p E-base2)) +(defmethod eitest-F ((_p E-base2)) (eieio-test-method-store :PRIMARY 'E-base2) (when (next-method-p) (call-next-method)) @@ -293,7 +293,7 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) ;(message "+Ja") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -304,7 +304,7 @@ (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) ;(message "+Jb") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -318,7 +318,7 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((this eitest-Jd) &rest slots) +(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) ;(message "+Jd") (when (next-method-p) (call-next-method)) @@ -357,7 +357,7 @@ (call-next-method this (cons 'CNM-1-1 args)))) -(defmethod CNM-M ((this CNM-1-2) args) +(defmethod CNM-M ((_this CNM-1-2) args) (push (cons 'CNM-1-2 (copy-sequence args)) eieio-test-call-next-method-arguments) (when (next-method-p) 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 5eee709d626..ddbef02c35a 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -1,4 +1,4 @@ -;;; eieio-test-persist.el --- Tests for eieio-persistent class +;;; eieio-test-persist.el --- Tests for eieio-persistent class -*- lexical-binding:t -*- ;; Copyright (C) 2011-2021 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 19f4b15586e..a47fb8053b9 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,4 +1,4 @@ -;;; eieio-tests.el -- eieio tests routines +;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2021 Free Software ;; Foundation, Inc. @@ -356,7 +356,7 @@ METHOD is the method that was attempting to be called." (oset a test-tag 1)) (let ((ca (class-a))) - (should-not (/= (oref ca test-tag) 2)))) + (should (= (oref ca test-tag) 2)))) ;;; Perform slot testing @@ -852,6 +852,7 @@ Subclasses to override slot attributes.") "Instance Tracker test object.") (ert-deftest eieio-test-33-instance-tracker () + (defvar IT-list) (let (IT-list IT1) (should (setq IT1 (IT))) ;; The instance tracker must find this diff --git a/test/lisp/emacs-lisp/ert-tests.el b/test/lisp/emacs-lisp/ert-tests.el index 8014c5d56eb..bdacb0832b3 100644 --- a/test/lisp/emacs-lisp/ert-tests.el +++ b/test/lisp/emacs-lisp/ert-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -801,6 +801,21 @@ This macro is used to test if macroexpansion in `should' works." (should (eql 0 (ert-stats-completed-unexpected stats))) (should (eql 1 (ert-stats-skipped stats))))) +(ert-deftest ert-test-with-demoted-errors () + "Check that ERT correctly handles `with-demoted-errors'." + :expected-result :failed ;; FIXME! Bug#11218 + (should-not (with-demoted-errors (error "Foo")))) + +(ert-deftest ert-test-fail-inside-should () + "Check that `ert-fail' inside `should' works correctly." + (let ((result (ert-run-test + (make-ert-test + :name 'test-1 + :body (lambda () (should (integerp (ert-fail "Boo")))))))) + (should (ert-test-failed-p result)) + (should (equal (ert-test-failed-condition result) + '(ert-test-failed ("Boo")))))) + (provide 'ert-tests) diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index d190df34ca1..9f40a18d343 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -1,4 +1,4 @@ -;;; ert-x-tests.el --- Tests for ert-x.el +;;; ert-x-tests.el --- Tests for ert-x.el -*- lexical-binding:t -*- ;; Copyright (C) 2008, 2010-2021 Free Software Foundation, Inc. @@ -7,18 +7,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -187,18 +187,15 @@ "Tests `ert-describe-test'." (save-window-excursion (ert-with-buffer-renamed ("*Help*") - (if (< emacs-major-version 24) - (should (equal (should-error (ert-describe-test 'ert-describe-test)) - '(error "Requires Emacs 24"))) - (ert-describe-test 'ert-test-describe-test) - (with-current-buffer "*Help*" - (let ((case-fold-search nil)) - (should (string-match (concat - "\\`ert-test-describe-test is a test" - " defined in" - " ['`‘]ert-x-tests.elc?['’]\\.\n\n" - "Tests ['`‘]ert-describe-test['’]\\.\n\\'") - (buffer-string))))))))) + (ert-describe-test 'ert-test-describe-test) + (with-current-buffer "*Help*" + (let ((case-fold-search nil)) + (should (string-match (concat + "\\`ert-test-describe-test is a test" + " defined in" + " ['`‘]ert-x-tests.elc?['’]\\.\n\n" + "Tests ['`‘]ert-describe-test['’]\\.\n\\'") + (buffer-string)))))))) (ert-deftest ert-test-message-log-truncation () :tags '(:causes-redisplay) diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el index 7fefe3b15a1..9040cc07270 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -1,4 +1,4 @@ -;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. @@ -44,7 +44,7 @@ (0 (progn (add-text-properties (match-beginning 0) (match-end 0) - '(help-echo "Baloon tip: Fly smoothly!")) + '(help-echo "Balloon tip: Fly smoothly!")) font-lock-warning-face)))) "Highlight rules for `faceup-test-mode'.") @@ -67,8 +67,8 @@ If `prog-mode' is defined, inherit from it." (faceup-test-define-prog-mode faceup-test-mode "faceup-test" "Dummy major mode for testing `faceup', a test system for font-lock." - (set (make-local-variable 'syntax-propertize-function) - #'faceup-test-syntax-propertize) + (setq-local syntax-propertize-function + #'faceup-test-syntax-propertize) (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) (provide 'faceup-test-mode) 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 f859eb0688e..3303e7b178d 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 @@ -1,4 +1,4 @@ -;;; faceup-test-this-file-directory.el --- Support file for faceup tests +;;; faceup-test-this-file-directory.el --- Support file for faceup tests -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup index 7d4938adf17..ec9e82148fd 100644 --- a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -1,7 +1,7 @@ This is a test of `faceup', a regression test system for font-lock keywords. It should use major mode `faceup-test-mode'. -«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +«(help-echo):"Balloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use `font-lock-warning-face', and a tooltip should be displayed if the mouse pointer is moved over it. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el index fa3372fa240..0c7e001cc75 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -1,4 +1,4 @@ -;;; faceup-test-basics.el --- Tests for the `faceup' package. +;;; faceup-test-basics.el --- Tests for the `faceup' package. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el index b591fe2a241..16e172692c0 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -1,4 +1,4 @@ -;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/find-func-tests.el b/test/lisp/emacs-lisp/find-func-tests.el new file mode 100644 index 00000000000..28a9a7ecda3 --- /dev/null +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -0,0 +1,120 @@ +;;; find-func-tests.el --- Unit tests for find-func.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2021 Free Software Foundation, Inc. + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; 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-x) ;For `ert-run-keys'. +(require 'find-func) + +(ert-deftest find-func-tests--library-completion () ;bug#43393 + ;; FIXME: How can we make this work in batch (see also + ;; `mule-cmds--test-universal-coding-system-argument')? + ;; (skip-unless (not noninteractive)) + ;; Check that `partial-completion' works when completing library names. + (should (equal "org/org" + (ert-simulate-keys + (kbd "o / o r g TAB RET") + (read-library-name)))) + ;; Check that absolute file names also work. + (should (equal (expand-file-name "nxml/" data-directory) + (ert-simulate-keys + (concat data-directory (kbd "n x / TAB RET")) + (read-library-name))))) + +(ert-deftest find-func-tests--locate-symbols () + (should (cdr + (find-function-search-for-symbol + #'goto-line nil "simple"))) + (should (cdr + (find-function-search-for-symbol + 'minibuffer-history 'defvar "simple"))) + (should (cdr + (find-function-search-for-symbol + 'with-current-buffer nil "subr"))) + (should (cdr + (find-function-search-for-symbol + 'font-lock-warning-face 'defface "font-lock"))) + (should-not (cdr + (find-function-search-for-symbol + 'wrong-variable 'defvar "simple"))) + (should-not (cdr + (find-function-search-for-symbol + 'wrong-function nil "simple"))) + (should (cdr (find-function-noselect #'goto-line))) + (should (cdr (find-function-noselect #'goto-char))) + ;; Setting LISP-ONLY and passing a primitive should error. + (should-error (find-function-noselect #'goto-char t)) + (should-error (find-function-noselect 'wrong-function))) + +(defun test-locate-helper (func &optional expected-result) + "Assert on the result of `find-function-library' for FUNC. +EXPECTED-RESULT is an alist (FUNC . LIBRARY) with the +expected function symbol and function library, respectively." + (cl-destructuring-bind (orig-function . library) + (find-function-library func) + (cl-destructuring-bind (expected-func . expected-library) + expected-result + (should (eq orig-function expected-func)) + (should (and + (not (string-empty-p expected-library)) + (string-match-p expected-library library)))))) + +(ert-deftest find-func-tests--locate-library () + (test-locate-helper #'goto-line '(goto-line . "simple")) + (test-locate-helper #'forward-char '(forward-char . "cmds.c")) + (should-error (test-locate-helper 'wrong-function))) + +(ert-deftest find-func-tests--locate-adviced-symbols () + (defun my-message () + (message "Hello!")) + (advice-add #'mark-sexp :around 'my-message) + (test-locate-helper #'mark-sexp '(mark-sexp . "lisp")) + (advice-remove #'mark-sexp 'my-message)) + +(ert-deftest find-func-tests--find-library-verbose () + (find-function-library #'join-line nil t) + (with-current-buffer "*Messages*" + (save-excursion + (goto-char (point-max)) + (skip-chars-backward "\n") + (should (string-match-p + ".join-line. is an alias for .delete-indentation." + (buffer-substring + (line-beginning-position) + (point))))))) + +;; Avoid a byte-compilation warning that may confuse people reading +;; the result of the following test. +(declare-function compilation--message->loc nil "compile") + +(ert-deftest find-func-tests--locate-macro-generated-symbols () ;bug#45443 + (should (cdr (find-function-search-for-symbol + #'compilation--message->loc nil "compile"))) + (should (cdr (find-function-search-for-symbol + 'c-mode-hook 'defvar "cc-mode")))) + +(provide 'find-func-tests) +;;; find-func-tests.el ends here diff --git a/test/lisp/emacs-lisp/float-sup-tests.el b/test/lisp/emacs-lisp/float-sup-tests.el new file mode 100644 index 00000000000..9e87928c232 --- /dev/null +++ b/test/lisp/emacs-lisp/float-sup-tests.el @@ -0,0 +1,33 @@ +;;; float-sup-tests.el --- Tests for float-sup.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) + +(ert-deftest float-sup-degrees-and-radians () + (should (equal (degrees-to-radians 180.0) float-pi)) + (should (equal (radians-to-degrees float-pi) 180.0)) + (should (equal (radians-to-degrees (degrees-to-radians 360.0)) 360.0)) + (should (equal (degrees-to-radians (radians-to-degrees float-pi)) float-pi))) + +(provide 'float-sup-tests) +;;; float-sup-tests.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index c9ab42a7f67..ffcd16ad094 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -30,6 +30,8 @@ (require 'ert) (require 'cl-lib) +;;; Code: + (defun generator-list-subrs () (cl-loop for x being the symbols when (and (fboundp x) @@ -306,4 +308,13 @@ identical output." (1+ it))))))) -2))) +(ert-deftest generator-tests-edebug () + "Check that Bug#40434 is fixed." + (with-temp-buffer + (prin1 '(iter-defun generator-tests-edebug () + (iter-yield 123)) + (current-buffer)) + (edebug-defun)) + (should (eql (iter-next (generator-tests-edebug)) 123))) + ;;; generator-tests.el ends here diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 46c0ab17406..b9850eca8b9 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -19,6 +19,7 @@ ;;; Code: +(require 'edebug) (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -82,7 +83,10 @@ (with-temp-buffer (call-process (concat invocation-directory invocation-name) nil '(t t) nil - "-Q" "-batch" "--eval" (prin1-to-string `(byte-compile-file ,el)) + "-Q" "-batch" + "--eval" (prin1-to-string + `(let ((backtrace-on-error-noninteractive nil)) + (byte-compile-file ,el))) "-l" elc) (should (equal (buffer-string) "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) @@ -132,10 +136,71 @@ "-Q" "-batch" "--eval" (prin1-to-string `(byte-compile-file ,el)) "-l" elc "--eval" - (prin1-to-string '(progn (setf (gv-test-foo gv-test-pair) 99) - (message "%d" (car gv-test-pair))))) - (should (equal (buffer-string) - "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) + (prin1-to-string + '(let ((backtrace-on-error-noninteractive nil)) + (setf (gv-test-foo gv-test-pair) 99) + (message "%d" (car gv-test-pair))))) + (should (string-match + "\\`Symbol.s function definition is void: \\\\(setf\\\\ gv-test-foo\\\\)\n\\'" + (buffer-string)))))) + +(ert-deftest gv-setter-edebug () + "Check that a setter can be defined and edebugged together with +its getter (Bug#41853)." + (with-temp-buffer + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (dolist (form '((defun gv-setter-edebug-help (b) b) + (defun gv-setter-edebug-get (a b) + (get a (gv-setter-edebug-help b))) + (gv-define-setter gv-setter-edebug-get (x a b) + `(setf (get ,a (gv-setter-edebug-help ,b)) ,x)) + (push 123 (gv-setter-edebug-get 'gv-setter-edebug + 'gv-setter-edebug-prop)))) + (print form (current-buffer))) + ;; Only check whether evaluation works in general. + (eval-buffer))) + (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) + +(ert-deftest gv-plist-get () + (require 'cl-lib) + + ;; Simple setf usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :b) "modify") + target) + '(:a "a" :b "modify" :c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :c)) + target) + '(:a "a" :b "c" :c "b"))) + + ;; Add new key value pair at top of list if setf for missing key. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (setf (plist-get target :d) "modify") + target) + '(:d "modify" :a "a" :b "b" :c "c"))) + + ;; Rotate with missing value. + ;; The value corresponding to the missing key is assumed to be nil. + (should (equal (let ((target '(:a "a" :b "b" :c "c"))) + (cl-rotatef (plist-get target :b) (plist-get target :d)) + target) + '(:d "b" :a "a" :b nil :c "c"))) + + ;; Simple setf usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (setf (plist-get target 'b) "modify") + target) + '(a "a" b "modify" c "c"))) + + ;; Other function (cl-rotatef) usage for plist-get. (symbol plist) + (should (equal (let ((target '(a "a" b "b" c "c"))) + (cl-rotatef (plist-get target 'b) (plist-get target 'c)) + target) + '(a "a" b "c" c "b")))) ;; `ert-deftest' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). diff --git a/test/lisp/emacs-lisp/hierarchy-tests.el b/test/lisp/emacs-lisp/hierarchy-tests.el new file mode 100644 index 00000000000..41d3f2f3ccf --- /dev/null +++ b/test/lisp/emacs-lisp/hierarchy-tests.el @@ -0,0 +1,556 @@ +;;; hierarchy-tests.el --- Tests for hierarchy.el -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2019 Damien Cassou + +;; Author: Damien Cassou <damien@cassou.me> +;; Maintainer: emacs-devel@gnu.org + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for hierarchy.el + +;;; Code: + +(require 'ert) +(require 'hierarchy) + +(defun hierarchy-animals () + "Create a sorted animal hierarchy." + (let ((parentfn (lambda (item) (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal) + (dolphin 'animal) + (cow 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (hierarchy-add-tree hierarchy 'dolphin parentfn) + (hierarchy-add-tree hierarchy 'cow parentfn) + (hierarchy-sort hierarchy) + hierarchy)) + +(ert-deftest hierarchy-add-one-root () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-one-item-with-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-one-item-with-parent-and-grand-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-same-root-twice () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))))) + +(ert-deftest hierarchy-add-same-child-twice () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (hierarchy-add-tree hierarchy 'animal parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-item-and-its-child () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal parentfn) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))))) + +(ert-deftest hierarchy-add-two-items-sharing-parent () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-two-hierarchies () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (circle 'shape)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'circle parentfn) + (should (equal (hierarchy-roots hierarchy) '(bird shape))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))) + (should (equal (hierarchy-children hierarchy 'shape) '(circle))))) + +(ert-deftest hierarchy-add-with-childrenfn () + (let ((childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'animal nil childrenfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-add-with-parentfn-and-childrenfn () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (animal 'life-form)))) + (childrenfn (lambda (item) + (cl-case item + (bird '(dove pigeon)) + (pigeon '(ashy-wood-pigeon))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-roots hierarchy) '(life-form))) + (should (equal (hierarchy-children hierarchy 'life-form) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))) + (should (equal (hierarchy-children hierarchy 'pigeon) '(ashy-wood-pigeon))))) + +(ert-deftest hierarchy-add-twice-with-parentfn-and-childrenfn () + (let* ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (bird 'animal)))) + (childrenfn (lambda (item) + (cl-case item + (animal '(bird)) + (bird '(dove))))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn childrenfn) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove))))) + +(ert-deftest hierarchy-add-trees () + (let ((parentfn (lambda (item) + (cl-case item + (dove 'bird) + (pigeon 'bird) + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-trees hierarchy '(dove pigeon) parentfn) + (should (equal (hierarchy-roots hierarchy) '(animal))) + (should (equal (hierarchy-children hierarchy 'animal) '(bird))) + (should (equal (hierarchy-children hierarchy 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-from-list () + (let ((hierarchy (hierarchy-from-list + '(animal (bird (dove) + (pigeon)) + (cow) + (dolphin))))) + (hierarchy-sort hierarchy (lambda (item1 item2) + (string< (car item1) + (car item2)))) + (should (equal (hierarchy-to-string hierarchy (lambda (item) (symbol-name (car item)))) + "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-from-list-with-duplicates () + (let ((hierarchy (hierarchy-from-list + '(a (b) (b)) + t))) + (hierarchy-sort hierarchy (lambda (item1 item2) + ;; sort by ID + (< (car item1) (car item2)))) + (should (equal (hierarchy-length hierarchy) 3)) + (should (equal (hierarchy-to-string + hierarchy + (lambda (item) + (format "%s(%s)" + (cadr item) + (car item)))) + "a(1)\n b(2)\n b(3)\n")))) + +(ert-deftest hierarchy-from-list-with-childrenfn () + (let ((hierarchy (hierarchy-from-list + "abc" + nil + (lambda (item) + (when (string= item "abc") + (split-string item "" t)))))) + (hierarchy-sort hierarchy (lambda (item1 item2) (string< item1 item2))) + (should (equal (hierarchy-length hierarchy) 4)) + (should (equal (hierarchy-to-string hierarchy) + "abc\n a\n b\n c\n")))) + +(ert-deftest hierarchy-add-relation-check-error-when-different-parent () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'bird parentfn) + (should-error + (hierarchy--add-relation hierarchy 'bird 'cow #'identity)))) + +(ert-deftest hierarchy-empty-p-return-non-nil-for-empty () + (should (hierarchy-empty-p (hierarchy-new)))) + +(ert-deftest hierarchy-empty-p-return-nil-for-non-empty () + (should-not (hierarchy-empty-p (hierarchy-animals)))) + +(ert-deftest hierarchy-length-of-empty-is-0 () + (should (equal (hierarchy-length (hierarchy-new)) 0))) + +(ert-deftest hierarchy-length-of-non-empty-counts-items () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (equal (hierarchy-length hierarchy) 4)))) + +(ert-deftest hierarchy-has-root () + (let ((parentfn (lambda (item) + (cl-case item + (bird 'animal) + (dove 'bird) + (pigeon 'bird)))) + (hierarchy (hierarchy-new))) + (should-not (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)) + (hierarchy-add-tree hierarchy 'dove parentfn) + (hierarchy-add-tree hierarchy 'pigeon parentfn) + (should (hierarchy-has-root hierarchy 'animal)) + (should-not (hierarchy-has-root hierarchy 'bird)))) + +(ert-deftest hierarchy-leafs () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals) + '(dove pigeon dolphin cow))))) + +(ert-deftest hierarchy-leafs-includes-lonely-roots () + (let ((parentfn (lambda (_) nil)) + (hierarchy (hierarchy-new))) + (hierarchy-add-tree hierarchy 'foo parentfn) + (should (equal (hierarchy-leafs hierarchy) + '(foo))))) + +(ert-deftest hierarchy-leafs-of-node () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-leafs animals 'cow) '())) + (should (equal (hierarchy-leafs animals 'animal) '(dove pigeon dolphin cow))) + (should (equal (hierarchy-leafs animals 'bird) '(dove pigeon))) + (should (equal (hierarchy-leafs animals 'dove) '())))) + +(ert-deftest hierarchy-child-p () + (let ((animals (hierarchy-animals))) + (should (hierarchy-child-p animals 'dove 'bird)) + (should (hierarchy-child-p animals 'bird 'animal)) + (should (hierarchy-child-p animals 'cow 'animal)) + (should-not (hierarchy-child-p animals 'cow 'bird)) + (should-not (hierarchy-child-p animals 'bird 'cow)) + (should-not (hierarchy-child-p animals 'animal 'dove)) + (should-not (hierarchy-child-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant () + (let ((animals (hierarchy-animals))) + (should (hierarchy-descendant-p animals 'dove 'animal)) + (should (hierarchy-descendant-p animals 'dove 'bird)) + (should (hierarchy-descendant-p animals 'bird 'animal)) + (should (hierarchy-descendant-p animals 'cow 'animal)) + (should-not (hierarchy-descendant-p animals 'cow 'bird)) + (should-not (hierarchy-descendant-p animals 'bird 'cow)) + (should-not (hierarchy-descendant-p animals 'animal 'dove)) + (should-not (hierarchy-descendant-p animals 'animal 'bird)))) + +(ert-deftest hierarchy-descendant-if-not-same () + (let ((animals (hierarchy-animals))) + (should-not (hierarchy-descendant-p animals 'cow 'cow)) + (should-not (hierarchy-descendant-p animals 'dove 'dove)) + (should-not (hierarchy-descendant-p animals 'bird 'bird)) + (should-not (hierarchy-descendant-p animals 'animal 'animal)))) + +;; keywords supported: :test :key +(ert-deftest hierarchy--set-equal () + (should (hierarchy--set-equal '(1 2 3) '(1 2 3))) + (should (hierarchy--set-equal '(1 2 3) '(3 2 1))) + (should (hierarchy--set-equal '(3 2 1) '(1 2 3))) + (should-not (hierarchy--set-equal '(2 3) '(3 2 1))) + (should-not (hierarchy--set-equal '(1 2 3) '(2 3))) + (should-not (hierarchy--set-equal '("1" "2") '("2" "1") :test #'eq)) + (should (hierarchy--set-equal '("1" "2") '("2" "1") :test #'equal)) + (should-not (hierarchy--set-equal '(1 2) '(-1 -2))) + (should (hierarchy--set-equal '(1 2) '(-1 -2) :key #'abs)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)))) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car)) + (should-not (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :test #'equal)) + (should (hierarchy--set-equal '(("1" 1) ("2" 1)) '(("1" 2) ("2" 2)) :key #'car :test #'equal))) + +(ert-deftest hierarchy-equal-returns-true-for-same-hierarchy () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals animals)) + (should (hierarchy-equal (hierarchy-animals) animals)))) + +(ert-deftest hierarchy-equal-returns-true-for-hierarchy-copies () + (let ((animals (hierarchy-animals))) + (should (hierarchy-equal animals (hierarchy-copy animals))))) + +(ert-deftest hierarchy-map-item-on-leaf () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals))) + (should (equal result '((cow . 0)))))) + +(ert-deftest hierarchy-map-item-on-leaf-with-indent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'cow + animals + 2))) + (should (equal result '((cow . 2)))))) + +(ert-deftest hierarchy-map-item-on-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'bird + animals))) + (should (equal result '((bird . 0) (dove . 1) (pigeon . 1)))))) + +(ert-deftest hierarchy-map-item-on-grand-parent () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-item (lambda (item indent) (cons item indent)) + 'animal + animals))) + (should (equal result '((animal . 0) (bird . 1) (dove . 2) (pigeon . 2) + (cow . 1) (dolphin . 1)))))) + +(ert-deftest hierarchy-map-conses () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map (lambda (item indent) + (cons item indent)) + animals))) + (should (equal result '((animal . 0) + (bird . 1) + (dove . 2) + (pigeon . 2) + (cow . 1) + (dolphin . 1)))))) + +(ert-deftest hierarchy-map-tree () + (let ((animals (hierarchy-animals))) + (should (equal (hierarchy-map-tree (lambda (item indent children) + (list item indent children)) + animals) + '(animal + 0 + ((bird 1 ((dove 2 nil) (pigeon 2 nil))) + (cow 1 nil) + (dolphin 1 nil))))))) + +(ert-deftest hierarchy-map-hierarchy-keeps-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-map-hierarchy (lambda (item _) (identity item)) + animals))) + (should (hierarchy-equal animals result)))) + +(ert-deftest hierarchy-map-applies-function () + (let* ((animals (hierarchy-animals)) + (parentfn (lambda (item) + (cond + ((equal item "bird") "animal") + ((equal item "dove") "bird") + ((equal item "pigeon") "bird") + ((equal item "cow") "animal") + ((equal item "dolphin") "animal")))) + (expected (hierarchy-new))) + (hierarchy-add-tree expected "dove" parentfn) + (hierarchy-add-tree expected "pigeon" parentfn) + (hierarchy-add-tree expected "cow" parentfn) + (hierarchy-add-tree expected "dolphin" parentfn) + (should (hierarchy-equal + (hierarchy-map-hierarchy (lambda (item _) (symbol-name item)) animals) + expected)))) + +(ert-deftest hierarchy-extract-tree () + (let* ((animals (hierarchy-animals)) + (birds (hierarchy-extract-tree animals 'bird))) + (hierarchy-sort birds) + (should (equal (hierarchy-roots birds) '(animal))) + (should (equal (hierarchy-children birds 'animal) '(bird))) + (should (equal (hierarchy-children birds 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-extract-tree-nil-if-not-in-hierarchy () + (let* ((animals (hierarchy-animals))) + (should-not (hierarchy-extract-tree animals 'foobar)))) + +(ert-deftest hierarchy-items-of-empty-hierarchy-is-empty () + (should (seq-empty-p (hierarchy-items (hierarchy-new))))) + +(ert-deftest hierarchy-items-returns-sequence-of-same-length () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (= (seq-length result) (hierarchy-length animals))))) + +(ert-deftest hierarchy-items-return-all-elements-of-hierarchy () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-items animals))) + (should (equal (seq-sort #'string< result) '(animal bird cow dolphin dove pigeon))))) + +(ert-deftest hierarchy-labelfn-indent-no-indent-if-0 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 0) + (buffer-substring (point-min) (point-max))) + "foo")))) + +(ert-deftest hierarchy-labelfn-indent-three-times-if-3 () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 3) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-default-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base))) + (should (equal + (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))) + " foo")))) + +(ert-deftest hierarchy-labelfn-indent-custom-indent-string () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (labelfn (hierarchy-labelfn-indent labelfn-base "###")) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring (point-min) (point-max))))) + (should (equal content "###foo")))) + +(ert-deftest hierarchy-labelfn-button-propertize () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (properties (with-temp-buffer + (funcall labelfn "bar" 1) + (text-properties-at 1)))) + (should (equal (car properties) 'action)))) + +(ert-deftest hierarchy-labelfn-button-execute-labelfn () + (let* ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (actionfn #'identity) + (labelfn (hierarchy-labelfn-button labelfn-base actionfn)) + (content (with-temp-buffer + (funcall labelfn "bar" 1) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal content "foo")))) + +(ert-deftest hierarchy-labelfn-button-if-does-not-button-unless-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) nil))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 0))))) + +(ert-deftest hierarchy-labelfn-button-if-does-button-when-condition () + (let ((labelfn-base (lambda (_item _indent) (insert "foo"))) + (spy-count 0) + (condition (lambda (_item _indent) t))) + (cl-letf (((symbol-function 'hierarchy-labelfn-button) (lambda (_labelfn _actionfn) (lambda (_item _indent) (cl-incf spy-count))))) + (funcall (hierarchy-labelfn-button-if labelfn-base condition #'identity) nil nil) + (should (equal spy-count 1))))) + +(ert-deftest hierarchy-labelfn-to-string () + (let ((labelfn (lambda (item _indent) (insert item)))) + (should (equal (hierarchy-labelfn-to-string labelfn "foo" 1) "foo")))) + +(ert-deftest hierarchy-print () + (let* ((animals (hierarchy-animals)) + (result (with-temp-buffer + (hierarchy-print animals) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-to-string () + (let* ((animals (hierarchy-animals)) + (result (hierarchy-to-string animals))) + (should (equal result "animal\n bird\n dove\n pigeon\n cow\n dolphin\n")))) + +(ert-deftest hierarchy-tabulated-display () + (let* ((animals (hierarchy-animals)) + (labelfn (lambda (item _indent) (insert (symbol-name item)))) + (contents (with-temp-buffer + (hierarchy-tabulated-display animals labelfn (current-buffer)) + (buffer-substring-no-properties (point-min) (point-max))))) + (should (equal contents "animal\nbird\ndove\npigeon\ncow\ndolphin\n")))) + +(ert-deftest hierarchy-sort-non-root-nodes () + (let* ((animals (hierarchy-animals))) + (should (equal (hierarchy-roots animals) '(animal))) + (should (equal (hierarchy-children animals 'animal) '(bird cow dolphin))) + (should (equal (hierarchy-children animals 'bird) '(dove pigeon))))) + +(ert-deftest hierarchy-sort-roots () + (let* ((organisms (hierarchy-new)) + (parentfn (lambda (item) + (cl-case item + (oak 'plant) + (bird 'animal))))) + (hierarchy-add-tree organisms 'oak parentfn) + (hierarchy-add-tree organisms 'bird parentfn) + (hierarchy-sort organisms) + (should (equal (hierarchy-roots organisms) '(animal plant))))) + +(provide 'hierarchy-tests) +;;; hierarchy-tests.el ends here diff --git a/test/lisp/emacs-lisp/lisp-mode-tests.el b/test/lisp/emacs-lisp/lisp-mode-tests.el index 12d7aafb605..e2cecdf6b01 100644 --- a/test/lisp/emacs-lisp/lisp-mode-tests.el +++ b/test/lisp/emacs-lisp/lisp-mode-tests.el @@ -2,6 +2,8 @@ ;; Copyright (C) 2017-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 @@ -153,7 +155,7 @@ noindent\" 3 (should (equal (buffer-string) str))))) (ert-deftest indent-sexp-stop-before-eol-non-lisp () - "`indent-sexp' shouldn't be too agressive in non-Lisp modes." + "`indent-sexp' shouldn't be too aggressive in non-Lisp modes." ;; See https://debbugs.gnu.org/35286#13. (with-temp-buffer (prolog-mode) @@ -294,6 +296,18 @@ Expected initialization file: `%s'\" (insert "\"\n") (lisp-indent-region (point-min) (point-max)))) +(ert-deftest lisp-indent-defun () + (with-temp-buffer + (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))))) + ;;; Fontification diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 2ff8310cbfb..78ecf3ff03d 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -8,6 +8,8 @@ ;; Author: Marcin Borkowski <mbork@mbork.pl> ;; Keywords: internal +;; 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 @@ -136,8 +138,7 @@ (text-mode) (insert "\"foo\"") (goto-char (point-min)) - (delete-pair) - (should (string-equal "fo\"" (buffer-string))))) + (should-error (delete-pair)))) (ert-deftest lisp-delete-pair-quotes-text-mode-syntax-table () "Test \\[delete-pair] with modified Text Mode syntax for #15014." @@ -296,7 +297,7 @@ (lambda () (up-list 1 t t)) (or "(1 '2 ( 2' 1 '2 ) 2' 1)") ;; abcdefghijklmnopqrstuvwxy - i k x scan-error) + i k x user-error) (define-lisp-up-list-test backward-up-list-basic (lambda () (backward-up-list)) @@ -367,6 +368,61 @@ start." " "Test buffer for `mark-defun'.")) +;;; end-of-defun + +(ert-deftest end-of-defun-twice () + "Test behavior of prefix arg for `end-of-defun' (Bug#24427). +Calling `end-of-defun' twice should be the same as a prefix arg +of two." + (setq last-command nil) + (cl-flet ((eod2 (lambda () + (goto-char (point-min)) + (end-of-defun) + (end-of-defun) + (let ((pt-eod2 (point))) + (goto-char (point-min)) + (end-of-defun 2) + (should (= (point) pt-eod2)))))) + (with-temp-buffer + (insert "\ +\(defun a ()) + +\(defun b ()) + +\(defun c ())") + (eod2)) + (with-temp-buffer + (insert "\ +\(defun a ()) +\(defun b ()) +\(defun c ())") + (eod2))) + (elisp-tests-with-temp-buffer ";; Comment header + +\(defun func-1 (arg) + \"docstring\" + body) +=!p1= +;; Comment before a defun +\(defun func-2 (arg) + \"docstring\" + body) + +\(defun func-3 (arg) + \"docstring\" + body) +=!p2=(defun func-4 (arg) + \"docstring\" + body) + +;; end +" + (goto-char p1) + (end-of-defun 2) + (should (= (point) p2)))) + +;;; mark-defun + (ert-deftest mark-defun-no-arg-region-inactive () "Test `mark-defun' with no prefix argument and inactive region." diff --git a/test/lisp/emacs-lisp/macroexp-tests.el b/test/lisp/emacs-lisp/macroexp-tests.el new file mode 100644 index 00000000000..1124e3b8d91 --- /dev/null +++ b/test/lisp/emacs-lisp/macroexp-tests.el @@ -0,0 +1,36 @@ +;;; macroexp-tests.el --- Tests for macroexp.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2021 Stefan Monnier + +;; Author: Stefan Monnier <monnier@iro.umontreal.ca> +;; Keywords: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(ert-deftest macroexp--tests-fgrep () + (should (equal (macroexp--fgrep '((x) (y)) '([x] z ((u)))) + '((x)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([y] ((y #2#)))) + '((y)))) + (should (equal (macroexp--fgrep '((x) (y)) '#2=([r] ((a x)) a b c d . #2#)) + '((x))))) + +(provide 'macroexp-tests) +;;; macroexp-tests.el ends here diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index fe59eb6a809..9a2cd42a211 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -376,5 +376,11 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-plist-pcase () + (let ((plist '(:one 1 :two 2))) + (should (equal (pcase-let (((map :one (:two two)) plist)) + (list one two)) + '(1 2))))) + (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 new file mode 100644 index 00000000000..da5f4f5700f --- /dev/null +++ b/test/lisp/emacs-lisp/memory-report-tests.el @@ -0,0 +1,57 @@ +;;; memory-report-tests.el --- tests for memory-report.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/>. + +(require 'ert) +(require 'memory-report) + +(defun setup-memory-report-tests () + ;; Set the sizes on things based on a 64-bit architecture. (We're + ;; hard-coding this to be able to write simple tests that'll work on + ;; all architectures.) + (memory-report--set-size + '((conses 16 499173 99889) + (symbols 48 22244 3) + (strings 32 92719 4559) + (string-bytes 1 40402011) + (vectors 16 31919) + (vector-slots 8 385148 149240) + (floats 8 434 4519) + (intervals 56 24499 997) + (buffers 984 33)))) + +(ert-deftest memory-report-sizes () + (setup-memory-report-tests) + (should (equal (memory-report-object-size (cons nil nil)) 16)) + (should (equal (memory-report-object-size (cons 1 2)) 16)) + + (should (equal (memory-report-object-size (list 1 2)) 32)) + (should (equal (memory-report-object-size (list 1)) 16)) + + (should (equal (memory-report-object-size (list 'foo)) 16)) + + (should (equal (memory-report-object-size (vector 1 2 3 4)) 80)) + + (should (equal (memory-report-object-size "") 32)) + (should (equal (memory-report-object-size "a") 33)) + (should (equal (memory-report-object-size (propertize "a" 'face 'foo)) + 81))) + +(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 afd2e2e380d..358d9025ad5 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -1,4 +1,4 @@ -;;; advice-tests.el --- Test suite for the new advice thingy. +;;; nadvice-tests.el --- Test suite for the new advice thingy. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2021 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/package-resources/key.pub b/test/lisp/emacs-lisp/package-resources/key.pub index a326d34e54f..5e2ebc55d35 100644 --- a/test/lisp/emacs-lisp/package-resources/key.pub +++ b/test/lisp/emacs-lisp/package-resources/key.pub @@ -1,18 +1,20 @@ -----BEGIN PGP PUBLIC KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -mQENBFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAG0HkouIFIuIEhhY2tlciA8 -anJoQGV4YW1wbGUuY29tPokBOAQTAQIAIgUCUk0HyAIbAwYLCQgHAwIGFQgCCQoL -BBYCAwECHgECF4AACgkQtpVAhgkYletuhQf+JAyHYhTZNxjq0UYlikuLX8EtYbXX -PB+03J0B73SMzEai5XsiTU2ADxqxwr7pveVK1INf+IGLiiXBlQq+4DSOvQY4xLfp -58jTOYRV1ECvlXK/JtvVOwufXREADaydf9l/MUxA5G2PPBWIuQknh3ysPSsx68OJ -SzNHFwklLn0DKc4WloE/GLDpTzimnCg7QGzuUo3Iilpjdy8EvTdI5d3jx/mGJIwI -goB+YZgyxSPM+GjDwh5DEwD7OexNqqa7RynnmU0epmlYyi9UufCHLwgiiEIzjpWi -6+iF+CQ45ZAKncovByenIUv73J3ImOudrsskeAHBmahljv1he6uV9Egj2Q== -=b5Kg +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 -----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 d21e6ae9a45..dbc80f43cb7 100644 --- a/test/lisp/emacs-lisp/package-resources/key.sec +++ b/test/lisp/emacs-lisp/package-resources/key.sec @@ -1,33 +1,35 @@ -----BEGIN PGP PRIVATE KEY BLOCK----- -Version: GnuPG v1.4.14 (GNU/Linux) -lQO+BFJNB8gBCACfbtpvYrM8V1HM0KFlIwatcEJugHqwOHpr/Z9mrCW0fxyQAW/d -2L+3QVNsN9Tz/K9lLcBUgeR7rhVEzHNqhmhNj/HnikwGqXbIofhp+QbZmBKnAlCz -d77kg8K9lozHtfTkm1gX/7DdPzQKmgi7WOzzi2395wGubeqJLvYaEcqVbI0Eob+E -3CzRjNy/e/Tf3TJRW5etTcdZN6LVuIY7tNCHqlQZTwyycON/hfLTX6cLCnzDsqm/ -NxCuwn9aqP9aGRGfIu7Y+If3zTymvrXEPUN98OEID814bOKdx0uVTZRiSMbvuTGI -8uMa/kpGX/78rqI61gbZV51RFoU7pT2tzwY/ABEBAAH+AwMCKCCpPNXkXuVgF7cz -eByuvgIO7wImDYGOdJqsASSzV4q0u1acnGtlxg7WphKDF9RnC5+1ZZ1ZcrBcv2uJ -xZm2jHdjqM3FmgQTN70GVzO1nKEur2wxlKotG4Q+8BtaRDwHdKpQFk+QW9aInH3C -BkNWTK97iFwZaoUGxKuRJb35qjMe3SsDE7kdbtOqO+tOeppRVeOOZCn7F33ir/6i -j2gmIME6LFDzvBi6YAyMBSh90Ak70HJINt0QfXlZf5MtX1NaxaEcnsRmwwcNqxh9 -JvcC9q4WrR92NhHCHI+lOsAe7hbwo/VkwRjSSx0HdKkx6kvdcNj/9LeX/jykzLvg -kEqvAqT4Jmk57W2seqvpNcAO+eUVrJ5D1OR6khsUtikPp2pQH5MDXJDGcie+ZAFb -w6BwoWBDBjooKtfuP0LKqrdtJG2JLe6yhBhWvfqHPBlUU1SsA7a5aTCLo8FiqgEI -Kyy60zMx/2Mi48oN1a/mAoV1MTWLhOVUWJlIHM7nVLj1OaX0316LcLX/uTLTq40p -apHKwERanzY7f8ROiv/Fa/J+9cCsfOLKfjFAjpBVUVoOb39HsyS/vvkGMY4kgaD6 -K6r9JPdsaoYvsLkxk5HyHF7Mk2uS1z1EIArD2/3lRiX6ag+IU1Nl3XDkgfZj06K3 -juS84dGF8CmN49uOEjzAJAQZH9jTs5OKzUuZhGJF+gt0L78vLOoKRr8bu1N1GPqU -wnS908HWruXzjJl1CAhnuCa8FnDaU+tmEKjYpWuelx85kolpMW7LT5gOFZr84MIj -Kq3Rt2hU6qQ7Cdy1ep531YKkmyh9Y4l/Tgir1OtnQQqtNuwHI497l7qAUnKZBBHZ -guApjS9BoHsRXkw2mgDssZ+khOwj/xJm876nFSiQeCD0aIbU/4zJ9e2HUOJAZI1r -d7QeSi4gUi4gSGFja2VyIDxqcmhAZXhhbXBsZS5jb20+iQE4BBMBAgAiBQJSTQfI -AhsDBgsJCAcDAgYVCAIJCgsEFgIDAQIeAQIXgAAKCRC2lUCGCRiV626FB/4kDIdi -FNk3GOrRRiWKS4tfwS1htdc8H7TcnQHvdIzMRqLleyJNTYAPGrHCvum95UrUg1/4 -gYuKJcGVCr7gNI69BjjEt+nnyNM5hFXUQK+Vcr8m29U7C59dEQANrJ1/2X8xTEDk -bY88FYi5CSeHfKw9KzHrw4lLM0cXCSUufQMpzhaWgT8YsOlPOKacKDtAbO5SjciK -WmN3LwS9N0jl3ePH+YYkjAiCgH5hmDLFI8z4aMPCHkMTAPs57E2qprtHKeeZTR6m -aVjKL1S58IcvCCKIQjOOlaLr6IX4JDjlkAqdyi8HJ6chS/vcnciY652uyyR4AcGZ -qGWO/WF7q5X0SCPZ -=5FZK +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 -----END PGP PRIVATE KEY BLOCK----- diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el index 7251622fa59..61c1b045990 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el @@ -1,4 +1,4 @@ -;;; new-pkg.el --- A package only seen after "updating" archive-contents +;;; new-pkg.el --- A package only seen after "updating" archive-contents -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 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 7b1c00c06db..301993deb30 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 @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.4 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 658edd3f60e..dac168b0e4c 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 3734823876e..ff070c6526f 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 @@ -1,4 +1,4 @@ -;;; signed-bad.el --- A single-file package with bad signature +;;; signed-bad.el --- A single-file package with bad signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 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 22718df2763..60b1b8663d9 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 @@ -1,4 +1,4 @@ -;;; signed-good.el --- A single-file package with good signature +;;; signed-good.el --- A single-file package with good signature -*- lexical-binding: t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 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 747918794ca..5b1c721e32a 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/signed/update-signatures.sh b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh new file mode 100755 index 00000000000..ca16f8b27a1 --- /dev/null +++ b/test/lisp/emacs-lisp/package-resources/signed/update-signatures.sh @@ -0,0 +1,32 @@ +#! /bin/sh + +# Generate a new key and update the signatures for tests. + +# 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/>. + +export GPG_AGENT="" +KEYRING="./key.ring" +TRUSTDB="./trust.db" +GPG="gpg --no-default-keyring --trustdb-name $TRUSTDB --keyring $KEYRING --yes" + +rm $KEYRING +$GPG --full-generate-key +$GPG --export --armor > "../key.pub" +$GPG --export-secret-keys -armor > "../key.sec" +$GPG --detach-sign --sign "./archive-contents" +$GPG --detach-sign --sign "./signed-good-1.0.el" 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 b58b658d024..cb003905bb5 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 @@ -1,4 +1,4 @@ -;;; simple-depend.el --- A single-file package with a dependency. +;;; simple-depend.el --- A single-file package with a dependency. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 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 6756a28080b..9c3f427ff48 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 @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.3 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 9cfe5c0d4e2..a0a9607350a 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 @@ -1,4 +1,4 @@ -;;; simple-two-depend.el --- A single-file package with two dependencies. +;;; simple-two-depend.el --- A single-file package with two dependencies. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.1 diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 362f79f6863..67d647d3b9e 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -1,4 +1,4 @@ -;;; package-test.el --- Tests for the Emacs package system +;;; package-tests.el --- Tests for the Emacs package system -*- lexical-binding:t -*- ;; Copyright (C) 2013-2021 Free Software Foundation, Inc. @@ -39,6 +39,7 @@ (require 'package) (require 'ert) +(require 'ert-x) (require 'cl-lib) (setq package-menu-async nil) @@ -102,13 +103,9 @@ (multi-file (0 1)))) "`package-desc' used for testing dependencies.") -(defvar package-test-data-dir (expand-file-name "package-resources" package-test-file-dir) +(defvar package-test-data-dir (ert-resource-directory) "Base directory of package test files.") -(defvar package-test-fake-contents-file - (expand-file-name "archive-contents" package-test-data-dir) - "Path to a static copy of \"archive-contents\".") - (cl-defmacro with-package-test ((&optional &key file basedir install @@ -143,8 +140,8 @@ ,(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 r) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) + (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) @@ -154,6 +151,15 @@ `(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)) @@ -175,9 +181,8 @@ (defun package-test-suffix-matches (base suffix-list) "Return file names matching BASE concatenated with each item in SUFFIX-LIST" - (cl-mapcan - '(lambda (item) (file-expand-wildcards (concat base item))) - suffix-list)) + (mapcan (lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) (defvar tar-parse-info) (declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct @@ -216,20 +221,20 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-desc-from-buffer () "Parse an elisp buffer to get a `package-desc' object." - (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") (should (package-test--compatible-p (package-buffer-info) simple-single-desc 'kind))) - (with-package-test (:basedir "package-resources" :file "simple-depend-1.0.el") + (with-package-test (:basedir (ert-resource-directory) :file "simple-depend-1.0.el") (should (package-test--compatible-p (package-buffer-info) simple-depend-desc 'kind))) - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "multi-file-0.2.3.tar") (tar-mode) (should (equal (package-tar-file-info) multi-file-desc)))) (ert-deftest package-test-install-single () "Install a single file without using an archive." - (with-package-test (:basedir "package-resources" :file "simple-single-1.3.el") + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el") (should (package-install-from-buffer)) (package-initialize) (should (package-installed-p 'simple-single)) @@ -272,7 +277,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-macro-compilation () "Install a package which includes a dependency." - (with-package-test (:basedir "package-resources") + (with-package-test (:basedir (ert-resource-directory)) (package-install-file (expand-file-name "macro-problem-package-1.0/")) (require 'macro-problem) ;; `macro-problem-func' uses a macro from `macro-aux'. @@ -311,8 +316,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-prioritized () "Install a lower version from a higher-prioritized archive." (with-package-test () - (let* ((newer-version (expand-file-name "package-resources/newer-versions" - package-test-file-dir)) + (let* ((newer-version (ert-resource-file "newer-versions")) (package-archives `(("older" . ,package-test-data-dir) ("newer" . ,newer-version))) (package-archive-priorities '(("older" . 100)))) @@ -327,7 +331,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-install-multifile () "Check properties of the installed multi-file package." - (with-package-test (:basedir "package-resources" :install '(multi-file)) + (with-package-test (:basedir (ert-resource-directory) :install '(multi-file)) (let ((autoload-file (expand-file-name "multi-file-autoloads.el" (expand-file-name @@ -352,55 +356,128 @@ Must called from within a `tar-mode' buffer." (goto-char (point-min)) (should (re-search-forward re nil t))))))) + +;;; Package Menu tests + +(defmacro with-package-menu-test (&rest body) + "Set up Package Menu (\"*Packages*\") buffer for testing." + (declare (indent 0) (debug (([&rest form]) body))) + `(with-package-test () + (let ((buf (package-list-packages))) + (unwind-protect + (progn ,@body) + (kill-buffer buf))))) + (ert-deftest package-test-update-listing () "Ensure installed package status is updated." - (with-package-test () - (let ((buf (package-list-packages))) - (search-forward-regexp "^ +simple-single") - (package-menu-mark-install) - (package-menu-execute) - (run-hooks 'post-command-hook) - (should (package-installed-p 'simple-single)) - (switch-to-buffer "*Packages*") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) - (goto-char (point-min)) - (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) - (kill-buffer buf)))) + (with-package-menu-test + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)))) + +(ert-deftest package-test-list-filter-by-archive () + "Ensure package list is filtered correctly by archive version." + (with-package-menu-test + ;; TODO: Add another package archive to test filtering, because + ;; the testing environment currently only has one. + (package-menu-filter-by-archive "gnu") + (goto-char (point-min)) + (should (looking-at "^\\s-+multi-file")) + (should (= (count-lines (point-min) (point-max)) 4)) + (should-error (package-menu-filter-by-archive "non-existent archive")))) + +(ert-deftest package-test-list-filter-by-keyword () + "Ensure package list is filtered correctly by package keyword." + (with-package-menu-test + (package-menu-filter-by-keyword "frobnicate") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (should-error (package-menu-filter-by-keyword "non-existent-keyword")))) (ert-deftest package-test-list-filter-by-name () "Ensure package list is filtered correctly by package name." + (with-package-menu-test () + (package-menu-filter-by-name "ansi-color") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+ansi-color" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)))) + +(ert-deftest package-test-list-filter-by-status () + "Ensure package list is filtered correctly by package status." + (with-package-menu-test + (package-menu-filter-by-status "available") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+multi-file" nil t)) + (should (= (count-lines (point-min) (point-max)) 4)) + ;; No installed packages in default environment. + (should-error (package-menu-filter-by-status "installed")))) + +(ert-deftest package-test-list-filter-marked () + "Ensure package list is filtered correctly by non-empty mark." (with-package-test () - (let ((buf (package-list-packages))) - (package-menu-filter-by-name "tetris") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+tetris" nil t)) - (should (= (count-lines (point-min) (point-max)) 1)) - (kill-buffer buf)))) + (package-list-packages) + (revert-buffer) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-filter-marked) + (goto-char (point-min)) + (should (re-search-forward "^I +simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-mark-unmark) + ;; No marked packages in default environment. + (should-error (package-menu-filter-marked)))) + +(ert-deftest package-test-list-filter-by-version () + (with-package-menu-test + (should-error (package-menu-filter-by-version "1.1" 'unknown-symbol))) ) + +(defun package-test-filter-by-version (version predicate name) + (with-package-menu-test + (package-menu-filter-by-version version predicate) + (goto-char (point-min)) + ;; We just check that the given package is included in the + ;; listing. One could be more ambitious. + (should (re-search-forward name)))) + +(ert-deftest package-test-list-filter-by-version-= () + "Ensure package list is filtered correctly by package version (=)." + (package-test-filter-by-version "1.1" '= "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-< () + "Ensure package list is filtered correctly by package version (<)." + (package-test-filter-by-version "1.2" '< "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-> () + "Ensure package list is filtered correctly by package version (>)." + (package-test-filter-by-version "1.0" '> "^\\s-+simple-two-depend")) (ert-deftest package-test-list-clear-filter () "Ensure package list filter is cleared correctly." - (with-package-test () - (let ((buf (package-list-packages))) - (let ((num-packages (count-lines (point-min) (point-max)))) - (should (> num-packages 1)) - (package-menu-filter-by-name "tetris") - (should (= (count-lines (point-min) (point-max)) 1)) - (package-menu-clear-filter) - (should (= (count-lines (point-min) (point-max)) num-packages))) - (kill-buffer buf)))) + (with-package-menu-test + (let ((num-packages (count-lines (point-min) (point-max)))) + (package-menu-filter-by-name "ansi-color") + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-clear-filter) + (should (= (count-lines (point-min) (point-max)) num-packages))))) (ert-deftest package-test-update-archives () "Test updating package archives." (with-package-test () - (let ((buf (package-list-packages))) + (let ((_buf (package-list-packages))) (revert-buffer) (search-forward-regexp "^ +simple-single") (package-menu-mark-install) (package-menu-execute) (should (package-installed-p 'simple-single)) - (let ((package-test-data-dir - (expand-file-name "package-resources/newer-versions" package-test-file-dir))) + (let ((package-test-data-dir (ert-resource-file "newer-versions"))) (setq package-archives `(("gnu" . ,package-test-data-dir))) (revert-buffer) @@ -419,6 +496,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-update-archives-async () "Test updating package archives asynchronously." + :tags '(:expensive-test) (skip-unless (executable-find "python2")) (let* ((package-menu-async t) (default-directory package-test-data-dir) @@ -438,7 +516,7 @@ Must called from within a `tar-mode' buffer." (when (re-search-forward "Server started, \\(.*\\)\n" nil t) (setq addr (match-string 1)))) addr))) - (with-package-test (:basedir package-test-data-dir :location addr) + (with-package-test (:basedir (ert-resource-directory) :location addr) (list-packages) (should package--downloads-in-progress) (should mode-line-process) @@ -458,8 +536,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-test-update-archives/ignore-nil-entry () "Ignore any packages that are nil. Test for Bug#28502." (with-package-test () - (let* ((with-nil-entry (expand-file-name "package-resources/with-nil-entry" - package-test-file-dir)) + (let* ((with-nil-entry (ert-resource-file "with-nil-entry")) (package-archives `(("with-nil-entry" . ,with-nil-entry)))) (package-initialize) (package-refresh-contents) @@ -537,6 +614,7 @@ Must called from within a `tar-mode' buffer." (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))) @@ -559,8 +637,7 @@ Must called from within a `tar-mode' buffer." prog-alist))) (delete-directory homedir t)))) (let* ((keyring (expand-file-name "key.pub" package-test-data-dir)) - (package-test-data-dir - (expand-file-name "package-resources/signed" package-test-file-dir))) + (package-test-data-dir (ert-resource-file "signed"))) (with-package-test () (package-initialize) (package-import-keyring keyring) @@ -577,8 +654,8 @@ Must called from within a `tar-mode' buffer." (should (progn (package-install 'signed-good) 'noerror)) (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. - (let ((buf (package-list-packages))) - (revert-buffer) + (let ((_buf (package-list-packages))) + (revert-buffer) (should (re-search-forward "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" nil t)) @@ -621,7 +698,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-x-test-upload-buffer () "Test creating an \"archive-contents\" file" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -654,7 +731,7 @@ Must called from within a `tar-mode' buffer." (ert-deftest package-x-test-upload-new-version () "Test uploading a new version of a package" - (with-package-test (:basedir "package-resources" + (with-package-test (:basedir (ert-resource-directory) :file "simple-single-1.3.el" :upload-base t) (package-upload-buffer) @@ -731,4 +808,4 @@ Must called from within a `tar-mode' buffer." (provide 'package-test) -;;; package-test.el ends here +;;; package-tests.el ends here diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index f326919b088..e6f4c097504 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -1,4 +1,4 @@ -;;; pcase-tests.el --- Test suite for pcase macro. +;;; pcase-tests.el --- Test suite for pcase macro. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2021 Free Software Foundation, Inc. @@ -32,6 +32,10 @@ (should (equal (pcase '(2 . 3) ;bug#18554 (`(,hd . ,(and (pred atom) tl)) (list hd tl)) ((pred consp) nil)) + '(2 3))) + (should (equal (pcase '(2 . 3) + (`(,hd . ,(and (pred (not consp)) tl)) (list hd tl)) + ((pred consp) nil)) '(2 3)))) (pcase-defmacro pcase-tests-plus (pat n) diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index a4ba3e233d3..940feb5e828 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -25,27 +25,14 @@ (require 'regexp-opt) -(defun regexp-opt-test--permutation (n list) - "The Nth permutation of LIST, 0 ≤ N < (length LIST)!." - (let ((len (length list)) - (perm-list nil)) - (dotimes (i len) - (let* ((d (- len i)) - (k (mod n d))) - (push (nth k list) perm-list) - (setq list (append (butlast list (- (length list) k)) - (nthcdr (1+ k) list))) - (setq n (/ n d)))) - (nreverse perm-list))) - -(defun regexp-opt-test--factorial (n) - "N!" - (apply #'* (number-sequence 1 n))) - -(defun regexp-opt-test--permutations (list) - "All permutations of LIST." - (mapcar (lambda (i) (regexp-opt-test--permutation i list)) - (number-sequence 0 (1- (regexp-opt-test--factorial (length list)))))) +(defun regexp-opt-test--permutations (l) + "All permutations of L, assuming no duplicates." + (if (cdr l) + (mapcan (lambda (x) + (mapcar (lambda (p) (cons x p)) + (regexp-opt-test--permutations (remove x l)))) + l) + (list l))) (ert-deftest regexp-opt-longest-match () "Check that the regexp always matches as much as possible." diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index 34d513b1416..9d8f3d48014 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -5,18 +5,20 @@ ;; Author: Tino Calancha <tino.calancha@gmail.com> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index e000604d0de..12bf4f7978e 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -56,13 +56,17 @@ (ert-deftest rx-def-in-or () (rx-let ((a b) (b (or "abc" c)) - (c ?a)) + (c ?a) + (d (any "a-z"))) (should (equal (rx (or a (| "ab" "abcde") "abcd")) - "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")))) + "\\(?:a\\(?:b\\(?:c\\(?:de?\\)?\\)?\\)?\\)")) + (should (equal (rx (or ?m (not d))) + "[^a-ln-z]")))) (ert-deftest rx-char-any () "Test character alternatives with `]' and `-' (Bug#25123)." (should (equal + ;; relint suppression: Range .<-]. overlaps previous .]-{ (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:))) string-end) "\\`[.-:<-{-]+\\'"))) @@ -127,8 +131,12 @@ "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) "[][:lower:][:upper:]][^][:lower:][:upper:]]")) - (should (equal (rx (any "-a" "c-" "f-f" "--/*--")) - "[*-/acf]")) + ;; relint suppression: Duplicated character .-. + ;; relint suppression: Single-character range .f-f + ;; relint suppression: Range .--/. overlaps previous .- + ;; relint suppression: Range .\*--. overlaps previous .--/ + (should (equal (rx (any "-a" "c-" "f-f" "--/*--") (any "," "-" "A")) + "[*-/acf][,A-]")) (should (equal (rx (any "]-a" ?-) (not (any "]-a" ?-))) "[]-a-][^]-a-]")) (should (equal (rx (any "--]") (not (any "--]")) @@ -140,6 +148,7 @@ "\\`a\\`[^z-a]")) (should (equal (rx (any "") (not (any ""))) "\\`a\\`[^z-a]")) + ;; relint suppression: Duplicated class .space. (should (equal (rx (any space ?a digit space)) "[a[:space:][:digit:]]")) (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) @@ -379,6 +388,8 @@ (ert-deftest rx-regexp () (should (equal (rx (regexp "abc") (regex "[de]")) "\\(?:abc\\)[de]")) + (should (equal (rx "a" (regexp "$")) + "a\\(?:$\\)")) (let ((x "a*")) (should (equal (rx (regexp x) "b") "\\(?:a*\\)b")) @@ -392,6 +403,8 @@ "ab"))) (ert-deftest rx-literal () + (should (equal (rx (literal "$a")) + "\\$a")) (should (equal (rx (literal (char-to-string 42)) nonl) "\\*.")) (let ((x "a+b")) @@ -532,6 +545,9 @@ (ert-deftest rx-compat () "Test old symbol retained for compatibility (bug#37517)." - (should (equal (rx-submatch-n '(group-n 3 (+ nonl) eol)) "\\(?3:.+$\\)"))) + (should (equal + (with-no-warnings + (rx-submatch-n '(group-n 3 (+ nonl) eol))) + "\\(?3:.+$\\)"))) (provide 'rx-tests) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 97499ff4ea0..05c7fbe781e 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -1,4 +1,4 @@ -;;; seq-tests.el --- Tests for sequences.el +;;; seq-tests.el --- Tests for seq.el -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. @@ -29,6 +29,9 @@ (require 'ert) (require 'seq) +(eval-when-compile + (require 'cl-lib)) + (defmacro with-test-sequences (spec &rest body) "Successively bind VAR to a list, vector, and string built from SEQ. Evaluate BODY for each created sequence. @@ -108,16 +111,12 @@ Evaluate BODY for each created sequence. '((a 0) (b 1) (c 2) (d 3))))) (ert-deftest test-seq-do-indexed () - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - nil) - (should (equal result nil))) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) ()) + (should-not result)) (with-test-sequences (seq '(4 5 6)) - (let ((result nil)) - (seq-do-indexed (lambda (elt i) - (add-to-list 'result (list elt i))) - seq) + (let (result) + (seq-do-indexed (lambda (elt i) (push (list elt i) result)) seq) (should (equal (seq-elt result 0) '(6 2))) (should (equal (seq-elt result 1) '(5 1))) (should (equal (seq-elt result 2) '(4 0)))))) @@ -126,7 +125,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) - (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (should (equal (seq-filter (lambda (_) nil) seq) '()))) (with-test-sequences (seq '()) (should (equal (seq-filter #'test-sequences-evenp seq) '())))) @@ -134,7 +133,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) - (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (should (same-contents-p (seq-remove (lambda (_) nil) seq) seq))) (with-test-sequences (seq '()) (should (equal (seq-remove #'test-sequences-evenp seq) '())))) @@ -142,7 +141,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-count #'test-sequences-evenp seq) 3)) (should (equal (seq-count #'test-sequences-oddp seq) 2)) - (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (should (equal (seq-count (lambda (_) nil) seq) 0))) (with-test-sequences (seq '()) (should (equal (seq-count #'test-sequences-evenp seq) 0)))) @@ -199,7 +198,7 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-every-p () (with-test-sequences (seq '(43 54 22 1)) - (should (seq-every-p (lambda (elt) t) seq)) + (should (seq-every-p (lambda (_) t) seq)) (should-not (seq-every-p #'test-sequences-oddp seq)) (should-not (seq-every-p #'test-sequences-evenp seq))) (with-test-sequences (seq '(42 54 22 2)) @@ -410,12 +409,10 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-random-elt-take-all () (let ((seq '(a b c d e)) - (elts '())) - (should (= 0 (length elts))) + elts) (dotimes (_ 1000) (let ((random-elt (seq-random-elt seq))) - (add-to-list 'elts - random-elt))) + (cl-pushnew random-elt elts))) (should (= 5 (length elts))))) (ert-deftest test-seq-random-elt-signal-on-empty () diff --git a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el +++ b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el +++ b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-tests.el b/test/lisp/emacs-lisp/shadow-tests.el index ffb3c9bf189..52d1d21cee1 100644 --- a/test/lisp/emacs-lisp/shadow-tests.el +++ b/test/lisp/emacs-lisp/shadow-tests.el @@ -20,30 +20,23 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'shadow) (eval-when-compile (require 'cl-lib)) -(defconst shadow-tests-data-directory - (expand-file-name "lisp/emacs-lisp/shadow-resources" - (or (getenv "EMACS_TEST_DIRECTORY") - (expand-file-name "../../.." - (or load-file-name - buffer-file-name)))) - "Directory for shadow test files.") - (ert-deftest shadow-case-insensitive () "Test shadowing for case insensitive filenames." ;; Override `file-name-case-insensitive-p' so we test the same thing ;; regardless of what file system we're running on. (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) t))) - (should (equal (list (expand-file-name "p1/foo" shadow-tests-data-directory) - (expand-file-name "p2/FOO" shadow-tests-data-directory)) + (should (equal (list (ert-resource-file "p1/foo") + (ert-resource-file "p2/FOO")) (load-path-shadows-find - (list (expand-file-name "p1/" shadow-tests-data-directory) - (expand-file-name "p2/" shadow-tests-data-directory)))))) + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) (cl-letf (((symbol-function 'file-name-case-insensitive-p) (lambda (_f) nil))) (should-not (load-path-shadows-find - (list (expand-file-name "p1/" shadow-tests-data-directory) - (expand-file-name "p2/" shadow-tests-data-directory)))))) + (list (ert-resource-file "p1/") + (ert-resource-file "p2/")))))) ;;; shadow-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 666af298752..112f3c1dac1 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -1,22 +1,24 @@ -;;; subr-x-tests.el --- Testing the extended lisp routines +;;; subr-x-tests.el --- Testing the extended lisp routines -*- lexical-binding:t -*- ;; Copyright (C) 2014-2021 Free Software Foundation, Inc. ;; Author: Fabián E. Gallina <fgallina@gnu.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -580,5 +582,58 @@ (should (equal (string-remove-suffix "a" "aa") "a")) (should (equal (string-remove-suffix "a" "ba") "b"))) +(ert-deftest subr-clean-whitespace () + (should (equal (string-clean-whitespace " foo ") "foo")) + (should (equal (string-clean-whitespace " foo \r\n\t Bar") "foo Bar"))) + +(ert-deftest subr-string-fill () + (should (equal (string-fill "foo" 10) "foo")) + (should (equal (string-fill "foobar" 5) "foobar")) + (should (equal (string-fill "foo bar zot" 5) "foo\nbar\nzot")) + (should (equal (string-fill "foo bar zot" 7) "foo bar\nzot"))) + +(ert-deftest subr-string-limit () + (should (equal (string-limit "foo" 10) "foo")) + (should (equal (string-limit "foo" 2) "fo")) + (should (equal (string-limit "foo" 2 t) "oo")) + (should (equal (string-limit "abc" 10 t) "abc")) + (should (equal (string-limit "foo" 0) "")) + (should-error (string-limit "foo" -1))) + +(ert-deftest subr-string-limit-coding () + (should (not (multibyte-string-p (string-limit "foó" 10 nil 'utf-8)))) + (should (equal (string-limit "foó" 10 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foó" 3 nil 'utf-8) "fo")) + (should (equal (string-limit "foó" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóa" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóá" 4 nil 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóa" 4 nil 'iso-8859-1) "fo\363a")) + (should (equal (string-limit "foóá" 4 nil 'iso-8859-1) "fo\363\341")) + (should (equal (string-limit "foóá" 4 nil 'utf-16) "\376\377\000f")) + + (should (equal (string-limit "foó" 10 t 'utf-8) "fo\303\263")) + (should (equal (string-limit "foó" 3 t 'utf-8) "o\303\263")) + (should (equal (string-limit "foó" 4 t 'utf-8) "fo\303\263")) + (should (equal (string-limit "foóa" 4 t 'utf-8) "o\303\263a")) + (should (equal (string-limit "foóá" 4 t 'utf-8) "\303\263\303\241")) + (should (equal (string-limit "foóa" 4 t 'iso-8859-1) "fo\363a")) + (should (equal (string-limit "foóá" 4 t 'iso-8859-1) "fo\363\341")) + (should (equal (string-limit "foóá" 4 t 'utf-16) "\376\377\000\341"))) + +(ert-deftest subr-string-lines () + (should (equal (string-lines "foo") '("foo"))) + (should (equal (string-lines "foo \nbar") '("foo " "bar")))) + +(ert-deftest subr-string-pad () + (should (equal (string-pad "foo" 5) "foo ")) + (should (equal (string-pad "foo" 5 ?-) "foo--")) + (should (equal (string-pad "foo" 5 ?- t) "--foo")) + (should (equal (string-pad "foo" 2 ?-) "foo"))) + +(ert-deftest subr-string-chop-newline () + (should (equal (string-chop-newline "foo\n") "foo")) + (should (equal (string-chop-newline "foo\nbar\n") "foo\nbar")) + (should (equal (string-chop-newline "foo\nbar") "foo\nbar"))) + (provide 'subr-x-tests) ;;; subr-x-tests.el ends here diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..1ae1cbc93ff --- /dev/null +++ b/test/lisp/emacs-lisp/syntax-tests.el @@ -0,0 +1,67 @@ +;;; syntax-tests.el --- tests for syntax.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/>. + +;;; Code: + +(require 'ert) +(require 'syntax) + +(ert-deftest syntax-propertize--shift-groups-and-backrefs () + "Test shifting of numbered groups and back-references in regexps." + ;; A numbered group must be shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foobar" 2) + "\\(?4:[abc]+\\)foobar")) + ;; A back-reference \1 on a normal sub-regexp context must be + ;; shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2) + "\\(a\\)\\3")) + ;; Shifting must not happen if the \1 appears in a character class, + ;; or in a \{\} repetition construct (although \1 isn't valid there + ;; anyway). + (let ((rx-with-class "\\(a\\)[\\1-2]") + (rx-with-rep "\\(a\\)\\{1,\\1\\}")) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-class 2) + rx-with-class)) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2) + rx-with-rep))) + ;; Now numbered groups and back-references in combination. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foo\\(\\2\\)" 2) + "\\(?4:[abc]+\\)foo\\(\\4\\)")) + ;; Emacs supports only the back-references \1,...,\9, so when a + ;; shift would result in \10 or more, an error must be signalled. + (should-error + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; syntax-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 5dbf2272b1a..7ced257c6f9 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index 626769b1482..7854e33e77d 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -6,18 +6,18 @@ ;; This file is part of GNU Emacs. -;; This program is free software: you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation, either version 3 of the -;; License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see `https://www.gnu.org/licenses/'. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -31,26 +31,10 @@ ;;; Code: (require 'ert) +(require 'ert-x) (require 'testcover) (require 'skeleton) -;; Use `eval-and-compile' around all these definitions because they're -;; used by the macro `testcover-tests-define-tests'. - -(eval-and-compile - (defvar testcover-tests-file-dir - (expand-file-name - "testcover-resources/" - (file-name-directory (or (bound-and-true-p byte-compile-current-file) - load-file-name - buffer-file-name))) - "Directory of the \"testcover-tests.el\" file.")) - -(eval-and-compile - (defvar testcover-tests-test-cases - (expand-file-name "testcases.el" testcover-tests-file-dir) - "File containing marked up code to instrument and check.")) - ;; Convert Testcover's overlays to plain text. (eval-and-compile @@ -62,6 +46,7 @@ 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 @@ -114,7 +99,8 @@ 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"))) + (let ((tempfile (make-temp-file "testcover-tests-" nil ".el")) + (find-file-suppress-same-file-warnings t)) (unwind-protect (progn (with-temp-file tempfile @@ -149,7 +135,7 @@ Construct and return a list of `ert-deftest' forms. See testcases.el for documentation of the test definition format." (let (results) (with-temp-buffer - (insert-file-contents testcover-tests-test-cases) + (insert-file-contents (ert-resource-file "testcases.el")) (goto-char (point-min)) (while (re-search-forward (concat "^;; ==== \\([^ ]+?\\) ====\n" diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el index 93ab4219c17..90f06c3c4c0 100644 --- a/test/lisp/emacs-lisp/text-property-search-tests.el +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -1,22 +1,24 @@ -;;; text-property-search-tests.el --- Testing text-property-search +;;; text-property-search-tests.el --- Testing text-property-search -*- lexical-binding:t -*- ;; Copyright (C) 2018-2021 Free Software Foundation, Inc. ;; Author: Lars Ingebrigtsen <larsi@gnus.org> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <https://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -151,6 +153,24 @@ 46 57 nil (point-max))) + +;;;; Position after search. + +(defun text-property-search--pos-test (fun pos &optional reverse) + (with-temp-buffer + (insert (concat "foo " + (propertize "bar" 'x t) + " baz")) + (goto-char (if reverse (point-max) (point-min))) + (funcall fun 'x t) + (should (= (point) pos)))) + +(ert-deftest text-property-search-forward-point-at-beginning () + (text-property-search--pos-test #'text-property-search-forward 5)) + +(ert-deftest text-property-search-backward-point-at-end () + (text-property-search--pos-test #'text-property-search-backward 8 t)) + (provide 'text-property-search-tests) ;;; text-property-search-tests.el ends here diff --git a/test/lisp/emacs-lisp/timer-tests.el b/test/lisp/emacs-lisp/timer-tests.el index 74da33eff69..7856c217f9e 100644 --- a/test/lisp/emacs-lisp/timer-tests.el +++ b/test/lisp/emacs-lisp/timer-tests.el @@ -36,8 +36,8 @@ (ert-deftest timer-tests-debug-timer-check () ;; This function exists only if --enable-checking. - (if (fboundp 'debug-timer-check) - (should (debug-timer-check)) t)) + (skip-unless (fboundp 'debug-timer-check)) + (should (debug-timer-check))) (ert-deftest timer-test-multiple-of-time () (should (time-equal-p diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el new file mode 100644 index 00000000000..b2a48d80675 --- /dev/null +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -0,0 +1,154 @@ +;;; unsafep-tests.el --- tests for unsafep.el -*- lexical-binding: t; -*- + +;; Author: Jonathan Yavner <jyavner@member.fsf.org> + +;; Copyright (C) 2002-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 'unsafep) + +(defvar safe-functions) + +;;; These forms are all considered safe +(defconst unsafep-tests--safe + '(((lambda (x) (* x 2)) 14) + (apply 'cdr (mapcar (lambda (x) (car x)) y)) + (cond ((= x 4) 5) (t 27)) + (condition-case x (car y) (error (car x))) + (let (x) (dolist (y '(1 2 3) (1+ y)) (push y x))) + (let (x) (apply (lambda (x) (* x 2)) 14)) + (let ((x '(2))) (push 1 x) (pop x) (add-to-list 'x 2)) + (let ((x 1) (y 2)) (setq x (+ x y))) + (let ((x 1)) (let ((y (+ x 3))) (* x y))) + (let* nil (current-time)) + (let* ((x 1) (y (+ x 3))) (* x y)) + (mapcar (lambda (x &optional y &rest z) (setq y (+ x 2)) (* y 3)) '(1 2 3)) + (mapconcat #'(lambda (var) (propertize var 'face 'bold)) '("1" "2") ", ") + (setq buffer-display-count 14 mark-active t) + ;;This is not safe if you insert it into a buffer! + (propertize "x" 'display '(height (progn (delete-file "x") 1)))) + "List of forms that `unsafep' should decide are safe.") + +;;; These forms are considered unsafe +(defconst unsafep-tests--unsafe + '(( (add-to-list x y) + . (unquoted x)) + ( (add-to-list y x) + . (unquoted y)) + ( (add-to-list 'y x) + . (global-variable y)) + ( (not (delete-file "unsafep.el")) + . (function delete-file)) + ( (cond (t (aset local-abbrev-table 0 0))) + . (function aset)) + ( (cond (t (setq unsafep-vars ""))) + . (risky-local-variable unsafep-vars)) + ( (condition-case format-alist 1) + . (risky-local-variable format-alist)) + ( (condition-case x 1 (error (setq format-alist ""))) + . (risky-local-variable format-alist)) + ( (dolist (x (sort globalvar 'car)) (princ x)) + . (function sort)) + ( (dotimes (x 14) (delete-file "x")) + . (function delete-file)) + ( (let ((post-command-hook "/tmp/")) 1) + . (risky-local-variable post-command-hook)) + ( (let ((x (delete-file "x"))) 2) + . (function delete-file)) + ( (let (x) (add-to-list 'x (delete-file "x"))) + . (function delete-file)) + ( (let (x) (condition-case y (setq x 1 z 2))) + . (global-variable z)) + ( (let (x) (condition-case z 1 (error (delete-file "x")))) + . (function delete-file)) + ( (let (x) (mapc (lambda (x) (setcar x 1)) '((1 . 2) (3 . 4)))) + . (function setcar)) + ( (let (y) (push (delete-file "x") y)) + . (function delete-file)) + ( (let* ((x 1)) (setq y 14)) + . (global-variable y)) + ( (mapc 'car (list '(1 . 2) (cons 3 4) (kill-buffer "unsafep.el"))) + . (function kill-buffer)) + ( (mapcar x y) + . (unquoted x)) + ( (mapcar (lambda (x) (rename-file x "x")) '("unsafep.el")) + . (function rename-file)) + ( (mapconcat x1 x2 " ") + . (unquoted x1)) + ( (pop format-alist) + . (risky-local-variable format-alist)) + ( (push 1 format-alist) + . (risky-local-variable format-alist)) + ( (setq buffer-display-count (delete-file "x")) + . (function delete-file)) + ;;These are actually safe (they signal errors) + ( (apply '(x) '(1 2 3)) + . (function (x))) + ( (let (((x))) 1) + . (variable (x))) + ( (let (1) 2) + . (variable 1)) + ( (error "asdf") + . #'error) + ( (signal 'error "asdf") + . #'signal) + ( (throw 'asdf) + . #'throw) + ( (catch 'asdf 17) + . #'catch) + ( (play-sound-file "asdf") + . #'play-sound-file) + ( (replace-regexp-in-string "a" "b") + . #'replace-regexp-in-string) + ) + "A-list of (FORM . REASON)... that `unsafep' should decide are unsafe.") + +(ert-deftest test-unsafep/safe () + "Check safe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--safe) + (should-not (unsafep x))))) + +(ert-deftest test-unsafep/message () + "Check that message is considered unsafe." + (should (unsafep '(dolist (x y) (message "here: %s" x)))) + (should (unsafep '(dotimes (x 14 (* x 2)) (message "here: %d" x))))) + +(ert-deftest test-unsafep/unsafe () + "Check unsafe forms with safe-functions nil." + (let (safe-functions) + (dolist (x unsafep-tests--unsafe) + (should (equal (unsafep (car x)) (cdr x)))))) + +(ert-deftest test-unsafep/safe-functions-t () + "safe-functions=t should allow delete-file" + (let ((safe-functions t)) + (should-not (unsafep '(delete-file "x"))) + (should-not (unsafep-function 'delete-file)))) + +(ert-deftest test-unsafep/safe-functions-setcar () + "safe-functions=(setcar) should allow setcar but not setcdr" + (let ((safe-functions '(setcar))) + (should-not (unsafep '(setcar x 1))) + (should (unsafep '(setcdr x 1))))) + +(provide 'unsafep-tests) + +;;; unsafep-tests.el ends here diff --git a/test/lisp/emacs-lisp/warnings-tests.el b/test/lisp/emacs-lisp/warnings-tests.el new file mode 100644 index 00000000000..aa394634827 --- /dev/null +++ b/test/lisp/emacs-lisp/warnings-tests.el @@ -0,0 +1,60 @@ +;;; warnings-tests.el --- tests for warnings.el -*- lexical-binding: t; -*- + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; 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/>. + +;;; Code: + +(require 'ert) +(require 'warnings) + +(ert-deftest test-warning-suppress-p () + (should (warning-suppress-p 'foo '((foo)))) + (should (warning-suppress-p '(foo bar) '((foo bar)))) + (should (warning-suppress-p '(foo bar baz) '((foo bar)))) + (should-not (warning-suppress-p '(foo bar baz) '((foo bax)))) + (should-not (warning-suppress-p 'foobar nil))) + +(ert-deftest test-display-warning () + (dolist (level '(:emergency :error :warning)) + (with-temp-buffer + (display-warning '(foo) "Hello123" level (current-buffer)) + (should (string-match "foo" (buffer-string))) + (should (string-match "Hello123" (buffer-string)))) + (with-current-buffer "*Messages*" + (should (string-match "Hello123" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-level () + ;; This test only works interactively: + :expected-result :failed + (let ((warning-minimum-level :emergency)) + (with-temp-buffer + (display-warning '(foo) "baz" :warning (current-buffer))) + (with-current-buffer "*Messages*" + (should-not (string-match "baz" (buffer-string)))))) + +(ert-deftest test-display-warning/warning-minimum-log-level () + (let ((warning-minimum-log-level :error)) + (with-temp-buffer + (display-warning '(foo) "hello" :warning (current-buffer)) + (should-not (string-match "hello" (buffer-string)))))) + +(provide 'warnings-tests) + +;;; warnings-tests.el ends here |