From 8d558ce162d1360f92e4d65d054e2f61c786319e Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 2 May 2003 03:08:58 +0000 Subject: [PATCH] r4733: *** empty log message *** --- base/cmucl-compat.lisp | 42 +-- clsql-tests.asd | 40 +++ clsql.asd | 15 +- db-aodbc/aodbc-sql.lisp | 6 +- .../postgresql-socket-api.lisp | 9 +- .../postgresql-socket-sql.lisp | 7 +- debian/changelog | 8 + debian/cl-sql-tests.docs | 1 + debian/compat | 1 + debian/control | 15 +- debian/rules | 17 +- test-suite/.cvsignore | 1 - test-suite/old-tests/interactive-test.lisp | 138 --------- tests/README | 16 ++ {test-suite => tests}/acl-compat-tester.lisp | 8 +- .../old-tests/xptest-clsql.lisp | 2 +- tests/package.lisp | 20 ++ tests/rt.lisp | 254 +++++++++++++++++ tests/tables.lisp | 262 ++++++++++++++++++ .../tester-clsql.lisp => tests/tests.lisp | 24 +- 20 files changed, 669 insertions(+), 217 deletions(-) create mode 100644 clsql-tests.asd create mode 100644 debian/cl-sql-tests.docs create mode 100644 debian/compat delete mode 100755 test-suite/.cvsignore delete mode 100644 test-suite/old-tests/interactive-test.lisp create mode 100644 tests/README rename {test-suite => tests}/acl-compat-tester.lisp (99%) rename {test-suite => tests}/old-tests/xptest-clsql.lisp (99%) create mode 100644 tests/package.lisp create mode 100644 tests/rt.lisp create mode 100644 tests/tables.lisp rename test-suite/tester-clsql.lisp => tests/tests.lisp (93%) diff --git a/base/cmucl-compat.lisp b/base/cmucl-compat.lisp index 8b2b5a5..8e7df71 100644 --- a/base/cmucl-compat.lisp +++ b/base/cmucl-compat.lisp @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -16,7 +16,6 @@ ;;;; (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 @@ -56,9 +55,11 @@ Needs to be a macro to overwrite value of VEC." ((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) @@ -68,27 +69,10 @@ Needs to be a macro to overwrite value of VEC." ))) - -#-(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) @@ -97,11 +81,7 @@ Needs to be a macro to overwrite value of VEC." (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")) @@ -121,7 +101,3 @@ Needs to be a macro to overwrite value of VEC." #+(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)) diff --git a/clsql-tests.asd b/clsql-tests.asd new file mode 100644 index 0000000..1988302 --- /dev/null +++ b/clsql-tests.asd @@ -0,0 +1,40 @@ +;;;; -*- 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 " + :maintainer "Kevin M. Rosenberg " + :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"))) + diff --git a/clsql.asd b/clsql.asd index 0db72bf..55562fd 100644 --- a/clsql.asd +++ b/clsql.asd @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -20,16 +20,14 @@ #+(or allegro lispworks cmu sbcl openmcl mcl scl) (defsystem :clsql - :name "cl-sql" - :author "Kevin M. Rosenberg " - :version "0.9.2" + :name "clsql" + :author "Kevin Rosenberg " :maintainer "Kevin M. Rosenberg " + :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 @@ -42,3 +40,8 @@ (: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)) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 641764b..ed7bb24 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -7,7 +7,7 @@ ;;;; 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 ;;;; @@ -21,7 +21,7 @@ ;; 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)) @@ -145,6 +145,6 @@ (setf (car rest) elem)) list)))) - +#+ignore (when (clsql-base-sys:database-type-library-loaded :aodbc) (clsql-base-sys:initialize-database-type :database-type :aodbc)) diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp index 658addc..9e9b10e 100644 --- a/db-postgresql-socket/postgresql-socket-api.lisp +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; 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 @@ -40,12 +40,15 @@ (: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 diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index acd93c3..a9cb8f5 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -8,7 +8,7 @@ ;;;; 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 @@ -30,11 +30,6 @@ ;; 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) diff --git a/debian/changelog b/debian/changelog index 804e471..ca297b8 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,11 @@ +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 Thu, 1 May 2003 16:23:37 -0600 + cl-sql (1.4.6-1) unstable; urgency=low * Documentation fix diff --git a/debian/cl-sql-tests.docs b/debian/cl-sql-tests.docs new file mode 100644 index 0000000..8a81e98 --- /dev/null +++ b/debian/cl-sql-tests.docs @@ -0,0 +1 @@ +tests/README diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +4 diff --git a/debian/control b/debian/control index ddab432..9b198e1 100644 --- a/debian/control +++ b/debian/control @@ -32,7 +32,7 @@ Description: Common UFFI functions for CLSQL database backends 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 @@ -61,3 +61,16 @@ Provides: cl-sql-backend 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. + diff --git a/debian/rules b/debian/rules index 41d3289..299e58e 100755 --- a/debian/rules +++ b/debian/rules @@ -1,7 +1,5 @@ #!/usr/bin/make -f -export DH_COMPAT=4 - plain-pkg := clsql pkg := cl-sql @@ -11,7 +9,8 @@ pkg-mysql := cl-sql-mysql 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) @@ -26,6 +25,7 @@ srcs-mysql-so := $(wildcard db-mysql/*.so) 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 @@ -50,6 +50,8 @@ clc-pg-socket := $(clc-source)/clsql-postgresql-socket 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: @@ -100,6 +102,7 @@ install: build 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) @@ -125,6 +128,9 @@ install: build 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 @@ -133,10 +139,7 @@ install: build 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 diff --git a/test-suite/.cvsignore b/test-suite/.cvsignore deleted file mode 100755 index 102a86f..0000000 --- a/test-suite/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -test.config diff --git a/test-suite/old-tests/interactive-test.lisp b/test-suite/old-tests/interactive-test.lisp deleted file mode 100644 index 420c3ff..0000000 --- a/test-suite/old-tests/interactive-test.lisp +++ /dev/null @@ -1,138 +0,0 @@ -;;;; -*- 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))) diff --git a/tests/README b/tests/README new file mode 100644 index 0000000..a344c4b --- /dev/null +++ b/tests/README @@ -0,0 +1,16 @@ +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"))) diff --git a/test-suite/acl-compat-tester.lisp b/tests/acl-compat-tester.lisp similarity index 99% rename from test-suite/acl-compat-tester.lisp rename to tests/acl-compat-tester.lisp index b775ea9..e90adc5 100644 --- a/test-suite/acl-compat-tester.lisp +++ b/tests/acl-compat-tester.lisp @@ -24,7 +24,7 @@ ;; 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 $ +;; $Id: acl-compat-tester.lisp,v 1.1 2003/05/02 03:08:58 kevin Exp $ (defpackage :util.test @@ -399,17 +399,17 @@ discriminate on new versus known failures." (if catch-breaks `(handler-case (values-list (cons t (multiple-value-list ,form))) (error (condition) - (declare (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil) (simple-break (condition) - (declare (ignore-if-unused 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 (ignore-if-unused condition)) + (declare (ignorable condition)) ,@(if announce `((format *error-output* "~&Error: ~a~%" condition))) nil)))) diff --git a/test-suite/old-tests/xptest-clsql.lisp b/tests/old-tests/xptest-clsql.lisp similarity index 99% rename from test-suite/old-tests/xptest-clsql.lisp rename to tests/old-tests/xptest-clsql.lisp index c301941..c37e49a 100644 --- a/test-suite/old-tests/xptest-clsql.lisp +++ b/tests/old-tests/xptest-clsql.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; -;;;; $Id: xptest-clsql.lisp,v 1.1 2002/09/30 10:19:24 kevin Exp $ +;;;; $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/ diff --git a/tests/package.lisp b/tests/package.lisp new file mode 100644 index 0000000..fef952d --- /dev/null +++ b/tests/package.lisp @@ -0,0 +1,20 @@ +;;;; -*- 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) diff --git a/tests/rt.lisp b/tests/rt.lisp new file mode 100644 index 0000000..d4dd2ae --- /dev/null +++ b/tests/rt.lisp @@ -0,0 +1,254 @@ +#|----------------------------------------------------------------------------| + | 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)))) diff --git a/tests/tables.lisp b/tests/tables.lisp new file mode 100644 index 0000000..92ff34f --- /dev/null +++ b/tests/tables.lisp @@ -0,0 +1,262 @@ +;;;; -*- 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))))) diff --git a/test-suite/tester-clsql.lisp b/tests/tests.lisp similarity index 93% rename from test-suite/tester-clsql.lisp rename to tests/tests.lisp index 4959580..415fa2f 100644 --- a/test-suite/tester-clsql.lisp +++ b/tests/tests.lisp @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: tester-clsql.cl +;;;; Name: tests.lisp ;;;; 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 $ +;;;; $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 ;;;; @@ -16,7 +16,9 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -;;; This test suite looks for a configuration file named "test.config" +;;; 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: @@ -26,19 +28,13 @@ ;;; (:postgresql ("localhost" "another-db" "user2" "dont-tell")) ;;; (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))) +(in-package :clsql-tests) -(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 :defaults (user-homedir-pathname) + :name ".clsql-test" + :type "config")) -(defvar *config-pathname* (make-pathname :name "test" - :type "config" - :defaults *load-truename*)) (defclass conn-specs () ((aodbc-spec :accessor aodbc-spec) -- 2.34.1