Pulling in changes from darcs patch:

Tue Jun 12 17:51:57 EDT 2007  Nathan Bird <nathan@acceleration.net>
  * refactorng choose-database-for-instance method out
  this function encapsulates the logic about which database connection to use
  and is called by most of the update-*-from-* in the oodml functions.

  Also refactored update-record-from-instance to call update-record-from-slots.

WARNING: This patch may not represent a stable point as i was cutting and pasting to apply.

diff --git a/sql/generics.lisp b/sql/generics.lisp
index 792a9dec90c5ac7277369e4905b1755a995908e0..0814d0f2674d1bdf556c6bd4f0e128107daa0baa 100644 (file)
--- a/sql/generics.lisp
+++ b/sql/generics.lisp
@@ -21,6 +21,13 @@
 
 ;; FDML
 
 
 ;; FDML
 

+(defgeneric choose-database-for-instance (object database)
+  (:documentation "Used by the oodml functions to select which
+ database object to use. Chooses the database associated with the
+ object primarily, falls back to the database provided as an argument
+ or the *DEFAULT-DATABASE*."))
+
+

 (defgeneric execute-command (expression &key database)
   (:documentation
    "Executes the SQL command EXPRESSION, which may be an SQL
 (defgeneric execute-command (expression &key database)
   (:documentation
    "Executes the SQL command EXPRESSION, which may be an SQL


@@ -84,7 +91,7 @@ case, a record is created in the appropriate table of DATABASE
 using values from the slot values of OBJECT, and OBJECT becomes
 associated with DATABASE."))
 
 using values from the slot values of OBJECT, and OBJECT becomes
 associated with DATABASE."))
 

-(defgeneric delete-instance-records (object)
+(defgeneric delete-instance-records (object &key database)

   (:documentation
    "Deletes the records represented by OBJECT in the appropriate
 table of the database associated with OBJECT. If OBJECT is not
   (:documentation
    "Deletes the records represented by OBJECT in the appropriate
 table of the database associated with OBJECT. If OBJECT is not

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index fb76c55743fe7ff464377d42c08ac5958ec5dae6..8ffe50347e602c56027f761d13a814e600b3354c 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -158,9 +158,19 @@
       (mapc #'update-slot slotdeflist values)
       obj))
 
       (mapc #'update-slot slotdeflist values)
       obj))
 

+(defmethod choose-database-for-instance ((obj standard-db-object) database)
+  "Determine which database connection to use for a standard-db-object.
+        Errs if none is available."
+  (or (find-if #'(lambda (db)
+                  (and db (is-database-open db)))
+               (list (view-database obj)
+                     database
+                     *default-database*))
+      (signal-no-database-error nil)))
+

 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
 (defmethod update-record-from-slot ((obj standard-db-object) slot &key

-                                    (database *default-database*))
-  (let* ((database (or (view-database obj) database))
+                                   database)
+  (let* ((database (choose-database-for-instance obj database))

          (vct (view-table (class-of obj)))
          (sd (slotdef-for-slot-with-class slot (class-of obj))))
     (check-slot-type sd (slot-value obj slot))
          (vct (view-table (class-of obj)))
          (sd (slotdef-for-slot-with-class slot (class-of obj))))
     (check-slot-type sd (slot-value obj slot))


@@ -183,19 +193,22 @@
              (error "Unable to update record.")))))
   (values))
 
              (error "Unable to update record.")))))
   (values))
 

-(defmethod update-record-from-slots ((obj standard-db-object) slots &key
-                                     (database *default-database*))
-  (let* ((database (or (view-database obj) database))
-         (vct (view-table (class-of obj)))
-         (sds (slotdefs-for-slots-with-class slots (class-of obj)))
+(defmethod update-record-from-slots ((obj standard-db-object) slots
+                                    &key database)
+  (let* ((database (choose-database-for-instance obj database))
+        (vct (view-table (class-of obj)))
+        (view-class (class-of obj))

          (avps (mapcar #'(lambda (s)
          (avps (mapcar #'(lambda (s)

-                           (let ((val (slot-value
-                                       obj (slot-definition-name s))))
-                             (check-slot-type s val)
+                           (let* ((slot (etypecase s
+                                         (symbol (slotdef-for-slot-with-class s view-class))
+                                         (view-class-effective-slot-definition s)))
+                                 (val (slot-value
+                                       obj (slot-definition-name slot))))
+                             (check-slot-type slot val)

                              (list (sql-expression
                              (list (sql-expression

-                                    :attribute (view-class-slot-column s))
-                                   (db-value-from-slot s val database))))
-                       sds)))
+                                    :attribute (view-class-slot-column slot))
+                                   (db-value-from-slot slot val database))))
+                       slots)))

     (cond ((and avps (view-database obj))
            (update-records (sql-expression :table vct)
                            :av-pairs avps
     (cond ((and avps (view-database obj))
            (update-records (sql-expression :table vct)
                            :av-pairs avps


@@ -208,75 +221,53 @@
                            :database database)
            (setf (slot-value obj 'view-database) database))
           (t
                            :database database)
            (setf (slot-value obj 'view-database) database))
           (t

-           (error "Unable to update records"))))
+           (error "Unable to update record"))))

   (values))
 
 (defmethod update-records-from-instance ((obj standard-db-object) &key database)
   (values))
 
 (defmethod update-records-from-instance ((obj standard-db-object) &key database)

-  (let ((database (or database (view-database obj) *default-database*)))
-    (labels ((slot-storedp (slot)
-               (and (member (view-class-slot-db-kind slot) '(:base :key))
-                    (slot-boundp obj (slot-definition-name slot))))
-             (slot-value-list (slot)
-               (let ((value (slot-value obj (slot-definition-name slot))))
-                 (check-slot-type slot value)
-                 (list (sql-expression :attribute (view-class-slot-column slot))
-                       (db-value-from-slot slot value database)))))
-      (let* ((view-class (class-of obj))
-             (view-class-table (view-table view-class))
-             (slots (remove-if-not #'slot-storedp
-                                   (ordered-class-slots view-class)))
-             (record-values (mapcar #'slot-value-list slots)))
-        (unless record-values
-          (error "No settable slots."))
-        (if (view-database obj)
-            (update-records (sql-expression :table view-class-table)
-                            :av-pairs record-values
-                            :where (key-qualifier-for-instance
-                                    obj :database database)
-                            :database database)
-            (progn
-              (insert-records :into (sql-expression :table view-class-table)
-                              :av-pairs record-values
-                              :database database)
-              (setf (slot-value obj 'view-database) database))))))
-  (values))
-
-(defmethod delete-instance-records ((instance standard-db-object))
+  (labels ((slot-storedp (slot)
+            (and (member (view-class-slot-db-kind slot) '(:base :key))
+                 (slot-boundp obj (slot-definition-name slot)))))
+    (let* ((view-class (class-of obj))
+          (slots (remove-if-not #'slot-storedp
+                                (ordered-class-slots view-class))))
+      (update-record-from-slots obj slots :database database )))
+  )
+
+(defmethod delete-instance-records ((instance standard-db-object) &key database)

   (let ((vt (sql-expression :table (view-table (class-of instance))))
   (let ((vt (sql-expression :table (view-table (class-of instance))))

-        (vd (view-database instance)))
-    (if vd
-        (let ((qualifier (key-qualifier-for-instance instance :database vd)))
-          (delete-records :from vt :where qualifier :database vd)
-          (setf (record-caches vd) nil)
-          (setf (slot-value instance 'view-database) nil)
-          (values))
-        (signal-no-database-error vd))))
+       (database (choose-database-for-instance instance database)))
+    (let ((qualifier (key-qualifier-for-instance instance :database database)))
+      (delete-records :from vt :where qualifier :database database)
+      (setf (record-caches database) nil)
+      (setf (slot-value instance 'view-database) nil)
+      (values))))

 
 (defmethod update-instance-from-records ((instance standard-db-object)
 
 (defmethod update-instance-from-records ((instance standard-db-object)

-                                         &key (database *default-database*))
+                                         &key database)

   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))
   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))

-         (vd (or (view-database instance) database))
-         (view-qual (key-qualifier-for-instance instance :database vd))
+         (database (choose-database-for-instance instance database))
+         (view-qual (key-qualifier-for-instance instance :database database))

          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
                                             :where view-qual
          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
                                             :where view-qual

-                                            :result-types nil
-                                            :database vd)))))
+                                           :result-types nil
+                                           :database database)))))

     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
 (defmethod update-slot-from-record ((instance standard-db-object)
     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
 (defmethod update-slot-from-record ((instance standard-db-object)

-                                    slot &key (database *default-database*))
+                                    slot &key database)

   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))
   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))

-         (vd (or (view-database instance) database))
-         (view-qual (key-qualifier-for-instance instance :database vd))
+         (database (choose-database-for-instance instance database))
+         (view-qual (key-qualifier-for-instance instance :database database))

          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
          (res (select att-ref :from  view-table :where view-qual
          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
          (res (select att-ref :from  view-table :where view-qual

-                      :result-types nil)))
+                     :result-types nil)))

     (when res
       (get-slot-values-from-view instance (list slot-def) (car res)))))
 
     (when res
       (get-slot-values-from-view instance (list slot-def) (car res)))))