From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: npostavs@users.sourceforge.net Newsgroups: gmane.emacs.bugs Subject: bug#25497: 26.0.50; [PATCH] Add tests for lisp/emacs-lisp/testcover.el Date: Sat, 28 Jan 2017 12:26:14 -0500 Message-ID: <87lgtvrt8p.fsf@users.sourceforge.net> References: <83o9ys27fl.fsf@gnu.org> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1485624384 15620 195.159.176.226 (28 Jan 2017 17:26:24 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Sat, 28 Jan 2017 17:26:24 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/25.1 (gnu/linux) Cc: 25497@debbugs.gnu.org To: Gemini Lasswell Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Sat Jan 28 18:26:18 2017 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cXWlR-0002kE-GE for geb-bug-gnu-emacs@m.gmane.org; Sat, 28 Jan 2017 18:26:13 +0100 Original-Received: from localhost ([::1]:52647 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cXWlT-0002zM-Ke for geb-bug-gnu-emacs@m.gmane.org; Sat, 28 Jan 2017 12:26:15 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:48998) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cXWlL-0002zG-3J for bug-gnu-emacs@gnu.org; Sat, 28 Jan 2017 12:26:10 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cXWlH-0004wl-Oc for bug-gnu-emacs@gnu.org; Sat, 28 Jan 2017 12:26:07 -0500 Original-Received: from debbugs.gnu.org ([208.118.235.43]:51142) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cXWlH-0004wW-Jz for bug-gnu-emacs@gnu.org; Sat, 28 Jan 2017 12:26:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1cXWlG-0004ll-DX for bug-gnu-emacs@gnu.org; Sat, 28 Jan 2017 12:26:03 -0500 X-Loop: help-debbugs@gnu.org Resent-From: npostavs@users.sourceforge.net Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sat, 28 Jan 2017 17:26:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 25497 X-GNU-PR-Package: emacs X-GNU-PR-Keywords: patch Original-Received: via spool by 25497-submit@debbugs.gnu.org id=B25497.148562431418278 (code B ref 25497); Sat, 28 Jan 2017 17:26:02 +0000 Original-Received: (at 25497) by debbugs.gnu.org; 28 Jan 2017 17:25:14 +0000 Original-Received: from localhost ([127.0.0.1]:49341 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cXWkT-0004kj-Jh for submit@debbugs.gnu.org; Sat, 28 Jan 2017 12:25:14 -0500 Original-Received: from mail-it0-f43.google.com ([209.85.214.43]:38844) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1cXWkR-0004kW-9F for 25497@debbugs.gnu.org; Sat, 28 Jan 2017 12:25:12 -0500 Original-Received: by mail-it0-f43.google.com with SMTP id c7so76595320itd.1 for <25497@debbugs.gnu.org>; Sat, 28 Jan 2017 09:25:11 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=sender:from:to:cc:subject:references:date:in-reply-to:message-id :user-agent:mime-version; bh=gYJHt81QBwt88ywefR9NhztrlAcvAuMG739M2zj5fFg=; b=ntWkzCuGATLyzNSQ/fgttOjH0ah1yIgGVmBdCVblaDvRtuBBHHkZdtySLDKfvb4PvF tIwsa+iQIGwiUvRScam0XVJx09ZWdKJlqT7aqzXkaOl0RLpIRu7nnqAnj2Sn89hdp4YD Q18jsGwScuoEgduB7kfG9o0SLaW3rHBOEmcVX0gVDOaBy5T6RTjuur2Lx9Ik1UVsbOIx D+UuNj6lv6ps0SZzsn61KFPS0dklz0j3mN3qQe7+bk13YAkCxKrpQybbOW3/wLgDC18c jT1Rf0A8TuOpKJGgxUY7YagOgy7SS/JFs+ta/Y2N77uZpwqRT5VkXrMIuXEpVeH2xaRb 5P7g== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:sender:from:to:cc:subject:references:date :in-reply-to:message-id:user-agent:mime-version; bh=gYJHt81QBwt88ywefR9NhztrlAcvAuMG739M2zj5fFg=; b=V20GI8MHfe5xHyR/IpiCJKzVEo9CBaMZBNCCpzi0rfRQzc5YCQKVwJM3zpQ63bEgr2 gXiBHEOE/gjrb+tNCYZx6B0236P7seCkmHAor7MR4pgIk8GRR/KdY5CnaiHR1lLPl8za LZeIR15wlfYGJKYLoyUDl2U9IV/1BlQf0YoiHhjp1EzoJX571DC4C/znJ1Xi3ik0InTz Y+1/bymP+CZ4ZQwsQIvjPrff5JMR7ssQk8i2WwtTy6/tcstRLBnNKD/kgWk46fqHGEa4 6SNUVoPpXNE3o7jaYeQivThyK1WDfoKU2sAnW6vOlksybSlz33AchAwUvNKBwy0rkWPT Si3Q== X-Gm-Message-State: AIkVDXI63yh8XGNVL98ENA3I+XYTOUk3M6cGpjw/Z9t+PCg00GT6w95RbkB3QTWnOkowXA== X-Received: by 10.36.225.13 with SMTP id n13mr8944930ith.57.1485624305753; Sat, 28 Jan 2017 09:25:05 -0800 (PST) Original-Received: from zony ([45.2.7.65]) by smtp.googlemail.com with ESMTPSA id q65sm5291397ioe.16.2017.01.28.09.25.04 (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Sat, 28 Jan 2017 09:25:05 -0800 (PST) In-Reply-To: (Gemini Lasswell's message of "Sat, 28 Jan 2017 07:17:06 -0800") X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane.org@gnu.org Original-Sender: "bug-gnu-emacs" Xref: news.gmane.org gmane.emacs.bugs:128726 Archived-At: --=-=-= Content-Type: text/plain Gemini Lasswell writes: > Eli Zaretskii writes: > >> Thanks. When I run the tests, this doesn't compile for me: > > Sorry I missed that. It doesn't compile for me either, nor does it break > running the tests on my machine although it looks like it's supposed to, > and I was in the habit of just looking at the log file not make's > output. > > Since the way testcover-tests.el builds tests depends on the runtime > environment to find testcases.el, the simplest fix is to add > no-byte-compile to the file local variables which I have done in this > version: > > > > If it's important to be able to run the tests compiled, I could move all > the testcases into strings in testcover-tests.el, but they are easier to > read and edit when in their own file. I suggest instead using eval-and-compile, as in the attached patch. --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=v3-0001-Add-tests-for-lisp-emacs-lisp-testcover.el.patch Content-Description: patch >From b58deef468e6d81c75acf73a7ddaf57514acc9ac Mon Sep 17 00:00:00 2001 From: gazally Date: Fri, 20 Jan 2017 13:58:41 -0800 Subject: [PATCH v3] 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. --- .../emacs-lisp/testcover-resources/testcases.el | 493 +++++++++++++++++++++ test/lisp/emacs-lisp/testcover-tests.el | 186 ++++++++ 2 files changed, 679 insertions(+) create mode 100644 test/lisp/emacs-lisp/testcover-resources/testcases.el create mode 100644 test/lisp/emacs-lisp/testcover-tests.el diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el new file mode 100644 index 0000000..1eb791a --- /dev/null +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -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. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el new file mode 100644 index 0000000..d31379c --- /dev/null +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -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 -- 2.9.3 --=-=-=--