X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=07652f21c7f77d7712b35ddde07da23a5c945997;hb=12ad0234eb45fd831c5c905b8428868731ba3c54;hp=8fa98903a85450c436d20258b91cdb4c81345c68;hpb=e34a3ace07250c5c55b3f6598459ef7b6d292bdb;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 8fa9890..07652f2 100644
--- 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*))
@@ -690,7 +690,11 @@ superclass of the newly-defined View Class."
 (defmethod read-sql-value (val (type (eql 'float)) database)
   (declare (ignore database))
   ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
-  (float (read-from-string val))) 
+  (etypecase val
+    (string
+     (float (read-from-string val)))
+    (float
+     val)))
 
 (defmethod read-sql-value (val (type (eql 'boolean)) database)
   (case (database-underlying-type database)
@@ -852,6 +856,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 +1018,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) 
@@ -1111,27 +1128,34 @@ ENABLE-SQL-READER-SYNTAX."
                        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 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