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