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