-2014-01-17 Russ Tyndall <russ@acceleration.net>
+2014-01-30 Russ Tyndall <russ@acceleration.net>
+ * generic-odbc.lisp, ooddl.lisp, generic-postgresql.lisp,
+ test-init.lisp, ds-nodes.lisp, generic-odbc.lisp, odbc-sql.lisp
+
+ auto-increment-column support improvement (mssql esp, now will
+ auto-fill after insert). Use +auto-increment-names+ to determine
+ auto-increment-column-p.
+
+ This triggered much test failing as regards normalized classes /
+ autoincrement primary key stuff.
+
+ New odbc-postgresql-database sub-type
+
+ POSSIBLY BREAKING CHANGES:
+ 1 ) Previously all classes in a normalized heirachy had their p-key
+ marked as "auto-increment". Usually auto-increment means a key
+ supplied by the database system, so this was decidedly
+ non-standard usage (clsql is explicitly providing the key for all
+ normalized subclasses of any given parent see ds-nodes.lisp). Some
+ RDMS will not allow insertion/updates of autoincrement columns
+ without hoop jumping and, as it doesnt really make much sense, I
+ removed the "auto-increment" aspects of normalized sub-classes.
+ Now the primary keys are chained regardless. The parent-most key
+ can be autoincrement or not.
+
+ 2 ) ODBC Postgresql connections are now both GENERIC-ODBC-DATABASE
+ and GENERIC-POSTGRESQL-DATABASE. Probably not a widely used path,
+ but this change allows most of the previously failing tests to
+ pass on this backend (we now format stuff correctly for postgres).
+ I anticipate this probably is not perfect yet (IE: I probably
+ missed something)
+
+2014-01-29 Russ Tyndall <russ@acceleration.net>
* oodml.lisp, generics.lisp - added
clsql-sys::view-classes-and-storable-slots generic (added method
previously). Also added to-database-p keyword to allow overrides
-Note from Russ Tyndall <russ@acceleration.net> 2012-11-24 :
+Note from Russ Tyndall <russ@acceleration.net> 2013-01-30 :
This is the current results of running the test suite against all the database
backends I have accessible, on SBCL / UBUNTU64bit. It would be great to
continue improving the test suite and skip tests that reliably fail, improve
tests so that all pass. In the interim, I would like know that I am not
-increasing the number of failing
+increasing the number of failing tests
:mysql
1 out of 301 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
:odbc MSSQL2000/5
-1 out of 268 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
+1 out of 298 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1.
:odbc postgres
-32 out of 312 total tests failed: :OODML/DB-AUTO-SYNC/4, :OODML/DB-AUTO-SYNC/3,
- :OODML/UPDATE-INSTANCE/7, :OODML/UPDATE-INSTANCE/6, :OODML/UPDATE-INSTANCE/5,
- :OODML/UPDATE-INSTANCE/4, :OODML/UPDATE-INSTANCE/3, :OODML/UPDATE-RECORDS/12,
- :OODML/UPDATE-RECORDS/11, :OODML/UPDATE-RECORDS/9-SLOTS,
- :OODML/UPDATE-RECORDS/9, :OODML/UPDATE-RECORDS/8, :OODML/UPDATE-RECORDS/7,
- :OODML/UPDATE-RECORDS/6, :OODML/UPDATE-RECORDS/5-SLOTS,
- :OODML/UPDATE-RECORDS/5, :OODML/UPDATE-RECORDS/4-SLOTS,
- :OODML/UPDATE-RECORDS/4, :OODML/SELECT/23, :OODML/SELECT/22,
- :OODML/SELECT/21, :OODML/SELECT/20, :OODML/SELECT/19, :OODML/SELECT/18,
- :OODML/SELECT/17, :OODML/SELECT/16, :OODML/SELECT/15, :OODML/SELECT/14,
- :OODML/SELECT/13, :OODML/SELECT/12, :FDML/SELECT/36,
- :FDDL/CACHE-TABLE-QUERIES/1
-
-Most of these seem to have to do with not correctly dispatching AUTO_INCREMENT
-or not correctly skipping those tests
-
+2 out of 311 total tests failed: :FDML/SELECT/36, :FDDL/CACHE-TABLE-QUERIES/1.
:postgres-socket :postgres-socket-3
5 out of 300 total tests failed: :TIME/PG/OODML/USEC, :TIME/PG/OODML/NO-USEC,
:TIME/PG/FDML/USEC, :FDML/SELECT/36, :FDDL/CACHE-TABLE-QUERIES/1.
:sqlite3
-8 out of 300 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1, :FDDL/INDEX/3,
+9 out of 300 total tests failed: :FDDL/CACHE-TABLE-QUERIES/1, :FDDL/INDEX/3,
:FDDL/ATTRIBUTES/8, :FDDL/ATTRIBUTES/7, :FDDL/ATTRIBUTES/6,
- :FDDL/ATTRIBUTES/5, :FDDL/ATTRIBUTES/4, :FDDL/ATTRIBUTES/3.
+ :FDDL/ATTRIBUTES/5, :FDDL/ATTRIBUTES/4, :FDDL/ATTRIBUTES/3,
+ :FDDL/ATTRIBUTES/2.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ODBC interface
(defclass odbc-database (generic-odbc-database)
- ((odbc-db-type :accessor database-odbc-db-type)))
+ ())
+
+(defclass odbc-postgresql-database (generic-odbc-database
+ generic-postgresql-database)
+ ())
(defmethod database-name-from-spec (connection-spec
(database-type (eql :odbc)))
(destructuring-bind (dsn user password &key connection-string (completion :no-prompt) window-handle) connection-spec
(handler-case
(let ((db (make-instance 'odbc-database
- :name (database-name-from-spec connection-spec :odbc)
- :database-type :odbc
- :connection-spec connection-spec
- :dbi-package (find-package '#:odbc-dbi)
- :odbc-conn
- (odbc-dbi:connect :user user
- :password password
- :data-source-name dsn
- :connection-string connection-string
- :completion completion
- :window-handle window-handle))))
+ :name (database-name-from-spec connection-spec :odbc)
+ :database-type :odbc
+ :connection-spec connection-spec
+ :dbi-package (find-package '#:odbc-dbi)
+ :odbc-conn
+ (odbc-dbi:connect :user user
+ :password password
+ :data-source-name dsn
+ :connection-string connection-string
+ :completion completion
+ :window-handle window-handle))))
(store-type-of-connected-database db)
;; Ensure this database type is initialized so can check capabilities of
;; underlying database
(initialize-database-type :database-type database-type)
- db)
+ (if (eql :postgresql (database-underlying-type db))
+ (make-instance 'odbc-postgresql-database
+ :name (database-name-from-spec connection-spec :odbc)
+ :database-type :odbc
+ :connection-spec connection-spec
+ :dbi-package (find-package '#:odbc-dbi)
+ :odbc-db-type :postgresql
+ :odbc-conn (clsql-sys::odbc-conn db))
+ db))
#+ignore
(error () ;; Init or Connect failed
(error 'sql-connection-error
:connection-spec connection-spec
:message "Connection failed")))))
-(defmethod database-underlying-type ((database odbc-database))
- (database-odbc-db-type database))
+(defmethod database-underlying-type ((database generic-odbc-database))
+ (clsql-sys::database-odbc-db-type database))
(defun store-type-of-connected-database (db)
(let* ((odbc-conn (clsql-sys::odbc-conn db))
((or (search "oracle" server-name :test #'char-equal)
(search "oracle" dbms-name :test #'char-equal))
:oracle))))
- (setf (database-odbc-db-type db) type)))
+ (setf (clsql-sys::database-odbc-db-type db) type)))
Defaults to nil, i.e. non-normalized schemas. When true,
SQL database tables that map to this class and parent
classes are joined on their primary keys to get the full
- set of database columns for this class.
+ set of database columns for this class. This means that
+ the primary key of the base class will be copied to all
+ subclasses as we insert so that all parent classes of an
+ instance will have the same value in their primary key slots
+ (see tests/ds-nodes.lisp and oodml.lisp)
</para>
</listitem>
</itemizedlist>
is called by database backends."
`(handler-case
(destructuring-bind ,template ,connection-spec
- (declare (ignore ,@(remove '&optional template)))
+ (declare (ignore ,@(remove-if
+ (lambda (x) (member x '(&key &rest &optional)))
+ template)))
t)
(error ()
(error 'sql-user-error
(ecase (database-underlying-type database)
(:mssql "IDENTITY (1,1)")
((:sqlite :sqlite3) "PRIMARY KEY AUTOINCREMENT")
- (:mysql "AUTO_INCREMENT")))
+ (:mysql "AUTO_INCREMENT")
+ ;; this is modeled as a datatype instead of a constraint
+ (:postgresql "")))
;; everything else just get the name
(T (string-upcase (symbol-name constraint)))))
(close-query-fn :reader close-query-fn)
(fetch-row :reader fetch-row-fn)
(list-all-database-tables-fn :reader list-all-database-tables-fn)
- (list-all-table-columns-fn :reader list-all-table-columns-fn))
+ (list-all-table-columns-fn :reader list-all-table-columns-fn)
+ (odbc-db-type :accessor database-odbc-db-type :initarg :odbc-db-type ))
(:documentation "Encapsulate same behavior across odbc and aodbc backends."))
(defmethod initialize-instance :after ((db generic-odbc-database)
(when size (parse-integer size))
(when precision (parse-integer precision))
(when scale (parse-integer scale))))))))
+
+(defmethod database-last-auto-increment-id
+ ((database generic-odbc-database) table column)
+ (case (database-underlying-type database)
+ (:mssql
+ (first (clsql:query "SELECT SCOPE_IDENTITY()"
+ :flatp t
+ :database database
+ :result-types '(:int))))
+ (t (if (next-method-p)
+ (call-next-method)))))
+
+(defmethod clsql-sys:db-type-has-auto-increment? ((db-underlying-type (eql :mssql)))
+ t)
(when seq
(setf const (remove :auto-increment const))
(unless (member :default const)
- (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq))))
+ (let* ((next (format nil " nextval('~a')" (escaped-database-identifier seq))))
(setf const (append const (list :default next))))))
(append cdef const))))
(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
(declare (ignore database))
- (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef)))
+ (or (intersection
+ +auto-increment-names+
+ (listify (view-class-slot-db-constraints slotdef)))
(slot-value slotdef 'autoincrement-sequence)))
(defmethod %install-class ((self standard-db-class) database
(defun update-auto-increments-keys (class obj database)
" handle pulling any autoincrement values into the object
- if normalized and we now that all the "
+ Also handles normalized key chaining"
(let ((pk-slots (keyslots-for-class class))
(table (view-table class))
new-pk-value)
- (labels ((do-update (slot)
- (when (and (null (easy-slot-value obj slot))
- (auto-increment-column-p slot database))
- (update-slot-from-db-value
- obj slot
- (or new-pk-value
- (setf new-pk-value
- (database-last-auto-increment-id
- database table slot))))))
+ (labels ((do-update (slot &aux (val (easy-slot-value obj slot)))
+ (if val
+ (setf new-pk-value val)
+ (update-slot-from-db-value
+ obj slot
+ (or new-pk-value
+ (setf new-pk-value
+ (database-last-auto-increment-id
+ database table slot))))))
+ ;; NB: This interacts very strangely with autoincrement keys
+ ;; (see changelog 2014-01-30)
(chain-primary-keys (in-class)
"This seems kindof wrong, but this is mostly how it was working, so
its here to keep the normalized code path working"
(insert-records :into table-sql
:av-pairs avps
:database database)
+ ;; also handles normalized-class key chaining
(update-auto-increments-keys view-class obj database)
;; we dont set view database here, because there could be
;; N of these for each call to update-record-from-* because
(specifically clsql-helper:dirty-db-slots-mixin which only updates slots
that have changed )
"
- (declare (ignore to-database-p))
(setf class (to-class class))
(let* (rtns)
(labels ((storable-slots (class)
(loop for sd in (slots-for-possibly-normalized-class class)
- when (key-or-base-slot-p sd)
+ when (and (key-or-base-slot-p sd)
+ ;; we dont want to insert/update auto-increments
+ ;; but we do read them
+ (not (and to-database-p (auto-increment-column-p sd))))
collect sd))
(get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
(let ((slots (storable-slots class)))
(defun %dataset-init (name)
"Run initialization code and fill database for given dataset."
- ;;find items that looks like '(:setup ...),
- ;; dispatch the rest.
- (let ((setup (rest (find :setup name :key #'first)))
- (sqldata (rest (find :sqldata name :key #'first)))
- (objdata (rest (find :objdata name :key #'first))))
- (when setup
- (%dataset-dispatch setup))
- (when sqldata
- ;;run raw sql insert statements
- (destructuring-bind (table-name columns &rest values-list) sqldata
- (dolist (v values-list)
- (clsql-sys:execute-command
- (format nil
- "INSERT INTO ~a (~a) VALUES (~a)"
- table-name columns v)))))
- (when objdata
- ;;presumed to be view-class objects, force them to insert.
- (dolist (o objdata)
- (setf (slot-value o 'clsql-sys::view-database) nil)
- (clsql-sys:update-records-from-instance o)))))
+ ;;find items that looks like '(:setup ...),
+ ;; dispatch the rest.
+ (let ((*backend-warning-behavior*
+ (typecase *default-database*
+ (clsql-sys:generic-postgresql-database
+ :ignore)
+ (t *backend-warning-behavior*)))
+ (setup (rest (find :setup name :key #'first)))
+ (sqldata (rest (find :sqldata name :key #'first)))
+ (objdata (rest (find :objdata name :key #'first))))
+ (when setup
+ (handler-bind ((warning
+ (lambda (c)
+ (when (eql :ignore *backend-warning-behavior*)
+ (muffle-warning c)))))
+ (%dataset-dispatch setup)))
+ (when sqldata
+ ;;run raw sql insert statements
+ (destructuring-bind (table-name columns &rest values-list) sqldata
+ (dolist (v values-list)
+ (clsql-sys:execute-command
+ (format nil
+ "INSERT INTO ~a (~a) VALUES (~a)"
+ table-name columns v)))))
+ (when objdata
+ ;;presumed to be view-class objects, force them to insert.
+ (dolist (o objdata)
+ (setf (slot-value o 'clsql-sys::view-database) nil)
+ (clsql-sys:update-records-from-instance o)))))
(defun %dataset-cleanup (name)
"Run cleanup code associated with the given dataset."
- (restart-case
+ (restart-case
(handler-bind ((error #'generic-error))
(let ((cleanup (rest (find :cleanup name :key #'first))))
(when cleanup
(genre :accessor genre :initarg :genre :type (varchar 10) :db-constraints (:default "'Unknown'"))))
(defun initialize-ds-artists ()
- ; (start-sql-recording :type :both)
- ; (let ((*backend-warning-behavior*
- ; (if (member *test-database-type* '(:postgresql :postgresql-socket))
- ; :ignore
- ; :warn)))
(mapc #'clsql:create-view-from-class
'(artist))
(defun initialize-ds-employees ()
;; (start-sql-recording :type :both)
- (let ((*backend-warning-behavior*
- (if (member *test-database-type* '(:postgresql :postgresql-socket))
- :ignore
- :warn)))
- (mapc #'clsql:create-view-from-class
- '(employee company address employee-address)))
-
+ (mapc #'clsql:create-view-from-class
+ '(employee company address employee-address))
(setq *test-start-utime* (get-universal-time))
(let* ((*db-auto-sync* t)
(def-view-class setting (node)
((setting-id :accessor setting-id :initarg :setting-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :type integer :db-kind :key :db-constraints (:not-null ))
(vars :accessor vars :initarg :vars :type (varchar 240)))
(:normalizedp t))
(def-view-class user (node)
((user-id :accessor user-id :initarg :user-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :type integer :db-kind :key :db-constraints (:not-null ))
(nick :accessor nick :initarg :nick :type (varchar 64)))
(:base-table "nodeuser")
(:normalizedp t))
(def-view-class theme (setting)
((theme-id :accessor theme-id :initarg :theme-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :type integer :db-kind :key :db-constraints (:not-null ))
(doc :accessor doc :initarg :doc :type (varchar 240)))
(:normalizedp t))
(def-view-class subloc (location)
((subloc-id :accessor subloc-id :initarg :subloc-id
- :type integer :db-kind :key :db-constraints (:not-null :auto-increment))
+ :type integer :db-kind :key :db-constraints (:not-null ))
(loc :accessor loc :initarg :loc :type (varchar 64)))
(:normalizedp t))
(defun initialize-ds-nodes ()
;; (start-sql-recording :type :both)
- (let ((*backend-warning-behavior*
- (if (member *test-database-type* '(:postgresql :postgresql-socket))
- :ignore
- :warn)))
- (mapc #'clsql:create-view-from-class
- '(node setting user theme location subloc)))
+ (mapc #'clsql:create-view-from-class
+ '(node setting user theme location subloc))
(setq *test-start-utime* (get-universal-time))
(let* ((*db-auto-sync* t))
(setf node (make-instance 'node
- :title "Bare node")
- setting1 (make-instance 'setting
- :title "Setting1"
- :vars "var 1")
- setting2 (make-instance 'setting
- :title "Setting2"
- :vars "var 2")
- user1 (make-instance 'user
- :title "user-1"
- :nick "first user")
- user2 (make-instance 'user
- :title "user-2"
- :nick "second user")
- theme1 (make-instance 'theme
- :title "theme-1"
- :vars "empty"
- :doc "first theme")
- theme2 (make-instance 'theme
- :title "theme-2"
- :doc "second theme")
- loc1 (make-instance 'location
- :title "location-1")
- loc2 (make-instance 'location
- :title "location-2")
- subloc1 (make-instance 'subloc
- :title "subloc-1"
- :loc "a subloc")
- subloc2 (make-instance 'subloc
- :title "subloc-2"
- :loc "second subloc"))))
+ :title "Bare node")
+ setting1 (make-instance 'setting
+ :title "Setting1"
+ :vars "var 1")
+ setting2 (make-instance 'setting
+ :title "Setting2"
+ :vars "var 2")
+ user1 (make-instance 'user
+ :title "user-1"
+ :nick "first user")
+ user2 (make-instance 'user
+ :title "user-2"
+ :nick "second user")
+ theme1 (make-instance 'theme
+ :title "theme-1"
+ :vars "empty"
+ :doc "first theme")
+ theme2 (make-instance 'theme
+ :title "theme-2"
+ :doc "second theme")
+ loc1 (make-instance 'location
+ :title "location-1")
+ loc2 (make-instance 'location
+ :title "location-2")
+ subloc1 (make-instance 'subloc
+ :title "subloc-1"
+ :loc "a subloc")
+ subloc2 (make-instance 'subloc
+ :title "subloc-2"
+ :loc "second subloc"))))
(progn
(let ((*backend-warning-behavior*
(if (member *test-database-type*
- '(:postgresql :postgresql-socket))
+ '(:postgresql :postgresql-socket :postgresql-socket3))
:ignore
:warn)))
(case *test-database-underlying-type*
(progn
(let ((*backend-warning-behavior*
(if (member *test-database-type*
- '(:postgresql :postgresql-socket))
+ '(:postgresql :postgresql-socket :postgresql-socket3))
:ignore
:warn)))
(clsql:create-table [foo] '(([bar] integer :not-null)
(progn
(clsql:update-records [node]
:av-pairs '(([title] "altered title"))
- :where [= [node-id] 9])
+ :where [= [node-id] (node-id loc2)])
(clsql:update-slot-from-record loc2 'title)
(print-loc loc2))
(progn
(clsql:update-records [subloc]
:av-pairs '(([loc] "altered loc"))
- :where [= [subloc-id] 11])
+ :where [= [subloc-id] (subloc-id subloc2)])
(clsql:update-slot-from-record subloc2 'loc)
(print-subloc subloc2)))))
"9: location-2" "11: second subloc"
projects / clsql.git / commitdiff