From 0b35694f3659e5ee739ea72ce74d798c3f0ddb73 Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Thu, 30 Jan 2014 16:22:07 -0500 Subject: [PATCH] Changes to more broadly support auto-increment. new odbc-postgresql-database type --- ChangeLog | 34 ++++++++++++++++- LATEST-TEST-RESULTS | 28 ++++---------- db-odbc/odbc-sql.lisp | 44 +++++++++++++-------- doc/ref-ooddl.xml | 6 ++- sql/database.lisp | 4 +- sql/expressions.lisp | 4 +- sql/generic-odbc.lisp | 17 ++++++++- sql/generic-postgresql.lisp | 2 +- sql/ooddl.lisp | 4 +- sql/oodml.lisp | 29 ++++++++------ tests/datasets.lisp | 51 +++++++++++++++---------- tests/ds-artists.lisp | 5 --- tests/ds-employees.lisp | 9 +---- tests/ds-nodes.lisp | 76 ++++++++++++++++++------------------- tests/test-fddl.lisp | 4 +- tests/test-oodml.lisp | 4 +- 16 files changed, 188 insertions(+), 133 deletions(-) diff --git a/ChangeLog b/ChangeLog index 3944e59..cc2b381 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,36 @@ -2014-01-17 Russ Tyndall +2014-01-30 Russ Tyndall + * 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 * 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 diff --git a/LATEST-TEST-RESULTS b/LATEST-TEST-RESULTS index 235d8a7..037aaa4 100644 --- a/LATEST-TEST-RESULTS +++ b/LATEST-TEST-RESULTS @@ -1,43 +1,29 @@ -Note from Russ Tyndall 2012-11-24 : +Note from Russ Tyndall 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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index 447795c..b36833e 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -24,7 +24,11 @@ ;; 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))) @@ -40,22 +44,30 @@ (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 @@ -63,8 +75,8 @@ :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)) @@ -90,7 +102,7 @@ ((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))) diff --git a/doc/ref-ooddl.xml b/doc/ref-ooddl.xml index 891e213..4a2cffa 100644 --- a/doc/ref-ooddl.xml +++ b/doc/ref-ooddl.xml @@ -594,7 +594,11 @@ 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) diff --git a/sql/database.lisp b/sql/database.lisp index 982973e..b860d30 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -193,7 +193,9 @@ and signal an sql-user-error if they don't match. This function 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 diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 10bdb5e..4c57bc3 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -1108,7 +1108,9 @@ uninclusive, and the args from that keyword to the end." (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))))) diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp index fd701a9..706e4cf 100644 --- a/sql/generic-odbc.lisp +++ b/sql/generic-odbc.lisp @@ -20,7 +20,8 @@ (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) @@ -246,3 +247,17 @@ on schema since that's what tends to be exposed. Some DBs like mssql (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) diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 61d7e15..13d4f77 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -263,7 +263,7 @@ (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)))) diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 50c37a6..5832283 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -101,7 +101,9 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (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 diff --git a/sql/oodml.lisp b/sql/oodml.lisp index dbd5e6c..78c1a4f 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -219,19 +219,21 @@ (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" @@ -277,6 +279,7 @@ (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 @@ -321,12 +324,14 @@ (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))) diff --git a/tests/datasets.lisp b/tests/datasets.lisp index 63f1cd3..42698ec 100644 --- a/tests/datasets.lisp +++ b/tests/datasets.lisp @@ -67,30 +67,39 @@ should we debug (T) or just print and quit.") (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 diff --git a/tests/ds-artists.lisp b/tests/ds-artists.lisp index 6b65705..f4d3271 100644 --- a/tests/ds-artists.lisp +++ b/tests/ds-artists.lisp @@ -12,11 +12,6 @@ (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)) diff --git a/tests/ds-employees.lisp b/tests/ds-employees.lisp index 55312a4..1b1e36b 100644 --- a/tests/ds-employees.lisp +++ b/tests/ds-employees.lisp @@ -177,13 +177,8 @@ (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) diff --git a/tests/ds-nodes.lisp b/tests/ds-nodes.lisp index 00c8af4..098c742 100644 --- a/tests/ds-nodes.lisp +++ b/tests/ds-nodes.lisp @@ -31,20 +31,20 @@ (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)) @@ -56,7 +56,7 @@ (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)) @@ -64,46 +64,42 @@ (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")))) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index f7fb89b..41e79d5 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -107,7 +107,7 @@ B varchar(32))") (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* @@ -129,7 +129,7 @@ B varchar(32))") (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) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index da513da..953a604 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -780,13 +780,13 @@ (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" -- 2.34.1