X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=523ff6164973b7d1e778993927eaf9a0dcfeda67;hb=026988a3144e3ed7f48552b5567c34448fef51bc;hp=fcb2a66731549b58b7488b0575a428af31012e53;hpb=d5e70925c53fceafcbf9acce87a4c20ca03dc817;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index fcb2a66..523ff61 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -13,7 +13,7 @@
 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
 ;;;; *************************************************************************
 
-(in-package #:clsql)
+(in-package #:clsql-sys)
 
 (defclass standard-db-object ()
   ((view-database :initform nil :initarg :view-database :reader view-database
@@ -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*)
@@ -181,7 +182,7 @@ superclass of the newly-defined View Class."
     (defclass ,class ,supers ,slots 
       ,@(if (find :metaclass `,cl-options :key #'car)
 	    `,cl-options
-	    (cons '(:metaclass clsql::standard-db-class) `,cl-options)))
+	    (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
     (finalize-inheritance (find-class ',class))
     (find-class ',class)))
 
@@ -422,7 +423,7 @@ superclass of the newly-defined View Class."
 	(let ((qualifier (key-qualifier-for-instance instance :database vd)))
 	  (delete-records :from vt :where qualifier :database vd)
 	  (setf (slot-value instance 'view-database) nil))
-	(error 'clsql-base::clsql-no-database-error :database nil))))
+	(error 'clsql-no-database-error :database nil))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
                                          &key (database *default-database*))
@@ -481,7 +482,7 @@ superclass of the newly-defined View Class."
 
 (defmethod database-get-type-specifier (type args database)
   (declare (ignore type args))
-  (if (clsql-base::in (database-underlying-type database)
+  (if (in (database-underlying-type database)
 			  :postgresql :postgresql-socket)
           "VARCHAR"
           "VARCHAR(255)"))
@@ -505,7 +506,7 @@ superclass of the newly-defined View Class."
                                         database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base::in (database-underlying-type database) 
+    (if (in (database-underlying-type database) 
 			    :postgresql :postgresql-socket)
 	"VARCHAR"
       "VARCHAR(255)")))
@@ -514,7 +515,7 @@ superclass of the newly-defined View Class."
                                         database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base::in (database-underlying-type database) 
+    (if (in (database-underlying-type database) 
 			    :postgresql :postgresql-socket)
 	"VARCHAR"
       "VARCHAR(255)")))
@@ -522,7 +523,7 @@ superclass of the newly-defined View Class."
 (defmethod database-get-type-specifier ((type (eql 'string)) args database)
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base::in (database-underlying-type database) 
+    (if (in (database-underlying-type database) 
 			    :postgresql :postgresql-socket)
 	"VARCHAR"
       "VARCHAR(255)")))
@@ -586,7 +587,7 @@ superclass of the newly-defined View Class."
   (declare (ignore database))
   (progv '(*print-circle* *print-array*) '(t t)
     (let ((escaped (prin1-to-string val)))
-      (clsql-base::substitute-char-string
+      (substitute-char-string
        escaped #\Null " "))))
 
 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
@@ -666,8 +667,8 @@ superclass of the newly-defined View Class."
 (defmethod read-sql-value (val (type (eql 'symbol)) database)
   (declare (ignore database))
   (when (< 0 (length val))
-    (unless (string= val (clsql-base:symbol-name-default-case "NIL"))
-      (intern (clsql-base:symbol-name-default-case val)
+    (unless (string= val (symbol-name-default-case "NIL"))
+      (intern (symbol-name-default-case val)
               (symbol-package *update-context*)))))
 
 (defmethod read-sql-value (val (type (eql 'integer)) database)
@@ -805,15 +806,28 @@ superclass of the newly-defined View Class."
 
 (defun update-object-joins (objects &key (slots t) (force-p t)
 			    class-name (max-len *default-update-objects-max-len*))
-  "Updates the remote join slots, that is those slots defined without :retrieval :immediate."
+  "Updates the remote join slots, that is those slots defined without
+:retrieval :immediate."
   (when objects
     (unless class-name
-      (class-name (class-of (first objects))))
+      (setq 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.")
-	))))
+      (cond
+	(deferred-joins
+	    (mapcar
+	     #'(lambda (slotdef)
+		 ;; FIXME: Rather than simply reading the values for each
+		 ;; object, to meet CommonSQL spec need to generate a single
+		 ;; query to read values for all objects, up to max-len count
+		 (mapcar
+		  #'(lambda (object)
+		      (slot-value object (slot-definition-name slotdef)))
+		  objects))
+	     deferred-joins))
+	(t
+	 (warn "Class ~A does not have any deferred join slots." class-name)))
+      )))
 
   
 (defun fault-join-slot-raw (class object slot-def)
@@ -962,8 +976,7 @@ superclass of the newly-defined View Class."
 									     jcs))
 								 immediate-join-classes)
 							 sel-tables)
-						 :test #'tables-equal)))
-	   (res nil))
+						 :test #'tables-equal))))
       (dolist (ob (listify order-by))
 	(when (and ob (not (member ob (mapcar #'cdr fullsels)
 				   :test #'ref-equal)))
@@ -1000,18 +1013,19 @@ superclass of the newly-defined View Class."
 				  (when where (listify where))))))
 		     jclasses jslots)))
 	      sclasses immediate-join-classes immediate-join-slots)
-      (setq res 
-	    (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)))
-      (mapcar #'(lambda (r)
-		  (build-objects r sclasses immediate-join-classes sels immediate-join-sels database refresh flatp))
-	    res))))
+      (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)))
 
@@ -1054,30 +1068,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))