X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=e72e53aa8fc5247d68960d872e7041abc3978b20;hb=90011694c27b5b22673a34cb6948a2a721a9b6cd;hp=2ebad78b332af0017ff545b76edff45e3eff218d;hpb=1c5166f0e106b086a5f50a7ce5af2f50d6c6b58e;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 2ebad78..e72e53a 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -712,34 +712,72 @@ superclass of the newly-defined View Class."
       (when jq 
         (select jc :where jq :flatp t :result-types nil)))))
 
-(defun fault-join-slot (class object slot-def)
+;; this works, but is inefficient requiring (+ 1 n-rows)
+;; SQL queries
+#+ignore
+(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-target-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 :target-slot dbi) (gethash :set dbi))
-	(mapcar (lambda (obj)
-		  (let* ((target-name (gethash :target-slot dbi))
-			 (target-class (find-class target-name)))
-		    (list 
-		     (car
-		      (fault-join-slot-raw 
-		       target-class
-		       obj
-		       (find target-name (class-slots (class-of obj))
-			     :key #'slot-definition-name)))
-		     obj)))
-		 res))
-	((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)))))
+	 (jc (gethash :join-class dbi))
+	 (tdbi (view-class-slot-db-info 
+		(find ts (class-slots (find-class jc))
+		      :key #'slot-definition-name)))
+	 (jq (join-qualifier class object slot-def))
+	 (key (slot-value object (gethash :home-key dbi))))
+    (when jq
+      (let ((res
+	     (find-all (list ts) 
+		       :inner-join (sql-expression :attribute jc)
+		       :on (sql-operation 
+			    '==
+			    (sql-expression :attribute (gethash :foreign-key tdbi) :table ts)
+			    (sql-expression :attribute (gethash :home-key tdbi) :table jc))
+		       :where jq
+		       :result-types :auto)))
+	(mapcar #'(lambda (i)
+		    (let* ((instance (car i))
+			   (jcc (make-instance jc :view-database (view-database instance))))
+		      (setf (slot-value jcc (gethash :foreign-key dbi)) 
+			key)
+		      (setf (slot-value jcc (gethash :home-key tdbi)) 
+			(slot-value instance (gethash :foreign-key tdbi)))
+		      (list instance jcc)))
+		res)))))
+
+(defun fault-join-slot (class object slot-def)
+  (let* ((dbi (view-class-slot-db-info slot-def))
+	 (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))
@@ -780,15 +818,19 @@ superclass of the newly-defined View Class."
                 (apply #'sql-and jc)
                 jc))))))
 
-(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 result-types (database *default-database*))
+(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 result-types inner-join on 
+		      (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 result-types)
+  (declare (ignore all set-operation group-by having offset limit inner-join on)
            (optimize (debug 3) (speed 1)))
   (remf args :from)
   (remf args :flatp)
+  (remf args :additional-fields)
   (remf args :result-types)
   (labels ((table-sql-expr (table)
 	     (sql-expression :table (view-table table)))
@@ -854,7 +896,7 @@ superclass of the newly-defined View Class."
 			     (cons :from 
 				   (list (append (when from (listify from)) 
 						 (listify tables)))) 
-			     (list :result-types nil)
+			     (list :result-types result-types)
 			     args)))
 	(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 
@@ -900,7 +942,7 @@ ENABLE-SQL-READER-SYNTAX."
     (multiple-value-bind (target-args qualifier-args)
         (query-get-selections select-all-args)
       (if (select-objects target-args)
-          (apply #'find-all target-args qualifier-args)
+	  (apply #'find-all target-args qualifier-args)
 	(let* ((expr (apply #'make-query select-all-args))
 	       (specified-types
 		(mapcar #'(lambda (attrib)