r9209: read tinyint as integer for odbc, handle boolean reading/writing fields

[clsql.git] / sql / objects.lisp

diff --git a/sql/objects.lisp b/sql/objects.lisp
index ef9c0db369a469c6d2984ed01598761d38098e33..0232917ff4662b7ca80ae62d79b75b86cfd4c08d 100644 (file)
--- 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)))))))
+