TOP X mssql limit clause must appear after DISTINCT if they are both present

[clsql.git] / sql / oodml.lisp

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index 710e5e8e090c45548e4a41d6948ccd35c7c7536c..b2f16a6d3319adef5620d745e213175122f9809f 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -225,11 +225,14 @@
                                    (db-value-from-slot s val database))))
                        sds)))
     (cond ((and avps (view-database obj))
-           (update-records (sql-expression :table vct)
-                           :av-pairs avps
-                           :where (key-qualifier-for-instance
-                                   obj :database database)
-                           :database database))
+           (let ((where (key-qualifier-for-instance
+                         obj :database database)))
+             (unless where
+               (error "update-record-from-slots: could not generate a where clause for ~a" obj))
+             (update-records (sql-expression :table vct)
+                             :av-pairs avps
+                             :where where
+                             :database database)))
           ((and avps (not (view-database obj)))
            (insert-records :into (sql-expression :table vct)
                            :av-pairs avps
@@ -265,6 +268,7 @@
                                          (ordered-class-direct-slots view-class)
                                          (ordered-class-slots view-class))))
                (record-values (mapcar #'slot-value-list slots)))
+
           (cond ((and (not (normalizedp view-class))
                       (not record-values))
                  (error "No settable slots."))
@@ -282,21 +286,36 @@
                    (setf pk (or pk
                                 (slot-value obj (slot-definition-name pk-slot))))))
                 (t
-                 (insert-records :into (sql-expression :table view-class-table)
+                (insert-records :into (sql-expression :table view-class-table)
                                  :av-pairs record-values
                                  :database database)
-                 (when pk-slot
-                   (if (or (and (listp (view-class-slot-db-constraints pk-slot))
-                                (member :auto-increment (view-class-slot-db-constraints pk-slot)))
-                           (eql (view-class-slot-db-constraints pk-slot) :auto-increment))
-                       (setf pk (or pk
-                                    (car (query "SELECT LAST_INSERT_ID();"
-                                                :flatp t :field-names nil
-                                                :database database))))
-                       (setf pk (or pk
-                                    (slot-value obj (slot-definition-name pk-slot))))))
-                 (when (eql this-class nil)
-                   (setf (slot-value obj 'view-database) database)))))))
+
+                 (when (and pk-slot (not pk))
+                   (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot)))
+                                    (not (null (view-class-slot-autoincrement-sequence pk-slot))))
+                                (setf (slot-value obj (slot-definition-name pk-slot))
+                                      (database-last-auto-increment-id database
+                                                                      view-class-table
+                                                                      pk-slot)))))
+                 (when pk-slot
+                   (setf pk (or pk
+                                (slot-value
+                                 obj (slot-definition-name pk-slot)))))
+                 (when (eql this-class nil)
+                   (setf (slot-value obj 'view-database) database)))))))
+    ;; handle slots with defaults
+    (let* ((view-class (or this-class (class-of obj)))
+          (slots (if (normalizedp view-class)
+                    (ordered-class-direct-slots view-class)
+                    (ordered-class-slots view-class)))) 
+      (dolist (slot slots)
+       (when (and (slot-exists-p slot 'db-constraints)
+                  (listp (view-class-slot-db-constraints slot))
+                  (member :default (view-class-slot-db-constraints slot)))
+         (unless (and (slot-boundp obj (slot-definition-name slot))
+                      (slot-value obj (slot-definition-name slot)))
+           (update-slot-from-record obj (slot-definition-name slot))))))
+
     pk))
 
 (defmethod delete-instance-records ((instance standard-db-object))
@@ -1242,15 +1261,19 @@ as elements of a list."
            (when (and order-by (= 1 (length target-args)))
              (let ((table-name (view-table (find-class (car target-args))))
                    (order-by-list (copy-seq (listify order-by))))
-
-               (loop for i from 0 below (length order-by-list)
-                  do (etypecase (nth i order-by-list)
-                       (sql-ident-attribute
-                        (unless (slot-value (nth i order-by-list) 'qualifier)
-                          (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
-                       (cons
-                        (unless (slot-value (car (nth i order-by-list)) 'qualifier)
-                          (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+               (labels ((set-table-if-needed (val)
+                          (typecase val
+                            (sql-ident-attribute
+                             (handler-case
+                                 (unless (slot-value val 'qualifier)
+                                   (setf (slot-value val 'qualifier) table-name))
+                               (simple-error ()
+                                 ;; TODO: Check for a specific error we expect
+                                 )))
+                            (cons (set-table-if-needed (car val))))))
+                 (loop for i from 0 below (length order-by-list)
+                       for id = (nth i order-by-list)
+                       do (set-table-if-needed id)))
                (setf (getf qualifier-args :order-by) order-by-list)))
 
            (cond