Added to-database-p keyword to view-classes-and-storable-slots (and added generic)

[clsql.git] / sql / oodml.lisp

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index 1599f17e6fcf00b38cf15089811d23410e9c8fc9..dbd5e6c5d1b2ba9db199d97f3cde08781c108969 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -308,14 +308,20 @@
    the public api"
   (update-record-from-slots obj slot :database database))
 
-(defmethod view-classes-and-storable-slots (class)
+(defmethod view-classes-and-storable-slots (class &key to-database-p)
   "Get a list of all the tables we need to update and the slots on them
 
    for non normalized classes we return the class and all its storable slots
 
    for normalized classes we return a list of direct slots and the class they
    came from for each normalized view class
+
+   to-database-p is provided so that we can read / write different data
+   to the database in different circumstances
+   (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)
@@ -359,7 +365,7 @@
    view-database slot on the object is nil then the object is assumed to be
    new and is inserted"
   (let ((database (choose-database-for-instance obj database))
-        (classes-and-slots (view-classes-and-storable-slots obj)))
+        (classes-and-slots (view-classes-and-storable-slots obj :to-database-p t)))
     (loop for class-and-slots in classes-and-slots
           do (%update-instance-helper class-and-slots obj database))
     (setf (slot-value obj 'view-database) database)
@@ -388,10 +394,13 @@
          Can we just call build-objects?, update-objects-joins?
   "
 
-  (let* ((classes-and-slots (view-classes-and-storable-slots instance))
+  (let* ((classes-and-slots (view-classes-and-storable-slots
+                             instance :to-database-p nil))
          (vd (choose-database-for-instance instance database)))
     (labels ((do-update (class-and-slots)
-               (let* ((select-list (make-select-list class-and-slots :do-joins-p nil))
+               (let* ((select-list (make-select-list class-and-slots
+                                                     :do-joins-p nil
+                                                     :database database))
                       (view-table (sql-table select-list))
                       (view-qual (key-qualifier-for-instance
                                   instance :database vd
@@ -986,7 +995,13 @@
 (defmethod sql-table ((o select-list))
   (sql-expression :table (view-table o)))
 
-(defun make-select-list (class-and-slots &key (do-joins-p nil))
+(defmethod filter-select-list ((c clsql-sys::standard-db-object)
+                               (sl clsql-sys::select-list)
+                               database)
+  sl)
+
+(defun make-select-list (class-and-slots &key (do-joins-p nil)
+                                         (database *default-database*))
   "Make a select-list for the current class (or class-and-slots) object."
   (let* ((class-and-slots
            (etypecase class-and-slots
@@ -995,7 +1010,8 @@
               ;; find the first class with slots for us to select (this should be)
               ;; the first of its classes / parent-classes with slots
               (first (reverse (view-classes-and-storable-slots
-                               (to-class class-and-slots)))))))
+                               (to-class class-and-slots)
+                                :to-database-p nil))))))
          (class (view-class class-and-slots))
          (join-slots (when do-joins-p (immediate-join-slots class))))
     (multiple-value-bind (slots sqls)
@@ -1006,18 +1022,21 @@
               finally (return (values slots sqls)))
       (unless slots
         (error "No slots of type :base in view-class ~A" (class-name class)))
-      (make-instance
-       'select-list
-       :view-class class
-       :select-list sqls
-       :slot-list slots
-       :join-slots join-slots
-       ;; only do a single layer of join objects
-       :joins (when do-joins-p
-                (loop for js in join-slots
-                      collect (make-select-list
-                               (join-slot-class js)
-                               :do-joins-p nil)))))))
+      (let ((sl (make-instance
+                 'select-list
+                 :view-class class
+                 :select-list sqls
+                 :slot-list slots
+                 :join-slots join-slots
+                 ;; only do a single layer of join objects
+                 :joins (when do-joins-p
+                          (loop for js in join-slots
+                                collect (make-select-list
+                                         (join-slot-class js)
+                                         :do-joins-p nil
+                                         :database database))))))
+        (filter-select-list (make-instance class) sl database)
+        sl))))
 
 (defun full-select-list ( select-lists )
   "Returns a list of sql-ref of things to select for the given classes
@@ -1099,7 +1118,7 @@
                  appending (loop for slot in (immediate-join-slots class)
                                  collect (join-slot-qualifier class slot))))
          (select-lists (loop for class in sclasses
-                             collect (make-select-list class :do-joins-p t)))
+                             collect (make-select-list class :do-joins-p t :database database)))
          (full-select-list (full-select-list select-lists))
          (where (clsql-ands (append (listify where) (listify join-where))))
          #|