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