X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fobjects.lisp;h=63cef6a2d27f97dc394b78d645bc76165704cd74;hp=0ea28e93c244ab4054404a392a8ca79bac80c916;hb=21ae7203d719886a1f044992e463d5f463727ac0;hpb=9898f50385419417475b1c07874a16902695cb8b

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 0ea28e9..63cef6a 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -21,6 +21,11 @@
   (:metaclass standard-db-class)
   (:documentation "Superclass for all CLSQL View Classes."))
 
+(defvar *db-auto-sync* nil 
+  "A non-nil value means that creating View Class instances or
+  setting their slots automatically creates/updates the
+  corresponding records in the underlying database.")
+
 (defvar *db-deserializing* nil)
 (defvar *db-initializing* nil)
 
@@ -40,17 +45,25 @@
   (call-next-method))
 
 (defmethod (setf slot-value-using-class) (new-value (class standard-db-class)
-					  instance slot)
-  (declare (ignore new-value instance slot))
-  (call-next-method))
+					  instance slot-def)
+  (declare (ignore new-value))
+  (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*)
+	       (not *db-deserializing*)
+	       (not (eql slot-kind :virtual)))
+      (update-record-from-slot instance slot-name))))
 
-(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*
-      #+nil (created-object object)
+    (when (and *db-auto-sync*
+	       (not *db-deserializing*))
       (update-records-from-instance object))))
 
 ;;
@@ -59,9 +72,8 @@
 
 (defun create-view-from-class (view-class-name
                                &key (database *default-database*))
-  "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines
-the view. The argument DATABASE has a default value of
-*DEFAULT-DATABASE*."
+  "Creates a table as defined by the View Class VIEW-CLASS-NAME
+in DATABASE which defaults to *DEFAULT-DATABASE*."
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
@@ -77,7 +89,7 @@ the view. The argument DATABASE has a default value of
         (push res schemadef))))
   (unless schemadef
     (error "Class ~s has no :base slots" self))
-  (create-table (sql-expression :table (view-table self)) schemadef
+  (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
                 :database database
                 :constraints (database-pkey-constraint self database))
   (push self (database-view-classes database))
@@ -97,7 +109,7 @@ the view. The argument DATABASE has a default value of
   (when (member (view-class-slot-db-kind slotdef) '(:base :key))
     (let ((cdef
            (list (sql-expression :attribute (view-class-slot-column slotdef))
-                 (slot-type slotdef))))
+                 (specified-type slotdef))))
       (setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
       (let ((const (view-class-slot-db-constraints slotdef)))
         (when const 
@@ -110,9 +122,8 @@ the view. The argument DATABASE has a default value of
 ;;
 
 (defun drop-view-from-class (view-class-name &key (database *default-database*))
-  "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME
-which defines that view. The argument DATABASE has a default value of
-*DEFAULT-DATABASE*."
+  "Removes a table defined by the View Class VIEW-CLASS-NAME from
+DATABASE which defaults to *DEFAULT-DATABASE*."
   (let ((tclass (find-class view-class-name)))
     (if tclass
         (let ((*default-database* database))
@@ -135,12 +146,10 @@ which defines that view. The argument DATABASE has a default value of
 (defun list-classes (&key (test #'identity)
 		     (root-class (find-class 'standard-db-object))
 		     (database *default-database*))
-  "The LIST-CLASSES function collects all the classes below
-ROOT-CLASS, which defaults to standard-db-object, that are connected
-to the supplied DATABASE and which satisfy the TEST function. The
-default for the TEST argument is identity. By default, LIST-CLASSES
-returns a list of all the classes connected to the default database,
-*DEFAULT-DATABASE*."
+  "Returns a list of all the View Classes which are connected to
+DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend
+from the class ROOT-CLASS and which satisfy the function TEST. By
+default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY."
   (flet ((find-superclass (class) 
 	   (member root-class (class-precedence-list class))))
     (let ((view-classes (and database (database-view-classes database))))
@@ -154,23 +163,47 @@ returns a list of all the classes connected to the default database,
 ;;
 
 (defmacro def-view-class (class supers slots &rest cl-options)
-  "Extends the syntax of defclass to allow special slots to be mapped
-onto the attributes of database views. The macro DEF-VIEW-CLASS
-creates a class called CLASS which maps onto a database view. Such a
-class is called a View Class. The macro DEF-VIEW-CLASS extends the
-syntax of DEFCLASS to allow special base slots to be mapped onto the
-attributes of database views (presently single tables). When a select
-query that names a View Class is submitted, then the corresponding
-database view is queried, and the slots in the resulting View Class
-instances are filled with attribute values from the database. If
-SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the
-superclass of the newly-defined View Class."
+  "Creates a View Class called CLASS whose slots SLOTS can map
+onto the attributes of a table in a database. If SUPERS is nil
+then the superclass of CLASS will be STANDARD-DB-OBJECT,
+otherwise SUPERS is a list of superclasses for CLASS which must
+include STANDARD-DB-OBJECT or a descendent of this class. The
+syntax of DEFCLASS is extended through the addition of a class
+option :base-table which defines the database table onto which
+the View Class maps and which defaults to CLASS. The DEFCLASS
+syntax is also extended through additional slot
+options. The :db-kind slot option specifies the kind of DB
+mapping which is performed for this slot and defaults to :base
+which indicates that the slot maps to an ordinary column of the
+database table. A :db-kind value of :key indicates that this slot
+is a special kind of :base slot which maps onto a column which is
+one of the unique keys for the database table, the value :join
+indicates this slot represents a join onto another View Class
+which contains View Class objects, and the value :virtual
+indicates a standard CLOS slot which does not map onto columns of
+the database table. If a slot is specified with :db-kind :join,
+the slot option :db-info contains a list which specifies the
+nature of the join. For slots of :db-kind :base or :key,
+the :type slot option has a special interpretation such that Lisp
+types, such as string, integer and float are automatically
+converted into appropriate SQL types for the column onto which
+the slot maps. This behaviour may be over-ridden using
+the :db-type slot option which is a string specifying the
+vendor-specific database type for this slot's column definition
+in the database. The :column slot option specifies the name of
+the SQL column which the slot maps onto, if :db-kind is
+not :virtual, and defaults to the slot name. The :void-value slot
+option specifies the value to store if the SQL value is NULL and
+defaults to NIL. The :db-constraints slot option is a string
+representing an SQL table constraint expression or a list of such
+strings."
   `(progn
     (defclass ,class ,supers ,slots 
       ,@(if (find :metaclass `,cl-options :key #'car)
 	    `,cl-options
 	    (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options)))
-    (finalize-inheritance (find-class ',class))))
+    (finalize-inheritance (find-class ',class))
+    (find-class ',class)))
 
 (defun keyslots-for-class (class)
   (slot-value class 'key-slots))
@@ -222,18 +255,30 @@ superclass of the newly-defined View Class."
         (error "No slots of type :base in view-class ~A" (class-name vclass)))))
 
 
-;;
-;; Called by 'get-slot-values-from-view'
-;;
 
-(declaim (inline delistify))
-(defun delistify (list)
-  (if (listp list)
-      (car list)
-      list))
+(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 retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
+	(push slotdef join-slotdefs)))))
 
-(defun slot-type (slotdef)
-  (specified-type slotdef))
+(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'
+;;
 
 (defvar *update-context* nil)
 
@@ -241,13 +286,15 @@ superclass of the newly-defined View Class."
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let* ((slot-reader (view-class-slot-db-reader slotdef))
 	 (slot-name   (slot-definition-name slotdef))
-	 (slot-type   (slot-type slotdef))
+	 (slot-type   (specified-type slotdef))
 	 (*update-context* (cons (type-of instance) slot-name)))
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
                  (read-sql-value value (delistify slot-type)
-                                 (view-database instance))))
-          ((null value)
+                                 (view-database instance)
+				 (database-underlying-type
+				  (view-database instance)))))
+	  ((null value)
            (update-slot-with-null instance slot-name slotdef))
           ((typep slot-reader 'string)
            (setf (slot-value instance slot-name)
@@ -261,9 +308,10 @@ superclass of the newly-defined View Class."
 (defmethod key-value-from-db (slotdef value database) 
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let ((slot-reader (view-class-slot-db-reader slotdef))
-        (slot-type (slot-type slotdef)))
+        (slot-type (specified-type slotdef)))
     (cond ((and value (null slot-reader))
-           (read-sql-value value (delistify slot-type) database))
+           (read-sql-value value (delistify slot-type) database
+			   (database-underlying-type database)))
           ((null value)
            nil)
           ((typep slot-reader 'string)
@@ -275,26 +323,26 @@ superclass of the newly-defined View Class."
 
 (defun db-value-from-slot (slotdef val database)
   (let ((dbwriter (view-class-slot-db-writer slotdef))
-	(dbtype (slot-type slotdef)))
+	(dbtype (specified-type slotdef)))
     (typecase dbwriter
       (string (format nil dbwriter val))
       (function (apply dbwriter (list val)))
       (t
-       (typecase dbtype
-	 (cons
-	  (database-output-sql-as-type (car dbtype) val database))
-	 (t
-	  (database-output-sql-as-type dbtype val database)))))))
+       (database-output-sql-as-type
+	(typecase dbtype
+	  (cons (car dbtype))
+	  (t dbtype))
+	val database (database-underlying-type database))))))
 
 (defun check-slot-type (slotdef val)
-  (let* ((slot-type (slot-type slotdef))
+  (let* ((slot-type (specified-type slotdef))
          (basetype (if (listp slot-type) (car slot-type) slot-type)))
     (when (and slot-type val)
       (unless (typep val basetype)
-        (error 'clsql-type-error
-               :slotname (slot-definition-name slotdef)
-               :typespec slot-type
-               :value val)))))
+        (error 'sql-user-error
+	       :message
+	       (format nil "Invalid value ~A in slot ~A, not of type ~A."
+		       val (slot-definition-name slotdef) slot-type))))))
 
 ;;
 ;; Called by find-all
@@ -397,7 +445,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-no-database-error nil))))
+	(signal-no-database-error vd))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
                                          &key (database *default-database*))
@@ -408,7 +456,8 @@ superclass of the newly-defined View Class."
          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
-                                            :where view-qual)))))
+                                            :where view-qual)
+				      (list :result-types nil)))))
     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
@@ -420,35 +469,16 @@ superclass of the newly-defined View Class."
          (view-qual (key-qualifier-for-instance instance :database vd))
          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
-         (res (select att-ref :from  view-table :where view-qual)))
+         (res (select att-ref :from  view-table :where view-qual
+		      :result-types nil)))
     (when res 
       (get-slot-values-from-view instance (list slot-def) (car res)))))
 
 
-(defmethod database-null-value ((type t))
-  (cond
-    ((subtypep type 'string) nil)
-    ((subtypep type 'integer) nil)
-    ((subtypep type 'list) nil)
-    ((subtypep type 'boolean) nil)
-    ((eql type t) nil)
-    ((subtypep type 'symbol) nil)
-    ((subtypep type 'keyword) nil)
-    ((subtypep type 'wall-time) nil)
-    ((subtypep type 'duration) nil)
-    ((subtypep type 'money) nil)
-    (t
-     (error "Unable to handle null for type ~A" type))))
-
 (defmethod update-slot-with-null ((object standard-db-object)
 				  slotname
 				  slotdef)
-  (let ((st (slot-type slotdef))
-        (allowed (slot-value slotdef 'nulls-ok)))
-    (if allowed
-        (setf (slot-value object slotname) nil)
-        (setf (slot-value object slotname)
-              (database-null-value st)))))
+  (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 
 (defvar +no-slot-value+ '+no-slot-value+)
 
@@ -472,102 +502,103 @@ superclass of the newly-defined View Class."
 	    (error "No view-table for class ~A"  classname))
 	  (sql-expression :table (view-table class))))
 
-(defmethod database-get-type-specifier (type args database)
-  (declare (ignore type args))
-  (if (clsql-base-sys::in (database-underlying-type database)
-			  :postgresql :postgresql-socket)
-          "VARCHAR"
-          "VARCHAR(255)"))
+(defmethod database-get-type-specifier (type args database db-type)
+  (declare (ignore type args database db-type))
+  "VARCHAR(255)")
 
-(defmethod database-get-type-specifier ((type (eql 'integer)) args database)
-  (declare (ignore database))
-  ;;"INT8")
+(defmethod database-get-type-specifier ((type (eql 'integer)) args database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "INT(~A)" (car args))
       "INT"))
+
+(deftype bigint () 
+  "An integer larger than a 32-bit integer, this width may vary by SQL implementation."
+  'integer)
+
+(defmethod database-get-type-specifier ((type (eql 'bigint)) args database db-type)
+  (declare (ignore args database db-type))
+  "BIGINT")
               
 (defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args
-                                        database)
+                                        database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base-sys::in (database-underlying-type database) 
-			    :postgresql :postgresql-socket)
-	"VARCHAR"
-      "VARCHAR(255)")))
+      "VARCHAR(255)"))
 
 (defmethod database-get-type-specifier ((type (eql 'simple-string)) args
-                                        database)
+                                        database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base-sys::in (database-underlying-type database) 
-			    :postgresql :postgresql-socket)
-	"VARCHAR"
-      "VARCHAR(255)")))
+      "VARCHAR(255)"))
 
-(defmethod database-get-type-specifier ((type (eql 'string)) args database)
+(defmethod database-get-type-specifier ((type (eql 'string)) args database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "VARCHAR(~A)" (car args))
-    (if (clsql-base-sys::in (database-underlying-type database) 
-			    :postgresql :postgresql-socket)
-	"VARCHAR"
-      "VARCHAR(255)")))
-
-(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database)
-  (declare (ignore args))
-  (case (database-underlying-type database)
-    ((:postgresql :postgresql-socket)
-     "TIMESTAMP WITHOUT TIME ZONE")
-    (:mysql
-     "DATETIME")
-    (t "TIMESTAMP")))
-
-(defmethod database-get-type-specifier ((type (eql 'duration)) args database)
-  (declare (ignore database args))
+      "VARCHAR(255)"))
+
+(deftype universal-time () 
+  "A positive integer as returned by GET-UNIVERSAL-TIME."
+  '(integer 1 *))
+
+(defmethod database-get-type-specifier ((type (eql 'universal-time)) args database db-type)
+  (declare (ignore args database db-type))
+  "BIGINT")
+
+(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database db-type)
+  (declare (ignore args database db-type))
+  "TIMESTAMP")
+
+(defmethod database-get-type-specifier ((type (eql 'duration)) args database db-type)
+  (declare (ignore database args db-type))
   "VARCHAR")
 
-(defmethod database-get-type-specifier ((type (eql 'money)) args database)
-  (declare (ignore database args))
+(defmethod database-get-type-specifier ((type (eql 'money)) args database db-type)
+  (declare (ignore database args db-type))
   "INT8")
 
 (deftype raw-string (&optional len)
   "A string which is not trimmed when retrieved from the database"
   `(string ,len))
 
-(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database)
-  (declare (ignore database))
+(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "VARCHAR(~A)" (car args))
       "VARCHAR"))
 
-(defmethod database-get-type-specifier ((type (eql 'float)) args database)
-  (declare (ignore database))
+(defmethod database-get-type-specifier ((type (eql 'float)) args database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "FLOAT(~A)" (car args))
       "FLOAT"))
 
-(defmethod database-get-type-specifier ((type (eql 'long-float)) args database)
-  (declare (ignore database))
+(defmethod database-get-type-specifier ((type (eql 'long-float)) args database db-type)
+  (declare (ignore database db-type))
   (if args
       (format nil "FLOAT(~A)" (car args))
       "FLOAT"))
 
-(defmethod database-get-type-specifier ((type (eql 'boolean)) args database)
-  (declare (ignore args database))
+(defmethod database-get-type-specifier ((type (eql 'boolean)) args database db-type)
+  (declare (ignore args database db-type))
   "BOOL")
 
-(defmethod database-output-sql-as-type (type val database)
-  (declare (ignore type database))
+(defmethod database-output-sql-as-type (type val database db-type)
+  (declare (ignore type database db-type))
   val)
 
-(defmethod database-output-sql-as-type ((type (eql 'list)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'list)) val database db-type)
+  (declare (ignore database db-type))
   (progv '(*print-circle* *print-array*) '(t t)
     (let ((escaped (prin1-to-string val)))
-      (clsql-base-sys::substitute-char-string
+      (substitute-char-string
        escaped #\Null " "))))
 
-(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
+  (declare (ignore database db-type))
   (if (keywordp val)
       (symbol-name val)
       (if val
@@ -577,96 +608,117 @@ superclass of the newly-defined View Class."
                        (symbol-name val))
           "")))
 
-(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
+  (declare (ignore database db-type))
   (if val
       (symbol-name val)
       ""))
 
-(defmethod database-output-sql-as-type ((type (eql 'vector)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'vector)) val database db-type)
+  (declare (ignore database db-type))
   (progv '(*print-circle* *print-array*) '(t t)
     (prin1-to-string val)))
 
-(defmethod database-output-sql-as-type ((type (eql 'array)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'array)) val database db-type)
+  (declare (ignore database db-type))
   (progv '(*print-circle* *print-array*) '(t t)
     (prin1-to-string val)))
 
-(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database db-type)
+  (declare (ignore database db-type))
   (if val "t" "f"))
 
-(defmethod database-output-sql-as-type ((type (eql 'string)) val database)
-  (declare (ignore database))
+(defmethod database-output-sql-as-type ((type (eql 'string)) val database db-type)
+  (declare (ignore database db-type))
   val)
 
 (defmethod database-output-sql-as-type ((type (eql 'simple-string))
-					val database)
-  (declare (ignore database))
+					val database db-type)
+  (declare (ignore database db-type))
   val)
 
 (defmethod database-output-sql-as-type ((type (eql 'simple-base-string))
-					val database)
-  (declare (ignore database))
+					val database db-type)
+  (declare (ignore database db-type))
   val)
 
-(defmethod read-sql-value (val type database)
-  (declare (ignore type database))
+(defmethod read-sql-value (val type database db-type)
+  (declare (ignore type database db-type))
   (read-from-string val))
 
-(defmethod read-sql-value (val (type (eql 'string)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'string)) database db-type)
+  (declare (ignore database db-type))
   val)
 
-(defmethod read-sql-value (val (type (eql 'simple-string)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'simple-string)) database db-type)
+  (declare (ignore database db-type))
   val)
 
-(defmethod read-sql-value (val (type (eql 'simple-base-string)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'simple-base-string)) database db-type)
+  (declare (ignore database db-type))
   val)
 
-(defmethod read-sql-value (val (type (eql 'raw-string)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'raw-string)) database db-type)
+  (declare (ignore database db-type))
   val)
 
-(defmethod read-sql-value (val (type (eql 'keyword)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
+  (declare (ignore database db-type))
   (when (< 0 (length val))
     (intern (symbol-name-default-case val) 
 	    (find-package '#:keyword))))
 
-(defmethod read-sql-value (val (type (eql 'symbol)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
+  (declare (ignore database db-type))
   (when (< 0 (length val))
-    (unless (string= val (clsql-base-sys:symbol-name-default-case "NIL"))
-      (intern (clsql-base-sys: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)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
+  (declare (ignore database db-type))
+  (etypecase val
+    (string
+     (unless (string-equal "NIL" val)
+       (parse-integer val)))
+    (number val)))
+
+(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
+  (declare (ignore database db-type))
   (etypecase val
     (string
-     (read-from-string val))
+     (unless (string-equal "NIL" val)
+       (parse-integer val)))
     (number val)))
 
-(defmethod read-sql-value (val (type (eql 'float)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'float)) database db-type)
+  (declare (ignore database db-type))
   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
-  (float (read-from-string val))) 
+  (etypecase val
+    (string
+     (float (read-from-string val)))
+    (float
+     val)))
 
-(defmethod read-sql-value (val (type (eql 'boolean)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
+  (declare (ignore database db-type))
   (equal "t" val))
 
-(defmethod read-sql-value (val (type (eql 'wall-time)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'univeral-time)) database db-type)
+  (declare (ignore database db-type))
+  (unless (eq 'NULL val)
+    (etypecase val
+      (string
+       (parse-integer val))
+      (number val))))
+
+(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
+  (declare (ignore database db-type))
   (unless (eq 'NULL val)
     (parse-timestring val)))
 
-(defmethod read-sql-value (val (type (eql 'duration)) database)
-  (declare (ignore database))
+(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
+  (declare (ignore database db-type))
   (unless (or (eq 'NULL val)
               (equal "NIL" val))
     (parse-timestring val)))
@@ -674,28 +726,181 @@ superclass of the newly-defined View Class."
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots
 
+;; 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))
+	 (jc (gethash :join-class dbi))
+	 (ts-view-table (view-table (find-class ts)))
+	 (jc-view-table (view-table (find-class jc)))
+	 (tdbi (view-class-slot-db-info 
+		(find ts (class-slots (find-class jc))
+		      :key #'slot-definition-name)))
+	 (retrieval (gethash :retrieval tdbi))
+	 (jq (join-qualifier class object slot-def))
+	 (key (slot-value object (gethash :home-key dbi))))
+    (when jq
+      (ecase retrieval
+	(:immediate
+	 (let ((res
+		(find-all (list ts) 
+			  :inner-join (sql-expression :table jc-view-table)
+			  :on (sql-operation 
+			       '==
+			       (sql-expression 
+				:attribute (gethash :foreign-key tdbi) 
+				:table ts-view-table)
+			       (sql-expression 
+				:attribute (gethash :home-key tdbi) 
+				:table jc-view-table))
+			  :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)))
+	(:deferred
+	    ;; just fill in minimal slots
+	    (mapcar
+	     #'(lambda (k)
+		 (let ((instance (make-instance ts :view-database (view-database object)))
+		       (jcc (make-instance jc :view-database (view-database object)))
+		       (fk (car k)))
+		   (setf (slot-value instance (gethash :home-key tdbi)) fk)
+		   (setf (slot-value jcc (gethash :foreign-key dbi)) 
+			 key)
+		   (setf (slot-value jcc (gethash :home-key tdbi)) 
+			 fk)
+		   (list instance jcc)))
+	     (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
+		     :from (sql-expression :table jc-view-table)
+		     :where jq)))))))
+
+
+;;; Remote Joins
+
+(defvar *default-update-objects-max-len* nil
+  "The default value to use for the MAX-LEN keyword argument to
+  UPDATE-OBJECT-JOINS.")
+
+(defun update-objects-joins (objects &key (slots t) (force-p t)
+			    class-name (max-len
+			    *default-update-objects-max-len*))
+  "Updates from the records of the appropriate database tables
+the join slots specified by SLOTS in the supplied list of View
+Class instances OBJECTS.  SLOTS is t by default which means that
+all join slots with :retrieval :immediate are updated. CLASS-NAME
+is used to specify the View Class of all instance in OBJECTS and
+default to nil which means that the class of the first instance
+in OBJECTS is used. FORCE-P is t by default which means that all
+join slots are updated whereas a value of nil means that only
+unbound join slots are updated. MAX-LEN defaults to
+*DEFAULT-UPDATE-OBJECTS-MAX-LEN* and when non-nil specifies that
+UPDATE-OBJECT-JOINS may issue multiple database queries with a
+maximum of MAX-LEN instances updated in each query."
+  (assert (or (null max-len) (plusp max-len)))
+  (when objects
+    (unless class-name
+      (setq class-name (class-name (class-of (first objects)))))
+    (let* ((class (find-class class-name))
+	   (class-slots (ordered-class-slots class))
+	   (slotdefs 
+	    (if (eq t slots)
+		(generate-retrieval-joins-list class :deferred)
+	      (remove-if #'null
+			 (mapcar #'(lambda (name)
+				     (let ((slotdef (find name class-slots :key #'slot-definition-name)))
+				       (unless slotdef
+					 (warn "Unable to find slot named ~S in class ~S." name class))
+				       slotdef))
+				 slots)))))
+      (dolist (slotdef slotdefs)
+	(let* ((dbi (view-class-slot-db-info slotdef))
+	       (slotdef-name (slot-definition-name slotdef))
+	       (foreign-key (gethash :foreign-key dbi))
+	       (home-key (gethash :home-key dbi))
+	       (object-keys
+		(remove-duplicates
+		 (if force-p
+		     (mapcar #'(lambda (o) (slot-value o home-key)) objects)
+		   (remove-if #'null
+			      (mapcar
+			       #'(lambda (o) (if (slot-boundp o slotdef-name)
+						 nil
+					       (slot-value o home-key)))
+			       objects)))))
+	       (n-object-keys (length object-keys))
+	       (query-len (or max-len n-object-keys)))
+	  
+	  (do ((i 0 (+ i query-len)))
+	      ((>= i n-object-keys))
+	    (let* ((keys (if max-len
+			     (subseq object-keys i (min (+ i query-len) n-object-keys))
+			   object-keys))
+		   (results (find-all (list (gethash :join-class dbi))
+				      :where (make-instance 'sql-relational-exp
+					       :operator 'in
+					       :sub-expressions (list (sql-expression :attribute foreign-key)
+								      keys))
+				      :result-types :auto
+				      :flatp t)))
+	      (dolist (object objects)
+		(when (or force-p (not (slot-boundp object slotdef-name)))
+		  (let ((res (find (slot-value object home-key) results 
+				   :key #'(lambda (res) (slot-value res foreign-key))
+				   :test #'equal)))
+		    (when res
+		      (setf (slot-value object slotdef-name) res)))))))))))
+  (values))
+  
 (defun fault-join-slot-raw (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
 	 (jc (gethash :join-class dbi)))
     (let ((jq (join-qualifier class object slot-def)))
       (when jq 
-        (select jc :where jq)))))
+        (select jc :where jq :flatp t :result-types nil)))))
 
 (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))
@@ -736,87 +941,203 @@ 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 (database *default-database*))
-  "tweeze me apart someone pleeze"
-  (declare (ignore all set-operation group-by having offset limit)
+;; FIXME: add retrieval immediate for efficiency
+;; 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 instances)
+  "Used by find-all to build objects."
+  (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
+	     (let* ((db-vals (butlast vals (- (list-length vals)
+					      (list-length selects))))
+		    (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
+		    (join-vals (subseq vals (list-length selects)))
+		    (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 instance) 
+			(prog1
+			    (build-object vals sclass jclass sel immediate-join instance)
+			  (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
+					     vals))))
+		    sclasses immediate-join-classes sels immediate-joins instances)))
+      (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 
+		      order-by offset limit refresh flatp result-types 
+                      inner-join on 
+		      (database *default-database*)
+		      instances)
+  "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 inner-join on)
            (optimize (debug 3) (speed 1)))
-  (remf args :from)
-  (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))))
-		    (*db-initializing* t)
-		    (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) 
-					(build-object vals sclass sel))
-				    sclasses sels)))
-	       (if (= (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)
+    (remf args :instances)
     (let* ((*db-deserializing* t)
-	   (*default-database* (or database
-				   (error 'clsql-no-database-error nil)))
 	   (sclasses (mapcar #'find-class view-classes))
+	   (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 
-		  (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)))) args)))
-	(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
+	   (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)))
+	   (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
+				   (listify order-by))))
+				 
+      (dolist (ob order-by-slots)
+	(when (and ob (not (member ob (mapcar #'cdr fullsels)
+				   :test #'ref-equal)))
+	  (setq fullsels 
+	    (append fullsels (mapcar #'(lambda (att) (cons nil att))
+				     order-by-slots)))))
+      (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)))
+	     (instances-to-add (- (length rows) (length instances)))
+	     (perhaps-extended-instances
+	      (if (plusp instances-to-add)
+		  (append instances (do ((i 0 (1+ i))
+					 (res nil))
+					((= i instances-to-add) res)
+				      (push (make-list (length sclasses) :initial-element nil) res)))
+		instances))
+	     (objects (mapcar 
+		       #'(lambda (row instance)
+			   (build-objects row sclasses immediate-join-classes sels
+					  immediate-join-sels database refresh flatp 
+					  (if (and flatp (atom instance))
+					      (list instance)
+					    instance)))
+		       rows perhaps-extended-instances)))
+	objects))))
 
 (defmethod instance-refreshed ((instance standard-db-object)))
 
-(defun select (&rest select-all-args)
-  "Selects data from database given the constraints specified. Returns
-a list of lists of record values as specified by select-all-args. By
-default, the records are each represented as lists of attribute
-values. The selections argument may be either db-identifiers, literal
-strings or view classes.  If the argument consists solely of view
-classes, the return value will be instances of objects rather than raw
-tuples."
+(defun select (&rest select-all-args) 
+   "Executes a query on DATABASE, which has a default value of
+*DEFAULT-DATABASE*, specified by the SQL expressions supplied
+using the remaining arguments in SELECT-ALL-ARGS. The SELECT
+argument can be used to generate queries in both functional and
+object oriented contexts. 
+
+In the functional case, the required arguments specify the
+columns selected by the query and may be symbolic SQL expressions
+or strings representing attribute identifiers. Type modified
+identifiers indicate that the values selected from the specified
+column are converted to the specified lisp type. The keyword
+arguments ALL, DISTINCT, FROM, GROUP-by, HAVING, ORDER-BY,
+SET-OPERATION and WHERE are used to specify, using the symbolic
+SQL syntax, the corresponding components of the SQL query
+generated by the call to SELECT. RESULT-TYPES is a list of
+symbols which specifies the lisp type for each field returned by
+the query. If RESULT-TYPES is nil all results are returned as
+strings whereas the default value of :auto means that the lisp
+types are automatically computed for each field. FIELD-NAMES is t
+by default which means that the second value returned is a list
+of strings representing the columns selected by the query. If
+FIELD-NAMES is nil, the list of column names is not returned as a
+second value. 
+
+In the object oriented case, the required arguments to SELECT are
+symbols denoting View Classes which specify the database tables
+to query. In this case, SELECT returns a list of View Class
+instances whose slots are set from the attribute values of the
+records in the specified table. Slot-value is a legal operator
+which can be employed as part of the symbolic SQL syntax used in
+the WHERE keyword argument to SELECT. REFRESH is nil by default
+which means that the View Class instances returned are retrieved
+from a cache if an equivalent call to SELECT has previously been
+issued. If REFRESH is true, the View Class instances returned are
+updated as necessary from the database and the generic function
+INSTANCE-REFRESHED is called to perform any necessary operations
+on the updated instances.
+
+In both object oriented and functional contexts, FLATP has a
+default value of nil which means that the results are returned as
+a list of lists. If FLATP is t and only one result is returned
+for each record selected in the query, the results are returned
+as elements of a list."
+
   (flet ((select-objects (target-args)
            (and target-args
                 (every #'(lambda (arg)
@@ -825,15 +1146,115 @@ tuples."
                        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)))
-            (destructuring-bind (&key (flatp nil)
-				      (database *default-database*)
-                                      &allow-other-keys)
-                qualifier-args
-              (let ((res (query expr :database database)))
-		(if (and flatp
-			 (= (length (slot-value expr 'selections)) 1))
-		    (mapcar #'car res)
-		  res))))))))
+      (unless (or *default-database* (getf qualifier-args :database))
+	(signal-no-database-error nil))
+   
+	(cond
+	  ((select-objects target-args)
+	   (let ((caching (getf qualifier-args :caching t))
+		 (result-types (getf qualifier-args :result-types :auto))
+		 (refresh (getf qualifier-args :refresh nil))
+		 (database (or (getf qualifier-args :database) *default-database*))
+		 (order-by (getf qualifier-args :order-by)))
+	     (remf qualifier-args :caching)
+	     (remf qualifier-args :refresh)
+	     (remf qualifier-args :result-types)
+	     
+	     
+	     ;; Add explicity table name to order-by if not specified and only
+	     ;; one selected table. This is required so FIND-ALL won't duplicate
+	     ;; the field
+	     (when (and order-by (= 1 (length target-args)))
+	       (let ((table-name  (view-table (find-class (car target-args))))
+		     (order-by-list (copy-seq (listify order-by))))
+		 
+		 (loop for i from 0 below (length order-by-list)
+		     do (etypecase (nth i order-by-list)
+			  (sql-ident-attribute
+			   (unless (slot-value (nth i order-by-list) 'qualifier)
+			     (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
+			  (cons
+			   (unless (slot-value (car (nth i order-by-list)) 'qualifier)
+			     (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+		 (setf (getf qualifier-args :order-by) order-by-list)))
+	
+	     (cond
+	       ((null caching)
+		(apply #'find-all target-args
+		       (append qualifier-args (list :result-types result-types))))
+	       (t
+		(let ((cached (records-cache-results target-args qualifier-args database)))
+		  (cond
+		    ((and cached (not refresh))
+		     cached)
+		    ((and cached refresh)
+		     (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto)))))
+		       (setf (records-cache-results target-args qualifier-args database) results)
+		       results))
+		    (t
+		     (let ((results (apply #'find-all target-args (append qualifier-args
+									  '(:result-types :auto)))))
+		       (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
+			    (cons (cons (sql (car value)) (cdr 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))
+