+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.
+ All tests now pass on MySQL and SQLite in addition to postgresql
+ and postgresql-socket. ODBC fails only with OODDL/TIME/1 and OODDL/TIME/2.
+ * db-odbc/odbc-sql.lisp: Add DATABASE-LIST-VIEWS. Better support
+ DATABASE-LIST-SEQUENCES.
+ * clsql-uffi.asd, clsql-mysql.asd: Improve shared library loading
+ * Database_capabilies: add HAS-VIEWS, HAS-CREATE/DESTROY-DB,
+ HAS-BOOLEAN-WHERE, TRANSACTION-CAPABLE
+ * tests/*.lisp: Check database capabilities and remove tests which
+ the database backend does not support
+ * sql/table.lisp: Add :TRANSACTIONS keyword to create table which
+ controls whether InnoDB tables will be created when supported on
+ the underlying MySQL server.
+
20 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
* Version 2.9.0: New API function: LIST-TABLE-INDEXES,
supported by all database backends (except AODBC since
(database-type database))
(:documentation "Returns the type of the underlying database. For ODBC, needs to query ODBC driver."))
-(defgeneric db-use-column-on-drop-index? (db-type)
+(defgeneric db-type-use-column-on-drop-index? (db-type)
(:method (db-type)
(declare (ignore db-type))
- ;; Standard SQL does not use column name on DROP INDEX
nil)
- (:documentation "NIL [default] lif database-type does not use column name on DROP INDEX."))
+ (:documentation "NIL [default] if database-type does not use column name on DROP INDEX."))
+(defgeneric db-type-has-views? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ ;; SQL92 has views
+ t)
+ (:documentation "T [default] if database-type supports views."))
+
+(defgeneric db-type-has-subqueries? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if database-type supports views."))
+
+(defgeneric db-type-has-boolean-where? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ ;; SQL92 has boolean where
+ t)
+ (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'."))
+
+(defgeneric db-backend-has-create/destroy-db? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if backend can destroy and create databases."))
+
+(defgeneric db-type-transaction-capable? (db database)
+ (:method (db database)
+ (declare (ignore db database))
+ t)
+ (:documentation "T [default] if database can supports transactions."))
;;; Large objects support (Marc Battyani)
#:transaction
;; Database features specialized by backend
- #:db-use-column-on-drop-index?
-
+ #:db-type-use-column-on-drop-index?
+ #:db-type-has-views?
+ #:db-type-has-subqueries?
+ #:db-type-has-boolean-where?
+ #:db-backend-has-create/destroy-db?
+ #:db-type-transaction-capable?
))
(:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE."))
(defmethod database-probe (connection-spec (type (eql :aodbc)))
(warn "Not implemented."))
+;;; Backend capabilities
+
+(defmethod db-backend-has-create/destroy-db? ((db-type (eql :aodbc)))
+ nil)
+
#+ignore
(when (clsql-base-sys:database-type-library-loaded :aodbc)
(clsql-base-sys:initialize-database-type :database-type :aodbc))
(declaim (inline mysql-get-client-info))
+(defvar *mysql-client-info* nil)
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(uffi:def-function "mysql_get_client_info"
()
:module "mysql"
:returning :cstring)
- (let ((version (uffi:convert-from-cstring (mysql-get-client-info))))
- (cond
- ((eql (schar version 0) #\3)
- (pushnew :mysql-client-v3 cl:*features*))
- ((eql (schar version 0) #\4)
- (pushnew :mysql-client-v4 cl:*features*))
- (t
- (error "Unknown mysql client version '~A'." version)))))
-
-;;#-(or :mysql-client-v3 :mysql-client-v4)
-;;(eval-when (:compile-toplevel :load-toplevel :execute)
-;; (pushnew :mysql-client-v3 cl:*features*))
+ (setf *mysql-client-info* (uffi:convert-from-cstring (mysql-get-client-info)))
+
+ (cond
+ ((eql (schar *mysql-client-info* 0) #\3)
+ (pushnew :mysql-client-v3 cl:*features*))
+ ((eql (schar *mysql-client-info* 0) #\4)
+ (pushnew :mysql-client-v4 cl:*features*))
+ (t
+ (error "Unknown mysql client version '~A'." *mysql-client-info*))))
;;; Database capabilities
-(defmethod db-use-column-on-drop-index? ((db-type (eql :mysql)))
+(defmethod db-type-use-column-on-drop-index? ((db-type (eql :mysql)))
t)
+(defmethod db-type-has-views? ((db-type (eql :mysql)))
+ ;; MySQL 4.1 will apparently have views, need to check *mysql-client-info*
+ nil)
+
+(defmethod db-type-has-subqueries? ((db-type (eql :mysql)))
+ ;; MySQL 4.1 will apparently have subqueries, need to check *mysql-client-info*
+ nil)
+
+(defmethod db-type-has-boolean-where? ((db-type (eql :mysql)))
+ nil)
+
+(defmethod db-type-transaction-capable? ((db-type (eql :mysql)) database)
+ (let ((has-innodb (caar (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto))))
+ (and has-innodb (string-equal "YES" has-innodb))))
+
+
(when (clsql-base-sys:database-type-library-loaded :mysql)
(clsql-base-sys:initialize-database-type :database-type :mysql))
:error "Connection failed")))))
(defmethod database-underlying-type ((database odbc-database))
- (odbc-db-type database))
+ (database-odbc-db-type database))
(defun store-type-of-connected-database (db)
(let* ((odbc-conn (database-odbc-conn db))
(defmethod database-list-sequences ((database odbc-database)
&key (owner nil))
(declare (ignore owner))
- (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
- (database-query "SHOW TABLES LIKE '%clsql_seq%'"
- database nil)))
+ ;; FIXME: Underlying database backend stuff should come from that backend
+ ;; Would need to use ASDF to ensure underlying backend was loaded
+
+ (case (database-odbc-db-type database)
+ (:mysql
+ (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
+ (database-query "SHOW TABLES LIKE '%clsql_seq%'"
+ database nil)))
+ ((:postgresql :postgresql-socket)
+ (mapcar #'(lambda (s) (%table-name-to-sequence-name (car s)))
+ (database-query "SELECT RELNAME FROM pg_class WHERE RELNAME LIKE '%clsql_seq%'"
+ database nil)))))
(defmethod database-list-tables ((database odbc-database)
&key (owner nil))
(string-equal "TABLE" (nth 3 row)))
collect (nth 2 row))))
+(defmethod database-list-views ((database odbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (multiple-value-bind (rows col-names)
+ (odbc-dbi:list-all-database-tables :db (database-odbc-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 odbc-database)
&key (owner nil))
(declare (ignore owner))
(loop-rows rows (cdr loop-rows)))
((null loop-rows) (nreverse results))
(let* ((row (car loop-rows))
- (col (nth 5 row))
- (type (nth 3 row)))
- (unless (or (find col results :test #'string-equal)
- #+ignore (equal "0" type))
+ (col (nth 5 row)))
+ (unless (find col results :test #'string-equal)
(push col results))))))
+;;; Database capabilities
+
+(defmethod db-backend-has-create/destroy-db? ((db-type (eql :odbc)))
+ nil)
+
+
(defmethod database-initialize-database-type ((database-type (eql :odbc)))
;; nothing to do
t)
(defmethod database-list-table-indexes (table (database sqlite-database)
&key (owner nil))
(declare (ignore owner))
- (mapcar #'car
- (database-query
- (format
- nil
- "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
- table table)
- database nil)))
+ (let ((*print-circle* nil))
+ (mapcar #'car
+ (database-query
+ (format
+ nil
+ "SELECT name FROM sqlite_master WHERE type='index' AND tbl_name='~A' UNION ALL SELECT name FROM sqlite_temp_master WHERE type='index' AND tbl_name='~A' ORDER BY name"
+ table table)
+ database nil))))
(declaim (inline sqlite-table-info))
(defun sqlite-table-info (table database)
(or (string-equal ":memory:" name)
(and (probe-file name) t))))
+;;; Database capabilities
+
+(defmethod db-type-has-boolean-where? ((db-type (eql :sqlite)))
+ nil)
+
+cl-sql (2.9.2-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Wed, 21 Apr 2004 00:46:34 -0600
+
cl-sql (2.9.1-1) unstable; urgency=low
* Fix shared library loading in .asd files (closes:245004)
:initform nil)
(modifiers
:initarg :modifiers
+ :initform nil)
+ (transactions
+ :initarg :transactions
:initform nil))
(:documentation
"An SQL CREATE TABLE statement."))
(when constraints
(write-string " " *sql-stream*)
(write-string constraints *sql-stream*)))))))
- (with-slots (name columns modifiers)
+ (with-slots (name columns modifiers transactions)
stmt
(write-string "CREATE TABLE " *sql-stream*)
(output-sql name database)
((null modifier))
(write-string ", " *sql-stream*)
(write-string (car modifier) *sql-stream*)))
- (write-char #\) *sql-stream*)))
+ (write-char #\) *sql-stream*)
+ (when (and (eq :mysql (database-underlying-type database))
+ transactions
+ (db-type-transaction-capable? :mysql database))
+ (write-string " Type=InnoDB" *sql-stream*))))
t)
#:transaction
;; Database capabilities
- #:db-use-column-on-drop-index?
-
+ #:db-type-use-column-on-drop-index?
+ #:db-backend-has-create/destroy-db?
+ #:db-type-has-views?
+ #:db-type-has-subqueries?
+ #:db-type-has-boolean-where?
+ #:db-type-transaction-capable?
+ #:database-underlying-type
))
(:export
;; "Private" exports for use by interface packages
#:database-list-attributes
#:database-attribute-type
#:database-describe-table
+
+ #:db-backend-has-create/destroy-db?
+ #:db-type-has-views?
+ #:db-type-has-subqueries?
+ #:db-type-has-boolean-where?
+ #:db-type-transaction-capable?
+ #:database-underlying-type
.
;; Shared exports for re-export by CLSQL.
;; Tables
(defun create-table (name description &key (database *default-database*)
- (constraints nil))
+ (constraints nil) (transactions t))
"Create a table called NAME, in DATABASE which defaults to
*DEFAULT-DATABASE*, containing the attributes in DESCRIPTION which is
a list containing lists of attribute-name and type information pairs."
(stmt (make-instance 'sql-create-table
:name table-name
:columns description
- :modifiers constraints)))
+ :modifiers constraints
+ :transactions transactions)))
(execute-command stmt :database database)))
(defun drop-table (name &key (if-does-not-exist :error)
(unless (index-exists-p index-name :database database)
(return-from drop-index)))
(:error t))
- (unless (db-use-column-on-drop-index? (database-underlying-type database))
+ (unless (db-type-use-column-on-drop-index? (database-underlying-type database))
(setq on nil))
(execute-command (format nil "DROP INDEX ~A~A" index-name
(if (null on) ""
(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 CHAR(30))"
+ "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))
((eq types :auto)
(test (and (integerp int)
(typep float 'double-float)
- (or (eq db-type :aodbc) ;; aodbc considers bigints as strings
+ (or (member db-type '(:odbc :aodbc)) ;; aodbc considers bigints as strings
(integerp bigint))
(stringp str))
t
"birthday" "companyid" "email" "emplid" "first_name" "groupid" "height"
"last_name" "managerid" "married")
-;; create a view, test for existence, drop it and test again
+;; create a view, test for existence, drop it and test again
(deftest :fddl/view/1
(progn (clsql:create-view [lenins-group]
- ;;not in sqlite
- ;;:column-list '([forename] [surname] [email])
- :as [select [first-name] [last-name] [email]
- :from [employee]
- :where [= [managerid] 1]])
- (values
- (clsql:view-exists-p [lenins-group] :owner *test-database-user*)
- (progn
- (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)
- (clsql:view-exists-p [lenins-group] :owner *test-database-user*))))
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (values
+ (clsql:view-exists-p [lenins-group] :owner *test-database-user*)
+ (progn
+ (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)
+ (clsql:view-exists-p [lenins-group] :owner *test-database-user*))))
t nil)
-
-;; create a view, list its attributes and drop it
-(deftest :fddl/view/2
- (progn (clsql:create-view [lenins-group]
- ;;not in sqlite
- ;;:column-list '([forename] [surname] [email])
- :as [select [first-name] [last-name] [email]
- :from [employee]
- :where [= [managerid] 1]])
- (prog1
- (sort (mapcar #'string-downcase
- (clsql:list-attributes [lenins-group]))
- #'string<)
- (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)))
- ("email" "first_name" "last_name"))
-
-;; create a view, select stuff from it and drop it
+
+ ;; create a view, list its attributes and drop it
+(when (clsql-base-sys:db-type-has-views? *test-database-underlying-type*)
+ (deftest :fddl/view/2
+ (progn (clsql:create-view [lenins-group]
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (prog1
+ (sort (mapcar #'string-downcase
+ (clsql:list-attributes [lenins-group]))
+ #'string<)
+ (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)))
+ ("email" "first_name" "last_name")))
+
+ ;; create a view, select stuff from it and drop it
(deftest :fddl/view/3
(progn (clsql:create-view [lenins-group]
- :as [select [first-name] [last-name] [email]
- :from [employee]
- :where [= [managerid] 1]])
- (let ((result
- (list
- ;; Shouldn't exist
- (clsql:select [first-name] [last-name] [email]
- :from [lenins-group]
- :where [= [last-name] "Lenin"])
- ;; Should exist
- (car (clsql:select [first-name] [last-name] [email]
- :from [lenins-group]
- :where [= [last-name] "Stalin"])))))
- (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)
- (apply #'values result)))
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
+ (let ((result
+ (list
+ ;; Shouldn't exist
+ (clsql:select [first-name] [last-name] [email]
+ :from [lenins-group]
+ :where [= [last-name] "Lenin"])
+ ;; Should exist
+ (car (clsql:select [first-name] [last-name] [email]
+ :from [lenins-group]
+ :where [= [last-name] "Stalin"])))))
+ (clsql:drop-view [lenins-group] :if-does-not-exist :ignore)
+ (apply #'values result)))
nil ("Josef" "Stalin" "stalin@soviet.org"))
-
-;; not in sqlite
+
(deftest :fddl/view/4
(progn (clsql:create-view [lenins-group]
- :column-list '([forename] [surname] [email])
- :as [select [first-name] [last-name] [email]
- :from [employee]
- :where [= [managerid] 1]])
+ :column-list '([forename] [surname] [email])
+ :as [select [first-name] [last-name] [email]
+ :from [employee]
+ :where [= [managerid] 1]])
(let ((result
(list
;; Shouldn't exist
- (clsql:select [forename] [surname] [email]
- :from [lenins-group]
- :where [= [surname] "Lenin"])
- ;; Should exist
- (car (clsql:select [forename] [surname] [email]
- :from [lenins-group]
- :where [= [surname] "Stalin"])))))
+ (clsql:select [forename] [surname] [email]
+ :from [lenins-group]
+ :where [= [surname] "Lenin"])
+ ;; Should exist
+ (car (clsql:select [forename] [surname] [email]
+ :from [lenins-group]
+ :where [= [surname] "Stalin"])))))
(clsql:drop-view [lenins-group] :if-does-not-exist :ignore)
(apply #'values result)))
nil ("Josef" "Stalin" "stalin@soviet.org"))
(progn
(clsql:drop-index [bar] :on [i3test])
(clsql:drop-index [foo] :on [i3test])
+ (clsql:execute-command "DROP TABLE I3TEST")
t)))
("bar" "foo") nil t)
(deftest :fdml/select/10
(clsql:select [last-name] :from [employee]
:where [not [in [emplid]
- [select [managerid] :from [company]]]]
+ [select [managerid] :from [company]]]]
:flatp t
:order-by [last-name])
("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin"
;; test if we are in a transaction
(push (clsql:in-transaction-p) results)
;;Putin has got to go
- (unless (eql *test-database-type* :mysql)
- (clsql:delete-records :from [employee] :where [= [last-name] "Putin"]))
+ (clsql:delete-records :from [employee] :where [= [last-name] "Putin"])
;;Should be nil
(push
(clsql:select [*] :from [employee] :where [= [last-name] "Putin"])
;; test if we are in a transaction
(push (clsql:in-transaction-p) results)
;;Putin has got to go
- (unless (eql *test-database-type* :mysql)
- (clsql:update-records [employee]
- :av-pairs '((email "putin-nospam@soviet.org"))
- :where [= [last-name] "Putin"]))
+ (clsql:update-records [employee]
+ :av-pairs '((email "putin-nospam@soviet.org"))
+ :where [= [last-name] "Putin"])
;;Should be new value
(push (clsql:select [email] :from [employee]
:where [= [last-name] "Putin"]
(let ((results '()))
;; check status
(push (clsql:in-transaction-p) results)
- (unless (eql *test-database-type* :mysql)
- (handler-case
- (clsql:with-transaction ()
- ;; valid update
- (clsql:update-records [employee]
- :av-pairs '((email "lenin-nospam@soviet.org"))
- :where [= [emplid] 1])
- ;; invalid update which generates an error
+ (handler-case
+ (clsql:with-transaction ()
+ ;; valid update
+ (clsql:update-records [employee]
+ :av-pairs '((email "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1])
+ ;; invalid update which generates an error
(clsql:update-records [employee]
- :av-pairs
- '((emale "lenin-nospam@soviet.org"))
- :where [= [emplid] 1]))
- (clsql:clsql-sql-error ()
+ :av-pairs
+ '((emale "lenin-nospam@soviet.org"))
+ :where [= [emplid] 1]))
+ (clsql:clsql-error ()
(progn
;; check status
(push (clsql:in-transaction-p) results)
(push (clsql:select [email] :from [employee] :where [= [emplid] 1]
:flatp t)
results)
- (apply #'values (nreverse results)))))))
+ (apply #'values (nreverse results))))))
nil nil ("lenin@soviet.org"))
))
(defvar *rt-time*)
(defvar *test-database-type* nil)
+(defvar *test-database-underlying-type* nil)
(defvar *test-database-user* nil)
(defclass thing ()
(clsql:connect spec
:database-type database-type
:make-default t
- :if-exists :old))
+ :if-exists :old)
+
+ (setf *test-database-underlying-type*
+ (clsql-sys:database-underlying-type *default-database*))
+
+ *default-database*)
(defparameter company1 nil)
(defparameter employee1 nil)
(test-basic spec db-type))
(incf *error-count* *test-errors*)
- (ignore-errors (destroy-database spec :database-type db-type))
- (ignore-errors (create-database spec :database-type db-type))
+ (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)))
- (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
- *rt-ooddl* *rt-oodml* *rt-syntax*))
- (eval test))
(test-connect-to-database db-type spec)
+
+ (dolist (test-form (append *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)
(deftest :ooddl/time/1
(let* ((now (clsql-base:get-time)))
- (when (member *test-database-type* '(:postgresql :postgresql-socket))
+ (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
(clsql:execute-command "set datestyle to 'iso'"))
(clsql:update-records [employee] :av-pairs `((birthday ,now))
:where [= [emplid] 1])
(deftest :ooddl/time/2
(let* ((now (clsql-base:get-time))
(fail-index -1))
- (when (member *test-database-type* '(:postgresql :postgresql-socket))
+ (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket))
(clsql:execute-command "set datestyle to 'iso'"))
(dotimes (x 40)
(clsql:update-records [employee] :av-pairs `((birthday ,now))
projects / clsql.git / commitdiff