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 (db-type)
 124   (let ((spec (db-type-spec db-type (read-specs))))
 125     (when (db-backend-has-create/destroy-db? db-type)
 126       (ignore-errors (destroy-database spec :database-type db-type))
 127       (ignore-errors (create-database spec :database-type db-type)))
 128
 129
 130     (setf *test-database-type* db-type)
 131     (when (>= (length spec) 3)
 132       (setq *test-database-user* (third spec)))
 133
 134     ;; Connect to the database
 135     (clsql:connect spec
 136                    :database-type db-type
 137                    :make-default t
 138                    :if-exists :old))
 139
 140   (setf *test-database-underlying-type*
 141     (clsql-sys:database-underlying-type *default-database*))
 142
 143   *default-database*)
 144
 145 (defparameter company1 nil)
 146 (defparameter employee1 nil)
 147 (defparameter employee2 nil)
 148 (defparameter employee3 nil)
 149 (defparameter employee4 nil)
 150 (defparameter employee5 nil)
 151 (defparameter employee6 nil)
 152 (defparameter employee7 nil)
 153 (defparameter employee8 nil)
 154 (defparameter employee9 nil)
 155 (defparameter employee10 nil)
 156
 157 (defun test-initialise-database ()
 158   ;; Ensure that old objects are removed
 159   (unless (db-backend-has-create/destroy-db? *test-database-type*)
 160     (truncate-database *default-database*))
 161
 162   (test-basic-initialize)
 163
 164   (clsql:create-view-from-class 'employee)
 165   (clsql:create-view-from-class 'company)
 166
 167   (setf company1 (make-instance 'company
 168                    :companyid 1
 169                    :groupid 1
 170                    :name "Widgets Inc.")
 171         employee1 (make-instance 'employee
 172                     :emplid 1
 173                     :groupid 1
 174                     :married t
 175                     :height (1+ (random 1.00))
 176                     :birthday (clsql-base:get-time)
 177                     :first-name "Vladamir"
 178                     :last-name "Lenin"
 179                     :email "lenin@soviet.org")
 180         employee2 (make-instance 'employee
 181                     :emplid 2
 182                     :groupid 1
 183                     :height (1+ (random 1.00))
 184                     :married t
 185                     :birthday (clsql-base:get-time)
 186                     :first-name "Josef"
 187                     :last-name "Stalin"
 188                     :email "stalin@soviet.org")
 189         employee3 (make-instance 'employee
 190                     :emplid 3
 191                     :groupid 1
 192                     :height (1+ (random 1.00))
 193                     :married t
 194                     :birthday (clsql-base:get-time)
 195                     :first-name "Leon"
 196                     :last-name "Trotsky"
 197                     :email "trotsky@soviet.org")
 198         employee4 (make-instance 'employee
 199                     :emplid 4
 200                     :groupid 1
 201                     :height (1+ (random 1.00))
 202                     :married nil
 203                     :birthday (clsql-base:get-time)
 204                     :first-name "Nikita"
 205                     :last-name "Kruschev"
 206                     :email "kruschev@soviet.org")
 207
 208         employee5 (make-instance 'employee
 209                     :emplid 5
 210                     :groupid 1
 211                     :married nil
 212                     :height (1+ (random 1.00))
 213                     :birthday (clsql-base:get-time)
 214                     :first-name "Leonid"
 215                     :last-name "Brezhnev"
 216                     :email "brezhnev@soviet.org")
 217
 218         employee6 (make-instance 'employee
 219                     :emplid 6
 220                     :groupid 1
 221                     :married nil
 222                     :height (1+ (random 1.00))
 223                     :birthday (clsql-base:get-time)
 224                     :first-name "Yuri"
 225                     :last-name "Andropov"
 226                     :email "andropov@soviet.org")
 227         employee7 (make-instance 'employee
 228                     :emplid 7
 229                     :groupid 1
 230                     :height (1+ (random 1.00))
 231                     :married nil
 232                     :birthday (clsql-base:get-time)
 233                     :first-name "Konstantin"
 234                     :last-name "Chernenko"
 235                     :email "chernenko@soviet.org")
 236         employee8 (make-instance 'employee
 237                     :emplid 8
 238                     :groupid 1
 239                     :height (1+ (random 1.00))
 240                     :married nil
 241                     :birthday (clsql-base:get-time)
 242                     :first-name "Mikhail"
 243                     :last-name "Gorbachev"
 244                     :email "gorbachev@soviet.org")
 245         employee9 (make-instance 'employee
 246                     :emplid 9
 247                     :groupid 1
 248                     :married nil
 249                     :height (1+ (random 1.00))
 250                     :birthday (clsql-base:get-time)
 251                     :first-name "Boris"
 252                     :last-name "Yeltsin"
 253                     :email "yeltsin@soviet.org")
 254         employee10 (make-instance 'employee
 255                      :emplid 10
 256                      :groupid 1
 257                      :married nil
 258                      :height (1+ (random 1.00))
 259                      :birthday (clsql-base:get-time)
 260                      :first-name "Vladamir"
 261                      :last-name "Putin"
 262                      :email "putin@soviet.org"))
 263
 264   ;; Lenin manages everyone
 265   (clsql:add-to-relation employee2 'manager employee1)
 266   (clsql:add-to-relation employee3 'manager employee1)
 267   (clsql:add-to-relation employee4 'manager employee1)
 268   (clsql:add-to-relation employee5 'manager employee1)
 269   (clsql:add-to-relation employee6 'manager employee1)
 270   (clsql:add-to-relation employee7 'manager employee1)
 271   (clsql:add-to-relation employee8 'manager employee1)
 272   (clsql:add-to-relation employee9 'manager employee1)
 273   (clsql:add-to-relation employee10 'manager employee1)
 274   ;; Everyone works for Widgets Inc.
 275   (clsql:add-to-relation company1 'employees employee1)
 276   (clsql:add-to-relation company1 'employees employee2)
 277   (clsql:add-to-relation company1 'employees employee3)
 278   (clsql:add-to-relation company1 'employees employee4)
 279   (clsql:add-to-relation company1 'employees employee5)
 280   (clsql:add-to-relation company1 'employees employee6)
 281   (clsql:add-to-relation company1 'employees employee7)
 282   (clsql:add-to-relation company1 'employees employee8)
 283   (clsql:add-to-relation company1 'employees employee9)
 284   (clsql:add-to-relation company1 'employees employee10)
 285   ;; Lenin is president of Widgets Inc.
 286   (clsql:add-to-relation company1 'president employee1)
 287   ;; store these instances
 288   (clsql:update-records-from-instance employee1)
 289   (clsql:update-records-from-instance employee2)
 290   (clsql:update-records-from-instance employee3)
 291   (clsql:update-records-from-instance employee4)
 292   (clsql:update-records-from-instance employee5)
 293   (clsql:update-records-from-instance employee6)
 294   (clsql:update-records-from-instance employee7)
 295   (clsql:update-records-from-instance employee8)
 296   (clsql:update-records-from-instance employee9)
 297   (clsql:update-records-from-instance employee10)
 298   (clsql:update-records-from-instance company1))
 299
 300 (defvar *error-count* 0)
 301
 302 (defun run-tests ()
 303   (let ((specs (read-specs))
 304         (*error-count* 0))
 305     (unless specs
 306       (warn "Not running tests because test configuration file is missing")
 307       (return-from run-tests :skipped))
 308     (load-necessary-systems specs)
 309     (dolist (db-type +all-db-types+)
 310       (when (db-type-spec db-type specs)
 311         (do-tests-for-backend db-type)))
 312     (zerop *error-count*)))
 313
 314 (defun load-necessary-systems (specs)
 315   (dolist (db-type +all-db-types+)
 316     (when (db-type-spec db-type specs)
 317       (db-type-ensure-system db-type))))
 318
 319 (defun do-tests-for-backend (db-type)
 320   (format t
 321           "~&
 322 *******************************************************************
 323 ***     Running CLSQL tests with ~A backend.
 324 *******************************************************************
 325 " db-type)
 326
 327   (test-connect-to-database db-type)
 328   (unwind-protect
 329       (multiple-value-bind (test-forms skip-tests)
 330           (compute-tests-for-backend db-type *test-database-underlying-type*)
 331
 332         (test-initialise-database)
 333
 334         (regression-test:rem-all-tests)
 335         (dolist (test-form test-forms)
 336           (eval test-form))
 337
 338         (let ((remaining (rtest:do-tests)))
 339           (when (consp remaining)
 340             (incf *error-count* (length remaining))))
 341
 342         (format t "~&Tests skipped for ~A:" db-type)
 343         (if skip-tests
 344             (dolist (skipped skip-tests)
 345               (format t "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 346           (format t " None~%")))
 347     (disconnect)))
 348
 349
 350 (defun compute-tests-for-backend (db-type db-underlying-type)
 351   (declare (ignore db-type))
 352   (let ((test-forms '())
 353         (skip-tests '()))
 354     (dolist (test-form (append
 355                         (if (eq db-type :sqlite)
 356                             (test-basic-forms-untyped)
 357                           (test-basic-forms))
 358                         *rt-connection* *rt-fddl* *rt-fdml*
 359                         *rt-ooddl* *rt-oodml* *rt-syntax*))
 360       (let ((test (second test-form)))
 361         (cond
 362           ((and (null (db-type-has-views? db-underlying-type))
 363                 (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 364            (push (cons test "views not supported") skip-tests))
 365           ((and (null (db-type-has-boolean-where? db-underlying-type))
 366                 (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
 367            (push (cons test "boolean where not supported") skip-tests))
 368           ((and (null (db-type-has-subqueries? db-underlying-type))
 369                 (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
 370            (push (cons test "subqueries not supported") skip-tests))
 371           ((and (null (db-type-transaction-capable? db-underlying-type
 372                                                     *default-database*))
 373                 (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 374            (push (cons test "transactions not supported") skip-tests))
 375           ((and (null (db-type-has-fancy-math? db-underlying-type))
 376                 (clsql-base-sys::in test :fdml/select/1))
 377            (push (cons test "fancy math not supported") skip-tests))
 378           ((and (eql *test-database-type* :sqlite)
 379                 (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
 380            (push (cons test "not supported by sqlite") skip-tests))
 381           (t
 382            (push test-form test-forms)))))
 383     (values (nreverse test-forms) (nreverse skip-tests))))
 384