Major rewrite of table/column name output escaping system wide.

[clsql.git] / sql / oodml.lisp

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index cc57941e38e2520e80e48cad4ab50fa42b4c9b11..ecfc9fad808106af81ff5c2ed5a8891a6c4e97b2 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.


@@ -15,18 +13,19 @@
 (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))))
+(defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
+  (let* ((obj-class (or this-class (class-of obj)))
+         (tb (view-table obj-class)))

     (flet ((qfk (k)
              (sql-operation '==
                             (sql-expression :attribute
     (flet ((qfk (k)
              (sql-operation '==
                             (sql-expression :attribute

-                                            (view-class-slot-column k)
+                                            (database-identifier k database)

                                             :table tb)
                             (db-value-from-slot
                              k
                              (slot-value obj (slot-definition-name k))
                              database))))
                                             :table tb)
                             (db-value-from-slot
                              k
                              (slot-value obj (slot-definition-name k))
                              database))))

-      (let* ((keys (keyslots-for-class (class-of obj)))
+      (let* ((keys (keyslots-for-class obj-class))

              (keyxprs (mapcar #'qfk (reverse keys))))
         (cond
           ((= (length keyxprs) 0) nil)
              (keyxprs (mapcar #'qfk (reverse keys))))
         (cond
           ((= (length keyxprs) 0) nil)


@@ -39,22 +38,33 @@
 
 (defun generate-attribute-reference (vclass slotdef)
   (cond
 
 (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)))
+    ((eq (view-class-slot-db-kind slotdef) :base)
+     (sql-expression :attribute (database-identifier slotdef nil)
+                     :table (database-identifier vclass nil)))
+    ((eq (view-class-slot-db-kind slotdef) :key)
+     (sql-expression :attribute (database-identifier slotdef nil)
+                     :table (database-identifier vclass nil)))
+    (t nil)))

 
 ;;
 ;; 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,6 +93,17 @@
               (push (cons slotdef res) sels))))))
     sels))
 
               (push (cons slotdef res) sels))))))
     sels))
 

+(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'
 ;;
 
 ;; Called by 'get-slot-values-from-view'
 ;;


@@ -95,9 +116,9 @@
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
                  (read-sql-value value (delistify slot-type)
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
                  (read-sql-value value (delistify slot-type)

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

                                  (database-underlying-type
                                  (database-underlying-type

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

           ((null value)
            (update-slot-with-null instance slot-name slotdef))
           ((typep slot-reader 'string)
           ((null value)
            (update-slot-with-null instance slot-name slotdef))
           ((typep slot-reader 'string)


@@ -153,39 +174,57 @@
 ;;
 
 (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))
+  (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*))
 
 (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))
+  (let* ((database (choose-database-for-instance obj database))
+         (view-class (class-of obj)))
+    (when (normalizedp view-class)
+      ;; If it's normalized, find the class that actually contains
+      ;; the slot that's tied to the db
+      (setf view-class
+            (do ((this-class view-class
+                             (car (class-direct-superclasses this-class))))
+                ((member slot
+                         (mapcar #'(lambda (esd) (slot-definition-name esd))
+                                 (ordered-class-direct-slots this-class)))
+                 this-class))))
+    (let* ((vct (view-table view-class))
+           (sd (slotdef-for-slot-with-class slot view-class)))
+      (check-slot-type sd (slot-value obj slot))
+      (let* ((att (database-identifier sd database))
+             (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 :this-class view-class)
+                               :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)))

 
 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
                                      (database *default-database*))
 
 (defmethod update-record-from-slots ((obj standard-db-object) slots &key
                                      (database *default-database*))

-  (let* ((database (or (view-database obj) database))
+  (when (normalizedp (class-of obj))
+    ;; FIXME: Rewrite to bundle slots for same table to be written
+    ;; as avpairs (like how is done for non-normalized view-classes below)
+    (dolist (slot slots)
+      (update-record-from-slot obj slot :database database))
+    (return-from update-record-from-slots (values)))
+
+  (let* ((database (choose-database-for-instance obj database))

          (vct (view-table (class-of obj)))
          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
          (avps (mapcar #'(lambda (s)
          (vct (view-table (class-of obj)))
          (sds (slotdefs-for-slots-with-class slots (class-of obj)))
          (avps (mapcar #'(lambda (s)


@@ -193,15 +232,18 @@
                                        obj (slot-definition-name s))))
                              (check-slot-type s val)
                              (list (sql-expression
                                        obj (slot-definition-name s))))
                              (check-slot-type s val)
                              (list (sql-expression

-                                    :attribute (view-class-slot-column s))
+                                    :attribute (database-identifier s database))

                                    (db-value-from-slot s val database))))
                        sds)))
     (cond ((and avps (view-database obj))
                                    (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))
+           (let ((where (key-qualifier-for-instance
+                         obj :database database)))
+             (unless where
+               (error "update-record-from-slots: could not generate a where clause for ~a" obj))
+             (update-records (sql-expression :table vct)
+                             :av-pairs avps
+                             :where where
+                             :database database)))

           ((and avps (not (view-database obj)))
            (insert-records :into (sql-expression :table vct)
                            :av-pairs avps
           ((and avps (not (view-database obj)))
            (insert-records :into (sql-expression :table vct)
                            :av-pairs avps


@@ -211,75 +253,145 @@
            (error "Unable to update records"))))
   (values))
 
            (error "Unable to update records"))))
   (values))
 

-(defmethod update-records-from-instance ((obj standard-db-object) &key database)
-  (let ((database (or database (view-database obj) *default-database*)))
+(defmethod update-records-from-instance ((obj standard-db-object)
+                                         &key database this-class)
+  (let ((database (choose-database-for-instance obj database))
+        (pk nil))

     (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)
     (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))
+                 (list (sql-expression :attribute (database-identifier slot database))

                        (db-value-from-slot slot value database)))))
                        (db-value-from-slot slot value database)))))

-      (let* ((view-class (class-of obj))
+      (let* ((view-class (or this-class (class-of obj)))
+             (pk-slot (car (keyslots-for-class view-class)))

              (view-class-table (view-table view-class))
              (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)
+             (pclass (car (class-direct-superclasses view-class))))
+        (when (normalizedp view-class)
+          (setf pk (update-records-from-instance obj :database database
+                                                 :this-class pclass))
+          (when pk-slot
+            (setf (slot-value obj (slot-definition-name pk-slot)) pk)))
+        (let* ((slots (remove-if-not #'slot-storedp
+                                     (if (normalizedp view-class)
+                                         (ordered-class-direct-slots view-class)
+                                         (ordered-class-slots view-class))))
+               (record-values (mapcar #'slot-value-list slots)))
+
+          (cond ((and (not (normalizedp view-class))
+                      (not record-values))
+                 (error "No settable slots."))
+                ((and (normalizedp view-class)
+                      (not record-values))
+                 nil)
+                ((view-database obj)
+                 ;; if this slot is set, the database object was returned from a select
+                 ;; and has already been in the database, so we must need an update
+                 (update-records (sql-expression :table view-class-table)
+                                 :av-pairs record-values
+                                 :where (key-qualifier-for-instance
+                                         obj :database database
+                                         :this-class view-class)
+                                 :database database)
+                 (when pk-slot
+                   (setf pk (or pk
+                                (slot-value obj (slot-definition-name pk-slot))))))
+                (t
+                (insert-records :into (sql-expression :table view-class-table)
+                                 :av-pairs record-values
+                                 :database database)
+
+                 (when (and pk-slot (not pk))
+                   (setf pk
+                          (when (auto-increment-column-p pk-slot database)
+                            (setf (slot-value obj (slot-definition-name pk-slot))
+                                  (database-last-auto-increment-id
+                                   database view-class-table pk-slot)))))
+                 (when pk-slot
+                   (setf pk (or pk
+                                (slot-value
+                                 obj (slot-definition-name pk-slot)))))
+                 (when (eql this-class nil)
+                   (setf (slot-value obj 'view-database) database)))))))
+    ;; handle slots with defaults
+    (let* ((view-class (or this-class (class-of obj)))
+          (slots (if (normalizedp view-class)
+                    (ordered-class-direct-slots view-class)
+                    (ordered-class-slots view-class)))) 
+      (dolist (slot slots)
+       (when (and (slot-exists-p slot 'db-constraints)
+                  (listp (view-class-slot-db-constraints slot))
+                  (member :default (view-class-slot-db-constraints slot)))
+         (unless (and (slot-boundp obj (slot-definition-name slot))
+                      (slot-value obj (slot-definition-name slot)))
+           (update-slot-from-record obj (slot-definition-name slot))))))
+
+    pk))
+
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+  (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 update-slot-from-record ((instance standard-db-object)
                                     slot &key (database *default-database*))
   (let* ((view-class (find-class (class-name (class-of instance))))
 
 (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)))))
-
+         (slot-def (slotdef-for-slot-with-class slot view-class)))
+    (when (normalizedp view-class)
+      ;; If it's normalized, find the class that actually contains
+      ;; the slot that's tied to the db
+      (setf view-class
+            (do ((this-class view-class
+                             (car (class-direct-superclasses this-class))))
+                ((member slot
+                         (mapcar #'(lambda (esd) (slot-definition-name esd))
+                                 (ordered-class-direct-slots this-class)))
+                 this-class))))
+    (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))
+           (att-ref (generate-attribute-reference view-class slot-def))
+           (res (select att-ref :from  view-table :where view-qual
+                                                  :result-types nil)))
+      (when res
+       (setf (slot-value instance 'view-database) vd)
+        (get-slot-values-from-view instance (list slot-def) (car res))))))

 
 (defmethod update-slot-with-null ((object standard-db-object)
                                   slotname
 
 (defmethod update-slot-with-null ((object standard-db-object)
                                   slotname


@@ -289,17 +401,17 @@
 (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 +429,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 +537,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 +565,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 +607,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 +672,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 +782,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 +818,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 +841,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 +857,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 +870,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,7 +906,7 @@ 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))


@@ -796,44 +923,89 @@ maximum of MAX-LEN instances updated in each query."
               ((and (not ts) (gethash :set dbi))
                res)))))))
 
               ((and (not ts) (gethash :set dbi))
                res)))))))
 

+;;;; Should we not return the whole result, instead of only
+;;;; the one slot-value? We get all the values from the db
+;;;; anyway, so?
+(defun fault-join-normalized-slot (class object slot-def)
+  (labels ((getsc (this-class)
+             (let ((sc (car (class-direct-superclasses this-class))))
+               (if (key-slots sc)
+                   sc
+                   (getsc sc)))))
+    (let* ((sc (getsc class))
+           (hk (slot-definition-name (car (key-slots class))))
+           (fk (slot-definition-name (car (key-slots sc)))))
+      (let ((jq (sql-operation '==
+                               (typecase fk
+                                 (symbol
+                                  (sql-expression
+                                   :attribute
+                                   (database-identifier
+                                    (slotdef-for-slot-with-class fk sc) nil)
+                                   :table (view-table sc)))
+                                 (t fk))
+                               (typecase hk
+                                 (symbol
+                                  (slot-value object hk))
+                                 (t hk)))))
+
+        ;; Caching nil in next select, because in normalized mode
+        ;; records can be changed through other instances (children,
+        ;; parents) so changes possibly won't be noticed
+        (let ((res (car (select (class-name sc) :where jq
+                                                :flatp t :result-types nil
+                                                :caching nil
+                                                :database (choose-database-for-instance object))))
+              (slot-name (slot-definition-name slot-def)))
+
+          ;; If current class is normalized and wanted slot is not
+          ;; a direct member, recurse up
+          (if (and (normalizedp class)
+                   (not (member slot-name
+                                (mapcar #'(lambda (esd) (slot-definition-name esd))
+                                        (ordered-class-direct-slots class))))
+                   (not (slot-boundp res slot-name)))
+              (fault-join-normalized-slot sc res slot-def)
+              (slot-value res slot-name)))))) )
+

 (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))))))
+  (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
+                                              (database-identifier fksd nil)
+                                              :table (database-identifier jc nil)))
+                                            (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 =>
 
 ;; FIXME: add retrieval immediate for efficiency
 ;; For example, for (select 'employee-address) in test suite =>


@@ -856,7 +1028,11 @@ maximum of MAX-LEN instances updated in each query."
                (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
                (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)))
+                         (let* ((jo-class (class-of jo))
+                                (slots
+                                 (if (normalizedp jo-class)
+                                     (class-direct-slots jo-class)
+                                     (class-slots jo-class)))

                                 (pos-list (remove-if #'null
                                                      (mapcar
                                                       #'(lambda (s)
                                 (pos-list (remove-if #'null
                                                      (mapcar
                                                       #'(lambda (s)


@@ -874,12 +1050,14 @@ maximum of MAX-LEN instances updated in each query."
                      joins)
                (mapc
                 #'(lambda (jc)
                      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))))))
+                    (let* ((vslots
+                            (class-slots vclass))
+                           (slot (find (class-name (class-of jc)) vslots
+                                       :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 slot
                         (setf (slot-value obj (slot-definition-name slot)) jc))))
                 joins)


@@ -894,27 +1072,26 @@ maximum of MAX-LEN instances updated in each query."
                     sclasses immediate-join-classes sels immediate-joins instances)))
       (if (and flatp (= (length sclasses) 1))
           (car objects)
                     sclasses immediate-join-classes sels immediate-joins instances)))
       (if (and flatp (= (length sclasses) 1))
           (car objects)

-        objects))))
+          objects))))
+
+(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 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
   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)
   "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))))))
+                    (sql-output ref2 database))))

     (remf args :from)
     (remf args :where)
     (remf args :flatp)
     (remf args :from)
     (remf args :where)
     (remf args :flatp)


@@ -937,14 +1114,14 @@ maximum of MAX-LEN instances updated in each query."
            (sel-tables (collect-table-refs where))
            (tables (remove-if #'null
                               (remove-duplicates
            (sel-tables (collect-table-refs where))
            (tables (remove-if #'null
                               (remove-duplicates

-                               (append (mapcar #'table-sql-expr sclasses)
+                               (append (mapcar #'select-table-sql-expr sclasses)

                                        (mapcan #'(lambda (jc-list)
                                                    (mapcar
                                        (mapcan #'(lambda (jc-list)
                                                    (mapcar

-                                                    #'(lambda (jc) (when jc (table-sql-expr jc)))
+                                                    #'(lambda (jc) (when jc (select-table-sql-expr jc)))

                                                     jc-list))
                                                immediate-join-classes)
                                        sel-tables)
                                                     jc-list))
                                                immediate-join-classes)
                                        sel-tables)

-                               :test #'tables-equal)))
+                               :test #'database-identifier-equal)))

            (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
                                    (listify order-by)))
            (join-where nil))
            (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
                                    (listify order-by)))
            (join-where nil))


@@ -955,39 +1132,39 @@ maximum of MAX-LEN instances updated in each query."
         (when (and ob (not (member ob (mapcar #'cdr fullsels)
                                    :test #'ref-equal)))
           (setq fullsels
         (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)))))
+                (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
       (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))))))
+                (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
       (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))))))
+                                 (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
                      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)))))
+        ((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)
 
       (let* ((rows (apply #'select
                           (append (mapcar #'cdr fullsels)


@@ -1005,14 +1182,14 @@ maximum of MAX-LEN instances updated in each query."
                                          (res nil))
                                         ((= i instances-to-add) res)
                                       (push (make-list (length sclasses) :initial-element nil) res)))
                                          (res nil))
                                         ((= i instances-to-add) res)
                                       (push (make-list (length sclasses) :initial-element nil) res)))

-                instances))
+                  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)
              (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)))
+                                              instance)))

                        rows perhaps-extended-instances)))
         objects))))
 
                        rows perhaps-extended-instances)))
         objects))))
 


@@ -1023,7 +1200,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


@@ -1067,89 +1244,96 @@ 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."
 
 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)
-                            (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)))
+  (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
-              ((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
-                  (mapcar #'(lambda (attrib)
-                              (if (typep attrib 'sql-ident-attribute)
-                                  (let ((type (slot-value attrib 'type)))
-                                    (if type
-                                        type
-                                        t))
-                                  t))
-                          (slot-value expr 'selections))))
-            (destructuring-bind (&key (flatp nil)
-                                      (result-types :auto)
-                                      (field-names t)
-                                      (database *default-database*)
-                                      &allow-other-keys)
-                qualifier-args
-              (query expr :flatp flatp
-                     :result-types
-                     ;; specifying a type for an attribute overrides result-types
-                     (if (some #'(lambda (x) (not (eq t x))) specified-types)
-                         specified-types
-                         result-types)
-                     :field-names field-names
-                     :database database))))))))
+      (cond
+        ((select-objects target-args)
+         (let ((caching (getf qualifier-args :caching *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))))
+               (labels ((set-table-if-needed (val)
+                          (typecase val
+                            (sql-ident-attribute
+                             (handler-case
+                                 (unless (slot-value val 'qualifier)
+                                   (setf (slot-value val 'qualifier) table-name))
+                               (simple-error ()
+                                 ;; TODO: Check for a specific error we expect
+                                 )))
+                            (cons (set-table-if-needed (car val))))))
+                 (loop for i from 0 below (length order-by-list)
+                       for id = (nth i order-by-list)
+                       do (set-table-if-needed id)))
+               (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 :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))
+                (parameters (second (member :parameters 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
+             (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