initial patch for symbol storage refactoring
authorRuss Tyndall <russ@acceleration.net>
Wed, 23 Apr 2014 20:22:10 +0000 (16:22 -0400)
committerRuss Tyndall <russ@acceleration.net>
Wed, 23 Apr 2014 20:28:12 +0000 (16:28 -0400)
sql/conditions.lisp
sql/oodml.lisp
tests/test-oodml.lisp

index 3ef9412..6fc1af5 100644 (file)
@@ -142,3 +142,28 @@ connection is no longer usable."))
 
 (defun signal-database-too-strange (message)
   (error 'database-too-strange :message message))
+
+
+(define-condition sql-value-conversion-error (error)
+  ((expected-type :accessor expected-type :initarg :expected-type :initform nil)
+   (value :accessor value :initarg :value :initform nil)
+   (database :accessor database :initarg :database :initform nil)))
+
+(defun error-converting-value (val type &optional (database *default-database*))
+  (restart-case 
+      (error 'sql-value-conversion-error
+             :expected-type type :value val :database database)
+    (use-value (new-val)
+      :report
+      (lambda (stream)
+        (write-sequence
+         "Use a different value instead of this failed conversion" stream))
+      (values new-val t)
+      )))
+
+(defun maybe-error-converting-value
+    (new val type &optional (database *default-database*))
+  (if (typep new type)
+      new
+      (error-converting-value
+       val type database)))
index 44c3e9e..f2ed8c9 100644 (file)
              db-type type args database)
      (format nil "VARCHAR(~D)" *default-string-length*))))
 
+(defun print-readable-symbol (in &aux (*package* (find-package :keyword))
+                                 (*print-readably* t))
+  (prin1-to-string in))
+
 (defmethod database-output-sql-as-type (type val database db-type)
   (declare (ignore type database db-type))
   val)
      (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))
+           ((or symbol keyword)
+            (print-readable-symbol val))
            (string val)
            (char (etypecase val
                    (character (write-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?
+(defmethod read-sql-value :around
+    (val type database db-type
+     &aux *read-eval*)
+  (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))))
+    ;; 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 symbol) database db-type
+(defmethod read-sql-value (val type 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
+  ;; 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
index 953a604..63e1d50 100644 (file)
 (setq *rt-oodml*
       '(
 
+(deftest :oodml/read-symbol-value/1-into-this-package
+ (clsql-sys::read-sql-value
+  (clsql-sys::database-output-sql-as-type 'symbol 'clsql-tests::foo nil nil)
+  'symbol nil nil)
+ '(clsql-tests::foo))
+
+(deftest :oodml/read-symbol-value/2-into-another-pacakge
+ (clsql-sys::read-sql-value
+  (clsql-sys::database-output-sql-as-type 'symbol 'clsql-sys::foo nil nil)
+  'symbol nil nil)
+ '(clsql-sys::foo))
+
+(deftest :oodml/read-symbol-value/3-keyword
+ (clsql-sys::read-sql-value
+  (clsql-sys::database-output-sql-as-type 'keyword ':foo nil nil)
+  'keyword nil nil)
+ '(:foo))
+
+(deftest :oodml/read-symbol-value/4-keyword-error
+ (handler-case
+     (clsql-sys::read-sql-value
+      (clsql-sys::database-output-sql-as-type 'keyword 'foo nil nil)
+      'keyword nil nil)
+   (clsql-sys::sql-value-conversion-error (c) (declare (ignore c))
+     :error))
+ '(:error))
+
 (deftest :oodml/select/1
     (with-dataset *ds-employees*
       (mapcar #'(lambda (e) (slot-value e 'last-name))