diff options
Diffstat (limited to 'test/lisp/emacs-lisp')
44 files changed, 1735 insertions, 164 deletions
diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index f8efa7902a4..14f95a8bf80 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -96,4 +96,20 @@ (dest-ip . [192 168 1 100])))))) +(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-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 3aba9af3e79..a9dcf152617 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-2020 Free Software Foundation, Inc. @@ -47,6 +47,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) @@ -368,24 +373,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 +413,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) @@ -482,6 +487,7 @@ Subtests signal errors if something goes wrong." (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 () @@ -567,25 +573,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 +634,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 diff --git a/test/lisp/emacs-lisp/cconv-tests.el b/test/lisp/emacs-lisp/cconv-tests.el index c8d46541ad4..0ea9742be49 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..bb9542114c4 --- /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 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-generic-tests.el b/test/lisp/emacs-lisp/cl-generic-tests.el index 51c9884ddc8..5aa58782f36 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)) @@ -249,5 +250,42 @@ (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))) + ;; Make generated symbols reproducible. + (gensym-counter 10000)) + (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-generic-:method@10000 ((_ number))") + (intern "cl-generic-:method@10001 ((_ string))") + (intern "cl-generic-:method@10002 :around ((_ number))") + 'cl-defgeneric/edebug/method/1 + (intern "cl-generic-:method@10003 ((_ 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 57b9d23efb0..40dd7e4eeb0 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -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)) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index c357ecde951..29ae95e2771 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -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,13 @@ 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-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 cddefbbdee8..7e0f5384542 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/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index 60e49ab93a4..7be057db8b2 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-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/edebug-tests.el b/test/lisp/emacs-lisp/edebug-tests.el index 41811c9dc07..04a7b2f5a0f 100644 --- a/test/lisp/emacs-lisp/edebug-tests.el +++ b/test/lisp/emacs-lisp/edebug-tests.el @@ -938,5 +938,99 @@ 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-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) + (should (equal (reverse instrumented-names) + ;; The outer definitions come after the inner + ;; ones because their body ends later. + ;; FIXME: There are twice as many inner + ;; definitions as expected due to Bug#41988. + ;; Once that bug is fixed, remove the duplicates. + ;; FIXME: We'd rather have names such as + ;; `edebug-tests-cl-flet-1@inner@cl-flet@10000', + ;; but that requires further changes to Edebug. + '(inner@cl-flet@10000 + inner@cl-flet@10001 + inner@cl-flet@10002 + inner@cl-flet@10003 + edebug-tests-cl-flet-1 + inner@cl-flet@10004 + inner@cl-flet@10005 + 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 b3e296db16b..73c3ea82e2d 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-2020 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 3c5aeaf708f..6979da8482b 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-2020 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 34c20b2003f..21adc91e555 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-2020 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-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index e910329c201..b760f8c7869 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-2020 Free Software Foundation, Inc. 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 3017b52ab54..4bad36080a1 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-2020 Free Software Foundation, Inc. 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 ab638ef932f..d8ab02b650e 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-2020 Free Software Foundation, Inc. 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 0838981fcb9..3c9ec76cdf7 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-2020 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 4f5fe180bb3..a87c16d66c0 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-2020 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..f505e78566e --- /dev/null +++ b/test/lisp/emacs-lisp/find-func-tests.el @@ -0,0 +1,45 @@ +;;; find-func-tests.el --- Unit tests for find-func.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; 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: + +(require 'ert-x) ;For `ert-run-keys'. + +(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))))) + +(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..9f9a3daa28b --- /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 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 e0d9167118e..72eee07be8c 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 7fa4cd50b08..29e4273b478 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)) @@ -134,8 +135,67 @@ "--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"))))) + (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-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 8736ac70201..a2b8304c96a 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -367,6 +367,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/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index c52bb83fa33..1888baf6017 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/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index eabe3cb1970..a955df0a696 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-2020 Free Software Foundation, Inc. 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/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 4fcaf0e84c2..cbb2410f953 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-2020 Free Software Foundation, Inc. @@ -143,8 +143,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) @@ -175,9 +175,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 @@ -352,48 +351,122 @@ 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 "tetris") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+tetris" 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 "tetris") + (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) @@ -419,6 +492,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) @@ -537,6 +611,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))) @@ -577,8 +652,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)) @@ -731,4 +806,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 0b69bd99f32..ac512416b71 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-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 0179ac4f1f4..ff93b8b759e 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 5dee206e931..5add24c479a 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 0fece4004bd..3b01d89dbab 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) @@ -388,6 +397,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")) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 77ee4f5c38d..a6a80952360 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-2020 Free Software Foundation, Inc. @@ -126,7 +126,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 +134,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 +142,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 +199,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)) 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/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 220ce0c08f0..9d14a5ab7ec 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-2020 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: diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..9d4c4113fdd --- /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 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/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el index 26b89b72312..83d4b95b76b 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-2020 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: diff --git a/test/lisp/emacs-lisp/unsafep-tests.el b/test/lisp/emacs-lisp/unsafep-tests.el new file mode 100644 index 00000000000..2b920a00ca4 --- /dev/null +++ b/test/lisp/emacs-lisp/unsafep-tests.el @@ -0,0 +1,144 @@ +;;; unsafep-tests.el --- tests for unsafep.el -*- lexical-binding: t; -*- + +;; Author: Jonathan Yavner <jyavner@member.fsf.org> + +;; Copyright (C) 2002-2020 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 testcover-unsafep-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 testcover-unsafep-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)) + ) + "A-list of (FORM . REASON)... that`unsafep' should decide are unsafe.") + +(ert-deftest test-unsafep/safe () + "Executes all unsafep tests and displays the coverage results." + (let (safe-functions) + (dolist (x testcover-unsafep-safe) + (should-not (unsafep x))))) + +(ert-deftest test-unsafep/message () + ;; FIXME: This failed after converting these tests from testcover to + ;; ert. + :expected-result :failed + (should-not '(dolist (x y) (message "here: %s" x))) + (should-not '(dotimes (x 14 (* x 2)) (message "here: %d" x)))) + +(ert-deftest test-unsafep/unsafe () + "Executes all unsafep tests and displays the coverage results." + (let (safe-functions) + (dolist (x testcover-unsafep-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..02c09b41ca5 --- /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 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 |