X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fobjects.lisp;h=0232917ff4662b7ca80ae62d79b75b86cfd4c08d;hb=f69c5bfba59d54628f9a08b83413ec3df3c92432;hp=ef9c0db369a469c6d2984ed01598761d38098e33;hpb=9bbed78051e80e6ab76ae47834136035602bbbf1;p=clsql.git

diff --git a/sql/objects.lisp b/sql/objects.lisp
index ef9c0db..0232917 100644
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -408,7 +408,8 @@ superclass of the newly-defined View Class."
          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
-                                            :where view-qual)))))
+                                            :where view-qual)
+				      (list :result-types nil)))))
     (when res
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
@@ -420,7 +421,8 @@ superclass of the newly-defined View Class."
          (view-qual (key-qualifier-for-instance instance :database vd))
          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
-         (res (select att-ref :from  view-table :where view-qual)))
+         (res (select att-ref :from  view-table :where view-qual
+		      :result-types nil)))
     (when res 
       (get-slot-values-from-view instance (list slot-def) (car res)))))
 
@@ -428,9 +430,7 @@ superclass of the newly-defined View Class."
 (defmethod update-slot-with-null ((object standard-db-object)
 				  slotname
 				  slotdef)
-  (let ((st (slot-type slotdef))
-        (void-value (slot-value slotdef 'void-value)))
-    (setf (slot-value object slotname) void-value)))
+  (setf (slot-value object slotname) (slot-value slotdef 'void-value)))
 
 (defvar +no-slot-value+ '+no-slot-value+)
 
@@ -584,8 +584,11 @@ superclass of the newly-defined View Class."
     (prin1-to-string val)))
 
 (defmethod database-output-sql-as-type ((type (eql 'boolean)) val database)
-  (declare (ignore database))
-  (if val "t" "f"))
+  (case (database-underlying-type database)
+    (:mysql
+     (if val 1 0))
+    (t
+     (if val "t" "f"))))
 
 (defmethod database-output-sql-as-type ((type (eql 'string)) val database)
   (declare (ignore database))
@@ -656,8 +659,13 @@ superclass of the newly-defined View Class."
   (float (read-from-string val))) 
 
 (defmethod read-sql-value (val (type (eql 'boolean)) database)
-  (declare (ignore database))
-  (equal "t" val))
+  (case (database-underlying-type database)
+    (:mysql
+     (etypecase val
+       (string (if (string= "0" val) nil t))
+       (integer (if (zerop val) nil t))))
+    (t
+     (equal "t" val))))
 
 (defmethod read-sql-value (val (type (eql 'univeral-time)) database)
   (declare (ignore database))
@@ -686,7 +694,7 @@ superclass of the newly-defined View Class."
 	 (jc (gethash :join-class dbi)))
     (let ((jq (join-qualifier class object slot-def)))
       (when jq 
-        (select jc :where jq)))))
+        (select jc :where jq :flatp t :result-types nil)))))
 
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))
@@ -745,11 +753,14 @@ superclass of the newly-defined View Class."
 
 (defun find-all (view-classes &rest args &key all set-operation distinct from
                  where group-by having order-by order-by-descending offset limit
-		 refresh (database *default-database*))
-  "tweeze me apart someone pleeze"
+		 refresh flatp (database *default-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)
            (optimize (debug 3) (speed 1)))
   (remf args :from)
+  (remf args :flatp)
+  (remf args :result-types)
   (labels ((table-sql-expr (table)
 	     (sql-expression :table (view-table table)))
 	   (ref-equal (ref1 ref2)
@@ -771,9 +782,11 @@ superclass of the newly-defined View Class."
 	       obj))
 	   (build-objects (vals sclasses sels)
 	     (let ((objects (mapcar #'(lambda (sclass sel) 
-					(build-object vals sclass sel))
+					(prog1 (build-object vals sclass sel)
+					  (setf vals (nthcdr (list-length sel)
+							     vals))))
 				    sclasses sels)))
-	       (if (= (length sclasses) 1)
+	       (if (and flatp (= (length sclasses) 1))
 		   (car objects)
 		   objects))))
     (let* ((*db-deserializing* t)
@@ -811,12 +824,14 @@ superclass of the newly-defined View Class."
 		     (append (mapcar #'cdr fullsels)
 			     (cons :from 
 				   (list (append (when from (listify from)) 
-						 (listify tables)))) args)))
+						 (listify tables)))) 
+			     (list :result-types nil)
+			     args)))
 	(mapcar #'(lambda (r) (build-objects r sclasses sels)) res))))
 
 (defmethod instance-refreshed ((instance standard-db-object)))
 
-(defun select (&rest select-all-args)
+(defmethod select (&rest select-all-args)
   "Selects data from database given the constraints specified. Returns
 a list of lists of record values as specified by select-all-args. By
 default, the records are each represented as lists of attribute
@@ -836,11 +851,11 @@ tuples."
           (apply #'find-all target-args qualifier-args)
           (let ((expr (apply #'make-query select-all-args)))
             (destructuring-bind (&key (flatp nil)
+				      (result-types :auto)
+				      (field-names t) 
 				      (database *default-database*)
                                       &allow-other-keys)
                 qualifier-args
-              (let ((res (query expr :database database)))
-		(if (and flatp
-			 (= (length (slot-value expr 'selections)) 1))
-		    (mapcar #'car res)
-		  res))))))))
+	      (query expr :flatp flatp :result-types result-types 
+		     :field-names field-names :database database)))))))
+