X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=04951f9c0fe07419f7bb8d8d754d9dc3c9cb47d0;hb=1619f599a1e37dd30dfe7ab803374f5eed26544a;hp=0285ca45e4cf00fa1d2b04991290eaac63e34297;hpb=388e813f22e5443353299e4058b99747ccb42377;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 0285ca4..04951f9 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -47,8 +47,9 @@
 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
 					  instance slot-def)
   (declare (ignore new-value))
-  (let ((slot-name (%svuc-slot-name slot-def))
-        (slot-kind (view-class-slot-db-kind slot-def)))
+  (let* ((slot-name (%svuc-slot-name slot-def))
+	 (slot-object (%svuc-slot-object slot-def class))
+	 (slot-kind (view-class-slot-db-kind slot-object)))
     (call-next-method)
     (when (and *db-auto-sync* 
 	       (not *db-initializing*)
@@ -234,14 +235,28 @@ superclass of the newly-defined View Class."
 	sels
         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 
-(defun generate-immediate-joins-list (vclass)
-  "Returns list of pairs of join slots and their class for a class."
-  (let ((sels nil))
-    (dolist (slotdef (ordered-class-slots vclass))
+
+
+(defun generate-retrieval-joins-list (vclass 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 :immediate (gethash :retrieval (view-class-slot-db-info slotdef))))
-	(push slotdef sels)))
-    (cons vclass (list sels))))
+		 (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))
+
 
 ;; Called by 'get-slot-values-from-view'
 ;;
@@ -795,8 +810,11 @@ superclass of the newly-defined View Class."
   (when objects
     (unless class-name
       (class-name (class-of (first objects))))
-    )
-  )
+    (let* ((class (find-class class-name))
+	   (deferred-joins (generate-retrieval-joins-list class :deferred)))
+      (when deferred-joins
+	(warn "not yet implemented.")
+	))))
 
   
 (defun fault-join-slot-raw (class object slot-def)
@@ -864,6 +882,43 @@ superclass of the newly-defined View Class."
 ;; For example, for (select 'employee-address) in test suite =>
 ;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
 
+(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp)
+  "Used by find-all to build objects."
+  (labels ((build-object (vals vclass jclasses selects immediate-selects)
+	     (let* ((class-name (class-name vclass))
+		    (db-vals (butlast vals (- (list-length vals)
+					      (list-length selects))))
+		    (join-vals (subseq vals (list-length selects)))
+		    (obj (make-instance class-name :view-database database))
+		    (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
+				   jclasses)))
+	       ;;(format t "db-vals: ~S, join-values: ~S~%" db-vals join-vals)
+	       ;; use refresh keyword here 
+	       (setf obj (get-slot-values-from-view obj (mapcar #'car selects) 
+						    db-vals))
+	       (mapc #'(lambda (jc) (get-slot-values-from-view jc (mapcar #'car immediate-selects) join-vals))
+		     joins)
+	       (mapc
+		#'(lambda (jc) (let ((slot (find (class-name (class-of jc)) (class-slots vclass) 
+						 :key #'(lambda (slot) (when (and (eq :join (view-class-slot-db-kind slot))
+										  (eq (slot-definition-name slot)
+										      (gethash :join-class (view-class-slot-db-info slot))))
+									 (slot-definition-name slot))))))
+				 (when slot
+				   (setf (slot-value obj (slot-definition-name slot)) jc))))
+			  
+		joins)
+	       (when refresh (instance-refreshed obj))
+	       obj)))
+    (let ((objects (mapcar #'(lambda (sclass jclass sel immediate-join) 
+			       (prog1 (build-object vals sclass jclass sel immediate-join)
+				 (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
+						    vals))))
+			   sclasses immediate-join-classes sels immediate-joins)))
+      (if (and flatp (= (length sclasses) 1))
+	  (car objects)
+	  objects))))
+
 (defun find-all (view-classes 
 		 &rest args
 		 &key all set-operation distinct from where group-by having 
@@ -874,75 +929,90 @@ superclass of the newly-defined View Class."
   View Classes VIEW-CLASSES are passed as arguments to SELECT."
   (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)))
-	   (ref-equal (ref1 ref2)
+  (labels ((ref-equal (ref1 ref2)
 	     (equal (sql ref1)
 		    (sql ref2)))
+	   (table-sql-expr (table)
+	     (sql-expression :table (view-table table)))
 	   (tables-equal (table-a table-b)
-	     (string= (string (slot-value table-a 'name))
-		      (string (slot-value table-b 'name))))
-	   (build-object (vals vclass selects)
-	     (let* ((class-name (class-name vclass))
-		    (db-vals (butlast vals (- (list-length vals)
-					      (list-length selects))))
-		    (obj (make-instance class-name :view-database database)))
-	       ;; use refresh keyword here 
-	       (setf obj (get-slot-values-from-view obj (mapcar #'car selects) 
-						    db-vals))
-	       (when refresh (instance-refreshed obj))
-	       obj))
-	   (build-objects (vals sclasses sels)
-	     (let ((objects (mapcar #'(lambda (sclass sel) 
-					(prog1 (build-object vals sclass sel)
-					  (setf vals (nthcdr (list-length sel)
-							     vals))))
-				    sclasses sels)))
-	       (if (and flatp (= (length sclasses) 1))
-		   (car objects)
-		   objects))))
+	     (when (and table-a table-b)
+	       (string= (string (slot-value table-a 'name))
+			(string (slot-value table-b 'name))))))
+    (remf args :from)
+    (remf args :where)
+    (remf args :flatp)
+    (remf args :additional-fields)
+    (remf args :result-types)
     (let* ((*db-deserializing* t)
 	   (sclasses (mapcar #'find-class view-classes))
-	   (immediate-joins (mapcar #'generate-immediate-joins-list sclasses))
+	   (immediate-join-slots (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
+	   (immediate-join-classes (mapcar #'(lambda (jcs)
+					       (mapcar #'(lambda (slotdef)
+							   (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
+						       jcs))
+					   immediate-join-slots))
+	   (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
 	   (sels (mapcar #'generate-selection-list sclasses))
-	   (fullsels (apply #'append sels))
+	   (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
 	   (sel-tables (collect-table-refs where))
-	   (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
-					      sel-tables)
-				      :test #'tables-equal))
-	   (res nil))
-        (dolist (ob (listify order-by))
-          (when (and ob (not (member ob (mapcar #'cdr fullsels)
-                                     :test #'ref-equal)))
-            (setq fullsels 
-		  (append fullsels (mapcar #'(lambda (att) (cons nil att))
-					   (listify ob))))))
-        (dolist (ob (listify order-by-descending))
-          (when (and ob (not (member ob (mapcar #'cdr fullsels)
-                                     :test #'ref-equal)))
-            (setq fullsels 
+	   (tables (remove-if #'null
+			      (remove-duplicates (append (mapcar #'table-sql-expr sclasses)
+							 (mapcar #'(lambda (jcs)
+								     (mapcan #'(lambda (jc)
+										 (when jc (table-sql-expr jc)))
+									     jcs))
+								 immediate-join-classes)
+							 sel-tables)
+						 :test #'tables-equal))))
+      (dolist (ob (listify order-by))
+	(when (and ob (not (member ob (mapcar #'cdr fullsels)
+				   :test #'ref-equal)))
+	  (setq fullsels 
 		  (append fullsels (mapcar #'(lambda (att) (cons nil att))
 					   (listify ob))))))
-        (dolist (ob (listify distinct))
-          (when (and (typep ob 'sql-ident) 
-		     (not (member ob (mapcar #'cdr fullsels) 
-				  :test #'ref-equal)))
-            (setq fullsels 
-		  (append fullsels (mapcar #'(lambda (att) (cons nil att))
-					   (listify ob))))))
-        (setq res 
-	      (apply #'select 
-		     (append (mapcar #'cdr fullsels)
-			     (cons :from 
-				   (list (append (when from (listify from)) 
-						 (listify tables)))) 
-			     (list :result-types result-types)
-			     args)))
-	(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
+      (dolist (ob (listify order-by-descending))
+	(when (and ob (not (member ob (mapcar #'cdr fullsels)
+				   :test #'ref-equal)))
+	  (setq fullsels 
+		(append fullsels (mapcar #'(lambda (att) (cons nil att))
+					 (listify ob))))))
+      (dolist (ob (listify distinct))
+	(when (and (typep ob 'sql-ident) 
+		   (not (member ob (mapcar #'cdr fullsels) 
+				:test #'ref-equal)))
+	  (setq fullsels 
+	      (append fullsels (mapcar #'(lambda (att) (cons nil att))
+				       (listify ob))))))
+      (mapcar #'(lambda (vclass jclasses jslots)
+		  (when jclasses
+		    (mapcar
+		     #'(lambda (jclass jslot)
+			 (let ((dbi (view-class-slot-db-info jslot)))
+			   (setq where
+				 (append
+				  (list (sql-operation '==
+						      (sql-expression
+						       :attribute (gethash :foreign-key dbi)
+						       :table (view-table jclass))
+						      (sql-expression
+						       :attribute (gethash :home-key dbi)
+						       :table (view-table vclass))))
+				  (when where (listify where))))))
+		     jclasses jslots)))
+	      sclasses immediate-join-classes immediate-join-slots)
+      (let* ((rows (apply #'select 
+			  (append (mapcar #'cdr fullsels)
+				  (cons :from 
+					(list (append (when from (listify from)) 
+						      (listify tables)))) 
+				  (list :result-types result-types)
+				  (when where (list :where where))
+				  args)))
+	     (objects (mapcar 
+		       #'(lambda (r)
+			   (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp))
+		       rows)))
+	objects))))
 
 (defmethod instance-refreshed ((instance standard-db-object)))
 
@@ -985,30 +1055,85 @@ ENABLE-SQL-READER-SYNTAX."
                        target-args))))
     (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)
-	(let* ((expr (apply #'make-query select-all-args))
-	       (specified-types
-		(mapcar #'(lambda (attrib)
-			    (if (typep attrib 'sql-ident-attribute)
-				(let ((type (slot-value attrib 'type)))
-				  (if type
-				      type
-				    t))
-			      t))
-			(slot-value expr 'selections))))
-	  (destructuring-bind (&key (flatp nil)
-				    (result-types :auto)
-				    (field-names t) 
-				    (database *default-database*)
-			       &allow-other-keys)
-	      qualifier-args
-	    (query expr :flatp flatp 
-		   :result-types 
-		   ;; specifying a type for an attribute overrides result-types
-		   (if (some #'(lambda (x) (not (eq t x))) specified-types) 
-		       specified-types
-		     result-types)
-		   :field-names field-names
-		   :database database)))))))
+	(cond
+	  ((select-objects target-args)
+	   (let ((caching (getf qualifier-args :caching))
+		 (refresh (getf qualifier-args :refresh))
+		 (database (or (getf qualifier-args :database) *default-database*)))
+	     (remf qualifier-args :caching)
+	     (remf qualifier-args :refresh)
+	     (cond
+	       ((null caching)
+		(apply #'find-all target-args qualifier-args))
+	       (t
+		(let ((cached (records-cache-results target-args qualifier-args database)))
+		  (cond
+		    ((and cached (not refresh))
+		     cached)
+		    ((and cached refresh)
+		     (update-cached-results target-args qualifier-args database))
+		    (t
+		     (let ((results (apply #'find-all target-args qualifier-args)))
+		       (setf (records-cache-results target-args qualifier-args database) results)
+		       results))))))))
+	  (t
+	   (let* ((expr (apply #'make-query select-all-args))
+		  (specified-types
+		   (mapcar #'(lambda (attrib)
+			       (if (typep attrib 'sql-ident-attribute)
+				   (let ((type (slot-value attrib 'type)))
+				     (if type
+					 type
+					 t))
+				   t))
+			   (slot-value expr 'selections))))
+	     (destructuring-bind (&key (flatp nil)
+				       (result-types :auto)
+				       (field-names t) 
+				       (database *default-database*)
+				       &allow-other-keys)
+		 qualifier-args
+	       (query expr :flatp flatp 
+		      :result-types 
+		      ;; specifying a type for an attribute overrides result-types
+		      (if (some #'(lambda (x) (not (eq t x))) specified-types) 
+			  specified-types
+			  result-types)
+		      :field-names field-names
+		      :database database))))))))
+
+(defun compute-records-cache-key (targets qualifiers)
+  (list targets
+	(do ((args *select-arguments* (cdr args))
+	     (results nil))
+	    ((null args) results)
+	  (let* ((arg (car args))
+		 (value (getf qualifiers arg)))
+	    (when value
+	      (push (list arg
+			  (typecase value
+			    (%sql-expression (sql value))
+			    (t value)))
+		    results))))))
+
+(defun records-cache-results (targets qualifiers database)
+  (when (record-caches database)
+    (gethash (compute-records-cache-key targets qualifiers) (record-caches database)))) 
+
+(defun (setf records-cache-results) (results targets qualifiers database)
+  (unless (record-caches database)
+    (setf (record-caches database)
+	  (make-hash-table :test 'equal
+			   #+allegro :values #+allegro :weak)))
+  (setf (gethash (compute-records-cache-key targets qualifiers)
+		 (record-caches database)) results)
+  results)
+
+(defun update-cached-results (targets qualifiers database)
+  ;; FIXME: this routine will need to update slots in cached objects, perhaps adding or removing objects from cached
+  ;; for now, dump cache entry and perform fresh search
+  (let ((res (apply #'find-all targets qualifiers)))
+    (setf (gethash (compute-records-cache-key targets qualifiers)
+		   (record-caches database)) res)
+    res))