From 6ff97dd776b43347cb7b29a500e2da348ff7706a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 20 Sep 2002 07:34:06 +0000 Subject: [PATCH] r2788: *** empty log message *** --- debian/changelog | 6 + debian/cl-tester.doc-base | 10 + debian/control | 14 + debian/copyright | 34 +++ debian/copyright.~1~ | 32 +++ debian/postinst | 52 ++++ debian/prerm | 42 +++ debian/rules | 86 ++++++ debian/tester.asd | 42 +++ tester.cl | 568 ++++++++++++++++++++++++++++++++++++++ tester.html | 355 ++++++++++++++++++++++++ 11 files changed, 1241 insertions(+) create mode 100644 debian/changelog create mode 100644 debian/cl-tester.doc-base create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/copyright.~1~ create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 debian/tester.asd create mode 100644 tester.cl create mode 100644 tester.html diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..7e7276d --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +cl-tester (2.2.12.2.6.1-1) unstable; urgency=low + + * Initial Release (closes: ) + + -- Kevin M. Rosenberg Fri, 20 Sep 2002 01:08:33 -0600 + diff --git a/debian/cl-tester.doc-base b/debian/cl-tester.doc-base new file mode 100644 index 0000000..70c402b --- /dev/null +++ b/debian/cl-tester.doc-base @@ -0,0 +1,10 @@ +Document: cl-tester +Title: CL-Tester Manual +Author: Franz, Inc. +Abstract: This manual describes the + use the Tester Common Lisp library. +Section: programming + +Format: HTML +Index: /usr/share/doc/cl-tester/html/tester.html +Files: /usr/share/doc/cl-tester/html/*.html diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..da54743 --- /dev/null +++ b/debian/control @@ -0,0 +1,14 @@ +Source: cl-tester +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +Build-Depends-Indep: debhelper (>- 4.0.0) +Standards-Version: 3.5.7.0 + +Package: cl-tester +Architecture: all +Depends: ${shlibs:Depends}, common-lisp-controller +Description: Test suite for Common Lisp programs + tester is Franz, Inc. opensource testing suite. It can be used to write testing programs for + Common Lisp progams. + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..9965857 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,34 @@ +This package was debianized by Kevin M. Rosenberg on +Fri, 20 Sep 2002 01:08:33 -0600. + +It was downloaded from http://opensource.franz.com/test/test-dist/tester.cl +Upstream Author(s): Kevin Layer, Franz Inc. + +Changes compared to upstream: + - Added .asd file for use with Common Lisp Controller + - Defined condition SIMPLE-BREAK and BREAK for CMU + - Include if* source in the tester.cl file + +Copyright: + +;; copyright (c) 1985-1986 Franz Inc, Alameda, CA +;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the Franz +;; preamble to the LGPL found in +;; http://opensource.franz.com/preamble.html. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License can be +;; found at http://opensource.franz.com/license.html. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple +;; Place, Suite 330, Boston, MA 02111-1307 USA diff --git a/debian/copyright.~1~ b/debian/copyright.~1~ new file mode 100644 index 0000000..a18fc8e --- /dev/null +++ b/debian/copyright.~1~ @@ -0,0 +1,32 @@ +This package was debianized by Kevin M. Rosenberg on +Fri, 20 Sep 2002 01:08:33 -0600. + +It was downloaded from http://opensource.franz.com/test/test-dist/tester.cl +Upstream Author(s): Kevin Layer, Franz Inc. + +Changes compared to upstream: Added .asd file for use with Common Lisp Controller + + +Copyright: + +;; copyright (c) 1985-1986 Franz Inc, Alameda, CA +;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the Franz +;; preamble to the LGPL found in +;; http://opensource.franz.com/preamble.html. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License can be +;; found at http://opensource.franz.com/license.html. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple +;; Place, Suite 330, Boston, MA 02111-1307 USA diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..62b0cb4 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,52 @@ +#! /bin/sh +# postinst script for cl-tester +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=tester + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + + ;; + + abort-upgrade|abort-remove|abort-deconfigure) + + ;; + + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..5ad05d7 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for cl-tester +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_PKG=tester + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..0bafb8a --- /dev/null +++ b/debian/rules @@ -0,0 +1,86 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := lml +debpkg := cl-lml + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-lml := $(clc-source)/$(pkg) + +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp +configure-stamp: + dh_testdir + # Add here commands to configure the package. + + touch configure-stamp + + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + + # Add here commands to compile the package. + + touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -f debian/cl-lml.postinst.* debian/cl-lml.prerm.* + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/lml. + dh_installdirs $(clc-systems) $(clc-lml) $(doc-dir) + dh_install lml.asd $(shell echo *.cl) $(clc-lml) + dh_install $(shell echo doc/*.html) $(doc-dir) + dh_link $(clc-lml)/lml.asd $(clc-systems)/lml.asd + +# Build architecture-independent files here. +binary-indep: build install + + +# Build architecture-dependent files here. +binary-arch: build install + dh_testdir + dh_testroot +# dh_installdebconf + dh_installdocs + dh_installexamples doc/Makefile doc/make.cl $(shell echo doc/*.lml) +# dh_installmenu +# dh_installlogrotate +# dh_installemacsen +# dh_installpam +# dh_installmime +# dh_installinit +# dh_installcron +# dh_installman +# dh_installinfo +# dh_undocumented + dh_installchangelogs + dh_strip + dh_compress + dh_fixperms +# dh_makeshlibs + dh_installdeb +# dh_perl + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure + diff --git a/debian/tester.asd b/debian/tester.asd new file mode 100644 index 0000000..4766b00 --- /dev/null +++ b/debian/tester.asd @@ -0,0 +1,42 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: tester.asd +;;;; Purpose: ASDF definition file for Tester +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Sep 2002 +;;;; +;;;; $Id: tester.asd,v 1.1 2002/09/20 07:34:06 kevin Exp $ +;;;; +;;;; This file, part of cl-tester, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; cl-tester users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU Lesser General Public License +;;;; (http://www.gnu.org/licenses/lgpl.html) +;;;; ************************************************************************* + +(in-package :asdf) + +(defsystem :tester + :name "cl-tester" + :author "Kevin Layer, Franz, Inc" + :version "2.2.12.2.6.1" + :maintainer "Kevin M. Rosenberg " + :licence "GNU Lesser General Public License" + :description "Franz's Test Harness Package" + :long-description "Tester provides an framework for creating automated testing progams." + + :perform (load-op :after (op tester) + (pushnew :tester cl:*features*)) + + :components + ((:file "tester"))) + +(defmethod source-file-type ((c cl-source-file) (s (eql (find-system 'tester)))) + "cl") + +(when (ignore-errors (find-class 'load-compiled-op)) + (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :tester)))) + (pushnew :tester cl:*features*))) + diff --git a/tester.cl b/tester.cl new file mode 100644 index 0000000..ebdca71 --- /dev/null +++ b/tester.cl @@ -0,0 +1,568 @@ +;; tester.cl +;; A test harness for Allegro CL. +;; +;; copyright (c) 1985-1986 Franz Inc, Alameda, CA +;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved. +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the Franz +;; preamble to the LGPL found in +;; http://opensource.franz.com/preamble.html. +;; +;; This code 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 +;; Lesser General Public License for more details. +;; +;; Version 2.1 of the GNU Lesser General Public License can be +;; found at http://opensource.franz.com/license.html. +;; If it is not present, you can access it from +;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer +;; version) or write to the Free Software Foundation, Inc., 59 Temple +;; Place, Suite 330, Boston, MA 02111-1307 USA +;; +;;;; from the original ACL 6.1 sources: +;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp + +;; $Id: tester.cl,v 1.1 2002/09/20 07:34:06 kevin Exp $ + +(defpackage :util.test + (:use :common-lisp :excl) + (:shadow #:test) + (:export +;;;; Control variables: + #:*break-on-test-failures* + #:*error-protect-tests* + #:*test-errors* + #:*test-successes* + #:*test-unexpected-failures* + +;;;; The test macros: + #:test + #:test-error + #:test-no-error + #:test-warning + #:test-no-warning + + #:with-tests + )) + +(in-package :util.test) + +;; Added by Kevin Rosenberg + +(define-condition simple-break (error simple-condition) ()) + +#+cmu +(unless (find-class 'break nil) + (define-condition break (simple-condition) ())) + +;; the if* macro used in Allegro: +;; +;; This is in the public domain... please feel free to put this definition +;; in your code or distribute it with your version of lisp. + +(defvar if*-keyword-list '("then" "thenret" "else" "elseif")) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) + + +(defvar *break-on-test-failures* nil + "When a test failure occurs, common-lisp:break is called, allowing +interactive debugging of the failure.") + +(defvar *test-errors* 0 + "The value is the number of test errors which have occurred.") +(defvar *test-successes* 0 + "The value is the number of test successes which have occurred.") +(defvar *test-unexpected-failures* 0 + "The value is the number of unexpected test failures which have occurred.") + +(defvar *error-protect-tests* nil + "Protect each test from errors. If an error occurs, then that will be +taken as a test failure unless test-error is being used.") + +(defmacro test-values-errorset (form &optional announce catch-breaks) + ;; internal macro + (let ((g-announce (gensym)) + (g-catch-breaks (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks)) + (handler-case (cons t (multiple-value-list ,form)) + (condition (condition) + (if* (and (null ,g-catch-breaks) + (typep condition 'simple-break)) + then (break condition) + elseif ,g-announce + then (format *error-output* "~&Condition type: ~a~%" + (class-of condition)) + (format *error-output* "~&Message: ~a~%" condition)) + condition))))) + +(defmacro test-values (form &optional announce catch-breaks) + ;; internal macro + (if* *error-protect-tests* + then `(test-values-errorset ,form ,announce ,catch-breaks) + else `(cons t (multiple-value-list ,form)))) + +(defmacro test (expected-value test-form + &key (test #'eql test-given) + (multiple-values nil multiple-values-given) + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + +;;;;;;;;;; internal, undocumented keywords: +;;;; Note about these keywords: if they were documented, we'd have a +;;;; problem, since they break the left-to-right order of evaluation. +;;;; Specifically, errorset breaks it, and I don't see any way around +;;;; that. `errorset' is used by the old test.cl module (eg, +;;;; test-equal-errorset). + errorset + reported-form + (wanted-message nil wanted-message-given) + (got-message nil got-message-given)) + "Perform a single test. `expected-value' is the reference value for the +test. `test-form' is a form that will produce the value to be compared to +the expected-value. If the values are not the same, then an error is +logged, otherwise a success is logged. + +Normally the comparison of values is done with `eql'. The `test' keyword +argument can be used to specify other comparison functions, such as eq, +equal,equalp, string=, string-equal, etc. + +Normally, only the first return value from the test-form is considered, +however if `multiple-values' is t, then all values returned from test-form +are considered. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + `(test-check + :expected-result ,expected-value + :test-results + (,(if errorset 'test-values-errorset 'test-values) ,test-form t) + ,@(when test-given `(:predicate ,test)) + ,@(when multiple-values-given `(:multiple-values ,multiple-values)) + ,@(when fail-info-given `(:fail-info ,fail-info)) + ,@(when known-failure-given `(:known-failure ,known-failure)) + :test-form ',(if reported-form reported-form test-form) + ,@(when wanted-message-given `(:wanted-message ,wanted-message)) + ,@(when got-message-given `(:got-message ,got-message)))) + +(defmethod conditionp ((thing condition)) t) +(defmethod conditionp ((thing t)) nil) + +(defmacro test-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given) + (condition-type ''simple-error) + (include-subtypes nil include-subtypes-given) + (format-control nil format-control-given) + (format-arguments nil format-arguments-given)) + "Test that `form' signals an error. The order of evaluation of the +arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures. + +If `condition-type' is non-nil, it should be a symbol naming a condition +type, which is used to check against the signalled condition type. The +test will fail if they do not match. + +`include-subtypes', used with `condition-type', can be used to match a +condition to an entire subclass of the condition type hierarchy. + +`format-control' and `format-arguments' can be used to check the error +message itself." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-condition-type (gensym)) + (g-include-subtypes (gensym)) + (g-format-control (gensym)) + (g-format-arguments (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-condition-type ,condition-type) + ,@(when include-subtypes-given + `((,g-include-subtypes ,include-subtypes))) + ,@(when format-control-given + `((,g-format-control ,format-control))) + ,@(when format-arguments-given + `((,g-format-arguments ,format-arguments))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results + (test-values (and (conditionp ,g-c) + ,@(if* include-subtypes-given + then `((if* ,g-include-subtypes + then (typep ,g-c ,g-condition-type) + else (eq (class-of ,g-c) + (find-class + ,g-condition-type)))) + else `((eq (class-of ,g-c) + (find-class ,g-condition-type)))) + ,@(when format-control-given + `((or + (null ,g-format-control) + (string= + (concatenate 'simple-string + "~1@<" ,g-format-control "~:@>") + (simple-condition-format-control ,g-c))))) + ,@(when format-arguments-given + `((or + (null ,g-format-arguments) + (equal + ,g-format-arguments + (simple-condition-format-arguments ,g-c)))))) + t) + :test-form ',form + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)) + :condition-type ,g-condition-type + :condition ,g-c + ,@(when include-subtypes-given + `(:include-subtypes ,g-include-subtypes)) + ,@(when format-control-given + `(:format-control ,g-format-control)) + ,@(when format-arguments-given + `(:format-arguments ,g-format-arguments)))))) + +(defmacro test-no-error (form &key announce + catch-breaks + (fail-info nil fail-info-given) + (known-failure nil known-failure-given)) + "Test that `form' does not signal an error. The order of evaluation of +the arguments is keywords first, then test form. + +If `announce' is non-nil, then cause the error message to be printed. + +The `catch-breaks' is non-nil then consider a call to common-lisp:break an +`error'. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-announce (gensym)) + (g-catch-breaks (gensym)) + (g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-c (gensym))) + `(let* ((,g-announce ,announce) + (,g-catch-breaks ,catch-breaks) + ,@(when fail-info-given `((,g-fail-info ,fail-info))) + ,@(when known-failure-given `((,g-known-failure ,known-failure))) + (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks))) + (test-check + :predicate #'eq + :expected-result t + :test-results (test-values (not (conditionp ,g-c))) + :test-form ',form + :condition ,g-c + ,@(when fail-info-given `(:fail-info ,g-fail-info)) + ,@(when known-failure-given `(:known-failure ,g-known-failure)))))) + +(defvar *warn-cookie* (cons nil nil)) + +(defmacro test-warning (form &key fail-info known-failure) + "Test that `form' signals a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then *warn-cookie* + else ;; test produced no warning + nil) + :test #'eq + :reported-form ,form ;; quoted by test macro + :wanted-message "a warning" + :got-message "no warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defmacro test-no-warning (form &key fail-info known-failure) + "Test that `form' does not signal a warning. The order of evaluation of +the arguments is keywords first, then test form. + +`fail-info' allows more information to be printed with a test failure. + +`known-failure' marks the test as a known failure. This allows for +programs that do regression analysis on the output from a test run to +discriminate on new versus known failures." + (let ((g-fail-info (gensym)) + (g-known-failure (gensym)) + (g-value (gensym))) + `(let* ((,g-fail-info ,fail-info) + (,g-known-failure ,known-failure) + (,g-value (test-values-errorset ,form nil t))) + (test + *warn-cookie* + (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning)) + then nil ;; test produced warning + else *warn-cookie*) + :test #'eq + :reported-form ',form + :wanted-message "no warning" + :got-message "a warning" + :fail-info ,g-fail-info + :known-failure ,g-known-failure)))) + +(defvar *announce-test* nil) ;; if true announce each test that was done + +(defun test-check (&key (predicate #'eql) + expected-result test-results test-form + multiple-values fail-info known-failure + wanted-message got-message condition-type condition + include-subtypes format-control format-arguments + &aux fail predicate-failed got wanted) + ;; for debugging large/complex test sets: + (when *announce-test* + (format t "Just did test ~s~%" test-form) + (force-output)) + + ;; this is an internal function + (flet ((check (expected-result result) + (let* ((results + (multiple-value-list + (errorset (funcall predicate expected-result result) t))) + (failed (null (car results)))) + (if* failed + then (setq predicate-failed t) + nil + else (cadr results))))) + (when (conditionp test-results) + (setq condition test-results) + (setq test-results nil)) + (when (null (car test-results)) + (setq fail t)) + (if* (and (not fail) (not multiple-values)) + then ;; should be a single result + ;; expected-result is the single result wanted + (when (not (and (cdr test-results) + (check expected-result (cadr test-results)))) + (setq fail t)) + (when (and (not fail) (cddr test-results)) + (setq fail 'single-got-multiple)) + else ;; multiple results wanted + ;; expected-result is a list of results, each of which + ;; should be checked against the corresponding test-results + ;; using the predicate + (do ((got (cdr test-results) (cdr got)) + (want expected-result (cdr want))) + ((or (null got) (null want)) + (when (not (and (null want) (null got))) + (setq fail t))) + (when (not (check (car got) (car want))) + (return (setq fail t))))) + (if* fail + then (when (not known-failure) + (format *error-output* + "~& * * * UNEXPECTED TEST FAILURE * * *~%") + (incf *test-unexpected-failures*)) + (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%" + known-failure test-form) + (if* (eq 'single-got-multiple fail) + then (format + *error-output* + "~ +Reason: additional value were returned from test form.~%") + elseif predicate-failed + then (format *error-output* "Reason: predicate error.~%") + elseif (null (car test-results)) + then (format *error-output* "~ +Reason: an error~@[ (of type `~s')~] was detected.~%" + (when condition (class-of condition))) + elseif condition + then (if* (not (conditionp condition)) + then (format *error-output* "~ +Reason: expected but did not detect an error of type `~s'.~%" + condition-type) + elseif (null condition-type) + then (format *error-output* "~ +Reason: detected an unexpected error of type `~s': + ~a.~%" + (class-of condition) + condition) + elseif (not (if* include-subtypes + then (typep condition condition-type) + else (eq (class-of condition) + (find-class condition-type)))) + then (format *error-output* "~ +Reason: detected an incorrect condition type.~%") + (format *error-output* + " wanted: ~s~%" condition-type) + (format *error-output* + " got: ~s~%" (class-of condition)) + elseif (and format-control + (not (string= + (setq got + (concatenate 'simple-string + "~1@<" format-control "~:@>")) + (setq wanted + (simple-condition-format-control + condition))))) + then ;; format control doesn't match + (format *error-output* "~ +Reason: the format-control was incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + elseif (and format-arguments + (not (equal + (setq got format-arguments) + (setq wanted + (simple-condition-format-arguments + condition))))) + then (format *error-output* "~ +Reason: the format-arguments were incorrect.~%") + (format *error-output* " wanted: ~s~%" wanted) + (format *error-output* " got: ~s~%" got) + else ;; what else???? + (error "internal-error")) + else (let ((*print-length* 50) + (*print-level* 10)) + (if* wanted-message + then (format *error-output* + " wanted: ~a~%" wanted-message) + else (if* (not multiple-values) + then (format *error-output* + " wanted: ~s~%" + expected-result) + else (format + *error-output* + " wanted values: ~{~s~^, ~}~%" + expected-result))) + (if* got-message + then (format *error-output* + " got: ~a~%" got-message) + else (if* (not multiple-values) + then (format *error-output* " got: ~s~%" + (second test-results)) + else (format + *error-output* + " got values: ~{~s~^, ~}~%" + (cdr test-results)))))) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (incf *test-errors*) + (when *break-on-test-failures* + (break "~a is non-nil." '*break-on-test-failures*)) + else (when known-failure + (format *error-output* + "~&Expected test failure for ~s did not occur.~%" + test-form) + (when fail-info + (format *error-output* "Additional info: ~a~%" fail-info)) + (setq fail t)) + (incf *test-successes*)) + (not fail))) + +(defmacro with-tests ((&key (name "unnamed")) &body body) + (let ((g-name (gensym))) + `(flet ((doit () ,@body)) + (let ((,g-name ,name) + (*test-errors* 0) + (*test-successes* 0) + (*test-unexpected-failures* 0)) + (format *error-output* "Begin ~a test~%" ,g-name) + (if* *break-on-test-failures* + then (doit) + else (handler-case (doit) + (error (c) + (format + *error-output* + "~ +~&Test ~a aborted by signalling an uncaught error:~%~a~%" + ,g-name c)))) + (let ((state (sys:gsgc-switch :print))) + (setf (sys:gsgc-switch :print) nil) + (format t "~&**********************************~%" ,g-name) + (format t "End ~a test~%" ,g-name) + (format t "Errors detected in this test: ~s " *test-errors*) + (unless (zerop *test-unexpected-failures*) + (format t "UNEXPECTED: ~s" *test-unexpected-failures*)) + (format t "~%Successes this test:~s~%" *test-successes*) + (setf (sys:gsgc-switch :print) state)))))) + +(provide :tester #+module-versions 1.1) diff --git a/tester.html b/tester.html new file mode 100644 index 0000000..a6bef7a --- /dev/null +++ b/tester.html @@ -0,0 +1,355 @@ +The Allegro CL Test harness
ToCDocOverviewCGDocRelNotesIndexPermutedIndex
Allegro CL version 6.1
Unrevised

The Allegro CL Test harness

This document contains the following sections:

1.0 The tester module API
   1.1 Test Harness Variables
   1.2 Test Harness Macros
   1.3 Examples

+ANSI Common Lisp contains no functionality designed specifically for +testing applications. Because testing is an essential part of +application development, Franz Inc. is making public the test harness +used internally for testing Allegro CL itself. (A test harness is a +collection of macros and variables associated with testing, along with +templates for test forms.) +

+The test harness facility was added to Allegro CL in release 6.0. (It +was available as a patch for release 5.0.1). +

+To use the test harness, you must load the +tester.fasl module. Do this by evaluating +

+(require :tester)
+

1.0 The tester module API

+ +

+All of the following symbols are exported from the +util.test package. +

+ +

1.1 Test Harness Variables

+ +

+The test harness API includes the following variables, each described +fully on its own page and briefly here. +

+ + + +

1.2 Test Harness Macros

+ +

+These macros wrap around a form to be tested and supply the expected +value (for the test macro) or the expected behavior, which is encoded +in the macro name (e.g. test-error). For example: +

+ +
+(test 1 (+ 0 1))   ;; (testing that the result of (+ 0 1) is
+                   ;; the fixnum 1)
+(test-error (+ 1 "2"))  ;; (testing that an error is
+                                  ;; signaled when a string is 
+                                  ;; passed as an argument to +)
+
+ +

+Many more examples are given below. +

+ +

+with-tests wraps around +a collection of test or test-* +forms. +

+ +

+Note that many of the macros have fail-info and +known-failure keyword arguments. +

+ +
    +
  • fail-info, if non-nil, should be a string that will be printed if the test + fails. Typical strings provide information about what is being tested, such as "This + is bug2075".
    • +
  • known-failure, if non-nil, affects what is printed when the test fails or + succeeds. Thus a failure is reported as "Test failed: known failure: ..." and a + success as "Expected test failure for [...] did not occur."
    • +
+ +

+Each macro is described briefly here and fully on its documentation page. +

+ +
    + +
  • +

    +test +

    +

    Arguments: +expected-value test-form +&key (test #'eql) multiple-values fail-info known-failure +

    +

    +Perform a single test and compare expected-value +with the value actually returned by test-form. +

    +
    • + +
  • +

    +test-error +

    +

    Arguments: +form +&key announce catch-breaks fail-info known-failure (condition-type 'simple-error) include-subtypes format-control format-arguments +

    +

    +Perform a single test to see whether +form signals an error. +

    +
    • + +
  • +

    +test-no-error +

    +

    Arguments: +form +&key announce catch-breaks fail-info known-failure +

    +

    +Perform a single test to see that +form does not signal an error. +

    +
    • + +
  • +

    +test-warning +

    +

    Arguments: +form +&key fail-info known-failure +

    +

    +Perform a single test to see that +form signals a warning. +

    +
    • + +
  • +

    +test-no-warning +

    +

    Arguments: +form +&key fail-info known-failure +

    +

    +Perform a single test to see that +form does not signal a warning. +

    +
    • + +
  • +

    +with-tests +

    +

    Arguments: +(&key (name "unnamed")) + &body body +

    +

    +Evaluates +body, which should be a list of test forms, +and reports on the results. +

    +
    • + +
+ +

1.3 Examples

+ +

+The following are simple examples using the test harness. The test +forms themselves are trivial, and the purpose is to indicate the +behavior of the test harness macros. +

+ + +
+user(1): (require :tester)
+; Fasl loading .../tester.fasl
+t
+user(2): (use-package :util.test)
+t
+user(3): (test 1 1)
+t
+user(4): (test 1 2)
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: 2
+  wanted: 1
+     got: 2
+nil
+user(5): (defun foo (x) x)
+foo
+user(6): (test 1 (foo 1))
+t
+user(7): (test 1 (foo 2))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (foo 2)
+  wanted: 1
+     got: 2
+nil
+user(8): (setq *break-on-test-failures* t)
+t
+user(9): (test 1 (foo 2))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (foo 2)
+  wanted: 1
+     got: 2
+Break: *break-on-test-failures* is non-nil.
+
+Restart actions (select using :continue):
+ 0: return from break.
+ 1: Return to Top Level (an "abort" restart)
+ 2: Abort #<process Initial Lisp Listener>
+[1c] user(10): :pop
+user(11): (setq *break-on-test-failures* nil)
+nil
+user(12): (test 1 (error "foo"))
+Error: foo
+
+Restart actions (select using :continue):
+ 0: Return to Top Level (an "abort" restart)
+ 1: Abort #<process Initial Lisp Listener>
+[1] user(13): :pop
+user(14): (setq *error-protect-tests* t)
+t
+user(15): (test 1 (error "foo"))
+Condition type: simple-error
+Message: foo
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo")
+Reason: an error (of type `simple-error') was detected.
+nil
+user(16): (setq *error-protect-tests* nil)
+nil
+user(17): *test-errors*
+4
+user(18): *test-successes*
+2
+user(19): (test 1 2 :known-failure t)
+Test failed: known failure: 2
+  wanted: 1
+     got: 2
+nil
+user(20): (test 1 (foo 1) :known-failure t)
+Expected test failure for (foo 1) did not occur.
+nil
+user(21): (test 1 (foo 1) :known-failure t :fail-info "This is bug666.")
+Expected test failure for (foo 1) did not occur.
+Additional info: This is bug666.
+nil
+user(22): (test-error (error "foo"))
+t
+user(23): (test-no-error (error "foo"))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo")
+Reason: detected an unexpected error of type `simple-error'.
+nil
+user(24): (test-error (car '(10)))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (car '(10))
+Reason: expected but did not detect an error of type `condition'.
+nil
+user(25): (test-no-error (car '(10)))
+t
+user(26): (test-warning (warn "foo"))
+t
+user(27): (test-no-warning (warn "foo"))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (warn "foo")
+  wanted: no warning
+     got: a warning
+nil
+user(28): (test-warning (car '(10)))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (car '(10))
+  wanted: a warning
+     got: no warning
+nil
+user(29): (test-no-warning (car '(10)))
+t
+user(30): (test-error (error "foo: ~a" 10))
+t
+user(31): (test-error (error "foo: ~a" 10) :format-control "foo: ~a")
+t
+user(32): (test-error (error "foo: ~a" 10) :format-control "foo: ~a"
+	    :format-arguments '(10))
+t
+user(33): (test-error (error "foo: ~a" 10) :format-control "foo:  ~a")
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: the format-control was incorrect.
+  wanted: "~1@<foo: ~a~:@>"
+     got: "~1@<foo:  ~a~:@>"
+nil
+user(34): (test-error (error "foo: ~a" 10) :format-control "foo: ~a"
+	    :format-arguments '(11))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: the format-arguments were incorrect.
+  wanted: (10)
+     got: (11)
+nil
+user(35): (test-error (error "foo: ~a" 10) :condition-type 'condition
+	    :include-subtypes t)
+t
+user(36): (test-error (error "foo: ~a" 10) :condition-type 'simple-break
+	    :include-subtypes t)
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: detected an incorrect condition type.
+  wanted: simple-break
+     got: #<standard-class simple-error>
+nil
+user(37): (test-error (break "foo: ~a" 10) :condition-type 'simple-break
+	    :include-subtypes t)
+Break: foo: 10
+  [condition type: simple-break]
+
+Restart actions (select using :continue):
+ 0: return from break.
+ 1: Return to Top Level (an "abort" restart)
+ 2: Abort #<process Initial Lisp Listener>
+[1c] user(38): :pop
+user(39): (test-error (break "foo: ~a" 10) :catch-breaks t
+		      :condition-type 'simple-break :include-subtypes t)
+t
+
+ +

Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved.
Documentation for Allegro CL version 6.1 update # 1. This page was not revised.
Created 2001.12.15.

ToCDocOverviewCGDocRelNotesIndexPermutedIndex
Allegro CL version 6.1
Unrevised
\ No newline at end of file -- 2.34.1