r9408: 19 May 2004 Kevin Rosenberg (kevin@rosenberg.net)

[clsql.git] / sql / objects.lisp

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 8fa98903a85450c436d20258b91cdb4c81345c68..5e36e758bf9ed8b33c93f9280465fa0e0a928d67 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -317,10 +317,10 @@ superclass of the newly-defined View Class."
          (basetype (if (listp slot-type) (car slot-type) slot-type)))
     (when (and slot-type val)
       (unless (typep val basetype)
-        (error 'clsql-type-error
-               :slotname (slot-definition-name slotdef)
-               :typespec slot-type
-               :value val)))))
+        (error 'sql-user-error
+              :message
+              (format nil "Invalid value ~A in slot ~A, not of type ~A."
+                      val (slot-definition-name slotdef) slot-type))))))
 
 ;;
 ;; Called by find-all
@@ -423,7 +423,7 @@ superclass of the newly-defined View Class."
        (let ((qualifier (key-qualifier-for-instance instance :database vd)))
          (delete-records :from vt :where qualifier :database vd)
          (setf (slot-value instance 'view-database) nil))
-       (error 'clsql-no-database-error :database nil))))
+       (signal-no-database-error vd))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
                                          &key (database *default-database*))
@@ -852,6 +852,7 @@ superclass of the newly-defined View Class."
                                               :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)))
@@ -1013,13 +1014,25 @@ superclass of the newly-defined View Class."
                                                                             jcs))
                                                                 immediate-join-classes)
                                                         sel-tables)
-                                                :test #'tables-equal))))
-      (dolist (ob (listify order-by))
+                                                :test #'tables-equal)))
+          (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
+                                  (listify order-by))))
+                                   
+                                
+      (when (and order-by-slots (= 1 (length tables)))
+       ;; Add explicity table name if not specified and only one selected table
+       (let ((table-name (sql-output (car tables) database)))
+         (loop for i from 0 below (length order-by-slots)
+             do (when (typep (nth i order-by-slots) 'sql-ident-attribute)
+                  (unless (slot-value (nth i order-by-slots) 'qualifier)
+                    (setf (slot-value (nth i order-by-slots) 'qualifier) table-name)))))) 
+       
+      (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))
-                                          (listify ob))))))
+           (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) 
@@ -1114,24 +1127,28 @@ ENABLE-SQL-READER-SYNTAX."
        (cond
          ((select-objects target-args)
           (let ((caching (getf qualifier-args :caching t))
+                (result-types (getf qualifier-args :result-types :auto))
                 (refresh (getf qualifier-args :refresh nil))
                 (database (or (getf qualifier-args :database) *default-database*)))
             (remf qualifier-args :caching)
             (remf qualifier-args :refresh)
+            (remf qualifier-args :result-types)
             (cond
               ((null caching)
-               (apply #'find-all target-args qualifier-args))
+               (apply #'find-all target-args
+                      (append qualifier-args (list :result-types result-types))))
               (t
                (let ((cached (records-cache-results target-args qualifier-args database)))
                  (cond
                    ((and cached (not refresh))
                     cached)
                    ((and cached refresh)
-                    (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached)))))
+                    (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto)))))
                       (setf (records-cache-results target-args qualifier-args database) results)
                       results))
                    (t
-                    (let ((results (apply #'find-all target-args qualifier-args)))
+                    (let ((results (apply #'find-all target-args (append qualifier-args
+                                                                         '(:result-types :auto)))))
                       (setf (records-cache-results target-args qualifier-args database) results)
                       results))))))))
          (t