Refactored find-all and build-object to be more readable, shorter and

[clsql.git] / sql / oodml.lisp

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index cc57941e38e2520e80e48cad4ab50fa42b4c9b11..3c65919ea8db867b080898d54ab1e95974b56cbf 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -1,8 +1,6 @@
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;
 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
 ;;;; *************************************************************************
 ;;;;

-;;;; $Id$
-;;;;

 ;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
 ;;;;
 ;;;; This file is part of CLSQL.
 ;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
 ;;;;
 ;;;; This file is part of CLSQL.


@@ -14,47 +12,60 @@
 
 (in-package #:clsql-sys)
 
 
 (in-package #:clsql-sys)
 

-
-(defun key-qualifier-for-instance (obj &key (database *default-database*))
-  (let ((tb (view-table (class-of obj))))
-    (flet ((qfk (k)
-             (sql-operation '==
-                            (sql-expression :attribute
-                                            (view-class-slot-column k)
-                                            :table tb)
-                            (db-value-from-slot
-                             k
-                             (slot-value obj (slot-definition-name k))
-                             database))))
-      (let* ((keys (keyslots-for-class (class-of obj)))
-             (keyxprs (mapcar #'qfk (reverse keys))))
-        (cond
-          ((= (length keyxprs) 0) nil)
-          ((= (length keyxprs) 1) (car keyxprs))
-          ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
-
-;;
-;; Function used by 'generate-selection-list'
-;;
-
-(defun generate-attribute-reference (vclass slotdef)
-  (cond
-   ((eq (view-class-slot-db-kind slotdef) :base)
-    (sql-expression :attribute (view-class-slot-column slotdef)
-                    :table (view-table vclass)))
-   ((eq (view-class-slot-db-kind slotdef) :key)
-    (sql-expression :attribute (view-class-slot-column slotdef)
-                    :table (view-table vclass)))
-   (t nil)))
+(defun find-normalized-key (obj)
+  "Find the first / primary key of a normalized object"
+  (find-slot-if obj #'key-slot-p T T))
+
+(defun normalized-key-value (obj)
+  "Normalized classes share a single key for all their key slots"
+  (when (normalizedp (class-of obj))
+    (easy-slot-value obj (find-normalized-key obj))))
+
+(defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
+  "Generate a boolean sql-expression that identifies an object by its keys"
+  (let* ((obj-class (or this-class (class-of obj)))
+         (keys (keyslots-for-class obj-class))
+         (normal-db-value (normalized-key-value obj)))
+    (when keys
+      (labels ((db-value (k)
+                 (or normal-db-value
+                     (db-value-from-slot
+                      k
+                      (easy-slot-value obj k)
+                      database)))
+               (key-equal-exp (k)
+                 (sql-operation '== (generate-attribute-reference obj-class k database)
+                                (db-value k))))
+        (clsql-ands (mapcar #'key-equal-exp keys))))))
+
+(defun generate-attribute-reference (vclass slotdef &optional (database *default-database*))
+  "Turns key class and slot-def into a sql-expression representing the
+   table and column it comes from
+
+   used by things like generate-selection-list, update-slot-from-record"
+  (when (key-or-base-slot-p slotdef)
+    (sql-expression :attribute (database-identifier slotdef database)
+                    :table (database-identifier vclass database))))

 
 ;;
 ;; Function used by 'find-all'
 ;;
 
 (defun generate-selection-list (vclass)
 
 ;;
 ;; Function used by 'find-all'
 ;;
 
 (defun generate-selection-list (vclass)

-  (let ((sels nil))
-    (dolist (slotdef (ordered-class-slots vclass))
-      (let ((res (generate-attribute-reference vclass slotdef)))
+  (let* ((sels nil)
+         (this-class vclass)
+         (slots (if (normalizedp vclass)
+                    (labels ((getdslots ()
+                               (let ((sl (ordered-class-direct-slots this-class)))
+                                 (cond (sl)
+                                       (t
+                                        (setf this-class
+                                              (car (class-direct-superclasses this-class)))
+                                        (getdslots))))))
+                      (getdslots))
+                    (ordered-class-slots this-class))))
+    (dolist (slotdef slots)
+      (let ((res (generate-attribute-reference this-class slotdef)))

         (when res
           (push (cons slotdef res) sels))))
     (if sels
         (when res
           (push (cons slotdef res) sels))))
     (if sels


@@ -83,33 +94,50 @@
               (push (cons slotdef res) sels))))))
     sels))
 
               (push (cons slotdef res) sels))))))
     sels))
 

+(defun immediate-join-slots (class)
+  (generate-retrieval-joins-list class :immediate))
+
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
+  "Determine which database connection to use for a standard-db-object.
+        Errs if none is available."
+  (or (find-if #'(lambda (db)
+                   (and db (is-database-open db)))
+               (list (view-database obj)
+                     database
+                     *default-database*))
+      (signal-no-database-error nil)))
+

 
 

-;; Called by 'get-slot-values-from-view'
-;;

 
 

-(defmethod update-slot-from-db ((instance standard-db-object) slotdef value)
+(defmethod update-slot-with-null ((object standard-db-object) slotdef)
+  "sets a slot to the void value of the slot-def (usually nil)"
+  (setf (easy-slot-value object slotdef)
+        (slot-value slotdef 'void-value)))
+
+(defmethod update-slot-from-db-value ((instance standard-db-object) slotdef value)
+  "This gets a value from the database and turns it itno a lisp value
+   based on the slot's slot-db-reader or baring that read-sql-value"

   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let* ((slot-reader (view-class-slot-db-reader slotdef))
   (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   (specified-type slotdef)))
          (slot-type   (specified-type slotdef)))

-    (cond ((and value (null slot-reader))
-           (setf (slot-value instance slot-name)
-                 (read-sql-value value (delistify slot-type)
-                                 (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)
-                 (format nil slot-reader value)))
-          ((typep slot-reader '(or symbol function))
-           (setf (slot-value instance slot-name)
-                 (apply slot-reader (list value))))
-          (t
-           (error "Slot reader is of an unusual type.")))))
+    (cond
+      ((null value) (update-slot-with-null instance slotdef))
+      ((null slot-reader)
+       (setf (easy-slot-value instance slotdef)
+             (read-sql-value value (delistify slot-type)
+                             (choose-database-for-instance instance)
+                             (database-underlying-type
+                              (choose-database-for-instance instance)))))
+      (t (etypecase slot-reader
+           ((or symbol function)
+            (setf (easy-slot-value instance slotdef)
+                  (apply slot-reader (list value))))
+           (string
+            (setf (easy-slot-value instance slotdef)
+                  (format nil slot-reader value))))))))

 
 (defmethod key-value-from-db (slotdef value database)
 
 (defmethod key-value-from-db (slotdef value database)

+  "TODO: is this deprecated? there are no uses anywhere in clsql"

   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let ((slot-reader (view-class-slot-db-reader slotdef))
         (slot-type (specified-type slotdef)))
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let ((slot-reader (view-class-slot-db-reader slotdef))
         (slot-type (specified-type slotdef)))


@@ -148,158 +176,317 @@
                (format nil "Invalid value ~A in slot ~A, not of type ~A."
                        val (slot-definition-name slotdef) slot-type))))))
 
                (format nil "Invalid value ~A in slot ~A, not of type ~A."
                        val (slot-definition-name slotdef) slot-type))))))
 

-;;
-;; Called by find-all
-;;
-

 (defmethod get-slot-values-from-view (obj slotdeflist values)
 (defmethod get-slot-values-from-view (obj slotdeflist values)

-    (flet ((update-slot (slot-def values)
-             (update-slot-from-db obj slot-def values)))
-      (mapc #'update-slot slotdeflist values)
-      obj))
-
-(defmethod update-record-from-slot ((obj standard-db-object) slot &key
-                                    (database *default-database*))
-  (let* ((database (or (view-database obj) database))
-         (vct (view-table (class-of obj)))
-         (sd (slotdef-for-slot-with-class slot (class-of obj))))
-    (check-slot-type sd (slot-value obj slot))
-    (let* ((att (view-class-slot-column sd))
-           (val (db-value-from-slot sd (slot-value obj slot) database)))
-      (cond ((and vct sd (view-database obj))
-             (update-records (sql-expression :table vct)
-                             :attributes (list (sql-expression :attribute att))
-                             :values (list val)
-                             :where (key-qualifier-for-instance
-                                     obj :database database)
-                             :database database))
-            ((and vct sd (not (view-database obj)))
-             (insert-records :into (sql-expression :table vct)
-                             :attributes (list (sql-expression :attribute att))
-                             :values (list val)
-                             :database database)
-             (setf (slot-value obj 'view-database) database))
-            (t
-             (error "Unable to update record.")))))
-  (values))
+  "Used to copy values from the database into the object
+   used by things like find-all and select"
+  (loop for slot in slotdeflist
+        for value in values
+        do (update-slot-from-db-value obj slot value))
+  obj)

 
 

-(defmethod update-record-from-slots ((obj standard-db-object) slots &key
-                                     (database *default-database*))
-  (let* ((database (or (view-database obj) database))
-         (vct (view-table (class-of obj)))
-         (sds (slotdefs-for-slots-with-class slots (class-of obj)))
-         (avps (mapcar #'(lambda (s)
-                           (let ((val (slot-value
-                                       obj (slot-definition-name s))))
-                             (check-slot-type s val)
-                             (list (sql-expression
-                                    :attribute (view-class-slot-column s))
-                                   (db-value-from-slot s val database))))
-                       sds)))
-    (cond ((and avps (view-database obj))
-           (update-records (sql-expression :table vct)
-                           :av-pairs avps
-                           :where (key-qualifier-for-instance
-                                   obj :database database)
-                           :database database))
-          ((and avps (not (view-database obj)))
-           (insert-records :into (sql-expression :table vct)
+(defclass class-and-slots ()
+  ((view-class :accessor view-class :initarg :view-class :initform nil)
+   (slot-defs :accessor slot-defs :initarg :slot-defs :initform nil))
+  (:documentation "A helper class to keep track of which slot-defs from a
+   table need to be updated, a normalized class might have many of these
+   because each of its parent classes might represent some other table and we
+   need to match which slots came from which parent class/table"))
+
+(defun make-class-and-slots (c &optional s)
+  "Create a new class-and-slots object"
+  (make-instance 'class-and-slots :view-class c :slot-defs (listify s) ))
+
+(defmethod view-table ((o class-and-slots))
+  "get the view-table of the view-class of o"
+  (view-table (view-class o)))
+
+(defmethod view-table-exp ((o class-and-slots))
+  (sql-expression :table (view-table o)))
+
+(defmethod view-table-exp ((o standard-db-class))
+  (sql-expression :table (view-table o)))
+
+(defmethod attribute-references ((o class-and-slots))
+  "build sql-ident-attributes for a given class-and-slots"
+  (loop
+    with class = (view-class o)
+    for sd in (slot-defs o)
+    collect (generate-attribute-reference class sd)))
+
+(defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object)
+                                  database)
+  "for a given class-and-slots and object, create the sql-expression & value pairs
+   that need to be sent to the database"
+  (loop for s in (slot-defs def)
+        for n = (to-slot-name s)
+        when (slot-boundp o n)
+        collect (make-attribute-value-pair s (slot-value o n) database)))
+
+(defmethod view-classes-and-slots-by-name ((obj standard-db-object) slots-to-match)
+  "If it's normalized, find the class that actually contains
+   the slot that's tied to the db,
+
+   otherwise just search the current class
+  "
+  (let* ((view-class (class-of obj))
+         (normalizedp (normalizedp view-class))
+         rtns)
+    (labels ((get-c&s-obj (class)
+               (or (find class rtns :key #'view-class)
+                   (first (push (make-class-and-slots class) rtns))))
+             (associate-slot-with-class (class slot)
+               "Find the best class to associate with the slot. If it is
+                normalized then it needs to be a direct slot otherwise it just
+                needs to be on the class."
+               (let ((sd (find-slot-by-name class slot normalizedp nil)))
+                 (if sd
+                     ;;we found it directly or it's (not normalized)
+                     (pushnew sd (slot-defs (get-c&s-obj class)))
+                     (when normalizedp
+                       (loop for parent in (class-direct-superclasses class)
+                             until (associate-slot-with-class parent slot))))
+                 sd)))
+      (loop
+        for in-slot in (listify slots-to-match)
+        do (associate-slot-with-class view-class in-slot)))
+    rtns))
+
+(defun update-auto-increments-keys (class obj database)
+  " handle pulling any autoincrement values into the object
+   if normalized and we now that all the "
+  (let ((pk-slots (keyslots-for-class class))
+        (table (view-table class))
+        new-pk-value)
+    (labels ((do-update (slot)
+               (when (and (null (easy-slot-value obj slot))
+                          (auto-increment-column-p slot database))
+                 (update-slot-from-db-value
+                  obj slot
+                  (or new-pk-value
+                      (setf new-pk-value
+                            (database-last-auto-increment-id
+                             database table slot))))))
+             (chain-primary-keys (in-class)
+               "This seems kindof wrong, but this is mostly how it was working, so
+                  its here to keep the normalized code path working"
+               (when (typep in-class 'standard-db-class)
+                 (loop for slot in (ordered-class-slots in-class)
+                       when (key-slot-p slot)
+                       do (do-update slot)))))
+      (loop for slot in pk-slots do (do-update slot))
+      (let ((direct-class (to-class obj)))
+        (when (and new-pk-value (normalizedp direct-class))
+          (chain-primary-keys direct-class)))
+      new-pk-value)))
+
+(defmethod %update-instance-helper
+    (class-and-slots obj database
+     &aux (avps (attribute-value-pairs class-and-slots obj database)))
+  "A function to help us update a given table (based on class-and-slots)
+   with values from an object"
+  ;; we dont actually need to update anything on this particular
+  ;; class / parent class
+  (unless avps (return-from %update-instance-helper))
+
+  (let* ((view-class (view-class class-and-slots))
+         (table (view-table view-class))
+         (table-sql (sql-expression :table table)))
+
+    ;; view database is the flag we use to tell it was pulled from a database
+    ;; and thus probably needs an update instead of an insert
+    (cond ((view-database obj)
+           (let ((where (key-qualifier-for-instance
+                         obj :database database :this-class view-class)))
+             (unless where
+               (error "update-record-from-*: could not generate a where clause for ~a using ~A"
+                      obj view-class))
+             (update-records table-sql
+                             :av-pairs avps
+                             :where where
+                             :database database)))
+          (T ;; was not pulled from the db so insert it
+           ;; avps MUST contain any primary key slots set
+           ;; by previous inserts of the same object into different
+           ;; tables (ie: normalized stuff)
+           (insert-records :into table-sql

                            :av-pairs avps
                            :database database)
                            :av-pairs avps
                            :database database)

-           (setf (slot-value obj 'view-database) database))
-          (t
-           (error "Unable to update records"))))
+           (update-auto-increments-keys view-class obj database)
+           ;; we dont set view database here, because there could be
+           ;; N of these for each call to update-record-from-* because
+           ;; of normalized classes
+           ))
+    (update-slot-default-values obj class-and-slots)))
+
+(defmethod update-record-from-slots ((obj standard-db-object) slots
+                                     &key (database *default-database*))
+  "For a given list of slots, update all records associated with those slots
+   and classes.
+
+   Generally this will update the single record associated with this object,
+   but for normalized classes might update as many records as there are
+   inheritances "
+  (setf slots (listify slots))
+  (let* ((classes-and-slots (view-classes-and-slots-by-name obj slots))
+         (database (choose-database-for-instance obj database)))
+    (loop for class-and-slots in classes-and-slots
+          do (%update-instance-helper class-and-slots obj database))
+    (setf (slot-value obj 'view-database) database))

   (values))
 
   (values))
 

-(defmethod update-records-from-instance ((obj standard-db-object) &key database)
-  (let ((database (or database (view-database obj) *default-database*)))
-    (labels ((slot-storedp (slot)
-               (and (member (view-class-slot-db-kind slot) '(:base :key))
-                    (slot-boundp obj (slot-definition-name slot))))
-             (slot-value-list (slot)
-               (let ((value (slot-value obj (slot-definition-name slot))))
-                 (check-slot-type slot value)
-                 (list (sql-expression :attribute (view-class-slot-column slot))
-                       (db-value-from-slot slot value database)))))
-      (let* ((view-class (class-of obj))
-             (view-class-table (view-table view-class))
-             (slots (remove-if-not #'slot-storedp
-                                   (ordered-class-slots view-class)))
-             (record-values (mapcar #'slot-value-list slots)))
-        (unless record-values
-          (error "No settable slots."))
-        (if (view-database obj)
-            (update-records (sql-expression :table view-class-table)
-                            :av-pairs record-values
-                            :where (key-qualifier-for-instance
-                                    obj :database database)
-                            :database database)
-            (progn
-              (insert-records :into (sql-expression :table view-class-table)
-                              :av-pairs record-values
-                              :database database)
-              (setf (slot-value obj 'view-database) database))))))
-  (values))
-
-(defmethod delete-instance-records ((instance standard-db-object))
-  (let ((vt (sql-expression :table (view-table (class-of instance))))
-        (vd (view-database instance)))
-    (if vd
-        (let ((qualifier (key-qualifier-for-instance instance :database vd)))
-          (delete-records :from vt :where qualifier :database vd)
-          (setf (record-caches vd) nil)
+(defmethod update-record-from-slot
+    ((obj standard-db-object) slot &key (database *default-database*))
+  "just call update-records-from-slots which now handles this.
+
+   This function is only here to maintain backwards compatibility in
+   the public api"
+  (update-record-from-slots obj slot :database database))
+
+(defun view-classes-and-storable-slots (class)
+  "Get a list of all the tables we need to update and the slots on them
+
+   for non normalized classes we return the class and all its storable slots
+
+   for normalized classes we return a list of direct slots and the class they
+   came from for each normalized view class
+  "
+  (setf class (to-class class))
+  (let* (rtns)
+    (labels ((storable-slots (class)
+               (loop for sd in (slots-for-possibly-normalized-class class)
+                     when (key-or-base-slot-p sd)
+                     collect sd))
+             (get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
+               (let ((slots (storable-slots class)))
+                 (when slots
+                   (push (make-class-and-slots class slots) rtns)))
+               (when normalizedp
+                 (loop for new-class in (class-direct-superclasses class)
+                       do (when (typep new-class 'standard-db-class)
+                            (get-classes-and-slots new-class))))))
+      (get-classes-and-slots class))
+    rtns))
+
+(defmethod primary-key-slot-values ((obj standard-db-object)
+                                    &key class slots )
+  "Returns the values of all key-slots for a given class"
+  (defaulting class (class-of obj)
+              slots (keyslots-for-class class))
+  (loop for slot in slots
+        collect (easy-slot-value obj slot)))
+
+(defmethod update-slot-default-values ((obj standard-db-object)
+                                       classes-and-slots)
+  "Makes sure that if a class has unfilled slots that claim to have a default,
+   that we retrieve those defaults from the database
+
+   TODO: use update slots-from-record instead to batch this!"
+  (loop for class-and-slots in (listify classes-and-slots)
+        do (loop for slot in (slot-defs class-and-slots)
+                 do (when (and (slot-has-default-p slot)
+                               (not (easy-slot-value obj slot)))
+                      (update-slot-from-record obj (to-slot-name slot))))))
+
+(defmethod update-records-from-instance ((obj standard-db-object)
+                                         &key (database *default-database*))
+  "Updates the records in the database associated with this object if
+   view-database slot on the object is nil then the object is assumed to be
+   new and is inserted"
+  (let ((database (choose-database-for-instance obj database))
+        (classes-and-slots (view-classes-and-storable-slots obj)))
+    (loop for class-and-slots in classes-and-slots
+          do (%update-instance-helper class-and-slots obj database))
+    (setf (slot-value obj 'view-database) database)
+    (primary-key-slot-values obj)))
+
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+  "Removes the records associated with a given instance
+   (as determined by key-qualifier-for-instance)
+
+   TODO: Doesnt handle normalized classes at all afaict"
+  (let ((database (choose-database-for-instance instance database))
+        (vt (sql-expression :table (view-table (class-of instance)))))
+    (if database
+        (let ((qualifier (key-qualifier-for-instance instance :database database)))
+          (delete-records :from vt :where qualifier :database database)
+          (setf (record-caches database) nil)

           (setf (slot-value instance 'view-database) nil)
           (values))
           (setf (slot-value instance 'view-database) nil)
           (values))

-        (signal-no-database-error vd))))
+        (signal-no-database-error database))))

 
 (defmethod update-instance-from-records ((instance standard-db-object)
 
 (defmethod update-instance-from-records ((instance standard-db-object)

-                                         &key (database *default-database*))
-  (let* ((view-class (find-class (class-name (class-of instance))))
-         (view-table (sql-expression :table (view-table view-class)))
-         (vd (or (view-database instance) database))
-         (view-qual (key-qualifier-for-instance instance :database vd))
-         (sels (generate-selection-list view-class))
-         (res (apply #'select (append (mapcar #'cdr sels)
-                                      (list :from  view-table
-                                            :where view-qual
-                                            :result-types nil
-                                            :database vd)))))
-    (when res
-      (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
+                                         &key (database *default-database*)
+                                         this-class)
+  (let* ((view-class (or this-class (class-of instance)))
+         (pclass (car (class-direct-superclasses view-class)))
+         (pres nil))
+    (when (normalizedp view-class)
+      (setf pres (update-instance-from-records instance :database database
+                                               :this-class pclass)))
+    (let* ((view-table (sql-expression :table (view-table view-class)))
+           (vd (choose-database-for-instance instance database))
+           (view-qual (key-qualifier-for-instance instance :database vd
+                                                           :this-class view-class))
+           (sels (generate-selection-list view-class))
+           (res nil))
+      (cond (view-qual
+             (setf res (apply #'select (append (mapcar #'cdr sels)
+                                               (list :from  view-table
+                                                     :where view-qual
+                                                     :result-types nil
+                                                     :database vd))))
+             (when res
+              (setf (slot-value instance 'view-database) vd)
+               (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
+            (pres)
+            (t nil)))))
+
+
+(defmethod get-slot-value-from-record ((instance standard-db-object)
+                                       slot &key (database *default-database*))
+  (let* ((class-and-slot
+           (first
+            (view-classes-and-slots-by-name instance slot)))
+         (view-class (view-class class-and-slot))
+         (slot-def (first (slot-defs class-and-slot)))
+         (vd (choose-database-for-instance instance database))
+         (att-ref (first (attribute-references class-and-slot)))
+         (res (first
+               (select att-ref
+                 :from (view-table-exp class-and-slot)
+                 :where (key-qualifier-for-instance
+                         instance
+                         :database vd
+                         :this-class view-class)
+                 :result-types nil
+                 :flatp T))))
+    (values res slot-def)))

 
 (defmethod update-slot-from-record ((instance standard-db-object)
                                     slot &key (database *default-database*))
 
 (defmethod update-slot-from-record ((instance standard-db-object)
                                     slot &key (database *default-database*))

-  (let* ((view-class (find-class (class-name (class-of instance))))
-         (view-table (sql-expression :table (view-table view-class)))
-         (vd (or (view-database instance) database))
-         (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
-                      :result-types nil)))
-    (when res
-      (get-slot-values-from-view instance (list slot-def) (car res)))))
-
+  "Pulls the value of a given slot form the database and stores that in the
+   appropriate slot on instance"
+  (multiple-value-bind (res slot-def)
+      (get-slot-value-from-record instance slot :database database)
+    (let ((vd (choose-database-for-instance instance database)))
+      (setf (slot-value instance 'view-database) vd)
+      (update-slot-from-db-value instance slot-def res))))

 
 

-(defmethod update-slot-with-null ((object standard-db-object)
-                                  slotname
-                                  slotdef)
-  (setf (slot-value object slotname) (slot-value slotdef 'void-value)))

 
 (defvar +no-slot-value+ '+no-slot-value+)
 
 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
 
 (defvar +no-slot-value+ '+no-slot-value+)
 
 (defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))

-  (let* ((class (find-class classname))
-         (sld (slotdef-for-slot-with-class slot class)))
-    (if sld
-        (if (eq value +no-slot-value+)
-            (sql-expression :attribute (view-class-slot-column sld)
-                            :table (view-table class))
-            (db-value-from-slot
-             sld
-             value
-             database))
-        (error "Unknown slot ~A for class ~A" slot classname))))
+        (let* ((class (find-class classname))
+               (sld (slotdef-for-slot-with-class slot class)))
+          (if sld
+              (if (eq value +no-slot-value+)
+                  (sql-expression :attribute (database-identifier sld database)
+                                  :table (view-table class))
+                  (db-value-from-slot
+                   sld
+                   value
+                   database))
+              (error "Unknown slot ~A for class ~A" slot classname))))

 
 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
         (declare (ignore database))
 
 (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
         (declare (ignore database))


@@ -317,7 +504,7 @@
   (declare (ignore database db-type))
   (if args
       (format nil "INT(~A)" (car args))
   (declare (ignore database db-type))
   (if args
       (format nil "INT(~A)" (car args))

-    "INT"))
+      "INT"))

 
 (deftype tinyint ()
   "An 8-bit integer, this width may vary by SQL implementation."
 
 (deftype tinyint ()
   "An 8-bit integer, this width may vary by SQL implementation."


@@ -425,12 +612,12 @@
 (defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
   (declare (ignore database db-type))
   (cond
 (defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
   (declare (ignore database db-type))
   (cond

-   ((and (consp args) (= (length args) 2))
-    (format nil "NUMBER(~D,~D)" (first args) (second args)))
-   ((and (consp args) (= (length args) 1))
-    (format nil "NUMBER(~D)" (first args)))
-   (t
-    "NUMBER")))
+    ((and (consp args) (= (length args) 2))
+     (format nil "NUMBER(~D,~D)" (first args) (second args)))
+    ((and (consp args) (= (length args) 1))
+     (format nil "NUMBER(~D)" (first args)))
+    (t
+     "NUMBER")))

 
 (defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
   (declare (ignore database db-type))
 
 (defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
   (declare (ignore database db-type))


@@ -453,11 +640,11 @@
 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
   (declare (ignore database db-type))
   (if val
 (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
   (declare (ignore database db-type))
   (if val

-    (concatenate 'string
-                 (package-name (symbol-package val))
-                 "::"
-                 (symbol-name val))
-    ""))
+      (concatenate 'string
+                   (package-name (symbol-package val))
+                   "::"
+                   (symbol-name val))
+      ""))

 
 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
   (declare (ignore database db-type))
 
 (defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
   (declare (ignore database db-type))


@@ -495,12 +682,18 @@
 
 (defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
   (declare (ignore database db-type))
 
 (defmethod database-output-sql-as-type ((type (eql 'float)) val database db-type)
   (declare (ignore database db-type))

-  (let ((*read-default-float-format* (type-of val)))
-    (format nil "~F" val)))
+  (if (eq (type-of val) 'null)
+      nil
+      (let ((*read-default-float-format* (type-of val)))
+       (format nil "~F" val))))

 
 (defmethod read-sql-value (val type database db-type)
 
 (defmethod read-sql-value (val type database db-type)

-  (declare (ignore type database db-type))
-  (read-from-string val))
+  (declare (ignore database db-type))
+  (cond
+    ((null type) val) ;;we have no desired type, just give the value
+    ((typep val type) val) ;;check that it hasn't already been converted.
+    ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
+    (T (error "Unable to read-sql-value ~a as type ~a" val type))))

 
 (defmethod read-sql-value (val (type (eql 'string)) database db-type)
   (declare (ignore database db-type))
 
 (defmethod read-sql-value (val (type (eql 'string)) database db-type)
   (declare (ignore database db-type))


@@ -554,10 +747,19 @@
   (declare (ignore database db-type))
   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
   (etypecase val
   (declare (ignore database db-type))
   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
   (etypecase val

-    (string
-     (float (read-from-string val)))
-    (float
-     val)))
+    (string (float (read-from-string val)))
+    (float val)))
+
+(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
+  (declare (ignore database db-type))
+  ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
+  (etypecase val
+    (string (float
+            (let ((*read-default-float-format* 'double-float))
+              (read-from-string val))
+            1.0d0))
+    (double-float val)
+    (float (coerce val 'double-float))))

 
 (defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
   (declare (ignore database db-type))
 
 (defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
   (declare (ignore database db-type))


@@ -655,33 +857,33 @@
                                 :table jc-view-table))
                           :where jq
                           :result-types :auto
                                 :table jc-view-table))
                           :where jq
                           :result-types :auto

-                          :database (view-database object))))
+                          :database (choose-database-for-instance object))))

            (mapcar #'(lambda (i)
                        (let* ((instance (car i))
            (mapcar #'(lambda (i)
                        (let* ((instance (car i))

-                              (jcc (make-instance jc :view-database (view-database instance))))
+                              (jcc (make-instance jc :view-database (choose-database-for-instance 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)))
                          (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)))
+                         (list instance jcc)))

                    res)))
         (:deferred
                    res)))
         (:deferred

-            ;; just fill in minimal slots
-            (mapcar
-             #'(lambda (k)
-                 (let ((instance (make-instance tsc :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
-                     :database (view-database object))))))))
+         ;; just fill in minimal slots
+         (mapcar
+          #'(lambda (k)
+              (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+                    (jcc (make-instance jc :view-database (choose-database-for-instance 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
+                  :database (choose-database-for-instance object))))))))

 
 
 ;;; Remote Joins
 
 
 ;;; Remote Joins


@@ -691,8 +893,8 @@
   UPDATE-OBJECT-JOINS.")
 
 (defun update-objects-joins (objects &key (slots t) (force-p t)
   UPDATE-OBJECT-JOINS.")
 
 (defun update-objects-joins (objects &key (slots t) (force-p t)

-                            class-name (max-len
-                            *default-update-objects-max-len*))
+                             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
   "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


@@ -714,13 +916,13 @@ maximum of MAX-LEN instances updated in each query."
            (slotdefs
             (if (eq t slots)
                 (generate-retrieval-joins-list class :deferred)
            (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)))))
+                (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))
       (dolist (slotdef slotdefs)
         (let* ((dbi (view-class-slot-db-info slotdef))
                (slotdef-name (slot-definition-name slotdef))


@@ -730,12 +932,12 @@ maximum of MAX-LEN instances updated in each query."
                 (remove-duplicates
                  (if force-p
                      (mapcar #'(lambda (o) (slot-value o home-key)) objects)
                 (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)))))
+                     (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)))
 
                (n-object-keys (length object-keys))
                (query-len (or max-len n-object-keys)))
 


@@ -743,15 +945,15 @@ maximum of MAX-LEN instances updated in each query."
               ((>= i n-object-keys))
             (let* ((keys (if max-len
                              (subseq object-keys i (min (+ i query-len) n-object-keys))
               ((>= i n-object-keys))
             (let* ((keys (if max-len
                              (subseq object-keys i (min (+ i query-len) n-object-keys))

-                           object-keys))
+                             object-keys))

                    (results (unless (gethash :target-slot dbi)
                    (results (unless (gethash :target-slot dbi)

-                                (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)) ))
+                              (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)))
 
               (dolist (object objects)
                 (when (or force-p (not (slot-boundp object slotdef-name)))


@@ -779,242 +981,226 @@ maximum of MAX-LEN instances updated in each query."
     (let ((jq (join-qualifier class object slot-def)))
       (when jq
         (select jc :where jq :flatp t :result-types nil
     (let ((jq (join-qualifier class object slot-def)))
       (when jq
         (select jc :where jq :flatp t :result-types nil

-                :database (view-database object))))))
+                :database (choose-database-for-instance object))))))
+
+

 
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
 
 (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))
+         (ts (gethash :target-slot dbi))
+         (dbi-set (gethash :set dbi)))
+    (if (and ts dbi-set)

         (fault-join-target-slot class object slot-def)
         (let ((res (fault-join-slot-raw class object slot-def)))
           (when res
             (cond
         (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)))
+              ((and ts (not dbi-set))

                (mapcar (lambda (obj) (slot-value obj ts)) res))
                (mapcar (lambda (obj) (slot-value obj ts)) res))

-              ((and (not ts) (not (gethash :set dbi)))
+              ((and (not ts) (not dbi-set))

                (car res))
                (car res))

-              ((and (not ts) (gethash :set dbi))
+              ((and (not ts) dbi-set)

                res)))))))
 
                res)))))))
 

+(defun update-fault-join-normalized-slot (class object slot-def)
+  (if (and (normalizedp class) (key-slot-p slot-def))
+      (setf (easy-slot-value object slot-def)
+            (normalized-key-value object))
+      (update-slot-from-record object slot-def)))
+
+(defun all-home-keys-have-values-p (object slot-def)
+  "Do all of the home-keys have values ?"
+  (let ((home-keys (join-slot-info-value slot-def :home-key)))
+    (loop for key in (listify home-keys)
+          always (easy-slot-value object key))))
+

 (defun join-qualifier (class object slot-def)
 (defun join-qualifier (class object slot-def)

-    (declare (ignore class))
-    (let* ((dbi (view-class-slot-db-info slot-def))
-           (jc (find-class (gethash :join-class dbi)))
-           ;;(ts (gethash :target-slot dbi))
-           ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
-           (foreign-keys (gethash :foreign-key dbi))
-           (home-keys (gethash :home-key dbi)))
-      (when (every #'(lambda (slt)
-                       (and (slot-boundp object slt)
-                            (not (null (slot-value object slt)))))
-                   (if (listp home-keys) home-keys (list home-keys)))
-        (let ((jc
-               (mapcar #'(lambda (hk fk)
-                           (let ((fksd (slotdef-for-slot-with-class fk jc)))
-                             (sql-operation '==
-                                            (typecase fk
-                                              (symbol
-                                               (sql-expression
-                                                :attribute
-                                                (view-class-slot-column fksd)
-                                                :table (view-table jc)))
-                                              (t fk))
-                                            (typecase hk
-                                              (symbol
-                                               (slot-value object hk))
-                                              (t
-                                               hk)))))
-                       (if (listp home-keys)
-                           home-keys
-                           (list home-keys))
-                       (if (listp foreign-keys)
-                           foreign-keys
-                           (list foreign-keys)))))
-          (when jc
-            (if (> (length jc) 1)
-                (apply #'sql-and jc)
-                jc))))))
-
-;; 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 "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%"
-               ;;joins db-vals join-vals selects immediate-selects)
-
-               ;; use refresh keyword here
-               (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
-               (mapc #'(lambda (jo)
-                         ;; find all immediate-select slots and join-vals for this object
-                         (let* ((slots (class-slots (class-of jo)))
-                                (pos-list (remove-if #'null
-                                                     (mapcar
-                                                      #'(lambda (s)
-                                                          (position s immediate-selects
-                                                                    :key #'car
-                                                                    :test #'eq))
-                                                      slots))))
-                           (get-slot-values-from-view jo
-                                                      (mapcar #'car
-                                                              (mapcar #'(lambda (pos)
-                                                                          (nth pos immediate-selects))
-                                                                      pos-list))
-                                                      (mapcar #'(lambda (pos) (nth pos join-vals))
-                                                              pos-list))))
-                     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))))
+  "Builds the join where clause based on the keys of the join slot and values
+   of the object"
+  (declare (ignore class))
+  (let* ((jc (join-slot-class slot-def))
+         ;;(ts (gethash :target-slot dbi))
+         ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
+         (foreign-keys (listify (join-slot-info-value slot-def :foreign-key)))
+         (home-keys (listify (join-slot-info-value slot-def :home-key))))
+    (when (all-home-keys-have-values-p object slot-def)
+      (clsql-ands
+       (loop for hk in home-keys
+             for fk in foreign-keys
+             for fksd = (slotdef-for-slot-with-class fk jc)
+             for fk-sql = (typecase fk
+                            (symbol
+                             (sql-expression
+                              :attribute (database-identifier fksd nil)
+                              :table (database-identifier jc nil)))
+                            (t fk))
+             for hk-val = (typecase hk
+                            ((or symbol
+                                 view-class-effective-slot-definition
+                                 view-class-direct-slot-definition)
+                             (easy-slot-value object hk))
+                            (t hk))
+             collect (sql-operation '== fk-sql hk-val))))))
+
+(defmethod select-table-sql-expr ((table T))
+  "Turns an object representing a table into the :from part of the sql expression that will be executed "
+  (sql-expression :table (view-table table)))
+
+(defun select-reference-equal (r1 r2)
+  "determines if two sql select references are equal
+   using database identifier equal"
+  (flet ((id-of (r)
+           (etypecase r
+             (cons (cdr r))
+             (sql-ident-attribute r))))
+    (database-identifier-equal (id-of r1) (id-of r2))))
+
+(defun join-slot-qualifier (class join-slot)
+  "Creates a sql-expression expressing the join between the home-key on the table
+   and its respective key on the joined-to-table"
+  (sql-operation
+   '==
+   (sql-expression
+    :attribute (join-slot-info-value join-slot :foreign-key)
+    :table (view-table (join-slot-class join-slot)))
+   (sql-expression
+    :attribute (join-slot-info-value join-slot :home-key)
+    :table (view-table class))))
+
+(defun all-immediate-join-classes-for (classes)
+  "returns a list of all join-classes needed for a list of classes"
+  (loop for class in (listify classes)
+        appending (loop for slot in (immediate-join-slots class)
+                        collect (join-slot-class slot))))
+
+(defun %tables-for-query (classes from where inner-joins)
+  "Given lists of classes froms wheres and inner-join compile a list
+   of tables that should appear in the FROM section of the query.
+
+   This includes any immediate join classes from each of the classes"
+  (let ((inner-join-tables (collect-table-refs (listify inner-joins))))
+    (loop for tbl in (append
+                      (mapcar #'select-table-sql-expr classes)
+                      (mapcar #'select-table-sql-expr
+                              (all-immediate-join-classes-for classes))
+                      (collect-table-refs (listify where))
+                      (collect-table-refs (listify from)))
+          when (and tbl
+                    (not (find tbl rtn :test #'database-identifier-equal))
+                    ;; TODO: inner-join is currently hacky as can be
+                    (not (find tbl inner-join-tables :test #'database-identifier-equal)))
+          collect tbl into rtn
+          finally (return rtn))))
+
+(defun full-select-list ( classes )
+  "Returns a list of sql-ref of things to select for the given classes
+
+   THIS NEEDS TO MATCH THE ORDER OF build-objects
+
+   TODO: this used to include order-by and distinct as more things to select.
+    distinct seems to always be used in a boolean context, so it doesnt seem
+    like appending it to the select makes any sense
+
+    We also used to remove duplicates, but that seems like it would make
+    filling/building objects much more difficult so skipping for now...
+  "
+  (setf classes (mapcar #'to-class (listify classes)))
+  (mapcar
+   #'cdr
+   (loop for class in classes
+         appending (generate-selection-list class)
+         appending
+            (loop for join-slot in (immediate-join-slots class)
+                  for join-class = (join-slot-class-name join-slot)
+                  appending (generate-selection-list join-class)))))
+
+(defun build-objects (classes row database &optional existing-instances)
+  "Used by find-all to build objects.
+
+   THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST
+
+   TODO: this caching scheme seems bad for a number of reasons
+    * order is not guaranteed so references being held by one object
+      might change to represent a different database row (seems HIGHLY
+      suspect)
+    * also join objects are overwritten rather than refreshed
+
+   TODO: the way we handle immediate joins seems only valid if it is a single
+      object.  I suspect that making a :set :immediate join column would result
+      in an invalid number of objects returned from the database, because there
+      would be multiple rows per object, but we would return an object per row
+   "
+  (setf existing-instances (listify existing-instances))
+  (loop for class in classes
+        for existing = (pop existing-instances)
+        for object = (or existing
+                         (make-instance class :view-database database))
+        do (loop for (slot . _) in (generate-selection-list class)
+                 do (update-slot-from-db-value object slot (pop row)))
+        do (loop for join-slot in (immediate-join-slots class)
+                 for join-class = (join-slot-class-name join-slot)
+                 for join-object =
+                     (setf
+                      (easy-slot-value object join-slot)
+                      (make-instance join-class))
+                 do (loop for (slot . _) in (generate-selection-list join-class)
+                          do (update-slot-from-db-value join-object slot (pop row))))
+        do (when existing (instance-refreshed object))
+        collect object))

 
 (defun find-all (view-classes
                  &rest args
                  &key all set-operation distinct from where group-by having
 
 (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)
+                 order-by offset limit refresh flatp result-types
+                 inner-join on
+                 (database *default-database*)
+                 instances parameters)

   "Called by SELECT to generate object query results when the
   "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))
-  (flet ((ref-equal (ref1 ref2)
-           (string= (sql-output ref1 database)
-                    (sql-output ref2 database)))
-         (table-sql-expr (table)
-           (sql-expression :table (view-table table)))
-         (tables-equal (table-a table-b)
-           (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)
-           (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 (mapcar #'append sels immediate-join-sels)))
-           (sel-tables (collect-table-refs where))
-           (tables (remove-if #'null
-                              (remove-duplicates
-                               (append (mapcar #'table-sql-expr sclasses)
-                                       (mapcan #'(lambda (jc-list)
-                                                   (mapcar
-                                                    #'(lambda (jc) (when jc (table-sql-expr jc)))
-                                                    jc-list))
-                                               immediate-join-classes)
-                                       sel-tables)
-                               :test #'tables-equal)))
-           (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
-                                   (listify order-by)))
-           (join-where nil))
-
-      ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
-
-      (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 join-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 join-where (listify join-where))))))
-                     jclasses jslots)))
-              sclasses immediate-join-classes immediate-join-slots)
-      ;; Reported buggy on clsql-devel
-      ;; (when where (setq where (listify where)))
-      (cond
-       ((and where join-where)
-        (setq where (list (apply #'sql-and where join-where))))
-       ((and (null where) (> (length join-where) 1))
-        (setq where (list (apply #'sql-and join-where)))))
-
-      (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))))
+  View Classes VIEW-CLASSES are passed as arguments to SELECT.
+
+   TODO: the caching scheme of passing in instances and overwriting their
+         values seems bad for a number of reasons
+    * order is not guaranteed so references being held by one object
+      might change to represent a different database row (seems HIGHLY
+      suspect)
+
+   TODO: the way we handle immediate joins seems only valid if it is a single
+      object.  I suspect that making a :set :immediate join column would result
+      in an invalid number of objects returned from the database, because there
+      would be multiple objects returned from the database
+  "
+  (declare (ignore all set-operation group-by having offset limit on parameters
+                   distinct order-by)
+           (dynamic-extent args))
+  (let* ((args (filter-plist
+                args :from :where :flatp :additional-fields :result-types :instances))
+         (*db-deserializing* t)
+         (sclasses (mapcar #'to-class view-classes))
+         (tables (%tables-for-query sclasses from where inner-join))
+         (join-where
+           (loop for class in sclasses
+                 appending (loop for slot in (immediate-join-slots class)
+                                 collect (join-slot-qualifier class slot))))
+         (full-select-list (full-select-list sclasses))
+         (where (clsql-ands (append (listify where) (listify join-where))))
+         #|
+          (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%"
+                    sclasses immediate-join-classes tables))
+         |#
+         (rows (apply #'select
+                      (append full-select-list
+                              (list :from tables
+                                    :result-types result-types
+                                    :where where)
+                              args)))
+         (return-objects
+           (loop for row in rows
+                 for old-objs = (pop instances)
+                 for objs = (build-objects sclasses row database
+                                           (when refresh old-objs))
+                 collecting (if flatp
+                                (delist-if-single objs)
+                                objs))))
+    return-objects))

 
 (defmethod instance-refreshed ((instance standard-db-object)))
 
 
 (defmethod instance-refreshed ((instance standard-db-object)))
 


@@ -1023,7 +1209,7 @@ maximum of MAX-LEN instances updated in each query."
 specification states caching is on by default.")
 
 (defun select (&rest select-all-args)
 specification states caching is on by default.")
 
 (defun select (&rest select-all-args)

-   "Executes a query on DATABASE, which has a default value of
+  "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
 *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


@@ -1066,68 +1252,72 @@ 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."
 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."

+  (multiple-value-bind (target-args qualifier-args)
+      (query-get-selections select-all-args)
+    (unless (or *default-database* (getf qualifier-args :database))
+      (signal-no-database-error nil))

 
 

-   (flet ((select-objects (target-args)
-            (and target-args
-                 (every #'(lambda (arg)
-                            (and (symbolp arg)
-                                 (find-class arg nil)))
-                        target-args))))
-     (multiple-value-bind (target-args qualifier-args)
-         (query-get-selections select-all-args)
-       (unless (or *default-database* (getf qualifier-args :database))
-         (signal-no-database-error nil))
-
-       (cond
-         ((select-objects target-args)
-          (let ((caching (getf qualifier-args :caching *default-caching*))
-                (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)))
+    (let ((caching (getf qualifier-args :caching *default-caching*))
+          (result-types (getf qualifier-args :result-types :auto))
+          (refresh (getf qualifier-args :refresh nil))
+          (database (getf qualifier-args :database *default-database*)))

 
 

-            (cond
-              ((null caching)
-               (apply #'find-all target-args
-                      (append qualifier-args
-                              (list :result-types result-types :refresh refresh))))
-              (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 :refresh ,refresh)))))
-                      (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 :refresh ,refresh)))))
-                      (setf (records-cache-results target-args qualifier-args database) results)
-                      results))))))))
-         (t
-          (let* ((expr (apply #'make-query select-all-args))
-                 (specified-types
+      (cond
+        ((and target-args
+              (every #'(lambda (arg)
+                         (and (symbolp arg)
+                              (find-class arg nil)))
+                     target-args))
+
+         (setf qualifier-args (filter-plist qualifier-args :caching :refresh :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
+         (let ((order-by (getf qualifier-args :order-by)))
+           (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))))
+               (labels ((sv (val name) (ignore-errors (slot-value val name)))
+                        (set-table-if-needed (val)
+                          (typecase val
+                            (sql-ident-attribute
+                             (handler-case
+                                 (if (sv val 'qualifier)
+                                     val
+                                     (make-instance 'sql-ident-attribute
+                                                    :name (sv val 'name)
+                                                    :qualifier table-name))
+                               (simple-error ()
+                                 ;; TODO: Check for a specific error we expect
+                                 )))
+                            (cons (cons (set-table-if-needed (car val))
+                                        (cdr val)))
+                            (t val))))
+                 (setf order-by-list
+                       (loop for i from 0 below (length order-by-list)
+                             for id in order-by-list
+                             collect (set-table-if-needed id))))
+               (setf (getf qualifier-args :order-by) order-by-list))))
+
+         (cond
+           ((null caching)
+            (apply #'find-all target-args :result-types result-types :refresh refresh qualifier-args))
+           (t
+            (let ((cached (records-cache-results target-args qualifier-args database)))
+              (if (and cached (not refresh))
+                  cached
+                  (let ((results (apply #'find-all target-args
+                                        :result-types :auto :refresh refresh
+                                        :instances cached
+                                        qualifier-args)))
+                    (setf (records-cache-results target-args qualifier-args database) results)
+
+                    results))))))
+        (t
+         (let* ((expr (apply #'make-query select-all-args))
+                (parameters (second (member :parameters select-all-args)))
+                (specified-types

                   (mapcar #'(lambda (attrib)
                               (if (typep attrib 'sql-ident-attribute)
                                   (let ((type (slot-value attrib 'type)))
                   (mapcar #'(lambda (attrib)
                               (if (typep attrib 'sql-ident-attribute)
                                   (let ((type (slot-value attrib 'type)))


@@ -1135,21 +1325,20 @@ as elements of a list."
                                         type
                                         t))
                                   t))
                                         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))))))))
+                          (slot-value expr 'selections)))
+                (flatp (getf qualifier-args :flatp))
+                (field-names (getf qualifier-args :field-names t)))
+
+           (when parameters
+             (setf expr (command-object (sql-output expr database) parameters)))
+           (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
 
 (defun compute-records-cache-key (targets qualifiers)
   (list targets


@@ -1173,11 +1362,8 @@ as elements of a list."
 (defun (setf records-cache-results) (results targets qualifiers database)
   (unless (record-caches database)
     (setf (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
-                           #+clisp     :weak      #+clisp :value
-                           #+lispworks :weak-kind #+lispworks :value)))
-  (setf (gethash (compute-records-cache-key targets qualifiers)
+          (make-weak-hash-table :test 'equal)))
+  (setf (gethash (compute-records-cache-key (copy-list targets) qualifiers)

                  (record-caches database)) results)
   results)
 
                  (record-caches database)) results)
   results)