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   (when (>= (length spec) 3)
 186     (setq *test-database-user* (third spec)))
 187
 188   ;; Connect to the database
 189   (clsql:connect spec
 190                  :database-type db-type
 191                  :make-default t
 192                  :if-exists :old)
 193
 194   ;; Ensure database is empty
 195   (truncate-database :database *default-database*)
 196
 197   (setf *test-database-underlying-type*
 198         (clsql-sys:database-underlying-type *default-database*))
 199
 200   *default-database*)
 201
 202 (defparameter company1 nil)
 203 (defparameter employee1 nil)
 204 (defparameter employee2 nil)
 205 (defparameter employee3 nil)
 206 (defparameter employee4 nil)
 207 (defparameter employee5 nil)
 208 (defparameter employee6 nil)
 209 (defparameter employee7 nil)
 210 (defparameter employee8 nil)
 211 (defparameter employee9 nil)
 212 (defparameter employee10 nil)
 213 (defparameter address1 nil)
 214 (defparameter address2 nil)
 215 (defparameter employee-address1 nil)
 216 (defparameter employee-address2 nil)
 217 (defparameter employee-address3 nil)
 218 (defparameter employee-address4 nil)
 219 (defparameter employee-address5 nil)
 220
 221 (defun test-initialise-database ()
 222   (test-basic-initialize)
 223   (let ((*backend-warning-behavior*
 224          (if (member *test-database-type* '(:postgresql :postgresql-socket))
 225              :ignore
 226            :warn)))
 227     (clsql:create-view-from-class 'employee)
 228     (clsql:create-view-from-class 'company)
 229     (clsql:create-view-from-class 'address)
 230     (clsql:create-view-from-class 'employee-address))
 231
 232   (let ((*db-auto-sync* t))
 233     (setf company1 (make-instance 'company
 234                                   :presidentid 1
 235                                   :companyid 1
 236                                   :groupid 1
 237                                   :name "Widgets Inc.")
 238           employee1 (make-instance 'employee
 239                                    :emplid 1
 240                                    :groupid 1
 241                                    :married t
 242                                    :height (1+ (random 1.00))
 243                                    :birthday (clsql:get-time)
 244                                    :first-name "Vladamir"
 245                                    :last-name "Lenin"
 246                                    :email "lenin@soviet.org"
 247                                    :companyid 1)
 248           employee2 (make-instance 'employee
 249                                    :emplid 2
 250                                    :groupid 1
 251                                    :height (1+ (random 1.00))
 252                                    :married t
 253                                    :birthday (clsql:get-time)
 254                                    :first-name "Josef"
 255                                    :last-name "Stalin"
 256                                    :email "stalin@soviet.org"
 257                                    :managerid 1
 258                                    :companyid 1)
 259           employee3 (make-instance 'employee
 260                                    :emplid 3
 261                                    :groupid 1
 262                                    :height (1+ (random 1.00))
 263                                    :married t
 264                                    :birthday (clsql:get-time)
 265                                    :first-name "Leon"
 266                                    :last-name "Trotsky"
 267                                    :email "trotsky@soviet.org"
 268                                    :managerid 1
 269                                    :companyid 1)
 270           employee4 (make-instance 'employee
 271                                    :emplid 4
 272                                    :groupid 1
 273                                    :height (1+ (random 1.00))
 274                                    :married nil
 275                                    :birthday (clsql:get-time)
 276                                    :first-name "Nikita"
 277                                    :last-name "Kruschev"
 278                                    :email "kruschev@soviet.org"
 279                                    :managerid 1
 280                                    :companyid 1)
 281           employee5 (make-instance 'employee
 282                                    :emplid 5
 283                                    :groupid 1
 284                                    :married nil
 285                                    :height (1+ (random 1.00))
 286                                    :birthday (clsql:get-time)
 287                                    :first-name "Leonid"
 288                                    :last-name "Brezhnev"
 289                                    :email "brezhnev@soviet.org"
 290                                    :managerid 1
 291                                    :companyid 1)
 292           employee6 (make-instance 'employee
 293                                    :emplid 6
 294                                    :groupid 1
 295                                    :married nil
 296                                    :height (1+ (random 1.00))
 297                                    :birthday (clsql:get-time)
 298                                    :first-name "Yuri"
 299                                    :last-name "Andropov"
 300                                    :email "andropov@soviet.org"
 301                                    :managerid 1
 302                                    :companyid 1)
 303           employee7 (make-instance 'employee
 304                                    :emplid 7
 305                                    :groupid 1
 306                                    :height (1+ (random 1.00))
 307                                    :married nil
 308                                    :birthday (clsql:get-time)
 309                                    :first-name "Konstantin"
 310                                    :last-name "Chernenko"
 311                                    :email "chernenko@soviet.org"
 312                                    :managerid 1
 313                                    :companyid 1)
 314           employee8 (make-instance 'employee
 315                                    :emplid 8
 316                                    :groupid 1
 317                                    :height (1+ (random 1.00))
 318                                    :married nil
 319                                    :birthday (clsql:get-time)
 320                                    :first-name "Mikhail"
 321                                    :last-name "Gorbachev"
 322                                    :email "gorbachev@soviet.org"
 323                                    :managerid 1
 324                                    :companyid 1)
 325           employee9 (make-instance 'employee
 326                                    :emplid 9
 327                                    :groupid 1
 328                                    :married nil
 329                                    :height (1+ (random 1.00))
 330                                    :birthday (clsql:get-time)
 331                                    :first-name "Boris"
 332                                    :last-name "Yeltsin"
 333                                    :email "yeltsin@soviet.org"
 334                                    :managerid 1
 335                                    :companyid 1)
 336           employee10 (make-instance 'employee
 337                                     :emplid 10
 338                                     :groupid 1
 339                                     :married nil
 340                                     :height (1+ (random 1.00))
 341                                     :birthday (clsql:get-time)
 342                                     :first-name "Vladamir"
 343                                     :last-name "Putin"
 344                                     :email "putin@soviet.org"
 345                                     :managerid 1
 346                                     :companyid 1)
 347           address1 (make-instance 'address
 348                                   :addressid 1
 349                                   :street-number 10
 350                                   :street-name "Park Place"
 351                                   :city "Leningrad"
 352                                   :postal-code 123)
 353           address2 (make-instance 'address
 354                                   :addressid 2)
 355           employee-address1 (make-instance 'employee-address
 356                                            :emplid 1
 357                                            :addressid 1
 358                                            :verified t)
 359           employee-address2 (make-instance 'employee-address
 360                                            :emplid 2
 361                                            :addressid 2
 362                                            :verified t)
 363           employee-address3 (make-instance 'employee-address
 364                                            :emplid 3
 365                                            :addressid 1
 366                                            :verified nil)
 367           employee-address4 (make-instance 'employee-address
 368                                            :emplid 1
 369                                            :addressid 2
 370                                            :verified nil)
 371           employee-address5 (make-instance 'employee-address
 372                                            :emplid 3
 373                                            :addressid 2)
 374           ))
 375
 376   ;; sleep to ensure birthdays are no longer at current time
 377   (sleep 1)
 378
 379   #||
 380   ;; Lenin manages everyone
 381   (clsql:add-to-relation employee2 'manager employee1)
 382   (clsql:add-to-relation employee3 'manager employee1)
 383   (clsql:add-to-relation employee4 'manager employee1)
 384   (clsql:add-to-relation employee5 'manager employee1)
 385   (clsql:add-to-relation employee6 'manager employee1)
 386   (clsql:add-to-relation employee7 'manager employee1)
 387   (clsql:add-to-relation employee8 'manager employee1)
 388   (clsql:add-to-relation employee9 'manager employee1)
 389   (clsql:add-to-relation employee10 'manager employee1)
 390   ;; Everyone works for Widgets Inc.
 391   (clsql:add-to-relation company1 'employees employee1)
 392   (clsql:add-to-relation company1 'employees employee2)
 393   (clsql:add-to-relation company1 'employees employee3)
 394   (clsql:add-to-relation company1 'employees employee4)
 395   (clsql:add-to-relation company1 'employees employee5)
 396   (clsql:add-to-relation company1 'employees employee6)
 397   (clsql:add-to-relation company1 'employees employee7)
 398   (clsql:add-to-relation company1 'employees employee8)
 399   (clsql:add-to-relation company1 'employees employee9)
 400   (clsql:add-to-relation company1 'employees employee10)
 401   ;; Lenin is president of Widgets Inc.
 402   (clsql:add-to-relation company1 'president employee1)
 403   ||#
 404
 405   ;; store these instances
 406   #||
 407   (clsql:update-records-from-instance employee1)
 408   (clsql:update-records-from-instance employee2)
 409   (clsql:update-records-from-instance employee3)
 410   (clsql:update-records-from-instance employee4)
 411   (clsql:update-records-from-instance employee5)
 412   (clsql:update-records-from-instance employee6)
 413   (clsql:update-records-from-instance employee7)
 414   (clsql:update-records-from-instance employee8)
 415   (clsql:update-records-from-instance employee9)
 416   (clsql:update-records-from-instance employee10)
 417   (clsql:update-records-from-instance company1)
 418   (clsql:update-records-from-instance address1)
 419   (clsql:update-records-from-instance address2)
 420   ||#
 421   )
 422
 423 (defvar *error-count* 0)
 424 (defvar *error-list* nil)
 425
 426 (defun run-function-append-report-file (function report-file)
 427     (let* ((report-path (etypecase report-file
 428                         (pathname report-file)
 429                         (string (parse-namestring report-file))))
 430          (sexp-report-path (make-pathname :defaults report-path
 431                                           :type "sexp")))
 432       (with-open-file (rs report-path :direction :output
 433                           :if-exists :append
 434                       :if-does-not-exist :create)
 435         (with-open-file (srs sexp-report-path :direction :output
 436                              :if-exists :append
 437                              :if-does-not-exist :create)
 438           (funcall function :report-stream rs :sexp-report-stream srs)))))
 439
 440 (defun run-tests-append-report-file (report-file)
 441   (run-function-append-report-file 'run-tests report-file))
 442
 443
 444 (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
 445   (let ((specs (read-specs))
 446         (*report-stream* report-stream)
 447         (*sexp-report-stream* sexp-report-stream)
 448         (*error-count* 0)
 449         (*error-list* nil))
 450     (unless specs
 451       (warn "Not running tests because test configuration file is missing")
 452       (return-from run-tests :skipped))
 453     (load-necessary-systems specs)
 454     (dolist (db-type +all-db-types+)
 455       (dolist (spec (db-type-spec db-type specs))
 456         (do-tests-for-backend db-type spec))))
 457   (zerop *error-count*))
 458
 459 (defun load-necessary-systems (specs)
 460   (dolist (db-type +all-db-types+)
 461     (when (db-type-spec db-type specs)
 462       (clsql-sys:initialize-database-type :database-type db-type))))
 463
 464 (defun write-report-banner (report-type db-type stream)
 465   (format stream
 466           "~&
 467 ******************************************************************************
 468 ***     CLSQL ~A begun at ~A
 469 ***     ~A
 470 ***     ~A on ~A
 471 ***     Database ~:@(~A~) backend~A.
 472 ******************************************************************************
 473 "
 474           report-type
 475           (clsql:format-time
 476            nil
 477            (clsql:utime->time (get-universal-time)))
 478           (lisp-implementation-type)
 479           (lisp-implementation-version)
 480           (machine-type)
 481           db-type
 482           (if (not (eq db-type *test-database-underlying-type*))
 483               (format nil " with underlying type ~A"
 484                       *test-database-underlying-type*)
 485               "")
 486           ))
 487
 488 (defun do-tests-for-backend (db-type spec)
 489   (test-connect-to-database db-type spec)
 490
 491   (unwind-protect
 492        (multiple-value-bind (test-forms skip-tests)
 493           (compute-tests-for-backend db-type *test-database-underlying-type*)
 494
 495          (write-report-banner "Test Suite" db-type *report-stream*)
 496
 497         (test-initialise-database)
 498
 499         (regression-test:rem-all-tests)
 500         (dolist (test-form test-forms)
 501           (eval test-form))
 502
 503         (let ((remaining (regression-test:do-tests *report-stream*)))
 504           (when (regression-test:pending-tests)
 505             (incf *error-count* (length remaining))))
 506
 507         (let ((sexp-error (list db-type
 508                                 *test-database-underlying-type*
 509                                 (get-universal-time)
 510                                 (length test-forms)
 511                                 (regression-test:pending-tests)
 512                                 (lisp-implementation-type)
 513                                 (lisp-implementation-version)
 514                                 (machine-type))))
 515           (when *sexp-report-stream*
 516             (write sexp-error :stream *sexp-report-stream* :readably t))
 517           (push sexp-error *error-list*))
 518
 519         (format *report-stream* "~&Tests skipped:")
 520         (if skip-tests
 521             (dolist (skipped skip-tests)
 522               (format *report-stream*
 523                       "~&   ~20A ~A~%" (car skipped) (cdr skipped)))
 524           (format *report-stream* " None~%")))
 525     (disconnect)))
 526
 527
 528 (defun compute-tests-for-backend (db-type db-underlying-type)
 529   (let ((test-forms '())
 530         (skip-tests '()))
 531     (dolist (test-form (append *rt-connection* *rt-basic* *rt-fddl* *rt-fdml*
 532                                *rt-ooddl* *rt-oodml* *rt-syntax*))
 533       (let ((test (second test-form)))
 534         (cond
 535           ((and (null (clsql-sys:db-type-has-views? db-underlying-type))
 536                 (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
 537            (push (cons test "views not supported") skip-tests))
 538           ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type))
 539                 (clsql-sys:in test :fdml/select/11 :oodml/select/5))
 540            (push (cons test "boolean where not supported") skip-tests))
 541           ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type))
 542                 (clsql-sys:in test :fdml/select/5 :fdml/select/10
 543                               :fdml/select/32 :fdml/select/33))
 544            (push (cons test "subqueries not supported") skip-tests))
 545           ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
 546                                                     *default-database*))
 547                 (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 548            (push (cons test "transactions not supported") skip-tests))
 549           ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type))
 550                 (clsql-sys:in test :fdml/select/1))
 551            (push (cons test "fancy math not supported") skip-tests))
 552           ((and (eql *test-database-type* :sqlite)
 553                 (clsql-sys:in test :fddl/view/4 :fdml/select/10
 554                                 :fdml/select/21 :fdml/select/32
 555                                 :fdml/select/33))
 556            (push (cons test "not supported by sqlite") skip-tests))
 557           ((and (not (clsql-sys:db-type-has-bigint? db-type))
 558                 (clsql-sys:in test :basic/bigint/1))
 559            (push (cons test "bigint not supported") skip-tests))
 560           ((and (eql *test-database-underlying-type* :mysql)
 561                 (clsql-sys:in test :fdml/select/26))
 562            (push (cons test "string table aliases not supported on all mysql versions") skip-tests))
 563           ((and (eql *test-database-underlying-type* :mysql)
 564                 (clsql-sys:in test :fdml/select/22 :fdml/query/5
 565                                 :fdml/query/7 :fdml/query/8))
 566            (push (cons test "not supported by mysql") skip-tests))
 567           ((and (null (clsql-sys:db-type-has-union? db-underlying-type))
 568                 (clsql-sys:in test :fdml/query/6 :fdml/select/31))
 569            (push (cons test "union not supported") skip-tests))
 570           (t
 571            (push test-form test-forms)))))
 572       (values (nreverse test-forms) (nreverse skip-tests))))
 573
 574
 575 (defun rapid-load (type)
 576   "Rapid load for interactive testing."
 577   (when *default-database*
 578       (disconnect :database *default-database*))
 579   (test-connect-to-database type (car (db-type-spec type (read-specs))))
 580   (test-initialise-database))
 581
 582 (defun rl ()
 583   (rapid-load :postgresql))
 584
 585 (defun rlm ()
 586   (rapid-load :mysql))
 587
 588 (defun rlo ()
 589   (rapid-load :oracle))