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* nil "Stream to send text report.")
  20 (defvar *sexp-report-stream* nil "Stream to send sexp report.")
  21 (defvar *rt-connection*)
  22 (defvar *rt-fddl*)
  23 (defvar *rt-fdml*)
  24 (defvar *rt-ooddl*)
  25 (defvar *rt-oodml*)
  26 (defvar *rt-syntax*)
  27 (defvar *rt-time*)
  28
  29 (defvar *test-database-type* nil)
  30 (defvar *test-database-underlying-type* nil)
  31 (defvar *test-database-user* nil)
  32
  33 (defclass thing ()
  34   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  35
  36 (def-view-class person (thing)
  37   ((height :db-kind :base :accessor height :type float :nulls-ok t
  38            :initarg :height)
  39    (married :db-kind :base :accessor married :type boolean :nulls-ok t
  40             :initarg :married)
  41    (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday)
  42    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  43
  44 (def-view-class employee (person)
  45   ((emplid
  46     :db-kind :key
  47     :db-constraints :not-null
  48     :nulls-ok nil
  49     :type integer
  50     :initarg :emplid)
  51    (groupid
  52     :db-kind :key
  53     :db-constraints :not-null
  54     :nulls-ok nil
  55     :type integer
  56     :initarg :groupid)
  57    (first-name
  58     :accessor first-name
  59     :type (string 30)
  60     :initarg :first-name)
  61    (last-name
  62     :accessor last-name
  63     :type (string 30)
  64     :initarg :last-name)
  65    (email
  66     :accessor employee-email
  67     :type (string 100)
  68     :nulls-ok t
  69     :initarg :email)
  70    (companyid
  71     :type integer)
  72    (company
  73     :accessor employee-company
  74     :db-kind :join
  75     :db-info (:join-class company
  76                           :home-key companyid
  77                           :foreign-key companyid
  78                           :set nil))
  79    (managerid
  80     :type integer
  81     :nulls-ok t)
  82    (manager
  83     :accessor employee-manager
  84     :db-kind :join
  85     :db-info (:join-class employee
  86                           :home-key managerid
  87                           :foreign-key emplid
  88                           :set nil)))
  89   (:base-table employee))
  90
  91 (def-view-class company ()
  92   ((companyid
  93     :db-type :key
  94     :db-constraints :not-null
  95     :type integer
  96     :initarg :companyid)
  97    (groupid
  98     :db-type :key
  99     :db-constraints :not-null
 100     :type integer
 101     :initarg :groupid)
 102    (name
 103     :type (string 100)
 104     :initarg :name)
 105    (presidentid
 106     :type integer)
 107    (president
 108     :reader president
 109     :db-kind :join
 110     :db-info (:join-class employee
 111                           :home-key presidentid
 112                           :foreign-key emplid
 113                           :set nil))
 114    (employees
 115     :reader company-employees
 116     :db-kind :join
 117     :db-info (:join-class employee
 118                           :home-key (companyid groupid)
 119                           :foreign-key (companyid groupid)
 120                           :set t)))
 121   (:base-table company))
 122
 123
 124
 125 (defun test-connect-to-database (db-type spec)
 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   (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   ;; Ensure database is empty
 141   (truncate-database :database *default-database*)
 142
 143   (setf *test-database-underlying-type*
 144         (clsql-sys:database-underlying-type *default-database*))
 145
 146   *default-database*)
 147
 148 (defparameter company1 nil)
 149 (defparameter employee1 nil)
 150 (defparameter employee2 nil)
 151 (defparameter employee3 nil)
 152 (defparameter employee4 nil)
 153 (defparameter employee5 nil)
 154 (defparameter employee6 nil)
 155 (defparameter employee7 nil)
 156 (defparameter employee8 nil)
 157 (defparameter employee9 nil)
 158 (defparameter employee10 nil)
 159
 160 (defun test-initialise-database ()
 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 (defvar *error-list* nil)
 304
 305 (defun run-tests-append-report-file (report-file)
 306   (let* ((report-path (etypecase report-file
 307                         (pathname report-file)
 308                         (string (parse-namestring report-file))))
 309          (sexp-report-path (make-pathname :defaults report-path
 310                                           :type "sexp")))
 311   (with-open-file (rs report-path :direction :output
 312                       :if-exists :append
 313                       :if-does-not-exist :create)
 314     (with-open-file (srs sexp-report-path :direction :output
 315                          :if-exists :append
 316                          :if-does-not-exist :create)
 317       (run-tests :report-stream rs :sexp-report-stream srs)))))
 318
 319 (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
 320   (let ((specs (read-specs))
 321         (*report-stream* report-stream)
 322         (*sexp-report-stream* sexp-report-stream)
 323         (*error-count* 0)
 324         (*error-list* nil))
 325     (unless specs
 326       (warn "Not running tests because test configuration file is missing")
 327       (return-from run-tests :skipped))
 328     (load-necessary-systems specs)
 329     (dolist (db-type +all-db-types+)
 330       (dolist (spec (db-type-spec db-type specs))
 331         (do-tests-for-backend db-type spec))))
 332   (zerop *error-count*))
 333
 334 (defun load-necessary-systems (specs)
 335   (dolist (db-type +all-db-types+)
 336     (when (db-type-spec db-type specs)
 337       (clsql:initialize-database-type :database-type db-type))))
 338
 339 (defun do-tests-for-backend (db-type spec)
 340   (test-connect-to-database db-type spec)
 341
 342   (unwind-protect
 343       (multiple-value-bind (test-forms skip-tests)
 344           (compute-tests-for-backend db-type *test-database-underlying-type*)
 345
 346         (format *report-stream*
 347                 "~&
 348 ******************************************************************************
 349 ***     CLSQL Test Suite begun at ~A
 350 ***     ~A
 351 ***     ~A on ~A
 352 ***     Database ~A backend~A.
 353 ******************************************************************************
 354 "
 355                 (clsql-base:format-time
 356                  nil
 357                  (clsql-base:utime->time (get-universal-time)))
 358                 (lisp-implementation-type)
 359                 (lisp-implementation-version)
 360                 (machine-type)
 361                 db-type
 362                 (if (not (eq db-type *test-database-underlying-type*))
 363                     (format nil " with underlying type ~A"
 364                             *test-database-underlying-type*)
 365                   "")
 366                 )
 367
 368         (test-initialise-database)
 369
 370         (regression-test:rem-all-tests)
 371         (dolist (test-form test-forms)
 372           (eval test-form))
 373
 374         (let ((remaining (regression-test:do-tests *report-stream*)))
 375           (when (regression-test:pending-tests)
 376             (incf *error-count* (length remaining))))
 377
 378         (let ((sexp-error (list db-type
 379                                 *test-database-underlying-type*
 380                                 (get-universal-time)
 381                                 (length test-forms)
 382                                 (regression-test:pending-tests)
 383                                 (lisp-implementation-type)
 384                                 (lisp-implementation-version)
 385                                 (machine-type))))
 386           (when *sexp-report-stream*
 387             (write sexp-error :stream *sexp-report-stream*))
 388           (push sexp-error *error-list*))
 389
 390         (format *report-stream* "~&Tests skipped:")
 391         (if skip-tests
 392             (dolist (skipped skip-tests)
 393               (format *report-stream*
 394                       "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 395           (format *report-stream* " None~%")))
 396     (disconnect)))
 397
 398
 399 (defun compute-tests-for-backend (db-type db-underlying-type)
 400   (let ((test-forms '())
 401         (skip-tests '()))
 402     (dolist (test-form (append (test-basic-forms)
 403                                *rt-connection* *rt-fddl* *rt-fdml*
 404                                *rt-ooddl* *rt-oodml* *rt-syntax*))
 405       (let ((test (second test-form)))
 406         (cond
 407           ((and (null (db-type-has-views? db-underlying-type))
 408                 (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 409            (push (cons test "views not supported") skip-tests))
 410           ((and (null (db-type-has-boolean-where? db-underlying-type))
 411                 (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
 412            (push (cons test "boolean where not supported") skip-tests))
 413           ((and (null (db-type-has-subqueries? db-underlying-type))
 414                 (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
 415            (push (cons test "subqueries not supported") skip-tests))
 416           ((and (null (db-type-transaction-capable? db-underlying-type
 417                                                     *default-database*))
 418                 (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 419            (push (cons test "transactions not supported") skip-tests))
 420           ((and (null (db-type-has-fancy-math? db-underlying-type))
 421                 (clsql-base-sys::in test :fdml/select/1))
 422            (push (cons test "fancy math not supported") skip-tests))
 423           ((and (eql *test-database-type* :sqlite)
 424                 (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
 425            (push (cons test "not supported by sqlite") skip-tests))
 426           (t
 427            (push test-form test-forms)))))
 428     (values (nreverse test-forms) (nreverse skip-tests))))
 429