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
 115
 116 (defun test-connect-to-database (database-type spec)
 117   (setf *test-database-type* database-type)
 118   (when (>= (length spec) 3)
 119     (setq *test-database-user* (third spec)))
 120
 121   ;; Connect to the database
 122   (clsql:connect spec
 123                  :database-type database-type
 124                  :make-default t
 125                  :if-exists :old))
 126
 127 (defmacro with-ignore-errors (&rest forms)
 128   `(progn
 129      ,@(mapcar
 130         (lambda (x) (list 'ignore-errors x))
 131         forms)))
 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   ;; Create the tables for our view classes
 147   (ignore-errors
 148    (clsql:drop-view-from-class 'employee)
 149    (clsql:drop-view-from-class 'company))
 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   (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
 325                         *rt-ooddl* *rt-oodml* *rt-syntax*))
 326     (eval test))
 327   (test-connect-to-database db-type spec)
 328   (test-initialise-database)
 329   (let ((remaining (rtest:do-tests)))
 330     (when (consp remaining)
 331       (incf *error-count* (length remaining))))
 332   (disconnect))
 333