mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
Add tests for lisp/emacs-lisp/testcover.el
* test/lisp/emacs-lisp/testcover-tests.el: New file. * test/lisp/emacs-lisp/testcover-resources/testcases.el: New file. Co-authored-by: Noam Postavsky <npostavs@users.sourceforge.net>
This commit is contained in:
Gemini Lasswell
Eli Zaretskii
parent
12a79dc3ce
commit
331eb6c915
2 changed files with 679 additions and 0 deletions
493
test/lisp/emacs-lisp/testcover-resources/testcases.el
Normal file
493
test/lisp/emacs-lisp/testcover-resources/testcases.el
Normal file
|
|
@ -0,0 +1,493 @@
|
|||
;;;; testcases.el -- Test cases for testcover-tests.el
|
||||
|
||||
;; Copyright (C) 2017 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Gemini Lasswell
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; This program is free software: you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation, either version 3 of the
|
||||
;; License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see `http://www.gnu.org/licenses/'.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; * This file should not be loaded directly. It is meant to be read
|
||||
;; by `testcover-tests-build-test-cases'.
|
||||
;;
|
||||
;; * Test cases begin with ;; ==== name ====. The symbol name between
|
||||
;; the ===='s is used to create the name of the test.
|
||||
;;
|
||||
;; * Following the beginning comment place the test docstring and
|
||||
;; any tags or keywords for ERT. These will be spliced into the
|
||||
;; ert-deftest for the test.
|
||||
;;
|
||||
;; * To separate the above from the test case code, use another
|
||||
;; comment: ;; ====
|
||||
;;
|
||||
;; * These special comments should start at the beginning of a line.
|
||||
;;
|
||||
;; * `testcover-tests-skeleton' will prompt you for a test name and
|
||||
;; insert the special comments.
|
||||
;;
|
||||
;; * The test case code should be annotated with %%% at the end of
|
||||
;; each form where a tan splotch is expected, and !!! at the end
|
||||
;; of each form where a red mark is expected.
|
||||
;;
|
||||
;; * If Testcover is working correctly on your code sample, using
|
||||
;; `testcover-tests-markup-region' and
|
||||
;; `testcover-tests-unmarkup-region' can make creating test cases
|
||||
;; easier.
|
||||
|
||||
;;; Code:
|
||||
;;; Test Cases:
|
||||
|
||||
;; ==== constants-bug-25316 ====
|
||||
"Testcover doesn't splotch constants."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defconst testcover-testcase-const "apples")
|
||||
(defun testcover-testcase-zero () 0)
|
||||
(defun testcover-testcase-list-consts ()
|
||||
(list
|
||||
emacs-version 10
|
||||
"hello"
|
||||
`(a b c ,testcover-testcase-const)
|
||||
'(1 2 3)
|
||||
testcover-testcase-const
|
||||
(testcover-testcase-zero)
|
||||
nil))
|
||||
|
||||
(defun testcover-testcase-add-to-const-list (arg)
|
||||
(cons arg%%% (testcover-testcase-list-consts))%%%)
|
||||
|
||||
(should (equal (testcover-testcase-add-to-const-list 'a)
|
||||
`(a ,emacs-version 10 "hello" (a b c "apples") (1 2 3)
|
||||
"apples" 0 nil)))
|
||||
|
||||
;; ==== customize-defcustom-bug-25326 ====
|
||||
"Testcover doesn't prevent testing of defcustom values."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defgroup testcover-testcase nil
|
||||
"Test case for testcover"
|
||||
:group 'lisp
|
||||
:prefix "testcover-testcase-"
|
||||
:version "26.0")
|
||||
(defcustom testcover-testcase-flag t
|
||||
"Test value used by testcover-tests.el"
|
||||
:type 'boolean
|
||||
:group 'testcover-testcase)
|
||||
(defun testcover-testcase-get-flag ()
|
||||
testcover-testcase-flag)
|
||||
|
||||
(testcover-testcase-get-flag)
|
||||
(setq testcover-testcase-flag (not testcover-testcase-flag))
|
||||
(testcover-testcase-get-flag)
|
||||
|
||||
;; ==== no-returns ====
|
||||
"Testcover doesn't splotch functions which don't return."
|
||||
;; ====
|
||||
(defun testcover-testcase-play-ball (retval)
|
||||
(catch 'ball
|
||||
(throw 'ball retval%%%))%%%) ; catch gets marked but not throw
|
||||
|
||||
(defun testcover-testcase-not-my-favorite-error-message ()
|
||||
(signal 'wrong-type-argument (list 'consp nil)))
|
||||
|
||||
(should (testcover-testcase-play-ball t))
|
||||
(condition-case nil
|
||||
(testcover-testcase-not-my-favorite-error-message)
|
||||
(error nil))
|
||||
|
||||
;; ==== noreturn-symbol ====
|
||||
"Wrapping a form with noreturn prevents splotching."
|
||||
;; ====
|
||||
(defun testcover-testcase-cancel (spacecraft)
|
||||
(error "no destination for %s" spacecraft))
|
||||
(defun testcover-testcase-launch (spacecraft planet)
|
||||
(if (null planet)
|
||||
(noreturn (testcover-testcase-cancel spacecraft%%%))
|
||||
(list spacecraft%%% planet%%%)%%%)%%%)
|
||||
(defun testcover-testcase-launch-2 (spacecraft planet)
|
||||
(if (null planet%%%)%%%
|
||||
(testcover-testcase-cancel spacecraft%%%)!!!
|
||||
(list spacecraft!!! planet!!!)!!!)!!!)
|
||||
(should (equal (testcover-testcase-launch "Curiosity" "Mars") '("Curiosity" "Mars")))
|
||||
(condition-case err
|
||||
(testcover-testcase-launch "Voyager" nil)
|
||||
(error err))
|
||||
(condition-case err
|
||||
(testcover-testcase-launch-2 "Voyager II" nil)
|
||||
(error err))
|
||||
|
||||
(should-error (testcover-testcase-launch "Voyager" nil))
|
||||
(should-error (testcover-testcase-launch-2 "Voyager II" nil))
|
||||
|
||||
;; ==== 1-value-symbol-bug-25316 ====
|
||||
"Wrapping a form with 1value prevents splotching."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-always-zero (num)
|
||||
(- num%%% num%%%)%%%)
|
||||
(defun testcover-testcase-still-always-zero (num)
|
||||
(1value (- num%%% num%%% (- num%%% num%%%)%%%)))
|
||||
(defun testcover-testcase-never-called (num)
|
||||
(1value (/ num!!! num!!!)!!!)!!!)
|
||||
(should (eql 0 (testcover-testcase-always-zero 3)))
|
||||
(should (eql 0 (testcover-testcase-still-always-zero 5)))
|
||||
|
||||
;; ==== dotimes-dolist ====
|
||||
"Dolist and dotimes with a 1valued return value are 1valued."
|
||||
;; ====
|
||||
(defun testcover-testcase-do-over (things)
|
||||
(dolist (thing things%%%)
|
||||
(list thing))
|
||||
(dolist (thing things%%% 42)
|
||||
(list thing))
|
||||
(dolist (thing things%%% things%%%)
|
||||
(list thing))%%%)
|
||||
(defun testcover-testcase-do-more (count)
|
||||
(dotimes (num count%%%)
|
||||
(+ num num))
|
||||
(dotimes (num count%%% count%%%)
|
||||
(+ num num))%%%
|
||||
(dotimes (num count%%% 0)
|
||||
(+ num num)))
|
||||
(should (equal '(a b c) (testcover-testcase-do-over '(a b c))))
|
||||
(should (eql 0 (testcover-testcase-do-more 2)))
|
||||
|
||||
;; ==== let-last-form ====
|
||||
"A let form is 1valued if its last form is 1valued."
|
||||
;; ====
|
||||
(defun testcover-testcase-double (num)
|
||||
(let ((double (* num%%% 2)%%%))
|
||||
double%%%)%%%)
|
||||
(defun testcover-testcase-nullbody-let (num)
|
||||
(let* ((square (* num%%% num%%%)%%%)
|
||||
(double (* 2 num%%%)%%%))))
|
||||
(defun testcover-testcase-answer ()
|
||||
(let ((num 100))
|
||||
42))
|
||||
(should-not (testcover-testcase-nullbody-let 3))
|
||||
(should (eql (testcover-testcase-answer) 42))
|
||||
(should (eql (testcover-testcase-double 10) 20))
|
||||
|
||||
;; ==== if-with-1value-clauses ====
|
||||
"An if is 1valued if both then and else are 1valued."
|
||||
;; ====
|
||||
(defun testcover-testcase-describe (val)
|
||||
(if (zerop val%%%)%%%
|
||||
"a number"
|
||||
"a different number"))
|
||||
(defun testcover-testcase-describe-2 (val)
|
||||
(if (zerop val)
|
||||
"zero"
|
||||
"not zero"))
|
||||
(defun testcover-testcase-describe-3 (val)
|
||||
(if (zerop val%%%)%%%
|
||||
"zero"
|
||||
(format "%d" val%%%)%%%)%%%)
|
||||
(should (equal (testcover-testcase-describe 0) "a number"))
|
||||
(should (equal (testcover-testcase-describe-2 0) "zero"))
|
||||
(should (equal (testcover-testcase-describe-2 1) "not zero"))
|
||||
(should (equal (testcover-testcase-describe-3 1) "1"))
|
||||
|
||||
;; ==== cond-with-1value-clauses ====
|
||||
"A cond form is marked 1valued if all clauses are 1valued."
|
||||
;; ====
|
||||
(defun testcover-testcase-cond (num)
|
||||
(cond
|
||||
((eql num%%% 0)%%% 'a)
|
||||
((eql num%%% 1)%%% 'b)
|
||||
((eql num!!! 2)!!! 'c)))
|
||||
(defun testcover-testcase-cond-2 (num)
|
||||
(cond
|
||||
((eql num%%% 0)%%% (cons 'a 0)!!!)
|
||||
((eql num%%% 1)%%% 'b))%%%)
|
||||
(should (eql (testcover-testcase-cond 1) 'b))
|
||||
(should (eql (testcover-testcase-cond-2 1) 'b))
|
||||
|
||||
;; ==== condition-case-with-1value-components ====
|
||||
"A condition-case is marked 1valued if its body and handlers are."
|
||||
;; ====
|
||||
(defun testcover-testcase-cc (arg)
|
||||
(condition-case nil
|
||||
(if (null arg%%%)%%%
|
||||
(error "foo")
|
||||
"0")!!!
|
||||
(error nil)))
|
||||
(should-not (testcover-testcase-cc nil))
|
||||
|
||||
;; ==== quotes-within-backquotes-bug-25316 ====
|
||||
"Forms to instrument are found within quotes within backquotes."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-make-list ()
|
||||
(list 'defun 'defvar))
|
||||
(defmacro testcover-testcase-bq-macro (arg)
|
||||
(declare (debug t))
|
||||
`(memq ,arg%%% '(defconst ,@(testcover-testcase-make-list)))%%%)
|
||||
(defun testcover-testcase-use-bq-macro (arg)
|
||||
(testcover-testcase-bq-macro arg%%%)%%%)
|
||||
(should (equal '(defun defvar) (testcover-testcase-use-bq-macro 'defun)))
|
||||
|
||||
;; ==== progn-functions ====
|
||||
"Some forms are 1value if their last argument is 1value."
|
||||
;; ====
|
||||
(defun testcover-testcase-one (arg)
|
||||
(progn
|
||||
(setq arg (1- arg%%%)%%%)%%%)%%%
|
||||
(progn
|
||||
(setq arg (1+ arg%%%)%%%)%%%
|
||||
1))
|
||||
|
||||
(should (eql 1 (testcover-testcase-one 0)))
|
||||
;; ==== prog1-functions ====
|
||||
"Some forms are 1value if their first argument is 1value."
|
||||
;; ====
|
||||
(defun testcover-testcase-unwinder (arg)
|
||||
(unwind-protect
|
||||
(if ( > arg%%% 0)%%%
|
||||
1
|
||||
0)
|
||||
(format "unwinding %s!" arg%%%)%%%))
|
||||
(defun testcover-testcase-divider (arg)
|
||||
(unwind-protect
|
||||
(/ 100 arg%%%)%%%
|
||||
(format "unwinding! %s" arg%%%)%%%)%%%)
|
||||
|
||||
(should (eq 0 (testcover-testcase-unwinder 0)))
|
||||
(should (eq 1 (testcover-testcase-divider 100)))
|
||||
|
||||
;; ==== compose-functions ====
|
||||
"Some functions are 1value if all their arguments are 1value."
|
||||
;; ====
|
||||
(defconst testcover-testcase-count 3)
|
||||
(defun testcover-testcase-number ()
|
||||
(+ 1 testcover-testcase-count))
|
||||
(defun testcover-testcase-more ()
|
||||
(+ 1 (testcover-testcase-number) testcover-testcase-count))
|
||||
|
||||
(should (equal (testcover-testcase-more) 8))
|
||||
|
||||
;; ==== apply-quoted-symbol ====
|
||||
"Apply with a quoted function symbol treated as 1value if function is."
|
||||
;; ====
|
||||
(defun testcover-testcase-numlist (flag)
|
||||
(if flag%%%
|
||||
'(1 2 3)
|
||||
'(4 5 6)))
|
||||
(defun testcover-testcase-sum (flag)
|
||||
(apply '+ (testcover-testcase-numlist flag%%%)))
|
||||
(defun testcover-testcase-label ()
|
||||
(apply 'message "edebug uses: %s %s" (list 1 2)!!!)!!!)
|
||||
|
||||
(should (equal 6 (testcover-testcase-sum t)))
|
||||
|
||||
;; ==== backquote-1value-bug-24509 ====
|
||||
"Commas within backquotes are recognized as non-1value."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defmacro testcover-testcase-lambda (&rest body)
|
||||
`(lambda () ,@body))
|
||||
|
||||
(defun testcover-testcase-example ()
|
||||
(let ((lambda-1 (testcover-testcase-lambda (format "lambda-%d" 1))%%%)
|
||||
(lambda-2 (testcover-testcase-lambda (format "lambda-%d" 2))%%%))
|
||||
(concat (funcall lambda-1%%%)%%% " "
|
||||
(funcall lambda-2%%%)%%%)%%%)%%%)
|
||||
|
||||
(defmacro testcover-testcase-message-symbol (name)
|
||||
`(message "%s" ',name))
|
||||
|
||||
(defun testcover-testcase-example-2 ()
|
||||
(concat
|
||||
(testcover-testcase-message-symbol foo)%%%
|
||||
(testcover-testcase-message-symbol bar)%%%)%%%)
|
||||
|
||||
(should (equal "lambda-1 lambda-2" (testcover-testcase-example)))
|
||||
(should (equal "foobar" (testcover-testcase-example-2)))
|
||||
|
||||
;; ==== pcase-bug-24688 ====
|
||||
"Testcover copes with condition-case within backquoted list."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-pcase (form)
|
||||
(pcase form%%%
|
||||
(`(condition-case ,var ,protected-form . ,handlers)
|
||||
(list var%%% protected-form%%% handlers%%%)%%%)
|
||||
(_ nil))%%%)
|
||||
|
||||
(should (equal (testcover-testcase-pcase '(condition-case a
|
||||
(/ 5 a)
|
||||
(error 0)))
|
||||
'(a (/ 5 a) ((error 0)))))
|
||||
|
||||
;; ==== defun-in-backquote-bug-11307-and-24743 ====
|
||||
"Testcover handles defun forms within backquoted list."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defmacro testcover-testcase-defun (name &rest body)
|
||||
(declare (debug (symbolp def-body)))
|
||||
`(defun ,name () ,@body))
|
||||
|
||||
(testcover-testcase-defun foo (+ 1 2))
|
||||
(testcover-testcase-defun bar (+ 3 4))
|
||||
(should (eql (foo) 3))
|
||||
(should (eql (bar) 7))
|
||||
|
||||
;; ==== closure-1value-bug ====
|
||||
"Testcover does not mark closures as 1value."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
;; -*- lexical-binding:t -*-
|
||||
(setq testcover-testcase-foo nil)
|
||||
(setq testcover-testcase-bar 0)
|
||||
|
||||
(defun testcover-testcase-baz (arg)
|
||||
(setq testcover-testcase-foo
|
||||
(lambda () (+ arg testcover-testcase-bar%%%))))
|
||||
|
||||
(testcover-testcase-baz 2)
|
||||
(should (equal 2 (funcall testcover-testcase-foo)))
|
||||
(testcover-testcase-baz 3)
|
||||
(should (equal 3 (funcall testcover-testcase-foo)))
|
||||
|
||||
;; ==== by-value-vs-by-reference-bug-25351 ====
|
||||
"An object created by a 1value expression may be modified by other code."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-ab ()
|
||||
(list 'a 'b))
|
||||
(defun testcover-testcase-change-it (arg)
|
||||
(setf (cadr arg%%%)%%% 'c)%%%
|
||||
arg%%%)
|
||||
|
||||
(should (equal (testcover-testcase-change-it (testcover-testcase-ab)) '(a c)))
|
||||
(should (equal (testcover-testcase-ab) '(a b)))
|
||||
|
||||
;; ==== 1value-error-test ====
|
||||
"Forms wrapped by `1value' should always return the same value."
|
||||
;; ====
|
||||
(defun testcover-testcase-thing (arg)
|
||||
(1value (list 1 arg 3)))
|
||||
|
||||
(should (equal '(1 2 3) (testcover-testcase-thing 2)))
|
||||
(should-error (testcover-testcase-thing 3))
|
||||
|
||||
;; ==== dotted-backquote ====
|
||||
"Testcover correctly instruments dotted backquoted lists."
|
||||
;; ====
|
||||
(defun testcover-testcase-dotted-bq (flag extras)
|
||||
(let* ((bq
|
||||
`(a b c . ,(and flag extras%%%))))
|
||||
bq))
|
||||
|
||||
(should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e))))
|
||||
(should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e))))
|
||||
|
||||
;; ==== backquoted-vector-bug-25316 ====
|
||||
"Testcover reinstruments within backquoted vectors."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-vec (a b c)
|
||||
`[,a%%% ,(list b%%% c%%%)%%%]%%%)
|
||||
|
||||
(defun testcover-testcase-vec-in-list (d e f)
|
||||
`([[,d%%% ,e%%%] ,f%%%])%%%)
|
||||
|
||||
(defun testcover-testcase-vec-arg (num)
|
||||
(list `[,num%%%]%%%)%%%)
|
||||
|
||||
(should (equal [1 (2 3)] (testcover-testcase-vec 1 2 3)))
|
||||
(should (equal '([[4 5] 6]) (testcover-testcase-vec-in-list 4 5 6)))
|
||||
(should (equal '([100]) (testcover-testcase-vec-arg 100)))
|
||||
|
||||
;; ==== vector-in-macro-spec-bug-25316 ====
|
||||
"Testcover reinstruments within vectors."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defmacro testcover-testcase-nth-case (arg vec)
|
||||
(declare (indent 1)
|
||||
(debug (form (vector &rest form))))
|
||||
`(eval (aref ,vec%%% ,arg%%%))%%%)
|
||||
|
||||
(defun testcover-testcase-use-nth-case (choice val)
|
||||
(testcover-testcase-nth-case choice
|
||||
[(+ 1 val!!!)!!!
|
||||
(- 1 val%%%)%%%
|
||||
(* 7 val)
|
||||
(/ 4 val!!!)!!!]))
|
||||
|
||||
(should (eql 42 (testcover-testcase-use-nth-case 2 6)))
|
||||
(should (eql 49 (testcover-testcase-use-nth-case 2 7)))
|
||||
(should (eql 0 (testcover-testcase-use-nth-case 1 1 )))
|
||||
|
||||
;; ==== mapcar-is-not-compose ====
|
||||
"Mapcar with 1value arguments is not 1value."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defvar testcover-testcase-num 0)
|
||||
(defun testcover-testcase-add-num (n)
|
||||
(+ testcover-testcase-num n))
|
||||
(defun testcover-testcase-mapcar-sides ()
|
||||
(mapcar 'testcover-testcase-add-num '(1 2 3)))
|
||||
|
||||
(setq testcover-testcase-num 1)
|
||||
(should (equal (testcover-testcase-mapcar-sides) '(2 3 4)))
|
||||
(setq testcover-testcase-num 2)
|
||||
(should (equal (testcover-testcase-mapcar-sides) '(3 4 5)))
|
||||
|
||||
;; ==== function-with-edebug-spec-bug-25316 ====
|
||||
"Functions can have edebug specs too.
|
||||
See c-make-font-lock-search-function for an example in the Emacs
|
||||
sources. The other issue is that it's ok to use quote in an
|
||||
edebug spec, so testcover needs to cope with that."
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-make-function (forms)
|
||||
`(lambda (flag) (if flag 0 ,@forms%%%))%%%)
|
||||
|
||||
(def-edebug-spec testcover-testcase-make-function
|
||||
(("quote" (&rest def-form))))
|
||||
|
||||
(defun testcover-testcase-thing ()
|
||||
(testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%)
|
||||
|
||||
(defun testcover-testcase-use-thing ()
|
||||
(funcall (testcover-testcase-thing)%%% nil)%%%)
|
||||
|
||||
(should (equal (testcover-testcase-use-thing) 15))
|
||||
|
||||
;; ==== backquoted-dotted-alist ====
|
||||
"Testcover can instrument a dotted alist constructed with backquote."
|
||||
;; ====
|
||||
(defun testcover-testcase-make-alist (expr entries)
|
||||
`((0 . ,expr%%%) . ,entries%%%)%%%)
|
||||
|
||||
(should (equal (testcover-testcase-make-alist "foo" '((1 . "bar") (2 . "baz")))
|
||||
'((0 . "foo") (1 . "bar") (2 . "baz"))))
|
||||
|
||||
;; ==== coverage-of-the-unknown-symbol-bug-25471 ====
|
||||
"Testcover correctly records coverage of code which uses `unknown'"
|
||||
:expected-result :failed
|
||||
;; ====
|
||||
(defun testcover-testcase-how-do-i-know-you (name)
|
||||
(let ((val 'unknown))
|
||||
(when (equal name%%% "Bob")%%%
|
||||
(setq val 'known)!!!)
|
||||
val%%%)%%%)
|
||||
|
||||
(should (eq (testcover-testcase-how-do-i-know-you "Liz") 'unknown))
|
||||
|
||||
;; testcases.el ends here.
|
||||
186
test/lisp/emacs-lisp/testcover-tests.el
Normal file
186
test/lisp/emacs-lisp/testcover-tests.el
Normal file
|
|
@ -0,0 +1,186 @@
|
|||
;;; testcover-tests.el --- Testcover test suite -*- lexical-binding:t -*-
|
||||
|
||||
;; Copyright (C) 2017 Free Software Foundation, Inc.
|
||||
|
||||
;; Author: Gemini Lasswell
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
|
||||
;; This program is free software: you can redistribute it and/or
|
||||
;; modify it under the terms of the GNU General Public License as
|
||||
;; published by the Free Software Foundation, either version 3 of the
|
||||
;; License, or (at your option) any later version.
|
||||
;;
|
||||
;; This program is distributed in the hope that it will be useful, but
|
||||
;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;; General Public License for more details.
|
||||
;;
|
||||
;; You should have received a copy of the GNU General Public License
|
||||
;; along with this program. If not, see `http://www.gnu.org/licenses/'.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Testcover test suite.
|
||||
;; * All the test cases are in testcover-resources/testcover-cases.el.
|
||||
;; See that file for an explanation of the test case format.
|
||||
;; * `testcover-tests-define-tests', which is run when this file is
|
||||
;; loaded, reads testcover-resources/testcover-cases.el and defines
|
||||
;; ERT tests for each test case.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'testcover)
|
||||
(require 'skeleton)
|
||||
|
||||
;; Use `eval-and-compile' around all these definitions because they're
|
||||
;; used by the macro `testcover-tests-define-tests'.
|
||||
|
||||
(eval-and-compile
|
||||
(defvar testcover-tests-file-dir
|
||||
(expand-file-name
|
||||
"testcover-resources/"
|
||||
(file-name-directory (or (bound-and-true-p byte-compile-current-file)
|
||||
load-file-name
|
||||
buffer-file-name)))
|
||||
"Directory of the \"testcover-tests.el\" file."))
|
||||
|
||||
(eval-and-compile
|
||||
(defvar testcover-tests-test-cases
|
||||
(expand-file-name "testcases.el" testcover-tests-file-dir)
|
||||
"File containing marked up code to instrument and check."))
|
||||
|
||||
;; Convert Testcover's overlays to plain text.
|
||||
|
||||
(eval-and-compile
|
||||
(defun testcover-tests-markup-region (beg end &rest optargs)
|
||||
"Mark up test code within region between BEG and END.
|
||||
Convert Testcover's tan and red splotches to %%% and !!! for
|
||||
testcases.el. This can be used to create test cases if Testcover
|
||||
is working correctly on a code sample. OPTARGS are optional
|
||||
arguments for `testcover-start'."
|
||||
(interactive "r")
|
||||
(let ((tempfile (make-temp-file "testcover-tests-" nil ".el"))
|
||||
(code (buffer-substring beg end))
|
||||
(marked-up-code))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file tempfile
|
||||
(insert code))
|
||||
(save-current-buffer
|
||||
(let ((buf (find-file-noselect tempfile)))
|
||||
(set-buffer buf)
|
||||
(apply 'testcover-start (cons tempfile optargs))
|
||||
(testcover-mark-all buf)
|
||||
(dolist (overlay (overlays-in (point-min) (point-max)))
|
||||
(let ((ov-face (overlay-get overlay 'face)))
|
||||
(goto-char (overlay-end overlay))
|
||||
(cond
|
||||
((eq ov-face 'testcover-nohits) (insert "!!!"))
|
||||
((eq ov-face 'testcover-1value) (insert "%%%"))
|
||||
(t nil))))
|
||||
(setq marked-up-code (buffer-string)))
|
||||
(set-buffer-modified-p nil)))
|
||||
(ignore-errors (kill-buffer (find-file-noselect tempfile)))
|
||||
(ignore-errors (delete-file tempfile)))
|
||||
|
||||
;; Now replace the original code with the marked up code.
|
||||
(delete-region beg end)
|
||||
(insert marked-up-code))))
|
||||
|
||||
(eval-and-compile
|
||||
(defun testcover-tests-unmarkup-region (beg end)
|
||||
"Remove the markup used in testcases.el between BEG and END."
|
||||
(interactive "r")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(narrow-to-region beg end)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "!!!\\|%%%" nil t)
|
||||
(replace-match ""))))))
|
||||
|
||||
(define-skeleton testcover-tests-skeleton
|
||||
"Write a testcase for testcover-tests.el."
|
||||
"Enter name of test: "
|
||||
";; ==== " str " ====\n"
|
||||
"\"docstring\"\n"
|
||||
";; Directives for ERT should go here, if any.\n"
|
||||
";; ====\n"
|
||||
";; Replace this line with annotated test code.\n")
|
||||
|
||||
;; Check a test case.
|
||||
|
||||
(eval-and-compile
|
||||
(defun testcover-tests-run-test-case (marked-up-code)
|
||||
"Test the operation of Testcover on the string MARKED-UP-CODE."
|
||||
(let ((tempfile (make-temp-file "testcover-tests-" nil ".el")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file tempfile
|
||||
(insert marked-up-code))
|
||||
;; Remove the marks and mark the code up again. The original
|
||||
;; and recreated versions should match.
|
||||
(save-current-buffer
|
||||
(set-buffer (find-file-noselect tempfile))
|
||||
;; Fail the test if the debugger tries to become active,
|
||||
;; which will happen if Testcover's reinstrumentation
|
||||
;; leaves an edebug-enter in the code. This will also
|
||||
;; prevent debugging these tests using Edebug.
|
||||
(cl-letf (((symbol-function #'edebug-enter)
|
||||
(lambda (&rest _args)
|
||||
(ert-fail
|
||||
(concat "Debugger invoked during test run "
|
||||
"(possible edebug-enter not replaced)")))))
|
||||
(dolist (byte-compile '(t nil))
|
||||
(testcover-tests-unmarkup-region (point-min) (point-max))
|
||||
(unwind-protect
|
||||
(testcover-tests-markup-region (point-min) (point-max) byte-compile)
|
||||
(set-buffer-modified-p nil))
|
||||
(should (string= marked-up-code
|
||||
(buffer-string)))))))
|
||||
(ignore-errors (kill-buffer (find-file-noselect tempfile)))
|
||||
(ignore-errors (delete-file tempfile))))))
|
||||
|
||||
;; Convert test case file to ert-defmethod.
|
||||
|
||||
(eval-and-compile
|
||||
(defun testcover-tests-build-test-cases ()
|
||||
"Parse the test case file and return a list of ERT test definitions.
|
||||
Construct and return a list of `ert-deftest' forms. See testcases.el
|
||||
for documentation of the test definition format."
|
||||
(let (results)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents testcover-tests-test-cases)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward
|
||||
(concat "^;; ==== \\([^ ]+?\\) ====\n"
|
||||
"\\(\\(?:.*\n\\)*?\\)"
|
||||
";; ====\n"
|
||||
"\\(\\(?:.*\n\\)*?\\)"
|
||||
"\\(\\'\\|;; ====\\)")
|
||||
nil t)
|
||||
(let ((name (match-string 1))
|
||||
(splice (car (read-from-string
|
||||
(format "(%s)" (match-string 2)))))
|
||||
(code (match-string 3)))
|
||||
(push
|
||||
`(ert-deftest ,(intern (concat "testcover-tests-" name)) ()
|
||||
,@splice
|
||||
(testcover-tests-run-test-case ,code))
|
||||
results))
|
||||
(beginning-of-line)))
|
||||
results)))
|
||||
|
||||
;; Define all the tests.
|
||||
|
||||
(defmacro testcover-tests-define-tests ()
|
||||
"Construct and define ERT test methods using the test case file."
|
||||
(let* ((test-cases (testcover-tests-build-test-cases)))
|
||||
`(progn ,@test-cases)))
|
||||
|
||||
(testcover-tests-define-tests)
|
||||
|
||||
(provide 'testcover-tests)
|
||||
|
||||
;;; testcover-tests.el ends here
|
||||
Loading…
Add table
Add a link
Reference in a new issue