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 *report-stream*)
  20 (defvar *rt-connection*)
  21 (defvar *rt-fddl*)
  22 (defvar *rt-fdml*)
  23 (defvar *rt-ooddl*)
  24 (defvar *rt-oodml*)
  25 (defvar *rt-syntax*)
  26 (defvar *rt-time*)
  27
  28 (defvar *test-database-type* nil)
  29 (defvar *test-database-underlying-type* nil)
  30 (defvar *test-database-user* nil)
  31
  32 (defclass thing ()
  33   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  34
  35 (def-view-class person (thing)
  36   ((height :db-kind :base :accessor height :type float :nulls-ok t
  37            :initarg :height)
  38    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  39             :initarg :married)
  40    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  41    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  42
  43 (def-view-class employee (person)
  44   ((emplid
  45     :db-kind :key
  46     :db-constraints :not-null
  47     :nulls-ok nil
  48     :type integer
  49     :initarg :emplid)
  50    (groupid
  51     :db-kind :key
  52     :db-constraints :not-null
  53     :nulls-ok nil
  54     :type integer
  55     :initarg :groupid)
  56    (first-name
  57     :accessor first-name
  58     :type (string 30)
  59     :initarg :first-name)
  60    (last-name
  61     :accessor last-name
  62     :type (string 30)
  63     :initarg :last-name)
  64    (email
  65     :accessor employee-email
  66     :type (string 100)
  67     :nulls-ok t
  68     :initarg :email)
  69    (companyid
  70     :type integer)
  71    (company
  72     :accessor employee-company
  73     :db-kind :join
  74     :db-info (:join-class company
  75                           :home-key companyid
  76                           :foreign-key companyid
  77                           :set nil))
  78    (managerid
  79     :type integer
  80     :nulls-ok t)
  81    (manager
  82     :accessor employee-manager
  83     :db-kind :join
  84     :db-info (:join-class employee
  85                           :home-key managerid
  86                           :foreign-key emplid
  87                           :set nil)))
  88   (:base-table employee))
  89
  90 (def-view-class company ()
  91   ((companyid
  92     :db-type :key
  93     :db-constraints :not-null
  94     :type integer
  95     :initarg :companyid)
  96    (groupid
  97     :db-type :key
  98     :db-constraints :not-null
  99     :type integer
 100     :initarg :groupid)
 101    (name
 102     :type (string 100)
 103     :initarg :name)
 104    (presidentid
 105     :type integer)
 106    (president
 107     :reader president
 108     :db-kind :join
 109     :db-info (:join-class employee
 110                           :home-key presidentid
 111                           :foreign-key emplid
 112                           :set nil))
 113    (employees
 114     :reader company-employees
 115     :db-kind :join
 116     :db-info (:join-class employee
 117                           :home-key (companyid groupid)
 118                           :foreign-key (companyid groupid)
 119                           :set t)))
 120   (:base-table company))
 121
 122
 123
 124 (defun test-connect-to-database (db-type)
 125   (let ((spec (db-type-spec db-type (read-specs))))
 126     (when (db-backend-has-create/destroy-db? db-type)
 127       (ignore-errors (destroy-database spec :database-type db-type))
 128       (ignore-errors (create-database spec :database-type db-type)))
 129
 130
 131     (setf *test-database-type* db-type)
 132     (when (>= (length spec) 3)
 133       (setq *test-database-user* (third spec)))
 134
 135     ;; Connect to the database
 136     (clsql:connect spec
 137                    :database-type db-type
 138                    :make-default t
 139                    :if-exists :old))
 140
 141   (setf *test-database-underlying-type*
 142     (clsql-sys:database-underlying-type *default-database*))
 143
 144   *default-database*)
 145
 146 (defparameter company1 nil)
 147 (defparameter employee1 nil)
 148 (defparameter employee2 nil)
 149 (defparameter employee3 nil)
 150 (defparameter employee4 nil)
 151 (defparameter employee5 nil)
 152 (defparameter employee6 nil)
 153 (defparameter employee7 nil)
 154 (defparameter employee8 nil)
 155 (defparameter employee9 nil)
 156 (defparameter employee10 nil)
 157
 158 (defun test-initialise-database ()
 159   ;; Ensure that old objects are removed
 160   (unless (db-backend-has-create/destroy-db? *test-database-type*)
 161     (truncate-database *default-database*))
 162
 163   (test-basic-initialize)
 164
 165   (clsql:create-view-from-class 'employee)
 166   (clsql:create-view-from-class 'company)
 167
 168   (setf company1 (make-instance 'company
 169                    :companyid 1
 170                    :groupid 1
 171                    :name "Widgets Inc.")
 172         employee1 (make-instance 'employee
 173                     :emplid 1
 174                     :groupid 1
 175                     :married t
 176                     :height (1+ (random 1.00))
 177                     :birthday (clsql-base:get-time)
 178                     :first-name "Vladamir"
 179                     :last-name "Lenin"
 180                     :email "lenin@soviet.org")
 181         employee2 (make-instance 'employee
 182                     :emplid 2
 183                     :groupid 1
 184                     :height (1+ (random 1.00))
 185                     :married t
 186                     :birthday (clsql-base:get-time)
 187                     :first-name "Josef"
 188                     :last-name "Stalin"
 189                     :email "stalin@soviet.org")
 190         employee3 (make-instance 'employee
 191                     :emplid 3
 192                     :groupid 1
 193                     :height (1+ (random 1.00))
 194                     :married t
 195                     :birthday (clsql-base:get-time)
 196                     :first-name "Leon"
 197                     :last-name "Trotsky"
 198                     :email "trotsky@soviet.org")
 199         employee4 (make-instance 'employee
 200                     :emplid 4
 201                     :groupid 1
 202                     :height (1+ (random 1.00))
 203                     :married nil
 204                     :birthday (clsql-base:get-time)
 205                     :first-name "Nikita"
 206                     :last-name "Kruschev"
 207                     :email "kruschev@soviet.org")
 208
 209         employee5 (make-instance 'employee
 210                     :emplid 5
 211                     :groupid 1
 212                     :married nil
 213                     :height (1+ (random 1.00))
 214                     :birthday (clsql-base:get-time)
 215                     :first-name "Leonid"
 216                     :last-name "Brezhnev"
 217                     :email "brezhnev@soviet.org")
 218
 219         employee6 (make-instance 'employee
 220                     :emplid 6
 221                     :groupid 1
 222                     :married nil
 223                     :height (1+ (random 1.00))
 224                     :birthday (clsql-base:get-time)
 225                     :first-name "Yuri"
 226                     :last-name "Andropov"
 227                     :email "andropov@soviet.org")
 228         employee7 (make-instance 'employee
 229                     :emplid 7
 230                     :groupid 1
 231                     :height (1+ (random 1.00))
 232                     :married nil
 233                     :birthday (clsql-base:get-time)
 234                     :first-name "Konstantin"
 235                     :last-name "Chernenko"
 236                     :email "chernenko@soviet.org")
 237         employee8 (make-instance 'employee
 238                     :emplid 8
 239                     :groupid 1
 240                     :height (1+ (random 1.00))
 241                     :married nil
 242                     :birthday (clsql-base:get-time)
 243                     :first-name "Mikhail"
 244                     :last-name "Gorbachev"
 245                     :email "gorbachev@soviet.org")
 246         employee9 (make-instance 'employee
 247                     :emplid 9
 248                     :groupid 1
 249                     :married nil
 250                     :height (1+ (random 1.00))
 251                     :birthday (clsql-base:get-time)
 252                     :first-name "Boris"
 253                     :last-name "Yeltsin"
 254                     :email "yeltsin@soviet.org")
 255         employee10 (make-instance 'employee
 256                      :emplid 10
 257                      :groupid 1
 258                      :married nil
 259                      :height (1+ (random 1.00))
 260                      :birthday (clsql-base:get-time)
 261                      :first-name "Vladamir"
 262                      :last-name "Putin"
 263                      :email "putin@soviet.org"))
 264
 265   ;; Lenin manages everyone
 266   (clsql:add-to-relation employee2 'manager employee1)
 267   (clsql:add-to-relation employee3 'manager employee1)
 268   (clsql:add-to-relation employee4 'manager employee1)
 269   (clsql:add-to-relation employee5 'manager employee1)
 270   (clsql:add-to-relation employee6 'manager employee1)
 271   (clsql:add-to-relation employee7 'manager employee1)
 272   (clsql:add-to-relation employee8 'manager employee1)
 273   (clsql:add-to-relation employee9 'manager employee1)
 274   (clsql:add-to-relation employee10 'manager employee1)
 275   ;; Everyone works for Widgets Inc.
 276   (clsql:add-to-relation company1 'employees employee1)
 277   (clsql:add-to-relation company1 'employees employee2)
 278   (clsql:add-to-relation company1 'employees employee3)
 279   (clsql:add-to-relation company1 'employees employee4)
 280   (clsql:add-to-relation company1 'employees employee5)
 281   (clsql:add-to-relation company1 'employees employee6)
 282   (clsql:add-to-relation company1 'employees employee7)
 283   (clsql:add-to-relation company1 'employees employee8)
 284   (clsql:add-to-relation company1 'employees employee9)
 285   (clsql:add-to-relation company1 'employees employee10)
 286   ;; Lenin is president of Widgets Inc.
 287   (clsql:add-to-relation company1 'president employee1)
 288   ;; store these instances
 289   (clsql:update-records-from-instance employee1)
 290   (clsql:update-records-from-instance employee2)
 291   (clsql:update-records-from-instance employee3)
 292   (clsql:update-records-from-instance employee4)
 293   (clsql:update-records-from-instance employee5)
 294   (clsql:update-records-from-instance employee6)
 295   (clsql:update-records-from-instance employee7)
 296   (clsql:update-records-from-instance employee8)
 297   (clsql:update-records-from-instance employee9)
 298   (clsql:update-records-from-instance employee10)
 299   (clsql:update-records-from-instance company1))
 300
 301 (defvar *error-count* 0)
 302
 303 (defun run-tests-append-report-file (report-file)
 304   (with-open-file (out report-file :direction :output
 305                        :if-exists :append
 306                        :if-does-not-exist :create)
 307     (run-tests out)))
 308
 309 (defun run-tests (&optional (*report-stream* *standard-output*))
 310   (let ((specs (read-specs))
 311         (*error-count* 0))
 312     (unless specs
 313       (warn "Not running tests because test configuration file is missing")
 314       (return-from run-tests :skipped))
 315     (load-necessary-systems specs)
 316     (dolist (db-type +all-db-types+)
 317       (unless (and (eq db-type :aodbc)
 318                    (not (member :allegro cl:*features*)))
 319         (when (db-type-spec db-type specs)
 320           (do-tests-for-backend db-type))))
 321     (zerop *error-count*)))
 322
 323 (defun load-necessary-systems (specs)
 324   (dolist (db-type +all-db-types+)
 325     (when (db-type-spec db-type specs)
 326       (db-type-ensure-system db-type))))
 327
 328 (defun do-tests-for-backend (db-type)
 329   (test-connect-to-database db-type)
 330
 331   (unwind-protect
 332       (multiple-value-bind (test-forms skip-tests)
 333           (compute-tests-for-backend db-type *test-database-underlying-type*)
 334
 335   (format *report-stream*
 336           "~&
 337 ******************************************************************************
 338 ***     CLSQL Test Suite begun at ~A
 339 ***     ~A
 340 ***     ~A
 341 ***     Database ~A backend~A.
 342 ******************************************************************************
 343 "
 344 (clsql-base:format-time nil (clsql-base:utime->time (get-universal-time)))
 345 (lisp-implementation-type)
 346 (lisp-implementation-version)
 347 db-type
 348 (if (not (eq db-type *test-database-underlying-type*))
 349     (format nil " with underlying type ~A" *test-database-underlying-type*)
 350     "")
 351 )
 352
 353         (test-initialise-database)
 354
 355         (regression-test:rem-all-tests)
 356         (dolist (test-form test-forms)
 357           (eval test-form))
 358
 359         (let ((remaining (rtest:do-tests *report-stream*)))
 360           (when (consp remaining)
 361             (incf *error-count* (length remaining))))
 362
 363         (format *report-stream* "~&Tests skipped:")
 364         (if skip-tests
 365             (dolist (skipped skip-tests)
 366               (format *report-stream*
 367                       "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 368           (format *report-stream* " None~%")))
 369     (disconnect)))
 370
 371
 372 (defun compute-tests-for-backend (db-type db-underlying-type)
 373   (let ((test-forms '())
 374         (skip-tests '()))
 375     (dolist (test-form (append
 376                         (if (eq db-type :sqlite)
 377                             (test-basic-forms-untyped)
 378                           (test-basic-forms))
 379                         *rt-connection* *rt-fddl* *rt-fdml*
 380                         *rt-ooddl* *rt-oodml* *rt-syntax*))
 381       (let ((test (second test-form)))
 382         (cond
 383           ((and (null (db-type-has-views? db-underlying-type))
 384                 (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 385            (push (cons test "views not supported") skip-tests))
 386           ((and (null (db-type-has-boolean-where? db-underlying-type))
 387                 (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
 388            (push (cons test "boolean where not supported") skip-tests))
 389           ((and (null (db-type-has-subqueries? db-underlying-type))
 390                 (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
 391            (push (cons test "subqueries not supported") skip-tests))
 392           ((and (null (db-type-transaction-capable? db-underlying-type
 393                                                     *default-database*))
 394                 (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 395            (push (cons test "transactions not supported") skip-tests))
 396           ((and (null (db-type-has-fancy-math? db-underlying-type))
 397                 (clsql-base-sys::in test :fdml/select/1))
 398            (push (cons test "fancy math not supported") skip-tests))
 399           ((and (eql *test-database-type* :sqlite)
 400                 (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
 401            (push (cons test "not supported by sqlite") skip-tests))
 402           (t
 403            (push test-form test-forms)))))
 404     (values (nreverse test-forms) (nreverse skip-tests))))
 405