From f2a0eb003af406415567c9f8545455ede786db87 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 21 Apr 2004 20:34:42 +0000 Subject: [PATCH] r9123: test & capability updates --- ChangeLog | 12 ++ base/db-interface.lisp | 8 +- base/package.lisp | 2 + base/time.lisp | 57 +++---- clsql-odbc.asd | 2 +- db-aodbc/aodbc-sql.lisp | 25 ++- db-odbc/odbc-api.lisp | 13 +- db-odbc/odbc-package.lisp | 1 + .../postgresql-socket-sql.lisp | 10 ++ db-postgresql/postgresql-sql.lisp | 5 + sql/new-objects.lisp | 10 +- sql/objects.lisp | 30 ++-- sql/package.lisp | 2 + sql/sql.lisp | 3 + tests/test-basic.lisp | 136 ++++++++--------- tests/test-fddl.lisp | 12 +- tests/test-fdml.lisp | 43 +++--- tests/test-init.lisp | 142 ++++++++++-------- 18 files changed, 299 insertions(+), 214 deletions(-) diff --git a/ChangeLog b/ChangeLog index 6797204..5520368 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +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. diff --git a/base/db-interface.lisp b/base/db-interface.lisp index 9591c9c..9a91a69 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -224,6 +224,12 @@ the given lisp type and parameters.")) 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)) @@ -233,7 +239,7 @@ the given lisp type and parameters.")) (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'.")) diff --git a/base/package.lisp b/base/package.lisp index 5d460b8..d78b6ab 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -178,6 +178,7 @@ #:format-duration #:format-time #:get-time + #:utime->time #:interval-clear #:interval-contained #:interval-data @@ -291,6 +292,7 @@ #: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? )) diff --git a/base/time.lisp b/base/time.lisp index cd32be4..44f10e1 100644 --- a/base/time.lisp +++ b/base/time.lisp @@ -109,13 +109,17 @@ (%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) @@ -680,31 +684,32 @@ TIME2." (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) diff --git a/clsql-odbc.asd b/clsql-odbc.asd index 6da2c6e..fd7468f 100644 --- a/clsql-odbc.asd +++ b/clsql-odbc.asd @@ -28,7 +28,7 @@ :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 diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 7d49c7d..22aa329 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -37,7 +37,8 @@ ;; 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))) @@ -202,6 +203,20 @@ (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)) @@ -224,6 +239,11 @@ (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)) @@ -275,6 +295,9 @@ ;;; 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) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 03860af..b9223d6 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -24,11 +24,16 @@ May be locally bound to something else if a certain type is necessary.") (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)) diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp index c34147b..583d9a7 100644 --- a/db-odbc/odbc-package.lisp +++ b/db-odbc/odbc-package.lisp @@ -27,6 +27,7 @@ #:+null-ptr+ #:+max-precision+ #:*info-output* + #:*time-conversion-function* #:get-cast-long #:%free-statement #:%disconnect diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 6307f05..c63c58d 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -504,5 +504,15 @@ doesn't depend on UFFI." (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)) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 3d1eca3..7130af5 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -601,5 +601,10 @@ (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)) diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp index e7c49ce..64e9ade 100644 --- a/sql/new-objects.lisp +++ b/sql/new-objects.lisp @@ -524,7 +524,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (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)")) @@ -539,7 +539,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) 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)"))) @@ -547,20 +547,20 @@ DATABASE-NULL-VALUE on the type of the slot.")) 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 diff --git a/sql/objects.lisp b/sql/objects.lisp index 38c5f49..9f61624 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -544,7 +544,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) (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)")) @@ -559,31 +560,32 @@ DATABASE-NULL-VALUE on the type of the slot.")) 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") diff --git a/sql/package.lisp b/sql/package.lisp index 6a11503..76fbe5f 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -239,6 +239,7 @@ #:db-type-has-subqueries? #:db-type-has-boolean-where? #:db-type-transaction-capable? + #:db-type-has-fancy-math? #:database-underlying-type )) (:export @@ -276,6 +277,7 @@ #:db-type-has-subqueries? #:db-type-has-boolean-where? #:db-type-transaction-capable? + #:db-type-has-fancy-math? #:database-underlying-type . diff --git a/sql/sql.lisp b/sql/sql.lisp index 8227fea..21f5371 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -38,6 +38,9 @@ (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)) diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index 2a63c77..d6fcfa1 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -18,58 +18,69 @@ (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 @@ -79,30 +90,13 @@ (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 @@ -113,7 +107,8 @@ ((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 @@ -139,7 +134,7 @@ (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 @@ -161,6 +156,3 @@ (if (> diff (* 10 double-float-epsilon)) nil t)))) - -(defun drop-test-table (db) - (clsql:execute-command "DROP TABLE test_clsql" :database db)) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index 2cb4b2b..961cc3d 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -1,9 +1,9 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ====================================================================== -;;;; File: test-fddl.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: $Id$ +;;;; File: test-fddl.lisp +;;;; Authors: Marcus Pearce and Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; Updated: $Id$ ;;;; ;;;; Tests for the CLSQL Functional Data Definition Language ;;;; (FDDL). @@ -27,8 +27,8 @@ (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 diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index 81fea97..c8b5869 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -152,23 +152,22 @@ ;; 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 @@ -198,12 +197,12 @@ ("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 diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 0584762..ba69ba0 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -120,20 +120,26 @@ -(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) @@ -149,10 +155,12 @@ (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) @@ -299,9 +307,8 @@ (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) @@ -309,58 +316,69 @@ (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)))) -- 2.34.1