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 ;;;; This file is part of CLSQL.
  11 ;;;;
  12 ;;;; CLSQL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; ======================================================================
  16
  17 (in-package #:clsql-tests)
  18
  19 (defvar *rt-connection*)
  20 (defvar *rt-fddl*)
  21 (defvar *rt-fdml*)
  22 (defvar *rt-ooddl*)
  23 (defvar *rt-oodml*)
  24 (defvar *rt-syntax*)
  25 (defvar *rt-time*)
  26
  27 (defvar *test-database-type* nil)
  28 (defvar *test-database-underlying-type* nil)
  29 (defvar *test-database-user* nil)
  30
  31 (defclass thing ()
  32   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  33
  34 (def-view-class person (thing)
  35   ((height :db-kind :base :accessor height :type float :nulls-ok t
  36            :initarg :height)
  37    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  38             :initarg :married)
  39    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  40    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  41
  42 (def-view-class employee (person)
  43   ((emplid
  44     :db-kind :key
  45     :db-constraints :not-null
  46     :nulls-ok nil
  47     :type integer
  48     :initarg :emplid)
  49    (groupid
  50     :db-kind :key
  51     :db-constraints :not-null
  52     :nulls-ok nil
  53     :type integer
  54     :initarg :groupid)
  55    (first-name
  56     :accessor first-name
  57     :type (string 30)
  58     :initarg :first-name)
  59    (last-name
  60     :accessor last-name
  61     :type (string 30)
  62     :initarg :last-name)
  63    (email
  64     :accessor employee-email
  65     :type (string 100)
  66     :nulls-ok t
  67     :initarg :email)
  68    (companyid
  69     :type integer)
  70    (company
  71     :accessor employee-company
  72     :db-kind :join
  73     :db-info (:join-class company
  74                           :home-key companyid
  75                           :foreign-key companyid
  76                           :set nil))
  77    (managerid
  78     :type integer
  79     :nulls-ok t)
  80    (manager
  81     :accessor employee-manager
  82     :db-kind :join
  83     :db-info (:join-class employee
  84                           :home-key managerid
  85                           :foreign-key emplid
  86                           :set nil)))
  87   (:base-table employee))
  88
  89 (def-view-class company ()
  90   ((companyid
  91     :db-type :key
  92     :db-constraints :not-null
  93     :type integer
  94     :initarg :companyid)
  95    (groupid
  96     :db-type :key
  97     :db-constraints :not-null
  98     :type integer
  99     :initarg :groupid)
 100    (name
 101     :type (string 100)
 102     :initarg :name)
 103    (presidentid
 104     :type integer)
 105    (president
 106     :reader president
 107     :db-kind :join
 108     :db-info (:join-class employee
 109                           :home-key presidentid
 110                           :foreign-key emplid
 111                           :set nil))
 112    (employees
 113     :reader company-employees
 114     :db-kind :join
 115     :db-info (:join-class employee
 116                           :home-key (companyid groupid)
 117                           :foreign-key (companyid groupid)
 118                           :set t)))
 119   (:base-table company))
 120
 121
 122
 123 (defun test-connect-to-database (database-type spec)
 124   (setf *test-database-type* database-type)
 125   (when (>= (length spec) 3)
 126     (setq *test-database-user* (third spec)))
 127
 128   ;; Connect to the database
 129   (clsql:connect spec
 130                  :database-type database-type
 131                  :make-default t
 132                  :if-exists :old)
 133
 134   (setf *test-database-underlying-type*
 135         (clsql-sys:database-underlying-type *default-database*))
 136
 137   *default-database*)
 138
 139 (defparameter company1 nil)
 140 (defparameter employee1 nil)
 141 (defparameter employee2 nil)
 142 (defparameter employee3 nil)
 143 (defparameter employee4 nil)
 144 (defparameter employee5 nil)
 145 (defparameter employee6 nil)
 146 (defparameter employee7 nil)
 147 (defparameter employee8 nil)
 148 (defparameter employee9 nil)
 149 (defparameter employee10 nil)
 150
 151 (defun test-initialise-database ()
 152   ;; Remove the tables to support cases when destroy-database isn't supported, like odbc
 153   (ignore-errors (clsql:drop-table "EMPLOYEE"))
 154   (ignore-errors (clsql:drop-table "COMPANY"))
 155   (ignore-errors (clsql:drop-table "FOO"))
 156   (clsql:create-view-from-class 'employee)
 157   (clsql:create-view-from-class 'company)
 158
 159   (setf company1 (make-instance 'company
 160                    :companyid 1
 161                    :groupid 1
 162                    :name "Widgets Inc.")
 163         employee1 (make-instance 'employee
 164                     :emplid 1
 165                     :groupid 1
 166                     :married t
 167                     :height (1+ (random 1.00))
 168                     :birthday (clsql-base:get-time)
 169                     :first-name "Vladamir"
 170                     :last-name "Lenin"
 171                     :email "lenin@soviet.org")
 172         employee2 (make-instance 'employee
 173                     :emplid 2
 174                     :groupid 1
 175                     :height (1+ (random 1.00))
 176                     :married t
 177                     :birthday (clsql-base:get-time)
 178                     :first-name "Josef"
 179                     :last-name "Stalin"
 180                     :email "stalin@soviet.org")
 181         employee3 (make-instance 'employee
 182                     :emplid 3
 183                     :groupid 1
 184                     :height (1+ (random 1.00))
 185                     :married t
 186                     :birthday (clsql-base:get-time)
 187                     :first-name "Leon"
 188                     :last-name "Trotsky"
 189                     :email "trotsky@soviet.org")
 190         employee4 (make-instance 'employee
 191                     :emplid 4
 192                     :groupid 1
 193                     :height (1+ (random 1.00))
 194                     :married nil
 195                     :birthday (clsql-base:get-time)
 196                     :first-name "Nikita"
 197                     :last-name "Kruschev"
 198                     :email "kruschev@soviet.org")
 199
 200         employee5 (make-instance 'employee
 201                     :emplid 5
 202                     :groupid 1
 203                     :married nil
 204                     :height (1+ (random 1.00))
 205                     :birthday (clsql-base:get-time)
 206                     :first-name "Leonid"
 207                     :last-name "Brezhnev"
 208                     :email "brezhnev@soviet.org")
 209
 210         employee6 (make-instance 'employee
 211                     :emplid 6
 212                     :groupid 1
 213                     :married nil
 214                     :height (1+ (random 1.00))
 215                     :birthday (clsql-base:get-time)
 216                     :first-name "Yuri"
 217                     :last-name "Andropov"
 218                     :email "andropov@soviet.org")
 219         employee7 (make-instance 'employee
 220                     :emplid 7
 221                     :groupid 1
 222                     :height (1+ (random 1.00))
 223                     :married nil
 224                     :birthday (clsql-base:get-time)
 225                     :first-name "Konstantin"
 226                     :last-name "Chernenko"
 227                     :email "chernenko@soviet.org")
 228         employee8 (make-instance 'employee
 229                     :emplid 8
 230                     :groupid 1
 231                     :height (1+ (random 1.00))
 232                     :married nil
 233                     :birthday (clsql-base:get-time)
 234                     :first-name "Mikhail"
 235                     :last-name "Gorbachev"
 236                     :email "gorbachev@soviet.org")
 237         employee9 (make-instance 'employee
 238                     :emplid 9
 239                     :groupid 1
 240                     :married nil
 241                     :height (1+ (random 1.00))
 242                     :birthday (clsql-base:get-time)
 243                     :first-name "Boris"
 244                     :last-name "Yeltsin"
 245                     :email "yeltsin@soviet.org")
 246         employee10 (make-instance 'employee
 247                      :emplid 10
 248                      :groupid 1
 249                      :married nil
 250                      :height (1+ (random 1.00))
 251                      :birthday (clsql-base:get-time)
 252                      :first-name "Vladamir"
 253                      :last-name "Putin"
 254                      :email "putin@soviet.org"))
 255
 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 (defvar *error-count* 0)
 293
 294 (defun run-tests ()
 295   (let ((specs (read-specs))
 296         (*error-count* 0))
 297     (unless specs
 298       (warn "Not running tests because test configuration file is missing")
 299       (return-from run-tests :skipped))
 300     (load-necessary-systems specs)
 301     (dolist (db-type +all-db-types+)
 302       (let ((spec (db-type-spec db-type specs)))
 303         (when spec
 304           (do-tests-for-backend spec db-type))))
 305     (zerop *error-count*)))
 306
 307 (defun load-necessary-systems (specs)
 308   (dolist (db-type +all-db-types+)
 309     (when (db-type-spec db-type specs)
 310       (db-type-ensure-system db-type))))
 311
 312 (defun do-tests-for-backend (spec db-type)
 313   (format t
 314           "~&
 315 *******************************************************************
 316 ***     Running CLSQL tests with ~A backend.
 317 *******************************************************************
 318 " db-type)
 319   (regression-test:rem-all-tests)
 320
 321   ;; Tests of clsql-base
 322   (ignore-errors (destroy-database spec :database-type db-type))
 323   (ignore-errors (create-database spec :database-type db-type))
 324   (with-tests (:name "CLSQL")
 325     (test-basic spec db-type))
 326   (incf *error-count* *test-errors*)
 327
 328   (when (db-backend-has-create/destroy-db? db-type)
 329     (ignore-errors (destroy-database spec :database-type db-type))
 330     (ignore-errors (create-database spec :database-type db-type)))
 331
 332   (test-connect-to-database db-type spec)
 333
 334   (dolist (test-form (append *rt-connection* *rt-fddl* *rt-fdml*
 335                         *rt-ooddl* *rt-oodml* *rt-syntax*))
 336     (let ((test (second test-form)))
 337       (cond
 338         ((and (null (db-type-has-views? *test-database-underlying-type*))
 339               (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 340          ;; skip test
 341          )
 342         ((and (null (db-type-has-boolean-where? *test-database-underlying-type*))
 343               (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
 344          ;; skip tests
 345          )
 346         ((and (null (db-type-has-subqueries? *test-database-underlying-type*))
 347               (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
 348          ;; skip tests
 349          )
 350         ((and (null (db-type-transaction-capable? *test-database-underlying-type* *default-database*))
 351               (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 352          ;; skip tests
 353          )
 354         ((and (eql *test-database-type* :sqlite)
 355               (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
 356          ;; skip tests
 357          )
 358         (t
 359          (eval test-form)))))
 360
 361   (test-initialise-database)
 362   (let ((remaining (rtest:do-tests)))
 363     (when (consp remaining)
 364       (incf *error-count* (length remaining))))
 365   (disconnect))
 366