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