tests/test-init.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; ======================================================================
   3 ;;;; File:    test-init.lisp
   4 ;;;; Authors: Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg
   5 ;;;; Created: 30/03/2004
   6 ;;;; Updated: $Id$
   7 ;;;; ======================================================================
   8 ;;;;
   9 ;;;; Description ==========================================================
  10 ;;;; ======================================================================
  11 ;;;;
  12 ;;;; Initialisation utilities for running regression tests on CLSQL.
  13 ;;;;
  14 ;;;; ======================================================================
  15
  16 ;;; This test suite looks for a configuration file named ".clsql-test.config"
  17 ;;; located in the users home directory.
  18 ;;;
  19 ;;; This file contains a single a-list that specifies the connection
  20 ;;; specs for each database type to be tested. For example, to test all
  21 ;;; platforms, a sample "test.config" may look like:
  22 ;;;
  23 ;;; ((:mysql ("localhost" "a-mysql-db" "user1" "secret"))
  24 ;;;  (:aodbc ("my-dsn" "a-user" "pass"))
  25 ;;;  (:postgresql ("localhost" "another-db" "user2" "dont-tell"))
  26 ;;;  (:postgresql-socket ("pg-server" "a-db-name" "user" "secret-password"))
  27 ;;;  (:sqlite ("path-to-sqlite-db")))
  28
  29 (in-package #:clsql-tests)
  30
  31 (defvar *config-pathname*
  32   (make-pathname :defaults (user-homedir-pathname)
  33                  :name ".clsql-test"
  34                  :type "config"))
  35
  36 (defvar *rt-connection*)
  37 (defvar *rt-fddl*)
  38 (defvar *rt-fdml*)
  39 (defvar *rt-ooddl*)
  40 (defvar *rt-oodml*)
  41 (defvar *rt-syntax*)
  42
  43 (defvar *test-database-type* nil)
  44 (defvar *test-database-user* nil)
  45
  46 (defclass thing ()
  47   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  48
  49 (def-view-class person (thing)
  50   ((height :db-kind :base :accessor height :type float :nulls-ok t
  51            :initarg :height)
  52    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  53             :initarg :married)
  54    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  55    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  56
  57 (def-view-class employee (person)
  58   ((emplid
  59     :db-kind :key
  60     :db-constraints :not-null
  61     :nulls-ok nil
  62     :type integer
  63     :initarg :emplid)
  64    (groupid
  65     :db-kind :key
  66     :db-constraints :not-null
  67     :nulls-ok nil
  68     :type integer
  69     :initarg :groupid)
  70    (first-name
  71     :accessor first-name
  72     :type (string 30)
  73     :initarg :first-name)
  74    (last-name
  75     :accessor last-name
  76     :type (string 30)
  77     :initarg :last-name)
  78    (email
  79     :accessor employee-email
  80     :type (string 100)
  81     :nulls-ok t
  82     :initarg :email)
  83    (companyid
  84     :type integer)
  85    (company
  86     :accessor employee-company
  87     :db-kind :join
  88     :db-info (:join-class company
  89                           :home-key companyid
  90                           :foreign-key companyid
  91                           :set nil))
  92    (managerid
  93     :type integer
  94     :nulls-ok t)
  95    (manager
  96     :accessor employee-manager
  97     :db-kind :join
  98     :db-info (:join-class employee
  99                           :home-key managerid
 100                           :foreign-key emplid
 101                           :set nil)))
 102   (:base-table employee))
 103
 104 (def-view-class company ()
 105   ((companyid
 106     :db-type :key
 107     :db-constraints :not-null
 108     :type integer
 109     :initarg :companyid)
 110    (groupid
 111     :db-type :key
 112     :db-constraints :not-null
 113     :type integer
 114     :initarg :groupid)
 115    (name
 116     :type (string 100)
 117     :initarg :name)
 118    (presidentid
 119     :type integer)
 120    (president
 121     :reader president
 122     :db-kind :join
 123     :db-info (:join-class employee
 124                           :home-key presidentid
 125                           :foreign-key emplid
 126                           :set nil))
 127    (employees
 128     :reader company-employees
 129     :db-kind :join
 130     :db-info (:join-class employee
 131                           :home-key (companyid groupid)
 132                           :foreign-key (companyid groupid)
 133                           :set t)))
 134   (:base-table company))
 135
 136 (defparameter company1 (make-instance 'company
 137                                       :companyid 1
 138                                       :groupid 1
 139                                       :name "Widgets Inc."))
 140
 141 (defparameter employee1 (make-instance 'employee
 142                                        :emplid 1
 143                                        :groupid 1
 144                                        :married t
 145                                        :height (1+ (random 1.00))
 146                                        :birthday (clsql-base:get-time)
 147                                        :first-name "Vladamir"
 148                                        :last-name "Lenin"
 149                                        :email "lenin@soviet.org"))
 150
 151 (defparameter employee2 (make-instance 'employee
 152                                :emplid 2
 153                                :groupid 1
 154                                :height (1+ (random 1.00))
 155                                :married t
 156                                :birthday (clsql-base:get-time)
 157                                :first-name "Josef"
 158                                :last-name "Stalin"
 159                                :email "stalin@soviet.org"))
 160
 161 (defparameter employee3 (make-instance 'employee
 162                                :emplid 3
 163                                :groupid 1
 164                                :height (1+ (random 1.00))
 165                                :married t
 166                                :birthday (clsql-base:get-time)
 167                                :first-name "Leon"
 168                                :last-name "Trotsky"
 169                                :email "trotsky@soviet.org"))
 170
 171 (defparameter employee4 (make-instance 'employee
 172                                :emplid 4
 173                                :groupid 1
 174                                :height (1+ (random 1.00))
 175                                :married nil
 176                                :birthday (clsql-base:get-time)
 177                                :first-name "Nikita"
 178                                :last-name "Kruschev"
 179                                :email "kruschev@soviet.org"))
 180
 181 (defparameter employee5 (make-instance 'employee
 182                                :emplid 5
 183                                :groupid 1
 184                                :married nil
 185                                :height (1+ (random 1.00))
 186                                :birthday (clsql-base:get-time)
 187                                :first-name "Leonid"
 188                                :last-name "Brezhnev"
 189                                :email "brezhnev@soviet.org"))
 190
 191 (defparameter employee6 (make-instance 'employee
 192                                :emplid 6
 193                                :groupid 1
 194                                :married nil
 195                                :height (1+ (random 1.00))
 196                                :birthday (clsql-base:get-time)
 197                                :first-name "Yuri"
 198                                :last-name "Andropov"
 199                                :email "andropov@soviet.org"))
 200
 201 (defparameter employee7 (make-instance 'employee
 202                                  :emplid 7
 203                                  :groupid 1
 204                                  :height (1+ (random 1.00))
 205                                  :married nil
 206                                  :birthday (clsql-base:get-time)
 207                                  :first-name "Konstantin"
 208                                  :last-name "Chernenko"
 209                                  :email "chernenko@soviet.org"))
 210
 211 (defparameter employee8 (make-instance 'employee
 212                                  :emplid 8
 213                                  :groupid 1
 214                                  :height (1+ (random 1.00))
 215                                  :married nil
 216                                  :birthday (clsql-base:get-time)
 217                                  :first-name "Mikhail"
 218                                  :last-name "Gorbachev"
 219                                  :email "gorbachev@soviet.org"))
 220
 221 (defparameter employee9 (make-instance 'employee
 222                                  :emplid 9
 223                                  :groupid 1
 224                                  :married nil
 225                                  :height (1+ (random 1.00))
 226                                  :birthday (clsql-base:get-time)
 227                                  :first-name "Boris"
 228                                  :last-name "Yeltsin"
 229                                  :email "yeltsin@soviet.org"))
 230
 231 (defparameter employee10 (make-instance 'employee
 232                                   :emplid 10
 233                                   :groupid 1
 234                                   :married nil
 235                                   :height (1+ (random 1.00))
 236                                   :birthday (clsql-base:get-time)
 237                                   :first-name "Vladamir"
 238                                   :last-name "Putin"
 239                                   :email "putin@soviet.org"))
 240
 241 (defun test-connect-to-database (database-type spec)
 242   (setf *test-database-type* database-type)
 243   (when (>= (length spec) 3)
 244     (setq *test-database-user* (third spec)))
 245
 246   ;; Connect to the database
 247   (clsql:connect spec
 248                 :database-type database-type
 249                 :make-default t
 250                 :if-exists :old))
 251
 252 (defmacro with-ignore-errors (&rest forms)
 253   `(progn
 254      ,@(mapcar
 255         (lambda (x) (list 'ignore-errors x))
 256         forms)))
 257
 258 (defun test-initialise-database ()
 259   ;; Delete the instance records
 260   (with-ignore-errors
 261     (clsql:delete-instance-records company1)
 262     (clsql:delete-instance-records employee1)
 263     (clsql:delete-instance-records employee2)
 264     (clsql:delete-instance-records employee3)
 265     (clsql:delete-instance-records employee4)
 266     (clsql:delete-instance-records employee5)
 267     (clsql:delete-instance-records employee6)
 268     (clsql:delete-instance-records employee7)
 269     (clsql:delete-instance-records employee8)
 270     (clsql:delete-instance-records employee9)
 271     (clsql:delete-instance-records employee10)
 272     ;; Drop the required tables if they exist
 273     (clsql:drop-view-from-class 'employee)
 274     (clsql:drop-view-from-class 'company))
 275   ;; Create the tables for our view classes
 276   (clsql:create-view-from-class 'employee)
 277   (clsql:create-view-from-class 'company)
 278   ;; Lenin manages everyone
 279   (clsql:add-to-relation employee2 'manager employee1)
 280   (clsql:add-to-relation employee3 'manager employee1)
 281   (clsql:add-to-relation employee4 'manager employee1)
 282   (clsql:add-to-relation employee5 'manager employee1)
 283   (clsql:add-to-relation employee6 'manager employee1)
 284   (clsql:add-to-relation employee7 'manager employee1)
 285   (clsql:add-to-relation employee8 'manager employee1)
 286   (clsql:add-to-relation employee9 'manager employee1)
 287   (clsql:add-to-relation employee10 'manager employee1)
 288   ;; Everyone works for Widgets Inc.
 289   (clsql:add-to-relation company1 'employees employee1)
 290   (clsql:add-to-relation company1 'employees employee2)
 291   (clsql:add-to-relation company1 'employees employee3)
 292   (clsql:add-to-relation company1 'employees employee4)
 293   (clsql:add-to-relation company1 'employees employee5)
 294   (clsql:add-to-relation company1 'employees employee6)
 295   (clsql:add-to-relation company1 'employees employee7)
 296   (clsql:add-to-relation company1 'employees employee8)
 297   (clsql:add-to-relation company1 'employees employee9)
 298   (clsql:add-to-relation company1 'employees employee10)
 299   ;; Lenin is president of Widgets Inc.
 300   (clsql:add-to-relation company1 'president employee1)
 301   ;; store these instances
 302   (clsql:update-records-from-instance employee1)
 303   (clsql:update-records-from-instance employee2)
 304   (clsql:update-records-from-instance employee3)
 305   (clsql:update-records-from-instance employee4)
 306   (clsql:update-records-from-instance employee5)
 307   (clsql:update-records-from-instance employee6)
 308   (clsql:update-records-from-instance employee7)
 309   (clsql:update-records-from-instance employee8)
 310   (clsql:update-records-from-instance employee9)
 311   (clsql:update-records-from-instance employee10)
 312   (clsql:update-records-from-instance company1))
 313
 314 (defclass conn-specs ()
 315   ((aodbc-spec :accessor aodbc :initform nil)
 316    (mysql-spec :accessor mysql :initform nil)
 317    (pgsql-spec :accessor postgresql :initform nil)
 318    (pgsql-socket-spec :accessor postgresql-socket :initform nil)
 319    (sqlite-spec :accessor sqlite :initform nil))
 320   (:documentation "Connection specifications for CLSQL testing"))
 321
 322 (defun run-tests ()
 323   (let ((specs (read-specs)))
 324     (unless specs
 325       (warn "Not running tests because test configuration file is missing")
 326       (return-from run-tests :skipped))
 327     (dolist (accessor '(postgresql postgresql-socket sqlite aodbc mysql))
 328       (unless (find-package (symbol-name accessor))
 329         (asdf:operate 'asdf:load-op
 330                       (intern (concatenate 'string
 331                                            (symbol-name '#:clsql-)
 332                                            (symbol-name accessor)))))
 333       (rt:rem-all-tests)
 334       (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
 335                             *rt-ooddl* *rt-oodml* *rt-syntax*))
 336         (eval test))
 337
 338       (let ((spec (funcall accessor specs))
 339             (backend (intern (symbol-name accessor) (find-package :keyword))))
 340         (when spec
 341           (format t "~&Running CLSQL tests with ~A backend.~%" backend)
 342           (test-connect-to-database backend spec)
 343           (test-initialise-database)
 344           (rtest:do-tests))))))
 345
 346 (defun read-specs (&optional (path *config-pathname*))
 347   (if (probe-file path)
 348       (with-open-file (stream path :direction :input)
 349         (let ((config (read stream))
 350               (specs (make-instance 'conn-specs)))
 351           (setf (aodbc specs) (cadr (assoc :aodbc config)))
 352           (setf (mysql specs) (cadr (assoc :mysql config)))
 353           (setf (postgresql specs) (cadr (assoc :postgresql config)))
 354           (setf (postgresql-socket specs)
 355                 (cadr (assoc :postgresql-socket config)))
 356           (setf (sqlite specs) (cadr (assoc :sqlite config)))
 357           specs))
 358       (progn
 359         (warn "CLSQL tester config file ~S not found" path)
 360         nil)))
 361