;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: cmucl-compat.lisp,v 1.3 2002/10/21 07:45:49 kevin Exp $
+;;;; $Id: cmucl-compat.lisp,v 1.4 2003/05/02 03:05:54 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :cl-user)
(defpackage :cmucl-compat
((typep ,vec 'simple-array)
(let ((,new-vec (make-array ,len :element-type
(array-element-type ,vec))))
- (dotimes (i ,len)
- (declare (fixnum i))
- (setf (aref ,new-vec i) (aref ,vec i)))
+ (check-type ,len fixnum)
+ (locally (declare (speed 3) (safety 0) (space 0))
+ (dotimes (i ,len)
+ (declare (fixnum i))
+ (setf (aref ,new-vec i) (aref ,vec i))))
(setq ,vec ,new-vec)))
((typep ,vec 'vector)
(setf (fill-pointer ,vec) ,len)
)))
-
-#-(or cmu sbcl scl)
+#-(or cmu scl)
(defun make-sequence-of-type (type length)
"Returns a sequence of the given TYPE and LENGTH."
- (declare (fixnum length))
- (case type
- (list
- (make-list length))
- ((bit-vector simple-bit-vector)
- (make-array length :element-type '(mod 2)))
- ((string simple-string base-string simple-base-string)
- (make-string length))
- (simple-vector
- (make-array length))
- ((array simple-array vector)
- (if (listp type)
- (make-array length :element-type (cadr type))
- (make-array length)))
- (t
- (make-sequence-of-type (result-type-or-lose type t) length))))
-
+ (make-sequence type length))
#+(or cmu scl)
(if (fboundp 'lisp::make-sequence-of-type)
(defun make-sequence-of-type (type len)
(system::make-sequence-of-type type len)))
-#+sbcl
-(defun make-sequence-of-type (type len)
- (sb-impl::make-sequence-of-type type len))
-
-#-(or cmu sbcl scl)
+#-(or cmu scl)
(defun result-type-or-lose (type nil-ok)
(unless (or type nil-ok)
(error "NIL output type invalid for this sequence function"))
#+(or cmu scl)
(defun result-type-or-lose (type nil-ok)
(lisp::result-type-or-lose type nil-ok))
-
-#+sbcl
-(defun result-type-or-lose (type nil-ok)
- (sb-impl::result-type-or-lose type nil-ok))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: clsql-tests.asd
+;;;; Purpose: ASDF system definitionf for clsql testing package
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2003
+;;;;
+;;;; $Id: clsql-tests.asd,v 1.1 2003/05/02 03:05:54 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:clsql-tests-system
+ (:use #:asdf #:cl))
+(in-package #:clsql-tests-system)
+
+(defsystem clsql-tests
+ :name "clsql-tests"
+ :author "Kevin Rosenberg <kevin@rosenberg.net>"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :licence "Lessor Lisp General Public License"
+ :description "Testing suite for CLSQL"
+
+ :depends-on (:clsql :clsql-mysql :clsql-postgresql :clsql-postgresql-socket
+ #+allegro :clsql-aodbc)
+ :components
+ ((:module tests
+ :components
+ ((:file "rt")
+ (:file "acl-compat-tester")
+ (:file "package" :depends-on ("rt"))
+;; (:file "tables" :depends-on ("package")))
+ (:file "tests" :depends-on ("package" "acl-compat-tester")))
+ )))
+
+(defmethod perform ((o test-op) (c (eql (find-system :clsql-tests))))
+ (or (funcall (intern (symbol-name '#:do-tests)
+ (find-package '#:regression-test)))
+ (error "test-op failed")))
+
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: clsql.asd,v 1.16 2002/11/08 16:51:50 kevin Exp $
+;;;; $Id: clsql.asd,v 1.17 2003/05/02 03:05:54 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
#+(or allegro lispworks cmu sbcl openmcl mcl scl)
(defsystem :clsql
- :name "cl-sql"
- :author "Kevin M. Rosenberg <kmr@debian.org>"
- :version "0.9.2"
+ :name "clsql"
+ :author "Kevin Rosenberg <kevin@rosenberg.net>"
:maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :version "1.5.x"
:licence "Lessor Lisp General Public License"
:description "Common Lisp SQL Interface Library"
:long-description "cl-sql package provides the high-level interface for the CLSQL system."
- :perform (load-op :after (op clsql)
- (pushnew :clsql cl:*features*))
:components
((:module :sql
:components
(:file "usql" :depends-on ("sql")))))
:depends-on (:clsql-base)
)
+
+#+(or allegro lispworks cmu sbcl openmcl mcl scl)
+(defmethod perform ((o test-op) (c (eql (find-system :clsql))))
+ (oos 'load-op 'clsql-tests)
+ (oos 'test-op 'clsql-tests))
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: aodbc-sql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: aodbc-sql.lisp,v 1.2 2003/05/02 03:05:54 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;; interface foreign library loading routines
-(defmethod database-type-library-loaded ((database-type (eql :aodbc)))
+(defmethod clsql-base-sys:database-type-library-loaded ((database-type (eql :aodbc)))
"T if foreign library was able to be loaded successfully. "
(when (find-package :dbi) ;; finds Allegro's DBI (AODBC) package
t))
(setf (car rest) elem))
list))))
-
+#+ignore
(when (clsql-base-sys:database-type-library-loaded :aodbc)
(clsql-base-sys:initialize-database-type :database-type :aodbc))
;;;;
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: postgresql-socket-api.lisp,v 1.3 2003/03/02 20:02:02 kevin Exp $
+;;;; $Id: postgresql-socket-api.lisp,v 1.4 2003/05/02 03:05:54 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
(:float4 700)
(:float8 701)))
-(defmethod database-type-library-loaded ((database-type
+(defmethod clsql-base-sys:database-type-library-loaded ((database-type
(eql :postgresql-socket)))
"T if foreign library was able to be loaded successfully. Always true for
socket interface"
t)
-
+
+(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
+ t)
+
;;; Message I/O stuff
;;;; Original code by Pierre R. Mai
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: postgresql-socket-sql.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
+;;;; $Id: postgresql-socket-sql.lisp,v 1.2 2003/05/02 03:05:54 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;; interface foreign library loading routines
-(defmethod database-type-library-loaded ((database-type (eql :postgresql-socket)))
- t)
-
-(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :postgresql-socket)))
- t)
(clsql-base-sys:database-type-load-foreign :postgresql-socket)
+cl-sql (1.5.0-1) unstable; urgency=low
+
+ * Update SBCL support in cmucl-compat package.
+ * Use debian/compat rather than DH_COMPAT
+ * Add cl-sql-tests binary with test suite
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 1 May 2003 16:23:37 -0600
+
cl-sql (1.4.6-1) unstable; urgency=low
* Documentation fix
--- /dev/null
+tests/README
Package: cl-sql-mysql
Architecture: any
-Depends: cl-sql-base (>= ${Source-Version}), libmysqlclient12, cl-sql-uffi (>= ${Source-Version})
+Depends: cl-sql-base (>= ${Source-Version}), libmysqlclient10, cl-sql-uffi (>= ${Source-Version})
Provides: cl-sql-backend
Description: CLSQL database backend, MySQL
This package enables you to use the CLSQL data access package
Description: CLSQL database backend, PostgreSQL
This package enables you to use the CLSQL data access package
with PostgreSQL databases via a socket interface.
+
+Package: cl-sql-tests
+Architecture: all
+Depends: cl-sql-base, cl-sql-postgresql, cl-sql-postgresql-socket, cl-sql-mysql
+Suggests: acl-installer, libmyodbc, unixodbc,cl-sql-aodbc
+Description: Testing suite for CLSQL
+ This package contains a test suite for CLSQL. It requires manual
+ configuration of MySQL and PostgreSQL databases to execute.
+ A configured, licensed version of AllegroCL with ODBC setup is
+ required to test the clsql-aodbc interface. See the
+ /usr/share/doc/cl-sql-tests/README file if you want to try
+ running these regression tests.
+
#!/usr/bin/make -f
-export DH_COMPAT=4
-
plain-pkg := clsql
pkg := cl-sql
pkg-pg := cl-sql-postgresql
pkg-pg-socket := cl-sql-postgresql-socket
pkg-aodbc := cl-sql-aodbc
-all-pkgs := $(pkg) $(pkg-base) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc)
+pkg-tests := cl-sql-tests
+all-pkgs := $(pkg) $(pkg-base) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc) $(pkg-tests)
UPSTREAM_VER := $(shell sed -n -e "s/${pkg} (\(.*\)-[0-9A-Za-z\.]).*/\1/p" < debian/changelog |head -1)
srcs-pg := $(wildcard db-postgresql/*.lisp)
srcs-pg-socket := $(wildcard db-postgresql-socket/*.lisp)
srcs-aodbc := $(wildcard db-aodbc/*.lisp)
+srcs-tests := $(wildcard tests/*.lisp)
clc-base := usr/share/common-lisp
clc-source := $(clc-base)/source
lispdir-pg-socket := $(clc-pg-socket)/db-postgresql-socket
clc-aodbc := $(clc-source)/clsql-aodbc
lispdir-aodbc := $(clc-aodbc)/db-aodbc
+clc-tests := $(clc-source)/clsql-tests
+lispdir-tests := $(clc-tests)/tests
configure: configure-stamp
configure-stamp:
dh_installdirs -p $(pkg-pg-socket) $(lispdir-pg-socket)
dh_installdirs -p $(pkg-mysql) $(lispdir-mysql) $(sodir-mysql)
dh_installdirs -p $(pkg-aodbc) $(lispdir-aodbc)
+ dh_installdirs -p $(pkg-tests) $(lispdir-tests)
# Main package
dh_install -p $(pkg) $(srcs) $(lispdir-sql)
dh_install -p $(pkg-aodbc) $(srcs-aodbc) $(lispdir-aodbc)
dh_install -p $(pkg-aodbc) clsql-aodbc.asd $(clc-aodbc)
+ dh_install -p $(pkg-tests) $(srcs-tests) $(lispdir-tests)
+ dh_install -p $(pkg-tests) clsql-tests.asd $(clc-tests)
+
# CLC Systems
dh_link -p $(pkg) $(clc-clsql)/clsql.asd $(clc-systems)/clsql.asd
dh_link -p $(pkg-base) $(clc-base)/clsql-base.asd $(clc-systems)/clsql-base.asd
dh_link -p $(pkg-pg) $(clc-pg)/clsql-postgresql.asd $(clc-systems)/clsql-postgresql.asd
dh_link -p $(pkg-pg-socket) $(clc-pg-socket)/clsql-postgresql-socket.asd $(clc-systems)/clsql-postgresql-socket.asd
dh_link -p $(pkg-aodbc) $(clc-aodbc)/clsql-aodbc.asd $(clc-systems)/clsql-aodbc.asd
-
- # Test suite
- dh_installdirs -p $(pkg) $(doc-dir)/html $(doc-dir)/test-suite
- dh_install -p $(pkg) test-suite/tester-clsql.lisp test-suite/acl-compat-tester.lisp $(doc-dir)/test-suite
+ dh_link -p $(pkg-tests) $(clc-tests)/clsql-tests.asd $(clc-systems)/clsql-tests.asd
# Documentation
rm -rf doc/html
+++ /dev/null
-test.config
+++ /dev/null
-;; tester.cl
-;; A test harness for Allegro CL.
-;;
-;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
-;; copyright (c) 1986-2001 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: acl-compat-tester.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $
-
-
-(defpackage :util.test
- (:use :common-lisp)
- (: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)
-
-#+cmu
-(unless (find-class 'break nil)
- (define-condition break (simple-condition) ()))
-
-(define-condition simple-break (error 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 &optional announce catch-breaks)
- ;; Evaluate FORM, and if there are no errors and FORM returns
- ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
- ;; error occurs while evaluating FORM, then return nil immediately.
- ;; If ANNOUNCE is t, then the error message will be printed out.
- (if catch-breaks
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignore-if-unused condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- nil)
- (simple-break (condition)
- (declare (ignore-if-unused condition))
- ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
-)
- nil))
- `(handler-case (values-list (cons t (multiple-value-list ,form)))
- (error (condition)
- (declare (ignore-if-unused condition))
- ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
- 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) 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))))
- #+allegro
- (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))
- #-allegro
- (progn
- (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*))
- ))))
-
-(provide :tester #+module-versions 1.1)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: test-clsql.cl
-;;;; Purpose: Basic test of CLSQL
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: interactive-test.lisp,v 1.1 2002/09/30 10:19:24 kevin Exp $
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-
-(defvar *config-pathname* (make-pathname :name "test"
- :type "config"
- :defaults *load-truename*))
-(defparameter *config* nil)
-
-(defun do-test (&optional (interactive nil))
- (if interactive
- (test-interactive)
- (if (probe-file *config-pathname*)
- (with-open-file (stream *config-pathname* :direction :input)
- (setq *config* (read stream))
- (test-automated *config*))
- (test-interactive))))
-
-(defun test-interactive ()
- (do ((done nil))
- (done)
- (multiple-value-bind (spec type) (get-spec-and-type)
- (if spec
- (clsql-test-table spec type)
- (setq done t)))))
-
-(defun test-automated (config)
- (dolist (elem config)
- (let ((type (car elem))
- (spec (cadr elem)))
- #-allegro
- (unless (eq type :aodbc)
- (clsql-test-table spec type))
- #+allegro
- (clsql-test-table spec type)))
- )
-
-
-(defun create-test-table (db)
- (ignore-errors
- (clsql:execute-command
- "DROP TABLE test_clsql" :database db))
- (clsql:execute-command
- "CREATE TABLE test_clsql (n integer, n_pi float, n_pi_str CHAR(20))"
- :database db)
- (dotimes (i 11)
- (let ((n (- i 5)))
- (clsql:execute-command
- (format nil "INSERT INTO test_clsql VALUES (~a,~a,'~a')"
- n (clsql:float-to-sql-string (* pi n))
- (clsql:float-to-sql-string (* pi n)))
- :database db))))
-
-(defun drop-test-table (db)
- (clsql:execute-command "DROP TABLE test_clsql"))
-
-(defun clsql-test-table (spec type)
- (when (eq type :mysql)
- (test-clsql-mysql spec))
- (let ((db (clsql:connect spec :database-type type :if-exists :new)))
- (unwind-protect
- (progn
- (create-test-table db)
- (pprint (clsql:query "select * from test_clsql"
- :database db
- :types :auto))
- (pprint (clsql:map-query 'vector #'list "select * from test_clsql"
- :database db
- :types :auto)) ;;'(:int :double t)))
- (drop-test-table db))
- (clsql:disconnect :database db)))
- )
-
-(defun test-clsql-mysql (spec)
- (let ((db (clsql-mysql::database-connect spec :mysql)))
- (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
- (clsql-mysql::database-execute-command
- "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
- (dotimes (i 10)
- (clsql-mysql::database-execute-command
- (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
- i (sqrt i) (format nil "~d" (sqrt i)))
- db))
- (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
- (format t "~&Number rows: ~D~%" (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res)))
- (clsql-mysql::database-dump-result-set res db))
- (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
- (clsql-mysql::database-disconnect db)))
-
-
-(defun get-spec-and-type ()
- (format t "~&Test CLSQL")
- (format t "~&==========~%")
- (format t "~&Enter connection type (:mysql :postgresql :postgresql-socket")
- #+allegro (format t " :aodbc")
- (format t ") [default END]: ")
- (let ((type-string (read-line)))
- (if (zerop (length type-string))
- (values nil nil)
- (get-spec-for-type (read-from-string type-string)))))
-
-(defun get-spec-for-type (type)
- (let ((spec (get-spec-using-format type
- (ecase type
- ((:mysql :postgresql :postgresql-socket)
- '("host" "database" "user" "password"))
- (:aodbc
- '("dsn" "user" "password"))))))
- (values spec type)))
-
-
-(defun get-spec-using-format (type spec-format)
- (let (spec)
- (format t "~&Connection Spec for ~A" (symbol-name type))
- (format t "~&------------------------------")
-
- (dolist (elem spec-format)
- (format t "~&Enter ~A: " elem)
- (push (read-line) spec))
- (nreverse spec)))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: xptest-clsql.cl
-;;;; Purpose: Test of CLSQL using XPTest package
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: xptest-clsql.lisp,v 1.1 2002/09/30 10:19:24 kevin Exp $
-;;;;
-;;;; The XPTest package can be downloaded from
-;;;; http://alpha.onshored.com/lisp-software/
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-
-;;; This test suite looks for a configuration file named "test.config"
-;;; This file contains a single a-list that specifies the connection
-;;; specs for each database type to be tested. For example, to test all
-;;; platforms, a sample "test.config" may look like:
-;;;
-;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
-;;; (:aodbc ("my-dsn" "a-user" "pass"))
-;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell"))
-;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-(mk:load-system "XPTest")
-
-(in-package :clsql-user)
-(use-package :xptest)
-
-(def-test-fixture clsql-fixture ()
- ((aodbc-spec :accessor aodbc-spec)
- (mysql-spec :accessor mysql-spec)
- (pgsql-spec :accessor pgsql-spec)
- (pgsql-socket-spec :accessor pgsql-socket-spec))
- (:documentation "Test fixture for CLSQL testing"))
-
-(defvar *config-pathname* (make-pathname :name "test"
- :type "config"
- :defaults *load-truename*))
-(defmethod setup ((fix clsql-fixture))
- (if (probe-file *config-pathname*)
- (let (config)
- (with-open-file (stream *config-pathname* :direction :input)
- (setq config (read stream)))
- (setf (aodbc-spec fix) (cadr (assoc :aodbc config)))
- (setf (mysql-spec fix) (cadr (assoc :mysql config)))
- (setf (pgsql-spec fix) (cadr (assoc :postgresql config)))
- (setf (pgsql-socket-spec fix)
- (cadr (assoc :postgresql-socket config))))
- (error "XPTest Config file ~S not found" *config-pathname*)))
-
-(defmethod teardown ((fix clsql-fixture))
- t)
-
-(defmethod mysql-table-test ((test clsql-fixture))
- (test-table (mysql-spec test) :mysql))
-
-(defmethod aodbc-table-test ((test clsql-fixture))
- (test-table (aodbc-spec test) :aodbc))
-
-(defmethod pgsql-table-test ((test clsql-fixture))
- (test-table (pgsql-spec test) :postgresql))
-
-(defmethod pgsql-socket-table-test ((test clsql-fixture))
- (test-table (pgsql-socket-spec test) :postgresql-socket))
-
-
-(defmethod test-table (spec type)
- (when spec
- (let ((db (clsql:connect spec :database-type type :if-exists :new)))
- (unwind-protect
- (progn
- (create-test-table db)
- (dolist (row (query "select * from test_clsql" :database db :types :auto))
- (test-table-row row :auto))
- (dolist (row (query "select * from test_clsql" :database db :types nil))
- (test-table-row row nil))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :types :auto)
- do (test-table-row row :auto))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :types nil)
- do (test-table-row row nil))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :types nil)
- do (test-table-row row nil))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :types :auto)
- do (test-table-row row :auto))
- (when (map-query nil #'list "select * from test_clsql"
- :database db :types :auto)
- (failure "Expected NIL result from map-query nil"))
- (do-query ((int float bigint str) "select * from test_clsql")
- (test-table-row (list int float bigint str) nil))
- (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
- (test-table-row (list int float bigint str) :auto))
- (drop-test-table db)
- )
- (disconnect :database db)))))
-
-
-(defmethod mysql-low-level ((test clsql-fixture))
- (let ((spec (mysql-spec test)))
- (when spec
- (let ((db (clsql-mysql::database-connect spec :mysql)))
- (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
- (clsql-mysql::database-execute-command
- "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
- (dotimes (i 10)
- (clsql-mysql::database-execute-command
- (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
- i (number-to-sql-string (sqrt i))
- (number-to-sql-string (sqrt i)))
- db))
- (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
- (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res)))
- (failure "Error calling mysql-num-rows"))
- (clsql-mysql::database-dump-result-set res db))
- (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
- (clsql-mysql::database-disconnect db)))))
-
-(defparameter clsql-test-suite
- (make-test-suite
- "CLSQL Test Suite"
- "Basic test suite for database operations."
- ("MySQL Low Level Interface" 'clsql-fixture
- :test-thunk 'mysql-low-level
- :description "A test of MySQL low-level interface")
- ("MySQL Table" 'clsql-fixture
- :test-thunk 'mysql-table-test
- :description "A test of MySQL")
- ("PostgreSQL Table" 'clsql-fixture
- :test-thunk 'pgsql-table-test
- :description "A test of PostgreSQL tables")
- ("PostgreSQL Socket Table" 'clsql-fixture
- :test-thunk 'pgsql-socket-table-test
- :description "A test of PostgreSQL Socket tables")
- ))
-
-#+allegro
-(add-test (make-test-case "AODBC table test" 'clsql-fixture
- :test-thunk 'aodbc-table-test
- :description "Test AODBC table")
- clsql-test-suite)
-
-;;;; Testing functions
-
-(defun transform-float-1 (i)
- (* i (abs (/ i 2)) (expt 10 (* 2 i))))
-
-(defun transform-bigint-1 (i)
- (* i (expt 10 (* 3 (abs i)))))
-
-(defun create-test-table (db)
- (ignore-errors
- (clsql:execute-command
- "DROP TABLE test_clsql" :database db))
- (clsql:execute-command
- "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))"
- :database db)
- (dotimes (i 11)
- (let* ((test-int (- i 5))
- (test-flt (transform-float-1 test-int)))
- (clsql:execute-command
- (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
- test-int
- (number-to-sql-string test-flt)
- (transform-bigint-1 test-int)
- (number-to-sql-string test-flt)
- )
- :database db))))
-
-(defun parse-double (num-str)
- (let ((*read-default-float-format* 'double-float))
- (coerce (read-from-string num-str) 'double-float)))
-
-(defun test-table-row (row types)
- (unless (and (listp row)
- (= 4 (length row)))
- (failure "Row ~S is incorrect format" row))
- (destructuring-bind (int float bigint str) row
- (cond
- ((eq types :auto)
- (unless (and (integerp int)
- (typep float 'double-float)
- (integerp bigint)
- (stringp str))
- (failure "Incorrect field type for row ~S" row)))
- ((null types)
- (unless (and (stringp int)
- (stringp float)
- (stringp bigint)
- (stringp str))
- (failure "Incorrect field type for row ~S" row))
- (setq int (parse-integer int))
- (setq bigint (parse-integer bigint))
- (setq float (parse-double float)))
- ((listp types)
- (error "NYI")
- )
- (t
- (failure "Invalid types field (~S) passed to test-table-row" types)))
- (unless (= float (transform-float-1 int))
- (failure "Wrong float value ~A for int ~A (row ~S)" float int row))
- (unless (= float (parse-double str))
- (failure "Wrong string value ~A" str))))
-
-
-(defun drop-test-table (db)
- (clsql:execute-command "DROP TABLE test_clsql"))
-
-(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t)
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: tester-clsql.cl
-;;;; Purpose: Automated test of CLSQL using ACL's tester
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Mar 2002
-;;;;
-;;;; $Id: tester-clsql.lisp,v 1.2 2002/10/16 11:51:04 kevin Exp $
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-;;; This test suite looks for a configuration file named "test.config"
-;;; This file contains a single a-list that specifies the connection
-;;; specs for each database type to be tested. For example, to test all
-;;; platforms, a sample "test.config" may look like:
-;;;
-;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
-;;; (:aodbc ("my-dsn" "a-user" "pass"))
-;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell"))
-;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
-
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(unless (find-package :util.test)
- (load (make-pathname :name "acl-compat-tester" :defaults *load-truename*)))
-
-(in-package :clsql-user)
-(use-package :util.test)
-
-(defvar *config-pathname* (make-pathname :name "test"
- :type "config"
- :defaults *load-truename*))
-
-(defclass conn-specs ()
- ((aodbc-spec :accessor aodbc-spec)
- (mysql-spec :accessor mysql-spec)
- (pgsql-spec :accessor pgsql-spec)
- (pgsql-socket-spec :accessor pgsql-socket-spec))
- (:documentation "Test fixture for CLSQL testing"))
-
-
-(defun read-specs (&optional (path *config-pathname*))
- (if (probe-file path)
- (with-open-file (stream path :direction :input)
- (let ((config (read stream))
- (specs (make-instance 'conn-specs)))
- (setf (aodbc-spec specs) (cadr (assoc :aodbc config)))
- (setf (mysql-spec specs) (cadr (assoc :mysql config)))
- (setf (pgsql-spec specs) (cadr (assoc :postgresql config)))
- (setf (pgsql-socket-spec specs)
- (cadr (assoc :postgresql-socket config)))
- specs))
- (error "CLSQL tester config file ~S not found" path)))
-
-(defmethod mysql-table-test ((test conn-specs))
- (test-table (mysql-spec test) :mysql))
-
-(defmethod aodbc-table-test ((test conn-specs))
- (test-table (aodbc-spec test) :aodbc))
-
-(defmethod pgsql-table-test ((test conn-specs))
- (test-table (pgsql-spec test) :postgresql))
-
-(defmethod pgsql-socket-table-test ((test conn-specs))
- (test-table (pgsql-socket-spec test) :postgresql-socket))
-
-(defmethod test-table (spec type)
- (when spec
- (let ((db (clsql:connect spec :database-type type :if-exists :new)))
- (unwind-protect
- (progn
- (create-test-table db)
- (dolist (row (query "select * from test_clsql" :database db :types :auto))
- (test-table-row row :auto type))
- (dolist (row (query "select * from test_clsql" :database db :types nil))
- (test-table-row row nil type))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :types :auto)
- do (test-table-row row :auto type))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :types nil)
- do (test-table-row row nil type))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :types nil)
- do (test-table-row row nil type))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :types :auto)
- do (test-table-row row :auto type))
- (test (map-query nil #'list "select * from test_clsql"
- :database db :types :auto)
- nil
- :fail-info "Expected NIL result from map-query nil")
- (do-query ((int float bigint str) "select * from test_clsql")
- (test-table-row (list int float bigint str) nil type))
- (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
- (test-table-row (list int float bigint str) :auto type))
- (drop-test-table db)
- )
- (disconnect :database db)))))
-
-
-(defmethod mysql-low-level ((test conn-specs))
- (let ((spec (mysql-spec test)))
- (when spec
- (let ((db (clsql-mysql::database-connect spec :mysql)))
- (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
- (clsql-mysql::database-execute-command
- "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
- (dotimes (i 10)
- (clsql-mysql::database-execute-command
- (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
- i (clsql:number-to-sql-string (sqrt i))
- (clsql:number-to-sql-string (sqrt i)))
- db))
- (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
- (test (mysql:mysql-num-rows
- (clsql-mysql::mysql-result-set-res-ptr res))
- 10
- :test #'eql
- :fail-info "Error calling mysql-num-rows")
- (clsql-mysql::database-dump-result-set res db))
- (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
- (clsql-mysql::database-disconnect db)))))
-
-
-
-;;;; Testing functions
-
-(defun transform-float-1 (i)
- (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float))
-
-(defun transform-bigint-1 (i)
- (* i (expt 10 (* 3 (abs i)))))
-
-(defun create-test-table (db)
- (ignore-errors
- (clsql:execute-command
- "DROP TABLE test_clsql" :database db))
- (clsql:execute-command
- "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))"
- :database db)
- (dotimes (i 11)
- (let* ((test-int (- i 5))
- (test-flt (transform-float-1 test-int)))
- (clsql:execute-command
- (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
- test-int
- (number-to-sql-string test-flt)
- (transform-bigint-1 test-int)
- (number-to-sql-string test-flt)
- )
- :database db))))
-
-(defun parse-double (num-str)
- (let ((*read-default-float-format* 'double-float))
- (coerce (read-from-string num-str) 'double-float)))
-
-(defun test-table-row (row types db-type)
- (test (and (listp row)
- (= 4 (length row)))
- t
- :fail-info
- (format nil "Row ~S is incorrect format" row))
- (destructuring-bind (int float bigint str) row
- (cond
- ((eq types :auto)
- (test (and (integerp int)
- (typep float 'double-float)
- (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions
- (integerp bigint))
- (stringp str))
- t
- :fail-info
- (format nil "Incorrect field type for row ~S (types :auto)" row)))
- ((null types)
- (test (and (stringp int)
- (stringp float)
- (stringp bigint)
- (stringp str))
- t
- :fail-info
- (format nil "Incorrect field type for row ~S (types nil)" row))
- (setq int (parse-integer int))
- (setq bigint (parse-integer bigint))
- (setq float (parse-double float)))
- ((listp types)
- (error "NYI")
- )
- (t
- (test t nil
- :fail-info
- (format nil "Invalid types field (~S) passed to test-table-row" types))))
- (test (transform-float-1 int)
- float
- :test #'eql
- :fail-info
- (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))
- (test float
- (parse-double str)
- :test #'double-float-equal
- :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S"
- str float row))))
-
-
-(defun double-float-equal (a b)
- (if (zerop a)
- (if (zerop b)
- t
- nil)
- (let ((diff (abs (/ (- a b) a))))
- (if (> diff (* 10 double-float-epsilon))
- nil
- t))))
-
-(defun drop-test-table (db)
- (clsql:execute-command "DROP TABLE test_clsql" :database db))
-
-(defun do-test ()
- (let ((specs (read-specs)))
- (with-tests (:name "CLSQL")
- (mysql-low-level specs)
- (mysql-table-test specs)
- (pgsql-table-test specs)
- (pgsql-socket-table-test specs)
- (aodbc-table-test specs)
- )))
-
-
-(do-test)
--- /dev/null
+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
+ specs for each database type to be tested. For example, to test all
+platforms, a sample file might look like this:
+
+((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
+ (:aodbc ("my-dsn" "a-user" "pass"))
+ (:postgresql ("localhost" "another-db" "user2" "dont-tell"))
+ (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
--- /dev/null
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2001 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: acl-compat-tester.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $
+
+
+(defpackage :util.test
+ (:use :common-lisp)
+ (: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)
+
+#+cmu
+(unless (find-class 'break nil)
+ (define-condition break (simple-condition) ()))
+
+(define-condition simple-break (error 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 &optional announce catch-breaks)
+ ;; Evaluate FORM, and if there are no errors and FORM returns
+ ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn. If an
+ ;; error occurs while evaluating FORM, then return nil immediately.
+ ;; If ANNOUNCE is t, then the error message will be printed out.
+ (if catch-breaks
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ nil)
+ (simple-break (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
+)
+ nil))
+ `(handler-case (values-list (cons t (multiple-value-list ,form)))
+ (error (condition)
+ (declare (ignorable condition))
+ ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
+ 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) 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))))
+ #+allegro
+ (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))
+ #-allegro
+ (progn
+ (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*))
+ ))))
+
+(provide :tester #+module-versions 1.1)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: xptest-clsql.cl
+;;;; Purpose: Test of CLSQL using XPTest package
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: xptest-clsql.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $
+;;;;
+;;;; The XPTest package can be downloaded from
+;;;; http://alpha.onshored.com/lisp-software/
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+
+;;; This test suite looks for a configuration file named "test.config"
+;;; This file contains a single a-list that specifies the connection
+;;; specs for each database type to be tested. For example, to test all
+;;; platforms, a sample "test.config" may look like:
+;;;
+;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
+;;; (:aodbc ("my-dsn" "a-user" "pass"))
+;;; (:paostgresql ("localhost" "another-db" "user2" "dont-tell"))
+;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+(mk:load-system "XPTest")
+
+(in-package :clsql-user)
+(use-package :xptest)
+
+(def-test-fixture clsql-fixture ()
+ ((aodbc-spec :accessor aodbc-spec)
+ (mysql-spec :accessor mysql-spec)
+ (pgsql-spec :accessor pgsql-spec)
+ (pgsql-socket-spec :accessor pgsql-socket-spec))
+ (:documentation "Test fixture for CLSQL testing"))
+
+(defvar *config-pathname* (make-pathname :name "test"
+ :type "config"
+ :defaults *load-truename*))
+(defmethod setup ((fix clsql-fixture))
+ (if (probe-file *config-pathname*)
+ (let (config)
+ (with-open-file (stream *config-pathname* :direction :input)
+ (setq config (read stream)))
+ (setf (aodbc-spec fix) (cadr (assoc :aodbc config)))
+ (setf (mysql-spec fix) (cadr (assoc :mysql config)))
+ (setf (pgsql-spec fix) (cadr (assoc :postgresql config)))
+ (setf (pgsql-socket-spec fix)
+ (cadr (assoc :postgresql-socket config))))
+ (error "XPTest Config file ~S not found" *config-pathname*)))
+
+(defmethod teardown ((fix clsql-fixture))
+ t)
+
+(defmethod mysql-table-test ((test clsql-fixture))
+ (test-table (mysql-spec test) :mysql))
+
+(defmethod aodbc-table-test ((test clsql-fixture))
+ (test-table (aodbc-spec test) :aodbc))
+
+(defmethod pgsql-table-test ((test clsql-fixture))
+ (test-table (pgsql-spec test) :postgresql))
+
+(defmethod pgsql-socket-table-test ((test clsql-fixture))
+ (test-table (pgsql-socket-spec test) :postgresql-socket))
+
+
+(defmethod test-table (spec type)
+ (when spec
+ (let ((db (clsql:connect spec :database-type type :if-exists :new)))
+ (unwind-protect
+ (progn
+ (create-test-table db)
+ (dolist (row (query "select * from test_clsql" :database db :types :auto))
+ (test-table-row row :auto))
+ (dolist (row (query "select * from test_clsql" :database db :types nil))
+ (test-table-row row nil))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto))
+ (when (map-query nil #'list "select * from test_clsql"
+ :database db :types :auto)
+ (failure "Expected NIL result from map-query nil"))
+ (do-query ((int float bigint str) "select * from test_clsql")
+ (test-table-row (list int float bigint str) nil))
+ (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
+ (test-table-row (list int float bigint str) :auto))
+ (drop-test-table db)
+ )
+ (disconnect :database db)))))
+
+
+(defmethod mysql-low-level ((test clsql-fixture))
+ (let ((spec (mysql-spec test)))
+ (when spec
+ (let ((db (clsql-mysql::database-connect spec :mysql)))
+ (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
+ (clsql-mysql::database-execute-command
+ "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
+ (dotimes (i 10)
+ (clsql-mysql::database-execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
+ i (number-to-sql-string (sqrt i))
+ (number-to-sql-string (sqrt i)))
+ db))
+ (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
+ (unless (= 10 (mysql:mysql-num-rows (clsql-mysql::mysql-result-set-res-ptr res)))
+ (failure "Error calling mysql-num-rows"))
+ (clsql-mysql::database-dump-result-set res db))
+ (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
+ (clsql-mysql::database-disconnect db)))))
+
+(defparameter clsql-test-suite
+ (make-test-suite
+ "CLSQL Test Suite"
+ "Basic test suite for database operations."
+ ("MySQL Low Level Interface" 'clsql-fixture
+ :test-thunk 'mysql-low-level
+ :description "A test of MySQL low-level interface")
+ ("MySQL Table" 'clsql-fixture
+ :test-thunk 'mysql-table-test
+ :description "A test of MySQL")
+ ("PostgreSQL Table" 'clsql-fixture
+ :test-thunk 'pgsql-table-test
+ :description "A test of PostgreSQL tables")
+ ("PostgreSQL Socket Table" 'clsql-fixture
+ :test-thunk 'pgsql-socket-table-test
+ :description "A test of PostgreSQL Socket tables")
+ ))
+
+#+allegro
+(add-test (make-test-case "AODBC table test" 'clsql-fixture
+ :test-thunk 'aodbc-table-test
+ :description "Test AODBC table")
+ clsql-test-suite)
+
+;;;; Testing functions
+
+(defun transform-float-1 (i)
+ (* i (abs (/ i 2)) (expt 10 (* 2 i))))
+
+(defun transform-bigint-1 (i)
+ (* i (expt 10 (* 3 (abs i)))))
+
+(defun create-test-table (db)
+ (ignore-errors
+ (clsql:execute-command
+ "DROP TABLE test_clsql" :database db))
+ (clsql:execute-command
+ "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))"
+ :database db)
+ (dotimes (i 11)
+ (let* ((test-int (- i 5))
+ (test-flt (transform-float-1 test-int)))
+ (clsql:execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
+ test-int
+ (number-to-sql-string test-flt)
+ (transform-bigint-1 test-int)
+ (number-to-sql-string test-flt)
+ )
+ :database db))))
+
+(defun parse-double (num-str)
+ (let ((*read-default-float-format* 'double-float))
+ (coerce (read-from-string num-str) 'double-float)))
+
+(defun test-table-row (row types)
+ (unless (and (listp row)
+ (= 4 (length row)))
+ (failure "Row ~S is incorrect format" row))
+ (destructuring-bind (int float bigint str) row
+ (cond
+ ((eq types :auto)
+ (unless (and (integerp int)
+ (typep float 'double-float)
+ (integerp bigint)
+ (stringp str))
+ (failure "Incorrect field type for row ~S" row)))
+ ((null types)
+ (unless (and (stringp int)
+ (stringp float)
+ (stringp bigint)
+ (stringp str))
+ (failure "Incorrect field type for row ~S" row))
+ (setq int (parse-integer int))
+ (setq bigint (parse-integer bigint))
+ (setq float (parse-double float)))
+ ((listp types)
+ (error "NYI")
+ )
+ (t
+ (failure "Invalid types field (~S) passed to test-table-row" types)))
+ (unless (= float (transform-float-1 int))
+ (failure "Wrong float value ~A for int ~A (row ~S)" float int row))
+ (unless (= float (parse-double str))
+ (failure "Wrong string value ~A" str))))
+
+
+(defun drop-test-table (db)
+ (clsql:execute-command "DROP TABLE test_clsql"))
+
+(report-result (run-test clsql-test-suite :handle-errors nil) :verbose t)
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.lisp
+;;;; Purpose: Package file clsql testing suite
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2003
+;;;;
+;;;; $Id: package.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:clsql-tests
+ (:use #:asdf #:cl #:clsql #:rtest #:util.test))
+
+(in-package #:clsql-tests)
+
+(setf *catch-errors* nil)
+
+(rem-all-tests)
--- /dev/null
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+(defpackage #:regression-test
+ (:nicknames #:rtest #-lispworks #:rt)
+ (:use #:cl)
+ (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+ #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+ #:rem-all-tests #:rem-test)
+ (:documentation "The MIT regression tester with pfdietz's modifications"))
+
+(in-package :regression-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+ "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+ "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters."
+ (cond
+ ((eq x y) t)
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (aref x) (aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (null pending))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: tables.cl
+;;;; Purpose: Table creation tests in CLSQL
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: tables.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+;;; 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
+;;; specs for each database type to be tested. For example, to test all
+;;; platforms, a sample "test.config" may look like:
+;;;
+;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
+;;; (:aodbc ("my-dsn" "a-user" "pass"))
+;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell"))
+;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
+
+(in-package :clsql-tests)
+
+(defvar *config-pathname*
+ (make-pathname :default (user-homedir-pathname)
+ :name ".clsql-test"
+ :type ".config"))
+
+(defclass conn-specs ()
+ ((aodbc-spec :accessor aodbc-spec)
+ (mysql-spec :accessor mysql-spec)
+ (pgsql-spec :accessor pgsql-spec)
+ (pgsql-socket-spec :accessor pgsql-socket-spec))
+ (:documentation "Test fixture for CLSQL testing"))
+
+
+(defun read-specs (&optional (path *config-pathname*))
+ (if (probe-file path)
+ (with-open-file (stream path :direction :input)
+ (let ((config (read stream))
+ (specs (make-instance 'conn-specs)))
+ (setf (aodbc-spec specs) (cadr (assoc :aodbc config)))
+ (setf (mysql-spec specs) (cadr (assoc :mysql config)))
+ (setf (pgsql-spec specs) (cadr (assoc :postgresql config)))
+ (setf (pgsql-socket-spec specs)
+ (cadr (assoc :postgresql-socket config)))
+ specs))
+ (error "CLSQL tester config file ~S not found" path)))
+
+(defvar *conn-specs* (read-specs))
+
+(defmethod mysql-table-test ((test conn-specs))
+ (test-table (mysql-spec test) :mysql))
+
+(defmethod aodbc-table-test ((test conn-specs))
+ (test-table (aodbc-spec test) :aodbc))
+
+(defmethod pgsql-table-test ((test conn-specs))
+ (test-table (pgsql-spec test) :postgresql))
+
+(defmethod pgsql-socket-table-test ((test conn-specs))
+ (test-table (pgsql-socket-spec test) :postgresql-socket))
+
+(defmethod test-table (spec type)
+ (when spec
+ (let ((db (clsql:connect spec :database-type type :if-exists :new)))
+ (unwind-protect
+ (progn
+ (create-test-table db)
+ (dolist (row (query "select * from test_clsql" :database db :types :auto))
+ (test-table-row row :auto type))
+ (dolist (row (query "select * from test_clsql" :database db :types nil))
+ (test-table-row row nil type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (test (map-query nil #'list "select * from test_clsql"
+ :database db :types :auto)
+ nil
+ :fail-info "Expected NIL result from map-query nil")
+ (do-query ((int float bigint str) "select * from test_clsql")
+ (test-table-row (list int float bigint str) nil type))
+ (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
+ (test-table-row (list int float bigint str) :auto type))
+ (drop-test-table db)
+ )
+ (disconnect :database db)))))
+
+
+;;;; Testing functions
+
+(defun transform-float-1 (i)
+ (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float))
+
+(defun transform-bigint-1 (i)
+ (* i (expt 10 (* 3 (abs i)))))
+
+(defun create-test-table (db)
+ (ignore-errors
+ (clsql:execute-command
+ "DROP TABLE test_clsql" :database db))
+ (clsql:execute-command
+ "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))"
+ :database db)
+ (dotimes (i 11)
+ (let* ((test-int (- i 5))
+ (test-flt (transform-float-1 test-int)))
+ (clsql:execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
+ test-int
+ (number-to-sql-string test-flt)
+ (transform-bigint-1 test-int)
+ (number-to-sql-string test-flt)
+ )
+ :database db))))
+
+(defun parse-double (num-str)
+ (let ((*read-default-float-format* 'double-float))
+ (coerce (read-from-string num-str) 'double-float)))
+
+(defun test-table-row (row types db-type)
+ (test (and (listp row)
+ (= 4 (length row)))
+ t
+ :fail-info
+ (format nil "Row ~S is incorrect format" row))
+ (destructuring-bind (int float bigint str) row
+ (cond
+ ((eq types :auto)
+ (test (and (integerp int)
+ (typep float 'double-float)
+ (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions
+ (integerp bigint))
+ (stringp str))
+ t
+ :fail-info
+ (format nil "Incorrect field type for row ~S (types :auto)" row)))
+ ((null types)
+ (test (and (stringp int)
+ (stringp float)
+ (stringp bigint)
+ (stringp str))
+ t
+ :fail-info
+ (format nil "Incorrect field type for row ~S (types nil)" row))
+ (setq int (parse-integer int))
+ (setq bigint (parse-integer bigint))
+ (setq float (parse-double float)))
+ ((listp types)
+ (error "NYI")
+ )
+ (t
+ (test t nil
+ :fail-info
+ (format nil "Invalid types field (~S) passed to test-table-row" types))))
+ (test (transform-float-1 int)
+ float
+ :test #'eql
+ :fail-info
+ (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))
+ (test float
+ (parse-double str)
+ :test #'double-float-equal
+ :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S"
+ str float row))))
+
+
+(defun double-float-equal (a b)
+ (if (zerop a)
+ (if (zerop b)
+ t
+ nil)
+ (let ((diff (abs (/ (- a b) a))))
+ (if (> diff (* 10 double-float-epsilon))
+ nil
+ t))))
+
+(defun drop-test-table (db)
+ (clsql:execute-command "DROP TABLE test_clsql" :database db))
+
+
+(deftest lowlevel.mysql.table.1
+ (let ((spec (mysql-spec *conn-specs*))
+ (result))
+ (when spec
+ (let ((db (clsql-mysql::database-connect spec :mysql)))
+ (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
+ (clsql-mysql::database-execute-command
+ "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
+ (dotimes (i 10)
+ (clsql-mysql::database-execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
+ i (clsql:number-to-sql-string (sqrt i))
+ (clsql:number-to-sql-string (sqrt i)))
+ db))
+ (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
+ (setq result (mysql:mysql-num-rows
+ (clsql-mysql::mysql-result-set-res-ptr res)))
+ (clsql-mysql::database-dump-result-set res db))
+ (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
+ (clsql-mysql::database-disconnect db))))
+ 10)
+
+;(mysql-table-test specs)
+;(pgsql-table-test specs)
+;(pgsql-socket-table-test specs)
+;(aodbc-table-test specs)
+
+
+
+(defmacro def-test-table (name spec type)
+ (deftest ,name
+ (when ,spec
+ (let ((db (clsql:connect ,spec :database-type ,type :if-exists :new)))
+ (unwind-protect
+ (progn
+ (create-test-table db)
+ (dolist (row (query "select * from test_clsql" :database db :types :auto))
+ (test-table-row row :auto type))
+ (dolist (row (query "select * from test_clsql" :database db :types nil))
+ (test-table-row row nil type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (test (map-query nil #'list "select * from test_clsql"
+ :database db :types :auto)
+ nil
+ :fail-info "Expected NIL result from map-query nil")
+ (do-query ((int float bigint str) "select * from test_clsql")
+ (test-table-row (list int float bigint str) nil type))
+ (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
+ (test-table-row (list int float bigint str) :auto type))
+ (drop-test-table db)
+ )
+ (disconnect :database db)))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: tests.lisp
+;;;; Purpose: Automated test of CLSQL using ACL's tester
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Mar 2002
+;;;;
+;;;; $Id: tests.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+;;; 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
+;;; specs for each database type to be tested. For example, to test all
+;;; platforms, a sample "test.config" may look like:
+;;;
+;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
+;;; (:aodbc ("my-dsn" "a-user" "pass"))
+;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell"))
+;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password")))
+
+(in-package :clsql-tests)
+
+(defvar *config-pathname*
+ (make-pathname :defaults (user-homedir-pathname)
+ :name ".clsql-test"
+ :type "config"))
+
+
+(defclass conn-specs ()
+ ((aodbc-spec :accessor aodbc-spec)
+ (mysql-spec :accessor mysql-spec)
+ (pgsql-spec :accessor pgsql-spec)
+ (pgsql-socket-spec :accessor pgsql-socket-spec))
+ (:documentation "Test fixture for CLSQL testing"))
+
+
+(defun read-specs (&optional (path *config-pathname*))
+ (if (probe-file path)
+ (with-open-file (stream path :direction :input)
+ (let ((config (read stream))
+ (specs (make-instance 'conn-specs)))
+ (setf (aodbc-spec specs) (cadr (assoc :aodbc config)))
+ (setf (mysql-spec specs) (cadr (assoc :mysql config)))
+ (setf (pgsql-spec specs) (cadr (assoc :postgresql config)))
+ (setf (pgsql-socket-spec specs)
+ (cadr (assoc :postgresql-socket config)))
+ specs))
+ (error "CLSQL tester config file ~S not found" path)))
+
+(defmethod mysql-table-test ((test conn-specs))
+ (test-table (mysql-spec test) :mysql))
+
+(defmethod aodbc-table-test ((test conn-specs))
+ (test-table (aodbc-spec test) :aodbc))
+
+(defmethod pgsql-table-test ((test conn-specs))
+ (test-table (pgsql-spec test) :postgresql))
+
+(defmethod pgsql-socket-table-test ((test conn-specs))
+ (test-table (pgsql-socket-spec test) :postgresql-socket))
+
+(defmethod test-table (spec type)
+ (when spec
+ (let ((db (clsql:connect spec :database-type type :if-exists :new)))
+ (unwind-protect
+ (progn
+ (create-test-table db)
+ (dolist (row (query "select * from test_clsql" :database db :types :auto))
+ (test-table-row row :auto type))
+ (dolist (row (query "select * from test_clsql" :database db :types nil))
+ (test-table-row row nil type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (loop for row across (map-query 'vector #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types nil)
+ do (test-table-row row nil type))
+ (loop for row in (map-query 'list #'list "select * from test_clsql"
+ :database db :types :auto)
+ do (test-table-row row :auto type))
+ (test (map-query nil #'list "select * from test_clsql"
+ :database db :types :auto)
+ nil
+ :fail-info "Expected NIL result from map-query nil")
+ (do-query ((int float bigint str) "select * from test_clsql")
+ (test-table-row (list int float bigint str) nil type))
+ (do-query ((int float bigint str) "select * from test_clsql" :types :auto)
+ (test-table-row (list int float bigint str) :auto type))
+ (drop-test-table db)
+ )
+ (disconnect :database db)))))
+
+
+(defmethod mysql-low-level ((test conn-specs))
+ (let ((spec (mysql-spec test)))
+ (when spec
+ (let ((db (clsql-mysql::database-connect spec :mysql)))
+ (clsql-mysql::database-execute-command "DROP TABLE IF EXISTS test_clsql" db)
+ (clsql-mysql::database-execute-command
+ "CREATE TABLE test_clsql (i integer, sqrt double, sqrt_str CHAR(20))" db)
+ (dotimes (i 10)
+ (clsql-mysql::database-execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~d,~d,'~a')"
+ i (clsql:number-to-sql-string (sqrt i))
+ (clsql:number-to-sql-string (sqrt i)))
+ db))
+ (let ((res (clsql-mysql::database-query-result-set "select * from test_clsql" db :full-set t :types nil)))
+ (test (mysql:mysql-num-rows
+ (clsql-mysql::mysql-result-set-res-ptr res))
+ 10
+ :test #'eql
+ :fail-info "Error calling mysql-num-rows")
+ (clsql-mysql::database-dump-result-set res db))
+ (clsql-mysql::database-execute-command "DROP TABLE test_clsql" db)
+ (clsql-mysql::database-disconnect db)))))
+
+
+
+;;;; Testing functions
+
+(defun transform-float-1 (i)
+ (coerce (* i (abs (/ i 2)) (expt 10 (* 2 i))) 'double-float))
+
+(defun transform-bigint-1 (i)
+ (* i (expt 10 (* 3 (abs i)))))
+
+(defun create-test-table (db)
+ (ignore-errors
+ (clsql:execute-command
+ "DROP TABLE test_clsql" :database db))
+ (clsql:execute-command
+ "CREATE TABLE test_clsql (t_int integer, t_float float, t_bigint BIGINT, t_str CHAR(30))"
+ :database db)
+ (dotimes (i 11)
+ (let* ((test-int (- i 5))
+ (test-flt (transform-float-1 test-int)))
+ (clsql:execute-command
+ (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
+ test-int
+ (number-to-sql-string test-flt)
+ (transform-bigint-1 test-int)
+ (number-to-sql-string test-flt)
+ )
+ :database db))))
+
+(defun parse-double (num-str)
+ (let ((*read-default-float-format* 'double-float))
+ (coerce (read-from-string num-str) 'double-float)))
+
+(defun test-table-row (row types db-type)
+ (test (and (listp row)
+ (= 4 (length row)))
+ t
+ :fail-info
+ (format nil "Row ~S is incorrect format" row))
+ (destructuring-bind (int float bigint str) row
+ (cond
+ ((eq types :auto)
+ (test (and (integerp int)
+ (typep float 'double-float)
+ (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions
+ (integerp bigint))
+ (stringp str))
+ t
+ :fail-info
+ (format nil "Incorrect field type for row ~S (types :auto)" row)))
+ ((null types)
+ (test (and (stringp int)
+ (stringp float)
+ (stringp bigint)
+ (stringp str))
+ t
+ :fail-info
+ (format nil "Incorrect field type for row ~S (types nil)" row))
+ (setq int (parse-integer int))
+ (setq bigint (parse-integer bigint))
+ (setq float (parse-double float)))
+ ((listp types)
+ (error "NYI")
+ )
+ (t
+ (test t nil
+ :fail-info
+ (format nil "Invalid types field (~S) passed to test-table-row" types))))
+ (test (transform-float-1 int)
+ float
+ :test #'eql
+ :fail-info
+ (format nil "Wrong float value ~A for int ~A (row ~S)" float int row))
+ (test float
+ (parse-double str)
+ :test #'double-float-equal
+ :fail-info (format nil "Wrong string value ~A for double ~A~%Row: ~S"
+ str float row))))
+
+
+(defun double-float-equal (a b)
+ (if (zerop a)
+ (if (zerop b)
+ t
+ nil)
+ (let ((diff (abs (/ (- a b) a))))
+ (if (> diff (* 10 double-float-epsilon))
+ nil
+ t))))
+
+(defun drop-test-table (db)
+ (clsql:execute-command "DROP TABLE test_clsql" :database db))
+
+(defun do-test ()
+ (let ((specs (read-specs)))
+ (with-tests (:name "CLSQL")
+ (mysql-low-level specs)
+ (mysql-table-test specs)
+ (pgsql-table-test specs)
+ (pgsql-socket-table-test specs)
+ (aodbc-table-test specs)
+ )))
+
+
+(do-test)
projects / clsql.git / commitdiff