X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=9641c5116bbc7b1234237039a941940a4489bfa3;hb=82a46396a91b6eb30efb60eb6356b4a20a7a9136;hp=833abd79e0510f3a47682bbea747a793fdc27b1a;hpb=5990bfce392a05c10237d4f97b008c4f828028e5;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 833abd7..9641c51 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -21,6 +21,10 @@
   (:metaclass standard-db-class)
   (:documentation "Superclass for all CLSQL View Classes."))
 
+(defvar *update-records-on-make-instance* nil
+  "When T, UPDATE-RECORDS-FROM-INSTANCE will be automatically called
+when a new instance of a view-class is created.")
+
 (defvar *db-deserializing* nil)
 (defvar *db-initializing* nil)
 
@@ -39,17 +43,19 @@
               (setf (slot-value instance slot-name) nil))))))
   (call-next-method))
 
+#+ignore ;; not currently used
 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
 					  instance slot)
   (declare (ignore new-value instance slot))
   (call-next-method))
 
-(defmethod initialize-instance :around ((object standard-db-object)
+(defmethod initialize-instance ((object standard-db-object)
 					&rest all-keys &key &allow-other-keys)
   (declare (ignore all-keys))
   (let ((*db-initializing* t))
     (call-next-method)
-    (unless *db-deserializing*
+    (when (and *update-records-on-make-instance*
+	       (not *db-deserializing*))
       #+nil (created-object object)
       (update-records-from-instance object))))
 
@@ -706,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))
@@ -763,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)