X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Foodml.lisp;h=169fa89d70d6f0fe17e834749e9a27f337cfe2f8;hp=dbd5e6c5d1b2ba9db199d97f3cde08781c108969;hb=c1d990950afa607b9d7e428da384b057fd5c74f3;hpb=c5114f6d1dd70197d14c94ac8b83c19016e76880

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index dbd5e6c..169fa89 100644
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -219,19 +219,21 @@
 
 (defun update-auto-increments-keys (class obj database)
   " handle pulling any autoincrement values into the object
-   if normalized and we now that all the "
+    Also handles normalized key chaining"
   (let ((pk-slots (keyslots-for-class class))
         (table (view-table class))
         new-pk-value)
-    (labels ((do-update (slot)
-               (when (and (null (easy-slot-value obj slot))
-                          (auto-increment-column-p slot database))
-                 (update-slot-from-db-value
-                  obj slot
-                  (or new-pk-value
-                      (setf new-pk-value
-                            (database-last-auto-increment-id
-                             database table slot))))))
+    (labels ((do-update (slot &aux (val (easy-slot-value obj slot)))
+               (if val
+                   (setf new-pk-value val)
+                   (update-slot-from-db-value
+                    obj slot
+                    (or new-pk-value
+                        (setf new-pk-value
+                              (database-last-auto-increment-id
+                               database table slot))))))
+             ;; NB: This interacts very strangely with autoincrement keys
+             ;; (see changelog 2014-01-30)
              (chain-primary-keys (in-class)
                "This seems kindof wrong, but this is mostly how it was working, so
                   its here to keep the normalized code path working"
@@ -277,6 +279,7 @@
            (insert-records :into table-sql
                            :av-pairs avps
                            :database database)
+           ;; also handles normalized-class key chaining
            (update-auto-increments-keys view-class obj database)
            ;; we dont set view database here, because there could be
            ;; N of these for each call to update-record-from-* because
@@ -321,12 +324,14 @@
    (specifically clsql-helper:dirty-db-slots-mixin which only updates slots
     that have changed )
   "
-  (declare (ignore to-database-p))
   (setf class (to-class class))
   (let* (rtns)
     (labels ((storable-slots (class)
                (loop for sd in (slots-for-possibly-normalized-class class)
-                     when (key-or-base-slot-p sd)
+                     when (and (key-or-base-slot-p sd)
+                               ;; we dont want to insert/update auto-increments
+                               ;; but we do read them
+                               (not (and to-database-p (auto-increment-column-p sd))))
                      collect sd))
              (get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
                (let ((slots (storable-slots class)))
@@ -519,7 +524,7 @@
     (char (if args
               (format nil "CHAR(~D)" (first args))
               "CHAR(1)"))
-    ((varchar string)
+    ((varchar string symbol keyword)
      (if args
          (format nil "VARCHAR(~A)" (car args))
          (format nil "VARCHAR(~D)" *default-string-length*)))
@@ -550,105 +555,112 @@
              db-type type args database)
      (format nil "VARCHAR(~D)" *default-string-length*))))
 
-(defmethod database-output-sql-as-type (type val database db-type)
-  (declare (ignore type database db-type))
-  val)
+(defun print-readable-symbol (in &aux (*package* (find-package :keyword))
+                                 (*print-readably* t))
+  (prin1-to-string in))
 
-(defmethod database-output-sql-as-type ((type symbol) val database db-type)
+(defmethod database-output-sql-as-type
+    (type val database db-type
+     &aux
+     (*print-circle* t) (*print-array* t)
+     (*print-length* nil) (*print-base* #10r10))
   (declare (ignore database))
-  (case type ;; booleans handle null differently
-    ((boolean generalized-boolean)
+  (cond 
+    ((null type) val)
+    ((member type '(boolean generalized-boolean))
+     ;; booleans handle null differently
      (case db-type
        ;; done here so it can be done once
        ((:mssql :mysql) (if val 1 0))
        (otherwise (if val "t" "f"))))
-    (otherwise
-     ;; in all other cases if we have nil give everyone else a shot at it,
-     ;; which by default returns nil
-     (if (null val)
-         (call-next-method)
-         (case type
-           (symbol
-            (format nil "~A::~A"
-                    (package-name (symbol-package val))
-                    (symbol-name val)))
-           (keyword (symbol-name val))
-           (string val)
-           (char (etypecase val
-                   (character (write-to-string val))
-                   (string val)))
-           (float (format nil "~F" val))
-           ((list vector array)
-            (let* ((*print-circle* t)
-                   (*print-array* t)
-                   (value (prin1-to-string val)))
-              value))
-           (otherwise (call-next-method)))))))
-
-(defmethod read-sql-value (val type database db-type
-                           &aux *read-eval*)
-  (declare (ignore database db-type))
-  ;; TODO: All the read-from-strings in here do not check that
-  ;; what we read was of the correct type, should this change?
-
-  ;; TODO: Should this case `(typep val type)=>t` be an around
-  ;; method that short ciruits?
+    ((null val)
+     (when (next-method-p)
+       (call-next-method)))
+    (t
+     (case type
+       ((or symbol keyword)
+        (print-readable-symbol val))
+       (string val)
+       (char (etypecase val
+               (character (write-to-string val))
+               (string val)))
+       (float (format nil "~F" val))
+       ((list vector array)
+        (prin1-to-string val))
+       (otherwise
+        (if (next-method-p)
+            (call-next-method)
+            val))))))
+
+
+(defmethod read-sql-value :around
+    (val type database db-type
+     ;; never eval while reading values, always read base 10
+     &aux *read-eval* (*read-base* #10r10))
+  (declare (ignore 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 symbol) database db-type
-                           ;; never eval while reading values
-                           &aux *read-eval*)
-  ;; TODO: All the read-from-strings in here do not check that
-  ;; what we read was of the correct type, should this change?
-  (unless (or (equalp "nil" val) (eql 'null val))
-    (case type
-      ((string varchar) val)
-      (char (etypecase val
-              (string (schar val 0))
-              (character val)))
-      (keyword
-       (when (< 0 (length val))
-         (intern (symbol-name-default-case val) :keyword)))
-      (symbol
-       (when (< 0 (length val))
-         (intern (symbol-name-default-case val))))
-      ((smallint mediumint bigint integer universal-time)
-       (etypecase val
-         (string (parse-integer val))
-         (number val)))
-      ((double-float float)
-       ;; ensure that whatever we got is coerced to a float of the correct
-       ;; type (eg: 1=>1.0d0)
-       (float
-        (etypecase val
-          (string (let ((*read-default-float-format*
-                          (ecase type
-                            (float 'single-float)
-                            (double-float 'double-float))))
-                    (read-from-string val)))
-          (float val))
-        (if (eql type 'double-float) 1.0d0 1.0s0)))
-      (number
-       (etypecase val
+    ;; null value or type
+    ((or (equalp "nil" val) (eql 'null val)) nil) 
+    
+    ;; no specified type or already the right type
+    ((or (null type)
+         (ignore-errors (typep val type)))
+     val)
+
+    ;; actually convert
+    (t 
+     (let ((res (handler-bind
+                    ;; all errors should be converted to sql-value-conversion-error
+                    ((error (lambda (c)
+                              (when *debugger-hook*
+                                (invoke-debugger c))
+                              (unless (typep c 'sql-value-conversion-error)
+                                (error-converting-value val type database)))))
+                  (call-next-method))))
+       ;; if we didnt get the right type after converting, we should probably
+       ;; error right away
+       (maybe-error-converting-value
+        res val type database)))))
+
+(defmethod read-sql-value (val type database db-type)
+  ;; errors, nulls and preconverted types are already handled in around
+  (typecase type
+    (symbol
+     (case type
+       ((string varchar) val)
+       (char (string (schar val 0)))
+       ((or keyword symbol)
+        (read-from-string val))
+       ((smallint mediumint bigint integer universal-time)
+        (parse-integer val))
+       ((double-float float)
+        ;; ensure that whatever we got is coerced to a float of the correct
+        ;; type (eg: 1=>1.0d0)
+        (float
+         (etypecase val
+           (string (let ((*read-default-float-format*
+                           (ecase type
+                             (float 'single-float)
+                             (double-float 'double-float))))
+                     (read-from-string val)))
+           ;; maybe wrong type of float
+           (float val)) 
+         (if (eql type 'double-float) 1.0d0 1.0s0)))
+       (number (read-from-string val))
+       ((boolean generalized-boolean)
+        (if (member val '(nil t))
+            val
+            (etypecase val
+              (string
+               (when (member val '("1" "t" "true" "y") :test #'string-equal)
+                 t))
+              (number (not (zerop val))))))
+       ((wall-time duration) (parse-timestring val))
+       (date (parse-datestring val))
+       (t (call-next-method))))
+    (t (typecase val
          (string (read-from-string val))
-         (number val)))
-      ((boolean generalized-boolean)
-       (if (member val '(nil t))
-           val
-           (etypecase val
-             (string
-              (when (member val '("1" "t" "true" "y") :test #'string-equal)
-                t))
-             (number (not (zerop val))))))
-      ((wall-time duration)
-       (parse-timestring val))
-      (date
-       (parse-datestring val))
-      (t (call-next-method)))))
+         (t (error-converting-value val type database))))))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots