removed generate-selection-list in favor of a make-select-list
[clsql.git] / sql / oodml.lisp
index 3c65919..09de90a 100644 (file)
   "Turns key class and slot-def into a sql-expression representing the
    table and column it comes from
 
-   used by things like generate-selection-list, update-slot-from-record"
+   used by things like make-select-list, update-slot-from-record"
   (when (key-or-base-slot-p slotdef)
     (sql-expression :attribute (database-identifier slotdef database)
                     :table (database-identifier vclass database))))
 
-;;
-;; Function used by 'find-all'
-;;
-
-(defun generate-selection-list (vclass)
-  (let* ((sels nil)
-         (this-class vclass)
-         (slots (if (normalizedp vclass)
-                    (labels ((getdslots ()
-                               (let ((sl (ordered-class-direct-slots this-class)))
-                                 (cond (sl)
-                                       (t
-                                        (setf this-class
-                                              (car (class-direct-superclasses this-class)))
-                                        (getdslots))))))
-                      (getdslots))
-                    (ordered-class-slots this-class))))
-    (dolist (slotdef slots)
-      (let ((res (generate-attribute-reference this-class slotdef)))
-        (when res
-          (push (cons slotdef res) sels))))
-    (if sels
-        sels
-        (error "No slots of type :base in view-class ~A" (class-name vclass)))))
-
-
-
-(defun generate-retrieval-joins-list (vclass retrieval-method)
+(defun generate-retrieval-joins-list (class retrieval-method)
   "Returns list of immediate join slots for a class."
-  (let ((join-slotdefs nil))
-    (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
-      (when (and (eq :join (view-class-slot-db-kind slotdef))
-                 (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
-        (push slotdef join-slotdefs)))))
-
-(defun generate-immediate-joins-selection-list (vclass)
-  "Returns list of immediate join slots for a class."
-  (let (sels)
-    (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
-      (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
-             (join-class (when join-class-name (find-class join-class-name))))
-        (dolist (slotdef (ordered-class-slots join-class))
-          (let ((res (generate-attribute-reference join-class slotdef)))
-            (when res
-              (push (cons slotdef res) sels))))))
-    sels))
+  (setf class (to-class class))
+  (loop for slot in (ordered-class-slots class)
+        when (eql (join-slot-retrieval-method slot) retrieval-method)
+        collect slot))
 
 (defun immediate-join-slots (class)
   (generate-retrieval-joins-list class :immediate))
         (signal-no-database-error database))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
-                                         &key (database *default-database*)
-                                         this-class)
-  (let* ((view-class (or this-class (class-of instance)))
-         (pclass (car (class-direct-superclasses view-class)))
-         (pres nil))
-    (when (normalizedp 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 (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))
-           (res nil))
-      (cond (view-qual
-             (setf res (apply #'select (append (mapcar #'cdr sels)
-                                               (list :from  view-table
-                                                     :where view-qual
-                                                     :result-types nil
-                                                     :database vd))))
-             (when res
-              (setf (slot-value instance 'view-database) vd)
-               (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
-            (pres)
-            (t nil)))))
+                                         &key (database *default-database*))
+  "Updates a database object with the current values stored in the database
+
+   TODO: Should this update immediate join slots similar to build-objects?
+         Can we just call build-objects?, update-objects-joins?
+  "
+
+  (let* ((classes-and-slots (view-classes-and-storable-slots instance))
+         (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))
+                      (view-table (sql-table select-list))
+                      (view-qual (key-qualifier-for-instance
+                                  instance :database vd
+                                  :this-class (view-class select-list)))
+                      (res (when view-qual
+                             (first
+                              (apply #'select
+                                     (append (full-select-list select-list)
+                                             (list :from view-table
+                                                   :where view-qual
+                                                   :result-types nil
+                                                   :database vd)))))))
+                 (when res
+                   (setf (slot-value instance 'view-database) vd)
+                   (get-slot-values-from-view instance (slot-list select-list) res))
+                 )))
+      (loop for class-and-slots in classes-and-slots
+            do (do-update class-and-slots)))))
 
 
 (defmethod get-slot-value-from-record ((instance standard-db-object)
@@ -1091,29 +1055,69 @@ maximum of MAX-LEN instances updated in each query."
           collect tbl into rtn
           finally (return rtn))))
 
-(defun full-select-list ( classes )
-  "Returns a list of sql-ref of things to select for the given classes
 
-   THIS NEEDS TO MATCH THE ORDER OF build-objects
+(defclass select-list ()
+  ((view-class :accessor view-class :initarg :view-class :initform nil)
+   (select-list :accessor select-list :initarg :select-list :initform nil)
+   (slot-list :accessor slot-list :initarg :slot-list :initform nil)
+   (joins :accessor joins :initarg :joins :initform nil)
+   (join-slots :accessor join-slots :initarg :join-slots :initform nil))
+  (:documentation
+   "Collects the classes, slots and their respective sql representations
+    so that update-instance-from-recors, find-all, build-objects can share this
+    info and calculate it once.  Joins are select-lists for each immediate join-slot
+    but only if make-select-list is called with do-joins-p"))
+
+(defmethod view-table ((o select-list))
+  (view-table (view-class o)))
+
+(defmethod sql-table ((o select-list))
+  (sql-expression :table (view-table o)))
 
-   TODO: this used to include order-by and distinct as more things to select.
-    distinct seems to always be used in a boolean context, so it doesnt seem
-    like appending it to the select makes any sense
+(defun make-select-list (class-and-slots &key (do-joins-p nil))
+  "Make a select-list for the current class (or class-and-slots) object."
+  (let* ((class-and-slots
+           (etypecase class-and-slots
+             (class-and-slots class-and-slots)
+             ((or symbol standard-db-class)
+              ;; 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)))))))
+         (class (view-class class-and-slots))
+         (join-slots (when do-joins-p (immediate-join-slots class))))
+    (multiple-value-bind (slots sqls)
+        (loop for slot in (slot-defs class-and-slots)
+              for sql = (generate-attribute-reference class slot)
+              collect slot into slots
+              collect sql into sqls
+              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)))))))
+
+(defun full-select-list ( select-lists )
+  "Returns a list of sql-ref of things to select for the given classes
 
-    We also used to remove duplicates, but that seems like it would make
-    filling/building objects much more difficult so skipping for now...
+   THIS NEEDS TO MATCH THE ORDER OF build-objects
   "
-  (setf classes (mapcar #'to-class (listify classes)))
-  (mapcar
-   #'cdr
-   (loop for class in classes
-         appending (generate-selection-list class)
-         appending
-            (loop for join-slot in (immediate-join-slots class)
-                  for join-class = (join-slot-class-name join-slot)
-                  appending (generate-selection-list join-class)))))
-
-(defun build-objects (classes row database &optional existing-instances)
+  (loop for s in (listify select-lists)
+        appending (select-list s)
+        appending (loop for join in (joins s)
+                        appending (select-list join))))
+
+(defun build-objects (select-lists row database &optional existing-instances)
   "Used by find-all to build objects.
 
    THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST
@@ -1130,21 +1134,23 @@ maximum of MAX-LEN instances updated in each query."
       would be multiple rows per object, but we would return an object per row
    "
   (setf existing-instances (listify existing-instances))
-  (loop for class in classes
-        for existing = (pop existing-instances)
-        for object = (or existing
-                         (make-instance class :view-database database))
-        do (loop for (slot . _) in (generate-selection-list class)
-                 do (update-slot-from-db-value object slot (pop row)))
-        do (loop for join-slot in (immediate-join-slots class)
-                 for join-class = (join-slot-class-name join-slot)
-                 for join-object =
-                     (setf
-                      (easy-slot-value object join-slot)
+  (loop
+    for select-list in select-lists
+    for class = (view-class select-list)
+    for existing = (pop existing-instances)
+    for object = (or existing
+                     (make-instance class :view-database database))
+    do (loop for slot in (slot-list select-list)
+             do (update-slot-from-db-value object slot (pop row)))
+    do (loop for join-slot in (join-slots select-list)
+             for join in (joins select-list)
+             for join-class = (view-class join)
+             for join-object =
+                (setf (easy-slot-value object join-slot)
                       (make-instance join-class))
-                 do (loop for (slot . _) in (generate-selection-list join-class)
-                          do (update-slot-from-db-value join-object slot (pop row))))
-        do (when existing (instance-refreshed object))
+             do (loop for slot in (slot-list join)
+                      do (update-slot-from-db-value join-object slot (pop row))))
+    do (when existing (instance-refreshed object))
         collect object))
 
 (defun find-all (view-classes
@@ -1180,7 +1186,9 @@ maximum of MAX-LEN instances updated in each query."
            (loop for class in sclasses
                  appending (loop for slot in (immediate-join-slots class)
                                  collect (join-slot-qualifier class slot))))
-         (full-select-list (full-select-list sclasses))
+         (select-lists (loop for class in sclasses
+                             collect (make-select-list class :do-joins-p t)))
+         (full-select-list (full-select-list select-lists))
          (where (clsql-ands (append (listify where) (listify join-where))))
          #|
           (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%"
@@ -1195,7 +1203,7 @@ maximum of MAX-LEN instances updated in each query."
          (return-objects
            (loop for row in rows
                  for old-objs = (pop instances)
-                 for objs = (build-objects sclasses row database
+                 for objs = (build-objects select-lists row database
                                            (when refresh old-objs))
                  collecting (if flatp
                                 (delist-if-single objs)