+21 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
+ * Version 2.9.3
+ * test/test-init.lisp: Display names of skipped tests.
+ Use unwind-protect to ensure disconnect
+ * sql/objects.lisp: Change database-type to database-underlying-type
+ so that actual database engine is properly identified
+ * db-odbc/odbc-api.lisp: Have default *time-conversion-function*
+ return an ISO timestring for compatibility with other drivers
+ * test/test-fdml.lisp: Accomodate that odbc-postgresql driver
+ returns floating-point values for floor and truncate operations
+ * db-aodbc/aodbc-sql: Implement DATABASE-LIST-VIEWS
+
21 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
* Version 2.9.2: Improvments in database capability introspection
and querying. Support transactions in MySQL where available.
t)
(:documentation "T [default] if database-type supports views."))
+(defgeneric db-type-has-fancy-math? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ nil)
+ (:documentation "NIL [default] if database-type does not have fancy math."))
+
(defgeneric db-type-has-subqueries? (db-type)
(:method (db-type)
(declare (ignore db-type))
(defgeneric db-type-has-boolean-where? (db-type)
(:method (db-type)
(declare (ignore db-type))
- ;; SQL92 has boolean where
+ ;; SQL99 has boolean where
t)
(:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'."))
#:format-duration
#:format-time
#:get-time
+ #:utime->time
#:interval-clear
#:interval-contained
#:interval-data
#:db-type-has-views?
#:db-type-has-subqueries?
#:db-type-has-boolean-where?
+ #:db-type-has-fancy-math?
#:db-backend-has-create/destroy-db?
#:db-type-transaction-capable?
))
(%make-wall-time :mjd (time-mjd time)
:second (time-second time)))
-(defun get-time ()
+(defun utime->time (utime)
"Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
(multiple-value-bind (second minute hour day mon year)
- (decode-universal-time (get-universal-time))
+ (decode-universal-time utime)
(make-time :year year :month mon :day day :hour hour :minute minute
:second second)))
+(defun get-time ()
+ "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)"
+ (utime->time (get-universal-time)))
+
(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0)
(second 0))
(multiple-value-bind (minute-add second-60)
(internal-separator " "))
"produces on stream the timestring corresponding to the wall-time
with the given options"
- (multiple-value-bind (second minute hour day month year dow)
- (decode-time time)
- (case format
- (:pretty
- (format stream "~A ~A, ~A ~D, ~D"
- (pretty-time hour minute)
- (day-name dow)
- (month-name month)
- day
- year))
- (:short-pretty
- (format stream "~A, ~D/~D/~D"
- (pretty-time hour minute)
- month day year))
- (:iso
- (let ((string (iso-timestring time)))
- (if stream
- (write-string string stream)
+ (let ((*print-circle* nil))
+ (multiple-value-bind (second minute hour day month year dow)
+ (decode-time time)
+ (case format
+ (:pretty
+ (format stream "~A ~A, ~A ~D, ~D"
+ (pretty-time hour minute)
+ (day-name dow)
+ (month-name month)
+ day
+ year))
+ (:short-pretty
+ (format stream "~A, ~D/~D/~D"
+ (pretty-time hour minute)
+ month day year))
+ (:iso
+ (let ((string (iso-timestring time)))
+ (if stream
+ (write-string string stream)
string)))
- (t
- (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
- year date-separator month date-separator day
- internal-separator hour time-separator minute time-separator
- second)))))
-
+ (t
+ (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D"
+ year date-separator month date-separator day
+ internal-separator hour time-separator minute time-separator
+ second))))))
+
(defun pretty-time (hour minute)
(cond
((eq hour 0)
:description "Common Lisp SQL ODBC Driver"
:long-description "cl-sql-odbc package provides a database driver to the ODBC database system."
- :depends-on (uffi clsql-base clsql-uffi)
+ :depends-on (uffi clsql-base clsql-uffi clsql-mysql clsql-postgresql)
:components
((:module :db-odbc
:components
;; AODBC interface
(defclass aodbc-database (database)
- ((aodbc-conn :accessor database-aodbc-conn :initarg :aodbc-conn)))
+ ((aodbc-conn :accessor database-aodbc-conn :initarg :aodbc-conn)
+ (aodbc-db-type :accessor database-aodbc-db-type :initform :unknown)))
(defmethod database-name-from-spec (connection-spec
(database-type (eql :aodbc)))
(string-equal "TABLE" (nth 3 row)))
collect (nth 2 row))))
+(defmethod database-list-views ((database aodbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ #+aodbc-v2
+ (multiple-value-bind (rows col-names)
+ (dbi:list-all-database-tables :db (database-aodbc-conn database))
+ (declare (ignore col-names))
+ ;; TABLE_SCHEM is hard-coded in second column by ODBC Driver Manager
+ ;; TABLE_NAME in third column, TABLE_TYPE in fourth column
+ (loop for row in rows
+ when (and (not (string-equal "information_schema" (nth 1 row)))
+ (string-equal "VIEW" (nth 3 row)))
+ collect (nth 2 row))))
+
(defmethod database-list-attributes ((table string) (database aodbc-database)
&key (owner nil))
(declare (ignore owner))
(loop for row in rows
collect (nth pos row))))))
+(defmethod database-list-indexes ((database aodbc-database)
+ &key (owner nil))
+ (warn "database-list-indexes not implemented for AODBC.")
+ nil)
+
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database aodbc-database))
;;; Backend capabilities
+(defmethod database-underlying-type ((database aodbc-database))
+ (database-aodbc-db-type database))
+
(defmethod db-backend-has-create/destroy-db? ((db-type (eql :aodbc)))
nil)
(defvar *binary-format* :unsigned-byte-vector)
-(defvar *time-conversion-function* (lambda (universal-time &optional fraction)
- (declare (ignore fraction))
- universal-time)
+(defvar *time-conversion-function*
+ (lambda (universal-time &optional fraction)
+ (declare (ignore fraction))
+ (clsql-base:format-time
+ nil (clsql-base:utime->time universal-time)
+ :format :iso)
+ #+ignore
+ universal-time)
"Bound to a function that converts from a Lisp universal time fixnum (and a fractional
-as possible second argument) to the desired representation of date/time/timestamp.")
+as possible second argument) to the desired representation of date/time/timestamp. By default, returns an iso-timestring.")
(defvar +null-ptr+ (make-null-pointer :byte))
(defparameter +null-handle-ptr+ (make-null-pointer :void))
#:+null-ptr+
#:+max-precision+
#:*info-output*
+ #:*time-conversion-function*
#:get-cast-long
#:%free-statement
#:%disconnect
(sql-escape (string-downcase table)))
database :auto))
+
+;; Database capabilities
+
+(defmethod db-backend-has-create/destroy-db? ((db-type (eql :postgresql-socket)))
+ nil)
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql-socket)))
+ t)
+
+
(when (clsql-base-sys:database-type-library-loaded :postgresql-socket)
(clsql-base-sys:initialize-database-type :database-type :postgresql-socket))
(setf conn-ptr (%pg-database-connection connection-spec))
database))))
+;;; Database capabilities
+
+(defmethod db-type-has-fancy-math? ((db-type (eql :postgresql)))
+ t)
+
(when (clsql-base-sys:database-type-library-loaded :postgresql)
(clsql-base-sys:initialize-database-type :database-type :postgresql))
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)"))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)")))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'string)) args database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (member (database-underlying-type database) '(:postgresql :postgresql-socket))
"VARCHAR"
"VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
- (case (database-type database)
+ (case (database-underlying-type database)
(:postgresql
"TIMESTAMP WITHOUT TIME ZONE")
(:postgresql-socket
(defmethod database-get-type-specifier (type args database)
(declare (ignore type args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
+ (if (clsql-base-sys::in (database-underlying-type database)
+ :postgresql :postgresql-socket)
"VARCHAR"
"VARCHAR(255)"))
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
- "VARCHAR"
- "VARCHAR(255)")))
+ (if (clsql-base-sys::in (database-underlying-type database)
+ :postgresql :postgresql-socket)
+ "VARCHAR"
+ "VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'simple-string)) args
database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
- "VARCHAR"
- "VARCHAR(255)")))
+ (if (clsql-base-sys::in (database-underlying-type database)
+ :postgresql :postgresql-socket)
+ "VARCHAR"
+ "VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'string)) args database)
(if args
(format nil "VARCHAR(~A)" (car args))
- (if (member (database-type database) '(:postgresql :postgresql-socket))
- "VARCHAR"
- "VARCHAR(255)")))
+ (if (clsql-base-sys::in (database-underlying-type database)
+ :postgresql :postgresql-socket)
+ "VARCHAR"
+ "VARCHAR(255)")))
(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
(declare (ignore args))
- (case (database-type database)
- (:postgresql
- "TIMESTAMP WITHOUT TIME ZONE")
- (:postgresql-socket
+ (case (database-underlying-type database)
+ ((:postgresql :postgresql-socket)
"TIMESTAMP WITHOUT TIME ZONE")
(:mysql
"DATETIME")
#:db-type-has-subqueries?
#:db-type-has-boolean-where?
#:db-type-transaction-capable?
+ #:db-type-has-fancy-math?
#:database-underlying-type
))
(:export
#:db-type-has-subqueries?
#:db-type-has-boolean-where?
#:db-type-transaction-capable?
+ #:db-type-has-fancy-math?
#:database-underlying-type
.
(clsql-base-sys::signal-no-database-error database))
(unless (is-database-open database)
(database-reconnect database))
+ (when (db-type-has-views? (database-underlying-type database))
+ (dolist (view (list-views :database database))
+ (drop-view view :database database)))
(dolist (table (list-tables :database database))
(drop-table table :database database))
(dolist (index (list-indexes :database database))
(in-package #:clsql-tests)
+(defun test-basic-initialize ()
+ (ignore-errors
+ (clsql:execute-command "DROP TABLE TYPE_TABLE"))
+ (clsql:execute-command
+ "CREATE TABLE TYPE_TABLE (t_int integer, t_float double precision, t_bigint BIGINT, t_str VARCHAR(30))")
+ (dotimes (i 11)
+ (let* ((test-int (- i 5))
+ (test-flt (transform-float-1 test-int)))
+ (clsql:execute-command
+ (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,~a,'~a')"
+ test-int
+ (clsql-base:number-to-sql-string test-flt)
+ (transform-bigint-1 test-int)
+ (clsql-base:number-to-sql-string test-flt)
+ )))))
+
+(defun test-basic-forms ()
+ nil)
-(defun test-basic (spec type)
- (let ((db (clsql:connect spec :database-type type :if-exists :new)))
- (unwind-protect
- (if (eq type :sqlite)
- (%test-basic-untyped db type)
- (%test-basic db type))
- (disconnect :database db))))
-
-(defun %test-basic (db type)
- (create-test-table db)
- (dolist (row (query "select * from test_clsql" :database db :result-types :auto))
- (test-table-row row :auto type))
- (dolist (row (query "select * from test_clsql" :database db :result-types nil))
- (test-table-row row nil type))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :result-types :auto)
- do (test-table-row row :auto type))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :result-types nil)
- do (test-table-row row nil type))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :result-types nil)
- do (test-table-row row nil type))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :result-types :auto)
- do (test-table-row row :auto type))
- (test (map-query nil #'list "select * from test_clsql"
- :database db :result-types :auto)
+(defun test-basic-forms-untyped ()
+ nil)
+
+
+(defun %test-basic-forms ()
+ (dolist (row (query "select * from TYPE_TABLE" :result-types :auto))
+ (test-table-row row :auto))
+ (dolist (row (query "select * from TYPE_TABLE" :result-types nil))
+ (test-table-row row nil))
+ (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE"
+ :result-types :auto)
+ do (test-table-row row :auto))
+ (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE"
+ :result-types nil)
+ do (test-table-row row nil))
+ (loop for row in (map-query 'list #'list "select * from TYPE_TABLE"
+ :result-types nil)
+ do (test-table-row row nil))
+ (loop for row in (map-query 'list #'list "select * from TYPE_TABLE"
+ :result-types :auto)
+ do (test-table-row row :auto))
+ (test (map-query nil #'list "select * from TYPE_TABLE"
+ :result-types :auto)
nil
:fail-info "Expected NIL result from map-query nil")
- (do-query ((int float bigint str) "select * from test_clsql")
- (test-table-row (list int float bigint str) nil type))
- (do-query ((int float bigint str) "select * from test_clsql" :result-types :auto)
- (test-table-row (list int float bigint str) :auto type))
- (drop-test-table db))
-
-
-(defun %test-basic-untyped (db type)
- (create-test-table db)
- (dolist (row (query "select * from test_clsql" :database db :result-types nil))
- (test-table-row row nil type))
- (loop for row across (map-query 'vector #'list "select * from test_clsql"
- :database db :result-types nil)
- do (test-table-row row nil type))
- (loop for row in (map-query 'list #'list "select * from test_clsql"
- :database db :result-types nil)
- do (test-table-row row nil type))
+ (do-query ((int float bigint str) "select * from TYPE_TABLE")
+ (test-table-row (list int float bigint str) nil))
+ (do-query ((int float bigint str) "select * from TYPE_TABLE" :result-types :auto)
+ (test-table-row (list int float bigint str) :auto)))
+
+
+(defun %test-basic-forms-untyped ()
+ (dolist (row (query "select * from TYPE_TABLE" :result-types nil))
+ (test-table-row row nil))
+ (loop for row across (map-query 'vector #'list "select * from TYPE_TABLE"
+ :result-types nil)
+ do (test-table-row row nil))
+ (loop for row in (map-query 'list #'list "select * from TYPE_TABLE"
+ :result-types nil)
+ do (test-table-row row nil))
- (do-query ((int float bigint str) "select * from test_clsql")
- (test-table-row (list int float bigint str) nil type))
- (drop-test-table db))
+ (do-query ((int float bigint str) "select * from TYPE_TABLE")
+ (test-table-row (list int float bigint str) nil)))
+
;;;; Testing functions
(defun transform-bigint-1 (i)
(* i (expt 10 (* 3 (abs i)))))
-(defun create-test-table (db)
- (ignore-errors
- (clsql:execute-command
- "DROP TABLE test_clsql" :database db))
- (clsql:execute-command
- "CREATE TABLE test_clsql (t_int integer, t_float double precision, t_bigint BIGINT, t_str VARCHAR(30))"
- :database db)
- (dotimes (i 11)
- (let* ((test-int (- i 5))
- (test-flt (transform-float-1 test-int)))
- (clsql:execute-command
- (format nil "INSERT INTO test_clsql VALUES (~a,~a,~a,'~a')"
- test-int
- (clsql-base:number-to-sql-string test-flt)
- (transform-bigint-1 test-int)
- (clsql-base:number-to-sql-string test-flt)
- )
- :database db))))
+
(defun parse-double (num-str)
(let ((*read-default-float-format* 'double-float))
(coerce (read-from-string num-str) 'double-float)))
-(defun test-table-row (row types db-type)
+(defun test-table-row (row types)
(test (and (listp row)
(= 4 (length row)))
t
((eq types :auto)
(test (and (integerp int)
(typep float 'double-float)
- (or (member db-type '(:odbc :aodbc)) ;; aodbc considers bigints as strings
+ (or (member *test-database-type*
+ '(:odbc :aodbc)) ;; aodbc considers bigints as strings
(integerp bigint))
(stringp str))
t
(test t nil
:fail-info
(format nil "Invalid types field (~S) passed to test-table-row" types))))
- (unless (eq db-type :sqlite) ; SQLite is typeless.
+ (unless (eq *test-database-type* :sqlite) ; SQLite is typeless.
(test (transform-float-1 int)
float
:test #'double-float-equal
(if (> diff (* 10 double-float-epsilon))
nil
t))))
-
-(defun drop-test-table (db)
- (clsql:execute-command "DROP TABLE test_clsql" :database db))
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; ======================================================================
-;;;; File: test-fddl.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; Created: 30/03/2004
-;;;; Updated: $Id$
+;;;; File: test-fddl.lisp
+;;;; Authors: Marcus Pearce <m.t.pearce@city.ac.uk> and Kevin Rosenberg
+;;;; Created: 30/03/2004
+;;;; Updated: $Id$
;;;;
;;;; Tests for the CLSQL Functional Data Definition Language
;;;; (FDDL).
(apply #'values
(sort (mapcar #'string-downcase
(clsql:list-tables :owner *test-database-user*))
- #'string>))
- "employee" "company")
+ #'string<))
+ "company" "employee" "type_table")
;; create a table, test for its existence, drop it and test again
(deftest :fddl/table/2
;; compare min, max and average hieghts in inches (they're quite short
-;; these guys!) -- only works with pgsql
+;; these guys!)
(deftest :fdml/select/1
- (if (member *test-database-type* '(:postgresql-socket :postgresql))
- (let ((max (clsql:select [function "floor"
- [/ [* [max [height]] 100] 2.54]]
- :from [employee]
- :flatp t))
- (min (clsql:select [function "floor"
- [/ [* [min [height]] 100] 2.54]]
- :from [employee]
- :flatp t))
- (avg (clsql:select [function "floor"
- [avg [/ [* [height] 100] 2.54]]]
- :from [employee]
- :flatp t)))
- (apply #'< (mapcar #'parse-integer (append min avg max))))
- t)
+ (let ((max (clsql:select [function "floor"
+ [/ [* [max [height]] 100] 2.54]]
+ :from [employee]
+ :flatp t))
+ (min (clsql:select [function "floor"
+ [/ [* [min [height]] 100] 2.54]]
+ :from [employee]
+ :flatp t))
+ (avg (clsql:select [function "floor"
+ [avg [/ [* [height] 100] 2.54]]]
+ :from [employee]
+ :flatp t)))
+ (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t))
+ (append min avg max))))
t)
(deftest :fdml/select/2
("lenin@soviet.org"))
(deftest :fdml/select/6
- (if (member *test-database-type* '(:postgresql-socket :postgresql))
- (mapcar #'parse-integer
- (clsql:select [function "trunc" [height]] :from [employee]
- :flatp t))
- (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t)))
- (clsql:select [height] :from [employee] :flatp t)))
+ (if (db-type-has-fancy-math? *test-database-underlying-type*)
+ (mapcar #'(lambda (s) (parse-integer s :junk-allowed t))
+ (clsql:select [function "trunc" [height]] :from [employee]
+ :flatp t))
+ (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t)))
+ (clsql:select [height] :from [employee] :flatp t)))
(1 1 1 1 1 1 1 1 1 1))
(deftest :fdml/select/7
-(defun test-connect-to-database (database-type spec)
- (setf *test-database-type* database-type)
- (when (>= (length spec) 3)
- (setq *test-database-user* (third spec)))
-
- ;; Connect to the database
- (clsql:connect spec
- :database-type database-type
- :make-default t
- :if-exists :old)
+(defun test-connect-to-database (db-type)
+ (let ((spec (db-type-spec db-type (read-specs))))
+ (when (db-backend-has-create/destroy-db? db-type)
+ (ignore-errors (destroy-database spec :database-type db-type))
+ (ignore-errors (create-database spec :database-type db-type)))
+
+ (setf *test-database-type* db-type)
+ (when (>= (length spec) 3)
+ (setq *test-database-user* (third spec)))
+
+ ;; Connect to the database
+ (clsql:connect spec
+ :database-type db-type
+ :make-default t
+ :if-exists :old))
+
(setf *test-database-underlying-type*
- (clsql-sys:database-underlying-type *default-database*))
-
+ (clsql-sys:database-underlying-type *default-database*))
+
*default-database*)
(defparameter company1 nil)
(defparameter employee10 nil)
(defun test-initialise-database ()
- ;; Remove the tables to support cases when destroy-database isn't supported, like odbc
- (ignore-errors (clsql:drop-table "EMPLOYEE"))
- (ignore-errors (clsql:drop-table "COMPANY"))
- (ignore-errors (clsql:drop-table "FOO"))
+ ;; Ensure that old objects are removed
+ (unless (db-backend-has-create/destroy-db? *test-database-type*)
+ (truncate-database *default-database*))
+
+ (test-basic-initialize)
+
(clsql:create-view-from-class 'employee)
(clsql:create-view-from-class 'company)
(return-from run-tests :skipped))
(load-necessary-systems specs)
(dolist (db-type +all-db-types+)
- (let ((spec (db-type-spec db-type specs)))
- (when spec
- (do-tests-for-backend spec db-type))))
+ (when (db-type-spec db-type specs)
+ (do-tests-for-backend db-type)))
(zerop *error-count*)))
(defun load-necessary-systems (specs)
(when (db-type-spec db-type specs)
(db-type-ensure-system db-type))))
-(defun do-tests-for-backend (spec db-type)
+(defun do-tests-for-backend (db-type)
(format t
"~&
*******************************************************************
*** Running CLSQL tests with ~A backend.
*******************************************************************
" db-type)
- (regression-test:rem-all-tests)
- ;; Tests of clsql-base
- (ignore-errors (destroy-database spec :database-type db-type))
- (ignore-errors (create-database spec :database-type db-type))
- (with-tests (:name "CLSQL")
- (test-basic spec db-type))
- (incf *error-count* *test-errors*)
+ (test-connect-to-database db-type)
+ (unwind-protect
+ (multiple-value-bind (test-forms skip-tests)
+ (compute-tests-for-backend db-type *test-database-underlying-type*)
+
+ (test-initialise-database)
- (when (db-backend-has-create/destroy-db? db-type)
- (ignore-errors (destroy-database spec :database-type db-type))
- (ignore-errors (create-database spec :database-type db-type)))
+ (regression-test:rem-all-tests)
+ (dolist (test-form test-forms)
+ (eval test-form))
+
+ (let ((remaining (rtest:do-tests)))
+ (when (consp remaining)
+ (incf *error-count* (length remaining))))
+
+ (format t "~&Tests skipped for ~A:" db-type)
+ (if skip-tests
+ (dolist (skipped skip-tests)
+ (format t "~& ~20A ~A~%" (car skipped) (cdr skipped)))
+ (format t " None~%")))
+ (disconnect)))
- (test-connect-to-database db-type spec)
- (dolist (test-form (append *rt-connection* *rt-fddl* *rt-fdml*
+(defun compute-tests-for-backend (db-type db-underlying-type)
+ (declare (ignore db-type))
+ (let ((test-forms '())
+ (skip-tests '()))
+ (dolist (test-form (append
+ (if (eq db-type :sqlite)
+ (test-basic-forms-untyped)
+ (test-basic-forms))
+ *rt-connection* *rt-fddl* *rt-fdml*
*rt-ooddl* *rt-oodml* *rt-syntax*))
- (let ((test (second test-form)))
- (cond
- ((and (null (db-type-has-views? *test-database-underlying-type*))
- (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
- ;; skip test
- )
- ((and (null (db-type-has-boolean-where? *test-database-underlying-type*))
- (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
- ;; skip tests
- )
- ((and (null (db-type-has-subqueries? *test-database-underlying-type*))
- (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
- ;; skip tests
- )
- ((and (null (db-type-transaction-capable? *test-database-underlying-type* *default-database*))
- (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
- ;; skip tests
- )
- ((and (eql *test-database-type* :sqlite)
- (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
- ;; skip tests
- )
- (t
- (eval test-form)))))
-
- (test-initialise-database)
- (let ((remaining (rtest:do-tests)))
- (when (consp remaining)
- (incf *error-count* (length remaining))))
- (disconnect))
+ (let ((test (second test-form)))
+ (cond
+ ((and (null (db-type-has-views? db-underlying-type))
+ (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
+ (push (cons test "views not supported") skip-tests))
+ ((and (null (db-type-has-boolean-where? db-underlying-type))
+ (clsql-base-sys::in test :fdml/select/11 :oodml/select/5))
+ (push (cons test "boolean where not supported") skip-tests))
+ ((and (null (db-type-has-subqueries? db-underlying-type))
+ (clsql-base-sys::in test :fdml/select/5 :fdml/select/10))
+ (push (cons test "subqueries not supported") skip-tests))
+ ((and (null (db-type-transaction-capable? db-underlying-type
+ *default-database*))
+ (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
+ (push (cons test "transactions not supported") skip-tests))
+ ((and (null (db-type-has-fancy-math? db-underlying-type))
+ (clsql-base-sys::in test :fdml/select/1))
+ (push (cons test "fancy math not supported") skip-tests))
+ ((and (eql *test-database-type* :sqlite)
+ (clsql-base-sys::in test :fddl/view/4 :fdml/select/10))
+ (push (cons test "not supported by sqlite") skip-tests))
+ (t
+ (push test-form test-forms)))))
+ (values (nreverse test-forms) (nreverse skip-tests))))
projects / clsql.git / commitdiff