Changes to more broadly support auto-increment. new odbc-postgresql-database type
authorRuss Tyndall <russ@acceleration.net>
Thu, 30 Jan 2014 21:22:07 +0000 (16:22 -0500)
committerRuss Tyndall <russ@acceleration.net>
Thu, 30 Jan 2014 21:22:17 +0000 (16:22 -0500)
16 files changed:
ChangeLog
LATEST-TEST-RESULTS
db-odbc/odbc-sql.lisp
doc/ref-ooddl.xml
sql/database.lisp
sql/expressions.lisp
sql/generic-odbc.lisp
sql/generic-postgresql.lisp
sql/ooddl.lisp
sql/oodml.lisp
tests/datasets.lisp
tests/ds-artists.lisp
tests/ds-employees.lisp
tests/ds-nodes.lisp
tests/test-fddl.lisp
tests/test-oodml.lisp

index 3944e59..cc2b381 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,36 @@
-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
index 235d8a7..037aaa4 100644 (file)
@@ -1,43 +1,29 @@
-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.
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
index 447795c..b36833e 100644 (file)
 ;; 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
@@ -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))
            ((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)))
 
 
 
index 891e213..4a2cffa 100644 (file)
           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>
index 982973e..b860d30 100644 (file)
@@ -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
index 10bdb5e..4c57bc3 100644 (file)
@@ -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)))))
 
index fd701a9..706e4cf 100644 (file)
@@ -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)
index 61d7e15..13d4f77 100644 (file)
       (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))))
 
index 50c37a6..5832283 100644 (file)
@@ -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
index dbd5e6c..78c1a4f 100644 (file)
 
 (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)))
index 63f1cd3..42698ec 100644 (file)
@@ -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
index 6b65705..f4d3271 100644 (file)
    (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))
 
index 55312a4..1b1e36b 100644 (file)
 
 (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)
index 00c8af4..098c742 100644 (file)
 
 (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))
 
 
 (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"))))
 
 
 
index f7fb89b..41e79d5 100644 (file)
@@ -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)
index da513da..953a604 100644 (file)
        (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"