--- /dev/null
+;;;; 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.
--- /dev/null
+;;; 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
projects / emacs.git / commitdiff