r9249: separate target-slot processing in prep for rewrite to use single join statement

[clsql.git] / sql / objects.lisp

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 1342fe3a09ced2c6a4dc7b2740aed1e7788944f8..9641c5116bbc7b1234237039a941940a4489bfa3 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -712,21 +712,41 @@ superclass of the newly-defined View Class."
       (when jq 
         (select jc :where jq :flatp t :result-types nil)))))
 
+;; FIXME: Create a single join query for efficiency
+(defun fault-join-target-slot (class object slot-def)
+  (let* ((res (fault-join-slot-raw class object slot-def))
+        (dbi (view-class-slot-db-info slot-def))
+        (target-name (gethash :target-slot dbi))
+        (target-class (find-class target-name)))
+    (when res
+      (mapcar (lambda (obj)
+               (list 
+                (car
+                 (fault-join-slot-raw 
+                  target-class
+                  obj
+                  (find target-name (class-slots (class-of obj))
+                        :key #'slot-definition-name)))
+                obj))
+             res)
+      #+ignore ;; this doesn't work when attempting to call slot-value
+      (mapcar (lambda (obj)
+               (cons obj (slot-value obj ts))) res))))
+
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
-        (ts (gethash :target-slot dbi))
-        (res (fault-join-slot-raw class object slot-def)))
-    (when res
-      (cond
-       ((and ts (gethash :set dbi))
-        (mapcar (lambda (obj)
-                  (cons obj (slot-value obj ts))) res))
-       ((and ts (not (gethash :set dbi)))
-        (mapcar (lambda (obj) (slot-value obj ts)) res))
-       ((and (not ts) (not (gethash :set dbi)))
-        (car res))
-       ((and (not ts) (gethash :set dbi))
-        res)))))
+        (ts (gethash :target-slot dbi)))
+    (if (and ts (gethash :set dbi))
+       (fault-join-target-slot class object slot-def)
+       (let ((res (fault-join-slot-raw class object slot-def)))
+         (when res
+           (cond
+             ((and ts (not (gethash :set dbi)))
+              (mapcar (lambda (obj) (slot-value obj ts)) res))
+             ((and (not ts) (not (gethash :set dbi)))
+              (car res))
+             ((and (not ts) (gethash :set dbi))
+              res)))))))
 
 (defun join-qualifier (class object slot-def)
     (declare (ignore class))
@@ -769,10 +789,10 @@ superclass of the newly-defined View Class."
 
 (defun find-all (view-classes &rest args &key all set-operation distinct from
                  where group-by having order-by order-by-descending offset limit
-                refresh flatp (database *default-database*))
+                refresh flatp result-types (database *default-database*))
   "Called by SELECT to generate object query results when the
   View Classes VIEW-CLASSES are passed as arguments to SELECT."
-  (declare (ignore all set-operation group-by having offset limit)
+  (declare (ignore all set-operation group-by having offset limit result-types)
            (optimize (debug 3) (speed 1)))
   (remf args :from)
   (remf args :flatp)