mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-16 02:50:26 -08:00
bc511a64f6
Most of this change is to boilerplate commentary such as license URLs. This change was prompted by ftp://ftp.gnu.org's going-away party, planned for November. Change these FTP URLs to https://ftp.gnu.org instead. Make similar changes for URLs to other organizations moving away from FTP. Also, change HTTP to HTTPS for URLs to gnu.org and fsf.org when this works, as this will further help defend against man-in-the-middle attacks (for this part I omitted the MS-DOS and MS-Windows sources and the test tarballs to keep the workload down). HTTPS is not fully working to lists.gnu.org so I left those URLs alone for now.
503 lines
16 KiB
EmacsLisp
503 lines
16 KiB
EmacsLisp
;;;; 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 `https://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))
|
|
|
|
;; ==== circular-lists-bug-24402 ====
|
|
"Testcover captures and ignores circular list errors."
|
|
;; ====
|
|
(defun testcover-testcase-cyc1 (a)
|
|
(let ((ls (make-list 10 a%%%)))
|
|
(nconc ls ls)
|
|
ls))
|
|
(testcover-testcase-cyc1 1)
|
|
(testcover-testcase-cyc1 1)
|
|
|
|
;; testcases.el ends here.
|