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 allows overriding to control object connection
management (which is nice in heavily multithreaded (web) environs)

 * f10fc333da09ea7e24477e6199ffbc541adff2f1
 * 348cafca35b850b66b1181ba0661211e64f0d4f1

diff --git a/sql/generics.lisp b/sql/generics.lisp
index b0a44725e766490248ab2373d41df8047e96af02..3f3ee7c07262f20c338ce41adb3bfebbd711fb82 100644 (file)
--- a/sql/generics.lisp
+++ b/sql/generics.lisp
@@ -18,6 +18,11 @@
 
 
 ;; FDML
+(defgeneric choose-database-for-instance (object &optional 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
@@ -82,7 +87,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."))
 
-(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

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index b2f16a6d3319adef5620d745e213175122f9809f..ec54a346aa8db48b3d1b500fd3e0ec79b168738b 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -93,6 +93,17 @@
               (push (cons slotdef res) sels))))))
     sels))
 
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional 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)))
+
+
 
 ;; Called by 'get-slot-values-from-view'
 ;;
@@ -105,9 +116,9 @@
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
                  (read-sql-value value (delistify slot-type)
-                                 (view-database instance)
+                                 (choose-database-for-instance instance)
                                  (database-underlying-type
-                                  (view-database instance)))))
+                                  (choose-database-for-instance instance)))))
           ((null value)
            (update-slot-with-null instance slot-name slotdef))
           ((typep slot-reader 'string)
@@ -170,7 +181,7 @@
 
 (defmethod update-record-from-slot ((obj standard-db-object) slot &key
                                     (database *default-database*))
-  (let* ((database (or (view-database obj) database))
+  (let* ((database (choose-database-for-instance obj database))
          (view-class (class-of obj)))
     (when (normalizedp view-class)
       ;; If it's normalized, find the class that actually contains
@@ -213,7 +224,7 @@
       (update-record-from-slot obj slot :database database))
     (return-from update-record-from-slots (values)))
 
-  (let* ((database (or (view-database obj) database))
+  (let* ((database (choose-database-for-instance obj database))
          (vct (view-table (class-of obj)))
          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
          (avps (mapcar #'(lambda (s)
@@ -244,7 +255,7 @@
 
 (defmethod update-records-from-instance ((obj standard-db-object)
                                          &key database this-class)
-  (let ((database (or database (view-database obj) *default-database*))
+  (let ((database (choose-database-for-instance obj database))
         (pk nil))
     (labels ((slot-storedp (slot)
                (and (member (view-class-slot-db-kind slot) '(:base :key))
@@ -276,6 +287,8 @@
                       (not record-values))
                  nil)
                 ((view-database obj)
+                 ;; if this slot is set, the database object was returned from a select
+                 ;; and has already been in the database, so we must need an update
                  (update-records (sql-expression :table view-class-table)
                                  :av-pairs record-values
                                  :where (key-qualifier-for-instance
@@ -318,16 +331,16 @@
 
     pk))
 
-(defmethod delete-instance-records ((instance standard-db-object))
-  (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)
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+  (let ((database (choose-database-for-instance instance database))
+        (vt (sql-expression :table (view-table (class-of instance)))))
+    (if 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))
-        (signal-no-database-error vd))))
+        (signal-no-database-error database))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
                                          &key (database *default-database*)
@@ -339,7 +352,7 @@
       (setf pres (update-instance-from-records instance :database database
                                                :this-class pclass)))
     (let* ((view-table (sql-expression :table (view-table view-class)))
-           (vd (or (view-database instance) database))
+           (vd (choose-database-for-instance instance database))
            (view-qual (key-qualifier-for-instance instance :database vd
                                                            :this-class view-class))
            (sels (generate-selection-list view-class))
@@ -371,7 +384,7 @@
                                  (ordered-class-direct-slots this-class)))
                  this-class))))
     (let* ((view-table (sql-expression :table (view-table view-class)))
-           (vd (or (view-database instance) database))
+           (vd (choose-database-for-instance instance database))
            (view-qual (key-qualifier-for-instance instance :database vd
                                                            :this-class view-class))
            (att-ref (generate-attribute-reference view-class slot-def))
@@ -770,10 +783,10 @@
                                 :table jc-view-table))
                           :where jq
                           :result-types :auto
-                          :database (view-database object))))
+                          :database (choose-database-for-instance object))))
            (mapcar #'(lambda (i)
                        (let* ((instance (car i))
-                              (jcc (make-instance jc :view-database (view-database instance))))
+                              (jcc (make-instance jc :view-database (choose-database-for-instance instance))))
                          (setf (slot-value jcc (gethash :foreign-key dbi))
                                key)
                          (setf (slot-value jcc (gethash :home-key tdbi))
@@ -784,8 +797,8 @@
          ;; just fill in minimal slots
          (mapcar
           #'(lambda (k)
-              (let ((instance (make-instance tsc :view-database (view-database object)))
-                    (jcc (make-instance jc :view-database (view-database object)))
+              (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+                    (jcc (make-instance jc :view-database (choose-database-for-instance object)))
                     (fk (car k)))
                 (setf (slot-value instance (gethash :home-key tdbi)) fk)
                 (setf (slot-value jcc (gethash :foreign-key dbi))
@@ -796,7 +809,7 @@
           (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
                   :from (sql-expression :table jc-view-table)
                   :where jq
-                  :database (view-database object))))))))
+                  :database (choose-database-for-instance object))))))))
 
 
 ;;; Remote Joins
@@ -894,7 +907,7 @@ maximum of MAX-LEN instances updated in each query."
     (let ((jq (join-qualifier class object slot-def)))
       (when jq
         (select jc :where jq :flatp t :result-types nil
-                :database (view-database object))))))
+                :database (choose-database-for-instance object))))))
 
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
@@ -943,7 +956,7 @@ maximum of MAX-LEN instances updated in each query."
         (let ((res (car (select (class-name sc) :where jq
                                                 :flatp t :result-types nil
                                                 :caching nil
-                                                :database (view-database object))))
+                                                :database (choose-database-for-instance object))))
               (slot-name (slot-definition-name slot-def)))
 
           ;; If current class is normalized and wanted slot is not