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* *standard-output* "Stream to send text report.")
  20 (defvar *sexp-report-stream* nil "Stream to send sexp report.")
  21 (defvar *rt-connection*)
  22 (defvar *rt-basic*)
  23 (defvar *rt-fddl*)
  24 (defvar *rt-fdml*)
  25 (defvar *rt-ooddl*)
  26 (defvar *rt-oodml*)
  27 (defvar *rt-syntax*)
  28 (defvar *rt-time*)
  29
  30 (defvar *test-database-type* nil)
  31 (defvar *test-database-underlying-type* nil)
  32 (defvar *test-database-user* nil)
  33
  34 (defclass thing ()
  35   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  36
  37 (def-view-class person (thing)
  38   ((height :db-kind :base :accessor height :type float
  39            :initarg :height)
  40    (married :db-kind :base :accessor married :type boolean
  41             :initarg :married)
  42    (birthday :type clsql:wall-time :initarg :birthday)
  43    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  44
  45 (def-view-class employee (person)
  46   ((emplid
  47     :db-kind :key
  48     :db-constraints :not-null
  49     :type integer
  50     :initarg :emplid)
  51    (groupid
  52     :db-kind :key
  53     :db-constraints :not-null
  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     :initarg :email)
  68    (ecompanyid
  69     :type integer
  70     :initarg :companyid)
  71    (company
  72     :accessor employee-company
  73     :db-kind :join
  74     :db-info (:join-class company
  75                           :home-key ecompanyid
  76                           :foreign-key companyid
  77                           :set nil))
  78    (managerid
  79     :type integer
  80     :initarg :managerid)
  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    (addresses
  89     :accessor employee-addresses
  90     :db-kind :join
  91     :db-info (:join-class employee-address
  92                           :home-key emplid
  93                           :foreign-key aemplid
  94                           :target-slot address
  95                           :set t)))
  96   (:base-table employee))
  97
  98 (def-view-class company ()
  99   ((companyid
 100     :db-kind :key
 101     :db-constraints :not-null
 102     :type integer
 103     :initarg :companyid)
 104    (groupid
 105     :db-kind :key
 106     :db-constraints :not-null
 107     :type integer
 108     :initarg :groupid)
 109    (name
 110     :type (string 100)
 111     :initarg :name)
 112    (presidentid
 113     :type integer
 114     :initarg :presidentid)
 115    (president
 116     :reader president
 117     :db-kind :join
 118     :db-info (:join-class employee
 119                           :home-key presidentid
 120                           :foreign-key emplid
 121                           :set nil))
 122    (employees
 123     :reader company-employees
 124     :db-kind :join
 125     :db-info (:join-class employee
 126                           :home-key (companyid groupid)
 127                           :foreign-key (ecompanyid groupid)
 128                           :set t))))
 129
 130 (def-view-class address ()
 131   ((addressid
 132     :db-kind :key
 133     :db-constraints :not-null
 134     :type integer
 135     :initarg :addressid)
 136    (street-number
 137     :type integer
 138     :initarg :street-number)
 139    (street-name
 140     :type (string 30)
 141     :void-value ""
 142     :initarg :street-name)
 143    (city
 144     :column "city_field"
 145     :void-value "no city"
 146     :type (string 30)
 147     :initarg :city)
 148    (postal-code
 149     :column zip
 150     :type integer
 151     :void-value 0
 152     :initarg :postal-code))
 153   (:base-table addr))
 154
 155 ;; many employees can reside at many addressess
 156 (def-view-class employee-address ()
 157   ((aemplid :type integer :initarg :emplid)
 158    (aaddressid :type integer :initarg :addressid)
 159    (verified :type boolean :initarg :verified)
 160    (address :db-kind :join
 161             :db-info (:join-class address
 162                                   :home-key aaddressid
 163                                   :foreign-key addressid
 164                                   :retrieval :immediate)))
 165   (:base-table "ea_join"))
 166
 167 (def-view-class deferred-employee-address ()
 168   ((aemplid :type integer :initarg :emplid)
 169    (aaddressid :type integer :initarg :addressid)
 170    (verified :type boolean :initarg :verified)
 171    (address :db-kind :join
 172             :db-info (:join-class address
 173                                   :home-key aaddressid
 174                                   :foreign-key addressid
 175                                   :retrieval :deferred
 176                                   :set nil)))
 177   (:base-table "ea_join"))
 178
 179 (defun test-connect-to-database (db-type spec)
 180   (when (clsql-sys:db-backend-has-create/destroy-db? db-type)
 181     (ignore-errors (destroy-database spec :database-type db-type))
 182     (ignore-errors (create-database spec :database-type db-type)))
 183
 184   (setf *test-database-type* db-type)
 185   (setf *test-database-user*
 186     (cond
 187      ((eq :oracle db-type) (second spec))
 188      ((>= (length spec) 3) (third spec))))
 189
 190   ;; Connect to the database
 191   (clsql:connect spec
 192                  :database-type db-type
 193                  :make-default t
 194                  :if-exists :old)
 195
 196   ;; Ensure database is empty
 197   (truncate-database :database *default-database*)
 198
 199   (setf *test-database-underlying-type*
 200         (clsql-sys:database-underlying-type *default-database*))
 201
 202   *default-database*)
 203
 204 (defparameter company1 nil)
 205 (defparameter employee1 nil)
 206 (defparameter employee2 nil)
 207 (defparameter employee3 nil)
 208 (defparameter employee4 nil)
 209 (defparameter employee5 nil)
 210 (defparameter employee6 nil)
 211 (defparameter employee7 nil)
 212 (defparameter employee8 nil)
 213 (defparameter employee9 nil)
 214 (defparameter employee10 nil)
 215 (defparameter address1 nil)
 216 (defparameter address2 nil)
 217 (defparameter employee-address1 nil)
 218 (defparameter employee-address2 nil)
 219 (defparameter employee-address3 nil)
 220 (defparameter employee-address4 nil)
 221 (defparameter employee-address5 nil)
 222
 223 (defun test-initialise-database ()
 224   (test-basic-initialize)
 225   (let ((*backend-warning-behavior*
 226          (if (member *test-database-type* '(:postgresql :postgresql-socket))
 227              :ignore
 228            :warn)))
 229     (clsql:create-view-from-class 'employee)
 230     (clsql:create-view-from-class 'company)
 231     (clsql:create-view-from-class 'address)
 232     (clsql:create-view-from-class 'employee-address))
 233
 234   (let ((*db-auto-sync* t))
 235     (setf company1 (make-instance 'company
 236                                   :presidentid 1
 237                                   :companyid 1
 238                                   :groupid 1
 239                                   :name "Widgets Inc.")
 240           employee1 (make-instance 'employee
 241                                    :emplid 1
 242                                    :groupid 1
 243                                    :married t
 244                                    :height (1+ (random 1.00))
 245                                    :birthday (clsql:get-time)
 246                                    :first-name "Vladamir"
 247                                    :last-name "Lenin"
 248                                    :email "lenin@soviet.org"
 249                                    :companyid 1)
 250           employee2 (make-instance 'employee
 251                                    :emplid 2
 252                                    :groupid 1
 253                                    :height (1+ (random 1.00))
 254                                    :married t
 255                                    :birthday (clsql:get-time)
 256                                    :first-name "Josef"
 257                                    :last-name "Stalin"
 258                                    :email "stalin@soviet.org"
 259                                    :managerid 1
 260                                    :companyid 1)
 261           employee3 (make-instance 'employee
 262                                    :emplid 3
 263                                    :groupid 1
 264                                    :height (1+ (random 1.00))
 265                                    :married t
 266                                    :birthday (clsql:get-time)
 267                                    :first-name "Leon"
 268                                    :last-name "Trotsky"
 269                                    :email "trotsky@soviet.org"
 270                                    :managerid 1
 271                                    :companyid 1)
 272           employee4 (make-instance 'employee
 273                                    :emplid 4
 274                                    :groupid 1
 275                                    :height (1+ (random 1.00))
 276                                    :married nil
 277                                    :birthday (clsql:get-time)
 278                                    :first-name "Nikita"
 279                                    :last-name "Kruschev"
 280                                    :email "kruschev@soviet.org"
 281                                    :managerid 1
 282                                    :companyid 1)
 283           employee5 (make-instance 'employee
 284                                    :emplid 5
 285                                    :groupid 1
 286                                    :married nil
 287                                    :height (1+ (random 1.00))
 288                                    :birthday (clsql:get-time)
 289                                    :first-name "Leonid"
 290                                    :last-name "Brezhnev"
 291                                    :email "brezhnev@soviet.org"
 292                                    :managerid 1
 293                                    :companyid 1)
 294           employee6 (make-instance 'employee
 295                                    :emplid 6
 296                                    :groupid 1
 297                                    :married nil
 298                                    :height (1+ (random 1.00))
 299                                    :birthday (clsql:get-time)
 300                                    :first-name "Yuri"
 301                                    :last-name "Andropov"
 302                                    :email "andropov@soviet.org"
 303                                    :managerid 1
 304                                    :companyid 1)
 305           employee7 (make-instance 'employee
 306                                    :emplid 7
 307                                    :groupid 1
 308                                    :height (1+ (random 1.00))
 309                                    :married nil
 310                                    :birthday (clsql:get-time)
 311                                    :first-name "Konstantin"
 312                                    :last-name "Chernenko"
 313                                    :email "chernenko@soviet.org"
 314                                    :managerid 1
 315                                    :companyid 1)
 316           employee8 (make-instance 'employee
 317                                    :emplid 8
 318                                    :groupid 1
 319                                    :height (1+ (random 1.00))
 320                                    :married nil
 321                                    :birthday (clsql:get-time)
 322                                    :first-name "Mikhail"
 323                                    :last-name "Gorbachev"
 324                                    :email "gorbachev@soviet.org"
 325                                    :managerid 1
 326                                    :companyid 1)
 327           employee9 (make-instance 'employee
 328                                    :emplid 9
 329                                    :groupid 1
 330                                    :married nil
 331                                    :height (1+ (random 1.00))
 332                                    :birthday (clsql:get-time)
 333                                    :first-name "Boris"
 334                                    :last-name "Yeltsin"
 335                                    :email "yeltsin@soviet.org"
 336                                    :managerid 1
 337                                    :companyid 1)
 338           employee10 (make-instance 'employee
 339                                     :emplid 10
 340                                     :groupid 1
 341                                     :married nil
 342                                     :height (1+ (random 1.00))
 343                                     :birthday (clsql:get-time)
 344                                     :first-name "Vladamir"
 345                                     :last-name "Putin"
 346                                     :email "putin@soviet.org"
 347                                     :managerid 1
 348                                     :companyid 1)
 349           address1 (make-instance 'address
 350                                   :addressid 1
 351                                   :street-number 10
 352                                   :street-name "Park Place"
 353                                   :city "Leningrad"
 354                                   :postal-code 123)
 355           address2 (make-instance 'address
 356                                   :addressid 2)
 357           employee-address1 (make-instance 'employee-address
 358                                            :emplid 1
 359                                            :addressid 1
 360                                            :verified t)
 361           employee-address2 (make-instance 'employee-address
 362                                            :emplid 2
 363                                            :addressid 2
 364                                            :verified t)
 365           employee-address3 (make-instance 'employee-address
 366                                            :emplid 3
 367                                            :addressid 1
 368                                            :verified nil)
 369           employee-address4 (make-instance 'employee-address
 370                                            :emplid 1
 371                                            :addressid 2
 372                                            :verified nil)
 373           employee-address5 (make-instance 'employee-address
 374                                            :emplid 3
 375                                            :addressid 2)
 376           ))
 377
 378   ;; sleep to ensure birthdays are no longer at current time
 379   (sleep 1)
 380
 381   #||
 382   ;; Lenin manages everyone
 383   (clsql:add-to-relation employee2 'manager employee1)
 384   (clsql:add-to-relation employee3 'manager employee1)
 385   (clsql:add-to-relation employee4 'manager employee1)
 386   (clsql:add-to-relation employee5 'manager employee1)
 387   (clsql:add-to-relation employee6 'manager employee1)
 388   (clsql:add-to-relation employee7 'manager employee1)
 389   (clsql:add-to-relation employee8 'manager employee1)
 390   (clsql:add-to-relation employee9 'manager employee1)
 391   (clsql:add-to-relation employee10 'manager employee1)
 392   ;; Everyone works for Widgets Inc.
 393   (clsql:add-to-relation company1 'employees employee1)
 394   (clsql:add-to-relation company1 'employees employee2)
 395   (clsql:add-to-relation company1 'employees employee3)
 396   (clsql:add-to-relation company1 'employees employee4)
 397   (clsql:add-to-relation company1 'employees employee5)
 398   (clsql:add-to-relation company1 'employees employee6)
 399   (clsql:add-to-relation company1 'employees employee7)
 400   (clsql:add-to-relation company1 'employees employee8)
 401   (clsql:add-to-relation company1 'employees employee9)
 402   (clsql:add-to-relation company1 'employees employee10)
 403   ;; Lenin is president of Widgets Inc.
 404   (clsql:add-to-relation company1 'president employee1)
 405   ||#
 406
 407   ;; store these instances
 408   #||
 409   (clsql:update-records-from-instance employee1)
 410   (clsql:update-records-from-instance employee2)
 411   (clsql:update-records-from-instance employee3)
 412   (clsql:update-records-from-instance employee4)
 413   (clsql:update-records-from-instance employee5)
 414   (clsql:update-records-from-instance employee6)
 415   (clsql:update-records-from-instance employee7)
 416   (clsql:update-records-from-instance employee8)
 417   (clsql:update-records-from-instance employee9)
 418   (clsql:update-records-from-instance employee10)
 419   (clsql:update-records-from-instance company1)
 420   (clsql:update-records-from-instance address1)
 421   (clsql:update-records-from-instance address2)
 422   ||#
 423   )
 424
 425 (defvar *error-count* 0)
 426 (defvar *error-list* nil)
 427
 428 (defun run-function-append-report-file (function report-file)
 429     (let* ((report-path (etypecase report-file
 430                         (pathname report-file)
 431                         (string (parse-namestring report-file))))
 432          (sexp-report-path (make-pathname :defaults report-path
 433                                           :type "sexp")))
 434       (with-open-file (rs report-path :direction :output
 435                           :if-exists :append
 436                       :if-does-not-exist :create)
 437         (with-open-file (srs sexp-report-path :direction :output
 438                              :if-exists :append
 439                              :if-does-not-exist :create)
 440           (funcall function :report-stream rs :sexp-report-stream srs)))))
 441
 442 (defun run-tests-append-report-file (report-file)
 443   (run-function-append-report-file 'run-tests report-file))
 444
 445
 446 (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
 447   (let ((specs (read-specs))
 448         (*report-stream* report-stream)
 449         (*sexp-report-stream* sexp-report-stream)
 450         (*error-count* 0)
 451         (*error-list* nil))
 452     (unless specs
 453       (warn "Not running tests because test configuration file is missing")
 454       (return-from run-tests :skipped))
 455     (load-necessary-systems specs)
 456     (dolist (db-type +all-db-types+)
 457       (dolist (spec (db-type-spec db-type specs))
 458         (do-tests-for-backend db-type spec))))
 459   (zerop *error-count*))
 460
 461 (defun load-necessary-systems (specs)
 462   (dolist (db-type +all-db-types+)
 463     (when (db-type-spec db-type specs)
 464       (clsql-sys:initialize-database-type :database-type db-type))))
 465
 466 (defun write-report-banner (report-type db-type stream)
 467   (format stream
 468           "~&
 469 ******************************************************************************
 470 ***     CLSQL ~A begun at ~A
 471 ***     ~A
 472 ***     ~A on ~A
 473 ***     Database ~:@(~A~) backend~A.
 474 ******************************************************************************
 475 "
 476           report-type
 477           (clsql:format-time
 478            nil
 479            (clsql:utime->time (get-universal-time)))
 480           (lisp-implementation-type)
 481           (lisp-implementation-version)
 482           (machine-type)
 483           db-type
 484           (if (not (eq db-type *test-database-underlying-type*))
 485               (format nil " with underlying type ~A"
 486                       *test-database-underlying-type*)
 487               "")
 488           ))
 489
 490 (defun do-tests-for-backend (db-type spec)
 491   (test-connect-to-database db-type spec)
 492
 493   (unwind-protect
 494        (multiple-value-bind (test-forms skip-tests)
 495           (compute-tests-for-backend db-type *test-database-underlying-type*)
 496
 497          (write-report-banner "Test Suite" db-type *report-stream*)
 498
 499         (test-initialise-database)
 500
 501         (regression-test:rem-all-tests)
 502         (dolist (test-form test-forms)
 503           (eval test-form))
 504
 505         (let ((remaining (regression-test:do-tests *report-stream*)))
 506           (when (regression-test:pending-tests)
 507             (incf *error-count* (length remaining))))
 508
 509         (let ((sexp-error (list db-type
 510                                 *test-database-underlying-type*
 511                                 (get-universal-time)
 512                                 (length test-forms)
 513                                 (regression-test:pending-tests)
 514                                 (lisp-implementation-type)
 515                                 (lisp-implementation-version)
 516                                 (machine-type))))
 517           (when *sexp-report-stream*
 518             (write sexp-error :stream *sexp-report-stream* :readably t))
 519           (push sexp-error *error-list*))
 520
 521         (format *report-stream* "~&Tests skipped:")
 522         (if skip-tests
 523             (dolist (skipped skip-tests)
 524               (format *report-stream*
 525                       "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 526           (format *report-stream* " None~%")))
 527     (disconnect)))
 528
 529
 530 (defun compute-tests-for-backend (db-type db-underlying-type)
 531   (let ((test-forms '())
 532         (skip-tests '()))
 533     (dolist (test-form (append *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
 534                                *rt-ooddl* *rt-oodml* *rt-syntax*))
 535       (let ((test (second test-form)))
 536         (cond
 537           ((and (null (clsql-sys:db-type-has-views? db-underlying-type))
 538                 (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 539            (push (cons test "views not supported") skip-tests))
 540           ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type))
 541                 (clsql-sys:in test :fdml/select/11 :oodml/select/5))
 542            (push (cons test "boolean where not supported") skip-tests))
 543           ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type))
 544                 (clsql-sys:in test :fdml/select/5 :fdml/select/10
 545                               :fdml/select/32 :fdml/select/33))
 546            (push (cons test "subqueries not supported") skip-tests))
 547           ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
 548                                                     *default-database*))
 549                 (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 550            (push (cons test "transactions not supported") skip-tests))
 551           ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type))
 552                 (clsql-sys:in test :fdml/select/1))
 553            (push (cons test "fancy math not supported") skip-tests))
 554           ((and (eql *test-database-type* :sqlite)
 555                 (clsql-sys:in test :fddl/view/4 :fdml/select/10
 556                                 :fdml/select/21 :fdml/select/32
 557                                 :fdml/select/33))
 558            (push (cons test "not supported by sqlite") skip-tests))
 559           ((and (not (clsql-sys:db-type-has-bigint? db-type))
 560                 (clsql-sys:in test :basic/bigint/1))
 561            (push (cons test "bigint not supported") skip-tests))
 562           ((and (eql *test-database-underlying-type* :mysql)
 563                 (clsql-sys:in test :fdml/select/26))
 564            (push (cons test "string table aliases not supported on all mysql versions") skip-tests))
 565           ((and (eql *test-database-underlying-type* :mysql)
 566                 (clsql-sys:in test :fdml/select/22 :fdml/query/5
 567                                 :fdml/query/7 :fdml/query/8))
 568            (push (cons test "not supported by mysql") skip-tests))
 569           ((and (null (clsql-sys:db-type-has-union? db-underlying-type))
 570                 (clsql-sys:in test :fdml/query/6 :fdml/select/31))
 571            (push (cons test "union not supported") skip-tests))
 572           (t
 573            (push test-form test-forms)))))
 574       (values (nreverse test-forms) (nreverse skip-tests))))
 575
 576
 577 (defun rapid-load (type)
 578   "Rapid load for interactive testing."
 579   (when *default-database*
 580       (disconnect :database *default-database*))
 581   (test-connect-to-database type (car (db-type-spec type (read-specs))))
 582   (test-initialise-database)
 583   *default-database*)
 584
 585 (defun rl ()
 586   (rapid-load :postgresql))
 587
 588 (defun rlm ()
 589   (rapid-load :mysql))
 590
 591 (defun rlo ()
 592   (rapid-load :oracle))