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