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
 
 
 ;; 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
 
 (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."))
 
 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 b2f16a6d3319adef5620d745e213175122f9809f..ec54a346aa8db48b3d1b500fd3e0ec79b168738b 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -93,6 +93,17 @@
               (push (cons slotdef res) sels))))))
     sels))
 
               (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'
 ;;
 
 ;; 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)
     (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
                                  (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)
           ((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*))
 
 (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
          (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)))
 
       (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)
          (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)
 
 (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))
         (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)
                       (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
                  (update-records (sql-expression :table view-class-table)
                                  :av-pairs record-values
                                  :where (key-qualifier-for-instance


@@ -318,16 +331,16 @@
 
     pk))
 
 
     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))
           (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*)
 
 (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)))
       (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))
            (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)))
                                  (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))
            (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
                                 :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))
            (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))
                          (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)
          ;; 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))
                     (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
           (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
 
 
 ;;; 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
     (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))
 
 (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
         (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
               (slot-name (slot-definition-name slot-def)))
 
           ;; If current class is normalized and wanted slot is not