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