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 *rt-connection*)
  32 (defvar *rt-fddl*)
  33 (defvar *rt-fdml*)
  34 (defvar *rt-ooddl*)
  35 (defvar *rt-oodml*)
  36 (defvar *rt-syntax*)
  37
  38 (defvar *test-database-type* nil)
  39 (defvar *test-database-user* nil)
  40
  41 (defclass thing ()
  42   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  43
  44 (def-view-class person (thing)
  45   ((height :db-kind :base :accessor height :type float :nulls-ok t
  46            :initarg :height)
  47    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  48             :initarg :married)
  49    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  50    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  51
  52 (def-view-class employee (person)
  53   ((emplid
  54     :db-kind :key
  55     :db-constraints :not-null
  56     :nulls-ok nil
  57     :type integer
  58     :initarg :emplid)
  59    (groupid
  60     :db-kind :key
  61     :db-constraints :not-null
  62     :nulls-ok nil
  63     :type integer
  64     :initarg :groupid)
  65    (first-name
  66     :accessor first-name
  67     :type (string 30)
  68     :initarg :first-name)
  69    (last-name
  70     :accessor last-name
  71     :type (string 30)
  72     :initarg :last-name)
  73    (email
  74     :accessor employee-email
  75     :type (string 100)
  76     :nulls-ok t
  77     :initarg :email)
  78    (companyid
  79     :type integer)
  80    (company
  81     :accessor employee-company
  82     :db-kind :join
  83     :db-info (:join-class company
  84                           :home-key companyid
  85                           :foreign-key companyid
  86                           :set nil))
  87    (managerid
  88     :type integer
  89     :nulls-ok t)
  90    (manager
  91     :accessor employee-manager
  92     :db-kind :join
  93     :db-info (:join-class employee
  94                           :home-key managerid
  95                           :foreign-key emplid
  96                           :set nil)))
  97   (:base-table employee))
  98
  99 (def-view-class company ()
 100   ((companyid
 101     :db-type :key
 102     :db-constraints :not-null
 103     :type integer
 104     :initarg :companyid)
 105    (groupid
 106     :db-type :key
 107     :db-constraints :not-null
 108     :type integer
 109     :initarg :groupid)
 110    (name
 111     :type (string 100)
 112     :initarg :name)
 113    (presidentid
 114     :type integer)
 115    (president
 116     :reader president
 117     :db-kind :join
 118     :db-info (:join-class employee
 119                           :home-key presidentid
 120                           :foreign-key emplid
 121                           :set nil))
 122    (employees
 123     :reader company-employees
 124     :db-kind :join
 125     :db-info (:join-class employee
 126                           :home-key (companyid groupid)
 127                           :foreign-key (companyid groupid)
 128                           :set t)))
 129   (:base-table company))
 130
 131 (defparameter company1 (make-instance 'company
 132                                       :companyid 1
 133                                       :groupid 1
 134                                       :name "Widgets Inc."))
 135
 136 (defparameter employee1 (make-instance 'employee
 137                                        :emplid 1
 138                                        :groupid 1
 139                                        :married t
 140                                        :height (1+ (random 1.00))
 141                                        :birthday (clsql-base:get-time)
 142                                        :first-name "Vladamir"
 143                                        :last-name "Lenin"
 144                                        :email "lenin@soviet.org"))
 145
 146 (defparameter employee2 (make-instance 'employee
 147                                :emplid 2
 148                                :groupid 1
 149                                :height (1+ (random 1.00))
 150                                :married t
 151                                :birthday (clsql-base:get-time)
 152                                :first-name "Josef"
 153                                :last-name "Stalin"
 154                                :email "stalin@soviet.org"))
 155
 156 (defparameter employee3 (make-instance 'employee
 157                                :emplid 3
 158                                :groupid 1
 159                                :height (1+ (random 1.00))
 160                                :married t
 161                                :birthday (clsql-base:get-time)
 162                                :first-name "Leon"
 163                                :last-name "Trotsky"
 164                                :email "trotsky@soviet.org"))
 165
 166 (defparameter employee4 (make-instance 'employee
 167                                :emplid 4
 168                                :groupid 1
 169                                :height (1+ (random 1.00))
 170                                :married nil
 171                                :birthday (clsql-base:get-time)
 172                                :first-name "Nikita"
 173                                :last-name "Kruschev"
 174                                :email "kruschev@soviet.org"))
 175
 176 (defparameter employee5 (make-instance 'employee
 177                                :emplid 5
 178                                :groupid 1
 179                                :married nil
 180                                :height (1+ (random 1.00))
 181                                :birthday (clsql-base:get-time)
 182                                :first-name "Leonid"
 183                                :last-name "Brezhnev"
 184                                :email "brezhnev@soviet.org"))
 185
 186 (defparameter employee6 (make-instance 'employee
 187                                :emplid 6
 188                                :groupid 1
 189                                :married nil
 190                                :height (1+ (random 1.00))
 191                                :birthday (clsql-base:get-time)
 192                                :first-name "Yuri"
 193                                :last-name "Andropov"
 194                                :email "andropov@soviet.org"))
 195
 196 (defparameter employee7 (make-instance 'employee
 197                                  :emplid 7
 198                                  :groupid 1
 199                                  :height (1+ (random 1.00))
 200                                  :married nil
 201                                  :birthday (clsql-base:get-time)
 202                                  :first-name "Konstantin"
 203                                  :last-name "Chernenko"
 204                                  :email "chernenko@soviet.org"))
 205
 206 (defparameter employee8 (make-instance 'employee
 207                                  :emplid 8
 208                                  :groupid 1
 209                                  :height (1+ (random 1.00))
 210                                  :married nil
 211                                  :birthday (clsql-base:get-time)
 212                                  :first-name "Mikhail"
 213                                  :last-name "Gorbachev"
 214                                  :email "gorbachev@soviet.org"))
 215
 216 (defparameter employee9 (make-instance 'employee
 217                                  :emplid 9
 218                                  :groupid 1
 219                                  :married nil
 220                                  :height (1+ (random 1.00))
 221                                  :birthday (clsql-base:get-time)
 222                                  :first-name "Boris"
 223                                  :last-name "Yeltsin"
 224                                  :email "yeltsin@soviet.org"))
 225
 226 (defparameter employee10 (make-instance 'employee
 227                                   :emplid 10
 228                                   :groupid 1
 229                                   :married nil
 230                                   :height (1+ (random 1.00))
 231                                   :birthday (clsql-base:get-time)
 232                                   :first-name "Vladamir"
 233                                   :last-name "Putin"
 234                                   :email "putin@soviet.org"))
 235
 236 (defun test-connect-to-database (database-type spec)
 237   (setf *test-database-type* database-type)
 238   (when (>= (length spec) 3)
 239     (setq *test-database-user* (third spec)))
 240
 241   ;; Connect to the database
 242   (clsql:connect spec
 243                 :database-type database-type
 244                 :make-default t
 245                 :if-exists :old))
 246
 247 (defmacro with-ignore-errors (&rest forms)
 248   `(progn
 249      ,@(mapcar
 250         (lambda (x) (list 'ignore-errors x))
 251         forms)))
 252
 253 (defun test-initialise-database ()
 254   ;; Delete the instance records
 255   (with-ignore-errors
 256     (clsql:delete-instance-records company1)
 257     (clsql:delete-instance-records employee1)
 258     (clsql:delete-instance-records employee2)
 259     (clsql:delete-instance-records employee3)
 260     (clsql:delete-instance-records employee4)
 261     (clsql:delete-instance-records employee5)
 262     (clsql:delete-instance-records employee6)
 263     (clsql:delete-instance-records employee7)
 264     (clsql:delete-instance-records employee8)
 265     (clsql:delete-instance-records employee9)
 266     (clsql:delete-instance-records employee10)
 267     ;; Drop the required tables if they exist
 268     (clsql:drop-view-from-class 'employee)
 269     (clsql:drop-view-from-class 'company))
 270   ;; Create the tables for our view classes
 271   (clsql:create-view-from-class 'employee)
 272   (clsql:create-view-from-class 'company)
 273   ;; Lenin manages everyone
 274   (clsql:add-to-relation employee2 'manager employee1)
 275   (clsql:add-to-relation employee3 'manager employee1)
 276   (clsql:add-to-relation employee4 'manager employee1)
 277   (clsql:add-to-relation employee5 'manager employee1)
 278   (clsql:add-to-relation employee6 'manager employee1)
 279   (clsql:add-to-relation employee7 'manager employee1)
 280   (clsql:add-to-relation employee8 'manager employee1)
 281   (clsql:add-to-relation employee9 'manager employee1)
 282   (clsql:add-to-relation employee10 'manager employee1)
 283   ;; Everyone works for Widgets Inc.
 284   (clsql:add-to-relation company1 'employees employee1)
 285   (clsql:add-to-relation company1 'employees employee2)
 286   (clsql:add-to-relation company1 'employees employee3)
 287   (clsql:add-to-relation company1 'employees employee4)
 288   (clsql:add-to-relation company1 'employees employee5)
 289   (clsql:add-to-relation company1 'employees employee6)
 290   (clsql:add-to-relation company1 'employees employee7)
 291   (clsql:add-to-relation company1 'employees employee8)
 292   (clsql:add-to-relation company1 'employees employee9)
 293   (clsql:add-to-relation company1 'employees employee10)
 294   ;; Lenin is president of Widgets Inc.
 295   (clsql:add-to-relation company1 'president employee1)
 296   ;; store these instances
 297   (clsql:update-records-from-instance employee1)
 298   (clsql:update-records-from-instance employee2)
 299   (clsql:update-records-from-instance employee3)
 300   (clsql:update-records-from-instance employee4)
 301   (clsql:update-records-from-instance employee5)
 302   (clsql:update-records-from-instance employee6)
 303   (clsql:update-records-from-instance employee7)
 304   (clsql:update-records-from-instance employee8)
 305   (clsql:update-records-from-instance employee9)
 306   (clsql:update-records-from-instance employee10)
 307   (clsql:update-records-from-instance company1))
 308
 309 (defun run-tests ()
 310   (let ((specs (read-specs)))
 311     (unless specs
 312       (warn "Not running tests because test configuration file is missing")
 313       (return-from run-tests :skipped))
 314     (dolist (db-type +all-db-types+)
 315       (let ((spec (db-type-spec db-type specs)))
 316         (when spec
 317           (format t
 318 "~&
 319 *******************************************************************
 320 ***     Running CLSQL tests with ~A backend.
 321 *******************************************************************
 322 " db-type)
 323           (db-type-ensure-system db-type)
 324           (regression-test:rem-all-tests)
 325           (ignore-errors (destroy-database spec :database-type db-type))
 326           (ignore-errors (create-database spec :database-type db-type))
 327           (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
 328                                 *rt-ooddl* *rt-oodml* *rt-syntax*))
 329             (eval test))
 330           (test-connect-to-database db-type spec)
 331           (test-initialise-database)
 332           (rtest:do-tests))))))
 333