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
  38            :initarg :height)
  39    (married :db-kind :base :accessor married :type boolean
  40             :initarg :married)
  41    (birthday :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     :type integer
  49     :initarg :emplid)
  50    (groupid
  51     :db-kind :key
  52     :db-constraints :not-null
  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     :initarg :email)
  67    (companyid
  68     :type integer)
  69    (company
  70     :accessor employee-company
  71     :db-kind :join
  72     :db-info (:join-class company
  73                           :home-key companyid
  74                           :foreign-key companyid
  75                           :set nil))
  76    (managerid
  77     :type integer)
  78    (manager
  79     :accessor employee-manager
  80     :db-kind :join
  81     :db-info (:join-class employee
  82                           :home-key managerid
  83                           :foreign-key emplid
  84                           :set nil)))
  85   (:base-table employee))
  86
  87 (def-view-class company ()
  88   ((companyid
  89     :db-kind :key
  90     :db-constraints :not-null
  91     :type integer
  92     :initarg :companyid)
  93    (groupid
  94     :db-kind :key
  95     :db-constraints :not-null
  96     :type integer
  97     :initarg :groupid)
  98    (name
  99     :type (string 100)
 100     :initarg :name)
 101    (presidentid
 102     :type integer)
 103    (president
 104     :reader president
 105     :db-kind :join
 106     :db-info (:join-class employee
 107                           :home-key presidentid
 108                           :foreign-key emplid
 109                           :set nil))
 110    (employees
 111     :reader company-employees
 112     :db-kind :join
 113     :db-info (:join-class employee
 114                           :home-key (companyid groupid)
 115                           :foreign-key (companyid groupid)
 116                           :set t)))
 117   (:base-table company))
 118
 119
 120 (def-view-class address ()
 121   ((emplid
 122     :db-kind :key
 123     :db-constraints :not-null
 124     :type integer
 125     :initarg :emplid)
 126    (street-number
 127     :type integer
 128     :initarg :street-number)
 129    (street-name
 130     :type (string 30)
 131     :void-value ""
 132     :initarg :street-name)
 133    (city
 134     :column "city_field"
 135     :void-value "no city"
 136     :type (string 30)
 137     :initarg :city)
 138    (postal-code
 139     :column "zip"
 140     :type integer
 141     :void-value 0
 142     :initarg :postal-code)))
 143
 144 (defun test-connect-to-database (db-type spec)
 145   (when (db-backend-has-create/destroy-db? db-type)
 146     (ignore-errors (destroy-database spec :database-type db-type))
 147     (ignore-errors (create-database spec :database-type db-type)))
 148
 149   (setf *test-database-type* db-type)
 150   (when (>= (length spec) 3)
 151     (setq *test-database-user* (third spec)))
 152
 153   ;; Connect to the database
 154   (clsql:connect spec
 155                  :database-type db-type
 156                  :make-default t
 157                  :if-exists :old)
 158
 159   ;; Ensure database is empty
 160   (truncate-database :database *default-database*)
 161
 162   (setf *test-database-underlying-type*
 163         (clsql-sys:database-underlying-type *default-database*))
 164
 165   *default-database*)
 166
 167 (defparameter company1 nil)
 168 (defparameter employee1 nil)
 169 (defparameter employee2 nil)
 170 (defparameter employee3 nil)
 171 (defparameter employee4 nil)
 172 (defparameter employee5 nil)
 173 (defparameter employee6 nil)
 174 (defparameter employee7 nil)
 175 (defparameter employee8 nil)
 176 (defparameter employee9 nil)
 177 (defparameter employee10 nil)
 178 (defparameter address1 nil)
 179 (defparameter address2 nil)
 180
 181 (defun test-initialise-database ()
 182   (test-basic-initialize)
 183
 184   (let ((*backend-warning-behavior*
 185          (if (member *test-database-type* '(:postgresql :postgresql-socket))
 186              :ignore
 187            :warn)))
 188     (clsql:create-view-from-class 'employee)
 189     (clsql:create-view-from-class 'company)
 190     (clsql:create-view-from-class 'address))
 191
 192   (setf company1 (make-instance 'company
 193                    :companyid 1
 194                    :groupid 1
 195                    :name "Widgets Inc.")
 196         employee1 (make-instance 'employee
 197                     :emplid 1
 198                     :groupid 1
 199                     :married t
 200                     :height (1+ (random 1.00))
 201                     :birthday (clsql-base:get-time)
 202                     :first-name "Vladamir"
 203                     :last-name "Lenin"
 204                     :email "lenin@soviet.org")
 205         employee2 (make-instance 'employee
 206                     :emplid 2
 207                     :groupid 1
 208                     :height (1+ (random 1.00))
 209                     :married t
 210                     :birthday (clsql-base:get-time)
 211                     :first-name "Josef"
 212                     :last-name "Stalin"
 213                     :email "stalin@soviet.org")
 214         employee3 (make-instance 'employee
 215                     :emplid 3
 216                     :groupid 1
 217                     :height (1+ (random 1.00))
 218                     :married t
 219                     :birthday (clsql-base:get-time)
 220                     :first-name "Leon"
 221                     :last-name "Trotsky"
 222                     :email "trotsky@soviet.org")
 223         employee4 (make-instance 'employee
 224                     :emplid 4
 225                     :groupid 1
 226                     :height (1+ (random 1.00))
 227                     :married nil
 228                     :birthday (clsql-base:get-time)
 229                     :first-name "Nikita"
 230                     :last-name "Kruschev"
 231                     :email "kruschev@soviet.org")
 232
 233         employee5 (make-instance 'employee
 234                     :emplid 5
 235                     :groupid 1
 236                     :married nil
 237                     :height (1+ (random 1.00))
 238                     :birthday (clsql-base:get-time)
 239                     :first-name "Leonid"
 240                     :last-name "Brezhnev"
 241                     :email "brezhnev@soviet.org")
 242
 243         employee6 (make-instance 'employee
 244                     :emplid 6
 245                     :groupid 1
 246                     :married nil
 247                     :height (1+ (random 1.00))
 248                     :birthday (clsql-base:get-time)
 249                     :first-name "Yuri"
 250                     :last-name "Andropov"
 251                     :email "andropov@soviet.org")
 252         employee7 (make-instance 'employee
 253                     :emplid 7
 254                     :groupid 1
 255                     :height (1+ (random 1.00))
 256                     :married nil
 257                     :birthday (clsql-base:get-time)
 258                     :first-name "Konstantin"
 259                     :last-name "Chernenko"
 260                     :email "chernenko@soviet.org")
 261         employee8 (make-instance 'employee
 262                     :emplid 8
 263                     :groupid 1
 264                     :height (1+ (random 1.00))
 265                     :married nil
 266                     :birthday (clsql-base:get-time)
 267                     :first-name "Mikhail"
 268                     :last-name "Gorbachev"
 269                     :email "gorbachev@soviet.org")
 270         employee9 (make-instance 'employee
 271                     :emplid 9
 272                     :groupid 1
 273                     :married nil
 274                     :height (1+ (random 1.00))
 275                     :birthday (clsql-base:get-time)
 276                     :first-name "Boris"
 277                     :last-name "Yeltsin"
 278                     :email "yeltsin@soviet.org")
 279         employee10 (make-instance 'employee
 280                      :emplid 10
 281                      :groupid 1
 282                      :married nil
 283                      :height (1+ (random 1.00))
 284                      :birthday (clsql-base:get-time)
 285                      :first-name "Vladamir"
 286                      :last-name "Putin"
 287                      :email "putin@soviet.org")
 288
 289         address1 (make-instance 'address
 290                                 :emplid 1
 291                                 :street-number 10
 292                                 :street-name "Park Place"
 293                                 :city "Leningrad"
 294                                 :postal-code 123)
 295
 296         address2 (make-instance 'address
 297                                 :emplid 2))
 298
 299   ;; sleep to ensure birthdays are no longer at current time
 300   (sleep 2)
 301
 302   ;; Lenin manages everyone
 303   (clsql:add-to-relation employee2 'manager employee1)
 304   (clsql:add-to-relation employee3 'manager employee1)
 305   (clsql:add-to-relation employee4 'manager employee1)
 306   (clsql:add-to-relation employee5 'manager employee1)
 307   (clsql:add-to-relation employee6 'manager employee1)
 308   (clsql:add-to-relation employee7 'manager employee1)
 309   (clsql:add-to-relation employee8 'manager employee1)
 310   (clsql:add-to-relation employee9 'manager employee1)
 311   (clsql:add-to-relation employee10 'manager employee1)
 312   ;; Everyone works for Widgets Inc.
 313   (clsql:add-to-relation company1 'employees employee1)
 314   (clsql:add-to-relation company1 'employees employee2)
 315   (clsql:add-to-relation company1 'employees employee3)
 316   (clsql:add-to-relation company1 'employees employee4)
 317   (clsql:add-to-relation company1 'employees employee5)
 318   (clsql:add-to-relation company1 'employees employee6)
 319   (clsql:add-to-relation company1 'employees employee7)
 320   (clsql:add-to-relation company1 'employees employee8)
 321   (clsql:add-to-relation company1 'employees employee9)
 322   (clsql:add-to-relation company1 'employees employee10)
 323   ;; Lenin is president of Widgets Inc.
 324   (clsql:add-to-relation company1 'president employee1)
 325   ;; store these instances
 326   (clsql:update-records-from-instance employee1)
 327   (clsql:update-records-from-instance employee2)
 328   (clsql:update-records-from-instance employee3)
 329   (clsql:update-records-from-instance employee4)
 330   (clsql:update-records-from-instance employee5)
 331   (clsql:update-records-from-instance employee6)
 332   (clsql:update-records-from-instance employee7)
 333   (clsql:update-records-from-instance employee8)
 334   (clsql:update-records-from-instance employee9)
 335   (clsql:update-records-from-instance employee10)
 336   (clsql:update-records-from-instance company1)
 337   (clsql:update-records-from-instance address1)
 338   (clsql:update-records-from-instance address2))
 339
 340 (defvar *error-count* 0)
 341 (defvar *error-list* nil)
 342
 343 (defun run-function-append-report-file (function report-file)
 344     (let* ((report-path (etypecase report-file
 345                         (pathname report-file)
 346                         (string (parse-namestring report-file))))
 347          (sexp-report-path (make-pathname :defaults report-path
 348                                           :type "sexp")))
 349       (with-open-file (rs report-path :direction :output
 350                           :if-exists :append
 351                       :if-does-not-exist :create)
 352         (with-open-file (srs sexp-report-path :direction :output
 353                              :if-exists :append
 354                              :if-does-not-exist :create)
 355           (funcall function :report-stream rs :sexp-report-stream srs)))))
 356
 357 (defun run-tests-append-report-file (report-file)
 358   (run-function-append-report-file 'run-tests report-file))
 359
 360
 361 (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
 362   (let ((specs (read-specs))
 363         (*report-stream* report-stream)
 364         (*sexp-report-stream* sexp-report-stream)
 365         (*error-count* 0)
 366         (*error-list* nil))
 367     (unless specs
 368       (warn "Not running tests because test configuration file is missing")
 369       (return-from run-tests :skipped))
 370     (load-necessary-systems specs)
 371     (dolist (db-type +all-db-types+)
 372       (dolist (spec (db-type-spec db-type specs))
 373         (do-tests-for-backend db-type spec))))
 374   (zerop *error-count*))
 375
 376 (defun load-necessary-systems (specs)
 377   (dolist (db-type +all-db-types+)
 378     (when (db-type-spec db-type specs)
 379       (clsql:initialize-database-type :database-type db-type))))
 380
 381 (defun write-report-banner (report-type db-type stream)
 382   (format *report-stream*
 383           "~&
 384 ******************************************************************************
 385 ***     CLSQL ~A begun at ~A
 386 ***     ~A
 387 ***     ~A on ~A
 388 ***     Database ~A backend~A.
 389 ******************************************************************************
 390 "
 391           report-type
 392           (clsql-base:format-time
 393            nil
 394            (clsql-base:utime->time (get-universal-time)))
 395           (lisp-implementation-type)
 396           (lisp-implementation-version)
 397           (machine-type)
 398           db-type
 399           (if (not (eq db-type *test-database-underlying-type*))
 400               (format nil " with underlying type ~A"
 401                       *test-database-underlying-type*)
 402               "")
 403           ))
 404
 405 (defun do-tests-for-backend (db-type spec)
 406   (test-connect-to-database db-type spec)
 407
 408   (unwind-protect
 409        (multiple-value-bind (test-forms skip-tests)
 410           (compute-tests-for-backend db-type *test-database-underlying-type*)
 411
 412          (write-report-banner "Test Suite" db-type *report-stream*)
 413
 414         (test-initialise-database)
 415
 416         (regression-test:rem-all-tests)
 417         (dolist (test-form test-forms)
 418           (eval test-form))
 419
 420         (let ((remaining (regression-test:do-tests *report-stream*)))
 421           (when (regression-test:pending-tests)
 422             (incf *error-count* (length remaining))))
 423
 424         (let ((sexp-error (list db-type
 425                                 *test-database-underlying-type*
 426                                 (get-universal-time)
 427                                 (length test-forms)
 428                                 (regression-test:pending-tests)
 429                                 (lisp-implementation-type)
 430                                 (lisp-implementation-version)
 431                                 (machine-type))))
 432           (when *sexp-report-stream*
 433             (write sexp-error :stream *sexp-report-stream*))
 434           (push sexp-error *error-list*))
 435
 436         (format *report-stream* "~&Tests skipped:")
 437         (if skip-tests
 438             (dolist (skipped skip-tests)
 439               (format *report-stream*
 440                       "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 441           (format *report-stream* " None~%")))
 442     (disconnect)))
 443
 444
 445 (defun compute-tests-for-backend (db-type db-underlying-type)
 446   (let ((test-forms '())
 447         (skip-tests '()))
 448     (dolist (test-form (append (test-basic-forms)
 449                                *rt-connection* *rt-fddl* *rt-fdml*
 450                                *rt-ooddl* *rt-oodml* *rt-syntax*))
 451       (let ((test (second test-form)))
 452         (cond
 453           ((and (null (db-type-has-views? db-underlying-type))
 454                 (clsql-base::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 455            (push (cons test "views not supported") skip-tests))
 456           ((and (null (db-type-has-boolean-where? db-underlying-type))
 457                 (clsql-base::in test :fdml/select/11 :oodml/select/5))
 458            (push (cons test "boolean where not supported") skip-tests))
 459           ((and (null (db-type-has-subqueries? db-underlying-type))
 460                 (clsql-base::in test :fdml/select/5 :fdml/select/10))
 461            (push (cons test "subqueries not supported") skip-tests))
 462           ((and (null (db-type-transaction-capable? db-underlying-type
 463                                                     *default-database*))
 464                 (clsql-base::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 465            (push (cons test "transactions not supported") skip-tests))
 466           ((and (null (db-type-has-fancy-math? db-underlying-type))
 467                 (clsql-base::in test :fdml/select/1))
 468            (push (cons test "fancy math not supported") skip-tests))
 469           ((and (eql *test-database-type* :sqlite)
 470                 (clsql-base::in test :fddl/view/4 :fdml/select/10))
 471            (push (cons test "not supported by sqlite") skip-tests))
 472           (t
 473            (push test-form test-forms)))))
 474     (values (nreverse test-forms) (nreverse skip-tests))))
 475