From 67e6b9eaab9c9bcf8b57cbd476581437e4876b26 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Fri, 9 Apr 2004 17:57:14 +0000
Subject: [PATCH] r8914: rework test suites

---
 ChangeLog                  |  9 ++++-
 TODO                       |  6 ---
 base/database.lisp         |  4 ++
 base/utils.lisp            | 31 +++++++++++++++
 classic-tests/package.lisp | 16 +++++++-
 classic-tests/tests.lisp   | 80 +++++++++++++++++++++++---------------
 clsql-classic-tests.asd    |  7 +---
 clsql-tests.asd            |  6 +--
 debian/changelog           |  6 +++
 tests/package.lisp         |  2 +-
 tests/test-init.lisp       | 53 +++++--------------------
 11 files changed, 125 insertions(+), 95 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 931ef8c..aad7993 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,13 @@
 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
 	* Version 2.5.1 released:
-	tests/*.lisp: Rework so tests are run
+	* tests/*.lisp: Rework so tests are run
 	on multiple backends automatically based
-	on the contents of ~/.clsql-tests.config
+	on the contents of ~/.clsql-tests.config.
+	Reuse helper functions from classic-tests.
+	* base/database.lisp: Support connection-spec
+	as string for CONNECT
+	* classic-tests/tests.lisp: Automatically
+	load database backends as needed. 
 	
 09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
         * Version 2.5.0 released:
diff --git a/TODO b/TODO
index 35617a8..739fe7a 100644
--- a/TODO
+++ b/TODO
@@ -21,12 +21,6 @@ COMMONSQL SPEC
 
  >> Initialisation and connection 
 
-    CONNECT 
-     o should accept string as connection spec 
-
-    DISCONNECT
-     o should accept string as connection spec 
-
     INITIALIZE-DATABASE-TYPE
      o should initialise appropriate backend 
 
diff --git a/base/database.lisp b/base/database.lisp
index 78b6faa..a7313eb 100644
--- a/base/database.lisp
+++ b/base/database.lisp
@@ -81,6 +81,10 @@ connection.  If make-default is true, then *default-database* is set
 to the new connection, otherwise *default-database is not changed. If
 pool is t the connection will be taken from the general pool, if pool
 is a conn-pool object the connection will be taken from this pool."
+
+  (when (stringp connection-spec)
+    (setq connection-spec (string-to-list-connection-spec connection-spec)))
+  
   (if pool
       (acquire-from-pool connection-spec database-type pool)
       (let* ((db-name (database-name-from-spec connection-spec database-type))
diff --git a/base/utils.lisp b/base/utils.lisp
index f123b4f..3f9ad8a 100644
--- a/base/utils.lisp
+++ b/base/utils.lisp
@@ -81,3 +81,34 @@
       procstr)))
 
 
+(defun delimited-string-to-list (string &optional (separator #\space) 
+						  skip-terminal)
+  "Split a string with delimiter, from KMRCL."
+  (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
+	   (type string string)
+	   (type character separator))
+  (do* ((len (length string))
+	(output '())
+	(pos 0)
+	(end (position-char separator string pos len)
+	     (position-char separator string pos len)))
+       ((null end)
+	(if (< pos len)
+	    (push (subseq string pos) output)
+	    (when (or (not skip-terminal) (zerop len))
+	      (push "" output)))
+	(nreverse output))
+    (declare (type fixnum pos len)
+	     (type (or null fixnum) end))
+    (push (subseq string pos end) output)
+    (setq pos (1+ end))))
+
+(defun string-to-list-connection-spec (str)
+  (let ((at-pos (position #\@ str)))
+    (cond
+      ((and at-pos (> (length str) at-pos))
+       ;; Connection spec is SQL*NET format
+       (append (delimited-string-to-list (subseq str 0 at-pos) #\/)
+	       (list (subseq str (1+ at-pos)))))
+      (t
+       (delimited-string-to-list str #\/)))))
diff --git a/classic-tests/package.lisp b/classic-tests/package.lisp
index 27d73b9..b8d23bd 100644
--- a/classic-tests/package.lisp
+++ b/classic-tests/package.lisp
@@ -13,6 +13,20 @@
 (in-package #:cl-user)
 
 (defpackage #:clsql-classic-tests
-  (:use #:asdf #:cl #:clsql #:ptester))
+  (:use #:asdf #:cl #:clsql #:ptester)
+  (:export
+   #:*config-pathname*
+   #:+all-db-types+
+   #:conn-specs
+   #:aodbc-spec
+   #:mysql-spec
+   #:postgresql-spec
+   #:postgresql-socket-spec
+   #:sqlite-spec
+   #:read-specs
+   #:db-type-spec
+   #:db-type-ensure-system
+   ))
+
 
 
diff --git a/classic-tests/tests.lisp b/classic-tests/tests.lisp
index 3faed38..94db68c 100644
--- a/classic-tests/tests.lisp
+++ b/classic-tests/tests.lisp
@@ -18,7 +18,23 @@
 
 ;;; This test suite looks for a configuration file named ".clsql-test.config"
 ;;; located in the users home directory.
-;;;
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; File:    tests.lisp
+;;;; Author: Kevin Rosenberg
+;;;; $Id$
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; 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.
+;;;; *************************************************************************
+
+;;; You need a file named "~/.clsql-tests.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:
@@ -36,14 +52,17 @@
 		 :name ".clsql-test"
 		 :type "config"))
 
+(defvar +all-db-types+
+  #-clisp '(:postgresql :postgresql-socket :sqlite :aodbc :mysql)
+  #+clisp '(:sqlite))
 
 (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)
-   (sqlite-spec :accessor sqlite-spec))
-  (:documentation "Test fixture for CLSQL testing"))
+  ((aodbc-spec :accessor aodbc-spec :initform nil)
+   (mysql-spec :accessor mysql-spec :initform nil)
+   (pgsql-spec :accessor postgresql-spec :initform nil)
+   (pgsql-socket-spec :accessor postgresql-socket-spec :initform nil)
+   (sqlite-spec :accessor sqlite-spec :initform nil))
+  (:documentation "Connection specs for CLSQL testing"))
 
 
 (defun read-specs (&optional (path *config-pathname*))
@@ -53,30 +72,15 @@
 	      (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) 
+	  (setf (postgresql-spec specs) (cadr (assoc :postgresql config)))
+	  (setf (postgresql-socket-spec specs) 
 		(cadr (assoc :postgresql-socket config)))
 	  (setf (sqlite-spec specs) (cadr (assoc :sqlite config)))
 	  specs))
       (progn
-	(warn "CLSQL tester config file ~S not found" path)
+	(warn "CLSQL test config file ~S not found" path)
 	nil)))
 
-(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 sqlite-table-test ((test conn-specs))
-  (test-table (sqlite-spec test) :sqlite))
-
 (defmethod test-table (spec type)
   (when spec
     (let ((db (clsql:connect spec :database-type type :if-exists :new)))
@@ -253,17 +257,29 @@
 (defun drop-test-table (db)
   (clsql:execute-command "DROP TABLE test_clsql" :database db))
 
+(defun db-type-spec (db-type specs)
+  (let ((accessor (intern (concatenate 'string (symbol-name db-type)
+				       (symbol-name '#:-spec))
+			  (find-package '#:clsql-classic-tests))))
+    (funcall accessor specs)))
+
+(defun db-type-ensure-system (db-type)
+  (unless (find-package (symbol-name db-type))
+    (asdf:operate 'asdf:load-op
+		  (intern (concatenate 'string
+				       (symbol-name '#:clsql-)
+				       (symbol-name db-type))))))
+
 (defun run-tests ()
   (let ((specs (read-specs)))
     (unless specs
       (warn "Not running test because test configuration file is missing")
       (return-from run-tests :skipped))
+    (mysql-low-level 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)
-      (sqlite-table-test specs)
-      ))
+      (dolist (db-type +all-db-types+)
+	(let ((spec (db-type-spec db-type specs)))
+	  (when spec
+	    (db-type-ensure-system db-type)
+	    (test-table spec db-type))))))
   t)
diff --git a/clsql-classic-tests.asd b/clsql-classic-tests.asd
index 74f2dfb..3d2961f 100644
--- a/clsql-classic-tests.asd
+++ b/clsql-classic-tests.asd
@@ -21,12 +21,7 @@
   :licence "Lessor Lisp General Public License"
   :description "Testing suite for CLSQL"
 
-  :depends-on (clsql #-clisp clsql-mysql 
-		     #-clisp clsql-postgresql
-		     #-clisp clsql-postgresql-socket
-		     ptester
-		     #+(and allegro (not allegro-cl-trial)) clsql-aodbc
-		     clsql-sqlite)
+  :depends-on (clsql ptester #-clisp clsql-mysql)
   :components
   ((:module :classic-tests
 	    :components
diff --git a/clsql-tests.asd b/clsql-tests.asd
index 46e7261..6d44b87 100644
--- a/clsql-tests.asd
+++ b/clsql-tests.asd
@@ -16,8 +16,8 @@
 ;;;; ======================================================================
 
 (in-package #:cl-user)
-(defpackage #:clsql-classic-tests-system (:use #:asdf #:cl))
-(in-package #:clsql-classic-tests-system)
+(defpackage #:clsql-tests-system (:use #:asdf #:cl))
+(in-package #:clsql-tests-system)
 
 (defsystem clsql-tests
     :name "CLSQL Tests"
@@ -26,7 +26,7 @@
     :version ""
     :licence ""
     :description "A regression test suite for CLSQL."
-    :depends-on (clsql rt)
+    :depends-on (clsql clsql-classic-tests rt)
     :components 
     ((:module tests
 	      :serial t
diff --git a/debian/changelog b/debian/changelog
index c230cd6..fcb6d45 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (2.5.1-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Fri,  9 Apr 2004 11:56:38 -0600
+
 cl-sql (2.5.0-1) unstable; urgency=low
 
   * New upstream
diff --git a/tests/package.lisp b/tests/package.lisp
index f3858d3..a4333f1 100644
--- a/tests/package.lisp
+++ b/tests/package.lisp
@@ -17,6 +17,6 @@
 (in-package #:cl-user)
 
 (defpackage #:clsql-tests
-  (:use #:clsql #:common-lisp #:rtest)
+  (:use #:clsql #:common-lisp #:rtest #:clsql-classic-tests)
   (:export #:run-tests #:test-initialise-database #:test-connect-to-database)
   (:documentation "Regression tests for CLSQL."))
diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 80bd6b3..89b6ce2 100644
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -28,11 +28,6 @@
 
 (in-package #:clsql-tests)
 
-(defvar *config-pathname*
-  (make-pathname :defaults (user-homedir-pathname)
-		 :name ".clsql-test"
-		 :type "config"))
-
 (defvar *rt-connection*)
 (defvar *rt-fddl*)
 (defvar *rt-fdml*)
@@ -311,51 +306,21 @@
   (clsql:update-records-from-instance employee10)
   (clsql:update-records-from-instance company1))
 
-(defclass conn-specs ()
-  ((aodbc-spec :accessor aodbc :initform nil)
-   (mysql-spec :accessor mysql :initform nil)
-   (pgsql-spec :accessor postgresql :initform nil)
-   (pgsql-socket-spec :accessor postgresql-socket :initform nil)
-   (sqlite-spec :accessor sqlite :initform nil))
-  (:documentation "Connection specifications for CLSQL testing"))
-
 (defun run-tests ()
   (let ((specs (read-specs)))
     (unless specs
       (warn "Not running tests because test configuration file is missing")
       (return-from run-tests :skipped))
-    (dolist (accessor '(postgresql postgresql-socket sqlite aodbc mysql))
-      (unless (find-package (symbol-name accessor))
-	(asdf:operate 'asdf:load-op
-		      (intern (concatenate 'string
-					   (symbol-name '#:clsql-)
-					   (symbol-name accessor)))))
-      (rt:rem-all-tests)
-      (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
-			    *rt-ooddl* *rt-oodml* *rt-syntax*))
-	(eval test))
-
-      (let ((spec (funcall accessor specs))
-	    (backend (intern (symbol-name accessor) (find-package :keyword))))
+    (dolist (db-type +all-db-types+)
+      (let ((spec (db-type-spec db-type specs)))
 	(when spec
-	  (format t "~&Running CLSQL tests with ~A backend.~%" backend)
-	  (test-connect-to-database backend spec)
+	  (db-type-ensure-system db-type)
+	  (rt:rem-all-tests)
+	  (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
+				*rt-ooddl* *rt-oodml* *rt-syntax*))
+	    (eval test))
+	  (format t "~&Running CLSQL tests with ~A backend.~%" db-type)
+	  (test-connect-to-database db-type spec)
 	  (test-initialise-database)
 	  (rtest:do-tests))))))
 
-(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 specs) (cadr (assoc :aodbc config)))
-	  (setf (mysql specs) (cadr (assoc :mysql config)))
-	  (setf (postgresql specs) (cadr (assoc :postgresql config)))
-	  (setf (postgresql-socket specs) 
-		(cadr (assoc :postgresql-socket config)))
-	  (setf (sqlite specs) (cadr (assoc :sqlite config)))
-	  specs))
-      (progn
-	(warn "CLSQL tester config file ~S not found" path)
-	nil)))
-
-- 
2.34.1