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-fddl*)
  23 (defvar *rt-fdml*)
  24 (defvar *rt-ooddl*)
  25 (defvar *rt-oodml*)
  26 (defvar *rt-syntax*)
  27 (defvar *rt-time*)
  28
  29 (defvar *test-database-type* nil)
  30 (defvar *test-database-underlying-type* nil)
  31 (defvar *test-database-user* nil)
  32
  33 (defclass thing ()
  34   ((extraterrestrial :initform nil :initarg :extraterrestrial)))
  35
  36 (def-view-class person (thing)
  37   ((height :db-kind :base :accessor height :type float
  38            :initarg :height)
  39    (married :db-kind :base :accessor married :type boolean
  40             :initarg :married)
  41    (birthday :type clsql:wall-time :initarg :birthday)
  42    (hobby :db-kind :virtual :initarg :hobby :initform nil)))
  43
  44 (def-view-class employee (person)
  45   ((emplid
  46     :db-kind :key
  47     :db-constraints :not-null
  48     :type integer
  49     :initarg :emplid)
  50    (groupid
  51     :db-kind :key
  52     :db-constraints :not-null
  53     :type integer
  54     :initarg :groupid)
  55    (first-name
  56     :accessor first-name
  57     :type (string 30)
  58     :initarg :first-name)
  59    (last-name
  60     :accessor last-name
  61     :type (string 30)
  62     :initarg :last-name)
  63    (email
  64     :accessor employee-email
  65     :type (string 100)
  66     :initarg :email)
  67    (ecompanyid
  68     :type integer
  69     :initarg :companyid)
  70    (company
  71     :accessor employee-company
  72     :db-kind :join
  73     :db-info (:join-class company
  74                           :home-key ecompanyid
  75                           :foreign-key companyid
  76                           :set nil))
  77    (managerid
  78     :type integer
  79     :initarg :managerid)
  80    (manager
  81     :accessor employee-manager
  82     :db-kind :join
  83     :db-info (:join-class employee
  84                           :home-key managerid
  85                           :foreign-key emplid
  86                           :set nil))
  87    (addresses
  88     :accessor employee-addresses
  89     :db-kind :join
  90     :db-info (:join-class employee-address
  91                           :home-key emplid
  92                           :foreign-key aemplid
  93                           :target-slot address
  94                           :set t)))
  95   (:base-table employee))
  96
  97 (def-view-class company ()
  98   ((companyid
  99     :db-kind :key
 100     :db-constraints :not-null
 101     :type integer
 102     :initarg :companyid)
 103    (groupid
 104     :db-kind :key
 105     :db-constraints :not-null
 106     :type integer
 107     :initarg :groupid)
 108    (name
 109     :type (string 100)
 110     :initarg :name)
 111    (presidentid
 112     :type integer
 113     :initarg :presidentid)
 114    (president
 115     :reader president
 116     :db-kind :join
 117     :db-info (:join-class employee
 118                           :home-key presidentid
 119                           :foreign-key emplid
 120                           :set nil))
 121    (employees
 122     :reader company-employees
 123     :db-kind :join
 124     :db-info (:join-class employee
 125                           :home-key (companyid groupid)
 126                           :foreign-key (ecompanyid groupid)
 127                           :set t))))
 128
 129 (def-view-class address ()
 130   ((addressid
 131     :db-kind :key
 132     :db-constraints :not-null
 133     :type integer
 134     :initarg :addressid)
 135    (street-number
 136     :type integer
 137     :initarg :street-number)
 138    (street-name
 139     :type (string 30)
 140     :void-value ""
 141     :initarg :street-name)
 142    (city
 143     :column "city_field"
 144     :void-value "no city"
 145     :type (string 30)
 146     :initarg :city)
 147    (postal-code
 148     :column zip
 149     :type integer
 150     :void-value 0
 151     :initarg :postal-code))
 152   (:base-table addr))
 153
 154 ;; many employees can reside at many addressess
 155 (def-view-class employee-address ()
 156   ((aemplid :type integer :initarg :emplid)
 157    (aaddressid :type integer :initarg :addressid)
 158    (verified :type boolean :initarg :verified)
 159    (address :db-kind :join
 160             :db-info (:join-class address
 161                                   :home-key aaddressid
 162                                   :foreign-key addressid
 163                                   :retrieval :immediate)))
 164   (:base-table "ea_join"))
 165
 166 (def-view-class deferred-employee-address ()
 167   ((aemplid :type integer :initarg :emplid)
 168    (aaddressid :type integer :initarg :addressid)
 169    (verified :type boolean :initarg :verified)
 170    (address :db-kind :join
 171             :db-info (:join-class address
 172                                   :home-key aaddressid
 173                                   :foreign-key addressid
 174                                   :retrieval :deferred
 175                                   :set nil)))
 176   (:base-table "ea_join"))
 177
 178 (defun test-connect-to-database (db-type spec)
 179   (when (clsql-sys:db-backend-has-create/destroy-db? db-type)
 180     (ignore-errors (destroy-database spec :database-type db-type))
 181     (ignore-errors (create-database spec :database-type db-type)))
 182
 183   (setf *test-database-type* db-type)
 184   (when (>= (length spec) 3)
 185     (setq *test-database-user* (third spec)))
 186
 187   ;; Connect to the database
 188   (clsql:connect spec
 189                  :database-type db-type
 190                  :make-default t
 191                  :if-exists :old)
 192
 193   ;; Ensure database is empty
 194   (truncate-database :database *default-database*)
 195
 196   (setf *test-database-underlying-type*
 197         (clsql-sys:database-underlying-type *default-database*))
 198
 199   *default-database*)
 200
 201 (defparameter company1 nil)
 202 (defparameter employee1 nil)
 203 (defparameter employee2 nil)
 204 (defparameter employee3 nil)
 205 (defparameter employee4 nil)
 206 (defparameter employee5 nil)
 207 (defparameter employee6 nil)
 208 (defparameter employee7 nil)
 209 (defparameter employee8 nil)
 210 (defparameter employee9 nil)
 211 (defparameter employee10 nil)
 212 (defparameter address1 nil)
 213 (defparameter address2 nil)
 214 (defparameter employee-address1 nil)
 215 (defparameter employee-address2 nil)
 216 (defparameter employee-address3 nil)
 217 (defparameter employee-address4 nil)
 218 (defparameter employee-address5 nil)
 219
 220 (defun test-initialise-database ()
 221   (test-basic-initialize)
 222
 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   (declare (ignorable db-type))
 530   (let ((test-forms '())
 531         (skip-tests '()))
 532     (dolist (test-form (append (test-basic-forms)
 533                                *rt-connection* *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            (push (cons test "subqueries not supported") skip-tests))
 546           ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
 547                                                     *default-database*))
 548                 (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
 549            (push (cons test "transactions not supported") skip-tests))
 550           ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type))
 551                 (clsql-sys:in test :fdml/select/1))
 552            (push (cons test "fancy math not supported") skip-tests))
 553           ((and (eql *test-database-type* :sqlite)
 554                 (clsql-sys:in test :fddl/view/4 :fdml/select/10
 555                                 :fdml/select/21))
 556            (push (cons test "not supported by sqlite") skip-tests))
 557           ((and (eql *test-database-underlying-type* :mysql)
 558                 (clsql-sys:in test :fdml/select/22 :fdml/query/5
 559                                 :fdml/query/7 :fdml/query/8))
 560            (push (cons test "not supported by mysql") skip-tests))
 561           ((and (null (clsql-sys:db-type-has-union? db-underlying-type))
 562                 (clsql-sys:in test :fdml/query/6))
 563            (push (cons test "union not supported") skip-tests))
 564           (t
 565            (push test-form test-forms)))))
 566       (values (nreverse test-forms) (nreverse skip-tests))))
 567
 568
 569 (defun rapid-load (type)
 570   "Rapid load for interactive testing."
 571   (when *default-database*
 572       (disconnect :database *default-database*))
 573   (test-connect-to-database type (car (db-type-spec type (read-specs))))
 574   (test-initialise-database))
 575
 576 (defun rl ()
 577   (rapid-load :postgresql))
 578
 579 (defun rlm ()
 580   (rapid-load :mysql))
 581
 582 (defun rlo ()
 583   (rapid-load :odbc))