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
8 ;;;; Initialisation utilities for running regression tests on CLSQL.
10 ;;;; This file is part of CLSQL.
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 ;;;; ======================================================================
17 (in-package #:clsql-tests
)
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
*)
23 (defvar *rt-connection
*)
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
)
37 ((extraterrestrial :initform nil
:initarg
:extraterrestrial
)))
39 (def-view-class person
(thing)
40 ((height :db-kind
:base
:accessor height
:type float
42 (married :db-kind
:base
:accessor married
:type boolean
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
)))
48 (def-view-class employee
(person)
51 :db-constraints
(:not-null
:unique
)
56 :db-constraints
:not-null
68 :accessor employee-email
75 :accessor employee-company
77 :db-info
(:join-class company
79 :foreign-key companyid
85 :accessor employee-manager
87 :db-info
(:join-class employee
92 :accessor employee-addresses
94 :db-info
(:join-class employee-address
99 (:base-table employee
))
101 (def-view-class company
()
104 :db-constraints
:not-null
109 :db-constraints
:not-null
117 :initarg
:presidentid
)
121 :db-info
(:join-class employee
122 :home-key presidentid
126 :reader company-employees
128 :db-info
(:join-class employee
129 :home-key
(companyid groupid
)
130 :foreign-key
(ecompanyid groupid
)
133 (def-view-class address
()
136 :db-constraints
:not-null
141 :initarg
:street-number
)
145 :initarg
:street-name
)
148 :void-value
"no city"
155 :initarg
:postal-code
))
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
166 :foreign-key addressid
167 :retrieval
:immediate
))
168 (employee :db-kind
:join
169 :db-info
(:join-class employee
172 :retrieval
:immediate
)))
173 (:base-table
"ea_join"))
175 (def-view-class deferred-employee-address
()
176 ((aemplid :type integer
:initarg
:emplid
)
177 (aaddressid :type integer
:initarg
:addressid
)
178 (verified :type boolean
:initarg
:verified
)
179 (address :db-kind
:join
180 :db-info
(:join-class address
182 :foreign-key addressid
185 (:base-table
"ea_join"))
187 (def-view-class big
()
188 ((i :type integer
:initarg
:i
)
189 (bi :type bigint
:initarg
:bi
)))
191 (defun test-connect-to-database (db-type spec
)
192 (when (clsql-sys:db-backend-has-create
/destroy-db? db-type
)
193 (ignore-errors (destroy-database spec
:database-type db-type
))
194 (ignore-errors (create-database spec
:database-type db-type
)))
196 (setf *test-database-type
* db-type
)
197 (setf *test-database-user
*
199 ((eq :oracle db-type
) (second spec
))
200 ((>= (length spec
) 3) (third spec
))))
202 ;; Connect to the database
204 :database-type db-type
208 ;; Ensure database is empty
209 (truncate-database :database
*default-database
*)
211 (setf *test-database-underlying-type
*
212 (clsql-sys:database-underlying-type
*default-database
*))
216 (defparameter company1 nil
)
217 (defparameter employee1 nil
)
218 (defparameter employee2 nil
)
219 (defparameter employee3 nil
)
220 (defparameter employee4 nil
)
221 (defparameter employee5 nil
)
222 (defparameter employee6 nil
)
223 (defparameter employee7 nil
)
224 (defparameter employee8 nil
)
225 (defparameter employee9 nil
)
226 (defparameter employee10 nil
)
227 (defparameter address1 nil
)
228 (defparameter address2 nil
)
229 (defparameter employee-address1 nil
)
230 (defparameter employee-address2 nil
)
231 (defparameter employee-address3 nil
)
232 (defparameter employee-address4 nil
)
233 (defparameter employee-address5 nil
)
235 (defun test-initialise-database ()
236 (test-basic-initialize)
237 (let ((*backend-warning-behavior
*
238 (if (member *test-database-type
* '(:postgresql
:postgresql-socket
))
241 (clsql:create-view-from-class
'employee
)
242 (clsql:create-view-from-class
'company
)
243 (clsql:create-view-from-class
'address
)
244 (clsql:create-view-from-class
'employee-address
)
245 (clsql:create-view-from-class
'big
))
247 (setq *test-start-utime
* (get-universal-time))
248 (let* ((*db-auto-sync
* t
)
249 (now-time (clsql:utime-
>time
*test-start-utime
*)))
250 (setf company1
(make-instance 'company
254 :name
"Widgets Inc.")
255 employee1
(make-instance 'employee
259 :height
(1+ (random 1.00))
260 :bd-utime
*test-start-utime
*
262 :first-name
"Vladimir"
264 :email
"lenin@soviet.org"
266 employee2
(make-instance 'employee
269 :height
(1+ (random 1.00))
271 :bd-utime
*test-start-utime
*
275 :email
"stalin@soviet.org"
278 employee3
(make-instance 'employee
281 :height
(1+ (random 1.00))
283 :bd-utime
*test-start-utime
*
287 :email
"trotsky@soviet.org"
290 employee4
(make-instance 'employee
293 :height
(1+ (random 1.00))
295 :bd-utime
*test-start-utime
*
298 :last-name
"Kruschev"
299 :email
"kruschev@soviet.org"
302 employee5
(make-instance 'employee
306 :height
(1+ (random 1.00))
307 :bd-utime
*test-start-utime
*
310 :last-name
"Brezhnev"
311 :email
"brezhnev@soviet.org"
314 employee6
(make-instance 'employee
318 :height
(1+ (random 1.00))
319 :bd-utime
*test-start-utime
*
322 :last-name
"Andropov"
323 :email
"andropov@soviet.org"
326 employee7
(make-instance 'employee
329 :height
(1+ (random 1.00))
331 :bd-utime
*test-start-utime
*
333 :first-name
"Konstantin"
334 :last-name
"Chernenko"
335 :email
"chernenko@soviet.org"
338 employee8
(make-instance 'employee
341 :height
(1+ (random 1.00))
343 :bd-utime
*test-start-utime
*
345 :first-name
"Mikhail"
346 :last-name
"Gorbachev"
347 :email
"gorbachev@soviet.org"
350 employee9
(make-instance 'employee
354 :height
(1+ (random 1.00))
355 :bd-utime
*test-start-utime
*
359 :email
"yeltsin@soviet.org"
362 employee10
(make-instance 'employee
366 :height
(1+ (random 1.00))
367 :bd-utime
*test-start-utime
*
369 :first-name
"Vladimir"
371 :email
"putin@soviet.org"
374 address1
(make-instance 'address
377 :street-name
"Park Place"
380 address2
(make-instance 'address
382 employee-address1
(make-instance 'employee-address
386 employee-address2
(make-instance 'employee-address
390 employee-address3
(make-instance 'employee-address
394 employee-address4
(make-instance 'employee-address
398 employee-address5
(make-instance 'employee-address
402 (let ((max (expt 2 60)))
404 (make-instance 'big
:i
(1+ i
) :bi
(truncate max
(1+ i
))))))
406 ;; sleep to ensure birthdays are no longer at current time
410 ;; Lenin manages everyone
411 (clsql:add-to-relation employee2
'manager employee1
)
412 (clsql:add-to-relation employee3
'manager employee1
)
413 (clsql:add-to-relation employee4
'manager employee1
)
414 (clsql:add-to-relation employee5
'manager employee1
)
415 (clsql:add-to-relation employee6
'manager employee1
)
416 (clsql:add-to-relation employee7
'manager employee1
)
417 (clsql:add-to-relation employee8
'manager employee1
)
418 (clsql:add-to-relation employee9
'manager employee1
)
419 (clsql:add-to-relation employee10
'manager employee1
)
420 ;; Everyone works for Widgets Inc.
421 (clsql:add-to-relation company1
'employees employee1
)
422 (clsql:add-to-relation company1
'employees employee2
)
423 (clsql:add-to-relation company1
'employees employee3
)
424 (clsql:add-to-relation company1
'employees employee4
)
425 (clsql:add-to-relation company1
'employees employee5
)
426 (clsql:add-to-relation company1
'employees employee6
)
427 (clsql:add-to-relation company1
'employees employee7
)
428 (clsql:add-to-relation company1
'employees employee8
)
429 (clsql:add-to-relation company1
'employees employee9
)
430 (clsql:add-to-relation company1
'employees employee10
)
431 ;; Lenin is president of Widgets Inc.
432 (clsql:add-to-relation company1
'president employee1
)
435 ;; store these instances
437 (clsql:update-records-from-instance employee1
)
438 (clsql:update-records-from-instance employee2
)
439 (clsql:update-records-from-instance employee3
)
440 (clsql:update-records-from-instance employee4
)
441 (clsql:update-records-from-instance employee5
)
442 (clsql:update-records-from-instance employee6
)
443 (clsql:update-records-from-instance employee7
)
444 (clsql:update-records-from-instance employee8
)
445 (clsql:update-records-from-instance employee9
)
446 (clsql:update-records-from-instance employee10
)
447 (clsql:update-records-from-instance company1
)
448 (clsql:update-records-from-instance address1
)
449 (clsql:update-records-from-instance address2
)
453 (defvar *error-count
* 0)
454 (defvar *error-list
* nil
)
456 (defun run-function-append-report-file (function report-file
)
457 (let* ((report-path (etypecase report-file
458 (pathname report-file
)
459 (string (parse-namestring report-file
))))
460 (sexp-report-path (make-pathname :defaults report-path
462 (with-open-file (rs report-path
:direction
:output
464 :if-does-not-exist
:create
)
465 (with-open-file (srs sexp-report-path
:direction
:output
467 :if-does-not-exist
:create
)
468 (funcall function
:report-stream rs
:sexp-report-stream srs
)))))
470 (defun run-tests-append-report-file (report-file)
471 (run-function-append-report-file 'run-tests report-file
))
474 (defun run-tests (&key
(report-stream *standard-output
*) (sexp-report-stream nil
))
475 (let ((specs (read-specs))
476 (*report-stream
* report-stream
)
477 (*sexp-report-stream
* sexp-report-stream
)
481 (warn "Not running tests because test configuration file is missing")
482 (return-from run-tests
:skipped
))
483 (load-necessary-systems specs
)
484 (dolist (db-type +all-db-types
+)
485 (dolist (spec (db-type-spec db-type specs
))
486 (do-tests-for-backend db-type spec
))))
487 (zerop *error-count
*))
489 (defun load-necessary-systems (specs)
490 (dolist (db-type +all-db-types
+)
491 (when (db-type-spec db-type specs
)
492 (clsql-sys:initialize-database-type
:database-type db-type
))))
494 (defun write-report-banner (report-type db-type stream
)
497 ******************************************************************************
498 *** CLSQL ~A begun at ~A
501 *** Database ~:@(~A~) backend~A.
502 ******************************************************************************
507 (clsql:utime-
>time
(get-universal-time)))
508 (lisp-implementation-type)
509 (lisp-implementation-version)
512 (if (not (eq db-type
*test-database-underlying-type
*))
513 (format nil
" with underlying type ~:@(~A~)"
514 *test-database-underlying-type
*)
518 (defun do-tests-for-backend (db-type spec
)
519 (test-connect-to-database db-type spec
)
522 (multiple-value-bind (test-forms skip-tests
)
523 (compute-tests-for-backend db-type
*test-database-underlying-type
*)
525 (write-report-banner "Test Suite" db-type
*report-stream
*)
527 (test-initialise-database)
529 (regression-test:rem-all-tests
)
530 (dolist (test-form test-forms
)
533 (let ((remaining (regression-test:do-tests
*report-stream
*)))
534 (when (regression-test:pending-tests
)
535 (incf *error-count
* (length remaining
))))
537 (let ((sexp-error (list db-type
538 *test-database-underlying-type
*
541 (regression-test:pending-tests
)
542 (lisp-implementation-type)
543 (lisp-implementation-version)
545 (when *sexp-report-stream
*
546 (write sexp-error
:stream
*sexp-report-stream
* :readably t
))
547 (push sexp-error
*error-list
*))
549 (format *report-stream
* "~&Tests skipped:")
551 (dolist (skipped skip-tests
)
552 (format *report-stream
*
553 "~& ~20A ~A~%" (car skipped
) (cdr skipped
)))
554 (format *report-stream
* " None~%")))
558 (defun compute-tests-for-backend (db-type db-underlying-type
)
559 (let ((test-forms '())
561 (dolist (test-form (append *rt-internal
* *rt-connection
* *rt-basic
* *rt-fddl
* *rt-fdml
*
562 *rt-ooddl
* *rt-oodml
* *rt-syntax
*))
563 (let ((test (second test-form
)))
565 ((and (null (clsql-sys:db-type-has-views? db-underlying-type
))
566 (clsql-sys:in test
:fddl
/view
/1 :fddl
/view
/2 :fddl
/view
/3 :fddl
/view
/4))
567 (push (cons test
"views not supported") skip-tests
))
568 ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type
))
569 (clsql-sys:in test
:fdml
/select
/11 :oodml
/select
/5))
570 (push (cons test
"boolean where not supported") skip-tests
))
571 ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type
))
572 (clsql-sys:in test
:fdml
/select
/5 :fdml
/select
/10
573 :fdml
/select
/32 :fdml
/select
/33))
574 (push (cons test
"subqueries not supported") skip-tests
))
575 ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
577 (clsql-sys:in test
:fdml
/transaction
/1 :fdml
/transaction
/2 :fdml
/transaction
/3 :fdml
/transaction
/4))
578 (push (cons test
"transactions not supported") skip-tests
))
579 ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type
))
580 (clsql-sys:in test
:fdml
/select
/1))
581 (push (cons test
"fancy math not supported") skip-tests
))
582 ((and (eql *test-database-type
* :sqlite
)
583 (clsql-sys:in test
:fddl
/view
/4 :fdml
/select
/10
584 :fdml
/select
/21 :fdml
/select
/32
586 (push (cons test
"not supported by sqlite") skip-tests
))
587 ((and (eql *test-database-type
* :sqlite3
)
588 (clsql-sys:in test
:fddl
/view
/4 :fdml
/select
/10
589 :fdml
/select
/21 :fdml
/select
/32
591 (push (cons test
"not supported by sqlite3") skip-tests
))
592 ((and (not (clsql-sys:db-type-has-bigint? db-type
))
593 (clsql-sys:in test
:basic
/bigint
/1))
594 (push (cons test
"bigint not supported") skip-tests
))
595 ((and (eql *test-database-underlying-type
* :mysql
)
596 (clsql-sys:in test
:fdml
/select
/26))
597 (push (cons test
"string table aliases not supported on all mysql versions") skip-tests
))
598 ((and (eql *test-database-underlying-type
* :mysql
)
599 (clsql-sys:in test
:fdml
/select
/22 :fdml
/query
/5
600 :fdml
/query
/7 :fdml
/query
/8))
601 (push (cons test
"not supported by mysql") skip-tests
))
602 ((and (null (clsql-sys:db-type-has-union? db-underlying-type
))
603 (clsql-sys:in test
:fdml
/query
/6 :fdml
/select
/31))
604 (push (cons test
"union not supported") skip-tests
))
605 ((and (eq *test-database-type
* :oracle
)
606 (clsql-sys:in test
:fdml
/query
/8 :fdml
/select
/21
608 (push (cons test
"syntax not supported") skip-tests
))
609 ((and (eq *test-database-type
* :odbc
)
610 (eq *test-database-underlying-type
* :postgresql
)
611 (clsql-sys:in test
:fddl
/owner
/1))
612 (push (cons test
"table ownership not supported by postgresql odbc driver") skip-tests
))
613 ((and (not (member *test-database-underlying-type
*
614 '(:postgresql
:oracle
)))
615 (clsql-sys:in test
:fddl
/owner
/1))
616 (push (cons test
"table ownership not supported") skip-tests
))
617 ((and (null (clsql-sys:db-type-has-intersect? db-underlying-type
))
618 (clsql-sys:in test
:fdml
/query
/7))
619 (push (cons test
"intersect not supported") skip-tests
))
620 ((and (null (clsql-sys:db-type-has-except? db-underlying-type
))
621 (clsql-sys:in test
:fdml
/query
/8))
622 (push (cons test
"except not supported") skip-tests
))
623 ((and (eq *test-database-underlying-type
* :mssql
)
624 (clsql-sys:in test
:fdml
/select
/9))
625 (push (cons test
"mssql uses integer math for AVG") skip-tests
))
626 ((and (not (member *test-database-underlying-type
*
627 '(:postgresql
:mysql
:sqlite3
)))
628 (clsql-sys:in test
:fdml
/select
/37 :fdml
/select
/38))
629 (push (cons test
"LIMIT keyword not supported in SELECT") skip-tests
))
631 (push test-form test-forms
)))))
632 (values (nreverse test-forms
) (nreverse skip-tests
))))
634 (defun rapid-load (type &optional
(position 0))
635 "Rapid load for interactive testing."
636 (when *default-database
*
637 (disconnect :database
*default-database
*))
638 (test-connect-to-database type
(nth position
(db-type-spec type
(read-specs))))
639 (test-initialise-database)
643 (rapid-load :postgresql
))
649 (rapid-load :oracle
))