clsql/tests ptester.lisp,NONE,1.1 README,1.1,1.2 package.lisp,1.3,1.4 acl-compat-tester.lisp,1.1,NONE
"Kevin M. Rosenberg" <[email protected]> Sun, 20 Jul 2003 12:31:24 -0600
| Newsgroups | gmane.lisp.clsql.cvs |
|---|---|
| Message-ID | <[email protected]> |
Update of /pubcvs/clsql/tests
In directory boa.b9.com:/tmp/cvs-serv22617/tests
Modified Files:
README package.lisp
Added Files:
ptester.lisp
Removed Files:
acl-compat-tester.lisp
Log Message:
--- NEW FILE: ptester.lisp ---
;; ptester.lisp
;; A test harness based on Franz's tester module
;;
;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2001-2003 Kevin Rosenberg (portability changes)
;;
;; 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: ptester.lisp,v 1.1 2003/07/20 18:31:22 kevin Exp $
(defpackage #:ptester
(:use #:cl)
(: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 #:ptester)
;; 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.
(eval-when (:compile-toplevel :load-toplevel :execute)
(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
(defmacro errorset (form) ;subset of test-values-errorset
`(handler-case
(values-list (cons t (multiple-value-list ,form)))
(error (cond)
(format *error-output* "~&An error occurred: ~a~%" cond)
nil)))
(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))))
(failed (null (car results))))
(if failed
(progn
(setq predicate-failed t)
nil)
(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))))
#+allegro
(let ((state (sys:gsgc-switch :print)))
(setf (sys:gsgc-switch :print) nil)
(format t "~&**********************************~%")
(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))
#-allegro
(progn
(format t "~&**********************************~%")
(format t "End ~a test~%" ,g-name)
(format t "Errors detected in this test: ~D " *test-errors*)
(unless (zerop *test-unexpected-failures*)
(format t "UNEXPECTED: ~D" *test-unexpected-failures*))
(format t "~%Successes this test:~D~%" *test-successes*))))))
(provide :tester #+module-versions 1.1)
Index: README
===================================================================
RCS file: /pubcvs/clsql/tests/README,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** README 2 May 2003 03:05:54 -0000 1.1
--- README 20 Jul 2003 18:31:22 -0000 1.2
***************
*** 1,9 ****
These tests require the setup of a configuration file with account
! information for MySQL and PostgreSQL SQL servers. Additionally,
! the Debian package acl-installer must be installed and a license downloaded
! to use the AODBC tests.
! This test suite looks for a configuration file named ".clsql-test.config"
! located in the users home directory.
This file contains a single a-list that specifies the connection
--- 1,13 ----
These tests require the setup of a configuration file with account
! information for MySQL and PostgreSQL SQL servers. Additionally, the
! Debian package acl-installer must be installed and a license
! downloaded to use the AODBC tests.
! Furthermore, if you are not using the Debian package of CLSQL, these
! tests require the downloading of the rtest and ptester packages from
! http://files.b9.com/.
!
! This test suite looks for a configuration file named
! ".clsql-test.config" located in the users home directory.
This file contains a single a-list that specifies the connection
Index: package.lisp
===================================================================
RCS file: /pubcvs/clsql/tests/package.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** package.lisp 7 May 2003 02:45:08 -0000 1.3
--- package.lisp 20 Jul 2003 18:31:22 -0000 1.4
***************
*** 14,18 ****
(defpackage #:clsql-tests
! (:use #:asdf #:cl #:clsql #:rtest #:util.test))
--- 14,18 ----
(defpackage #:clsql-tests
! (:use #:asdf #:cl #:clsql #:rtest #:ptester))
--- acl-compat-tester.lisp DELETED ---