refactored read-sql-value to centralize this logic and reduce

overloading cases

 * read-eval is off for all read-sql-value cases now
 * the type=symbol case uses intern instead read-from-string

diff --git a/ChangeLog b/ChangeLog
index 8dbbf356565a72f63a06d060a8e429fc4d85af91..5cf44bc3d4c31289bb106d45ce558a05bf647cb6 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,20 @@
+2013-06-19 Russ Tyndall <russ@acceleration.net>
+        * sql/oodml.lisp, db-postgresql-socket3/sql.lisp,
+          db-mysql/mysql-objects.lisp, sql/generic-odbc.lisp
+        Refactored read-sql-value similar to the other recent refactorings
+
+        * the symbol case now uses intern instead of read-from-string
+          (which may not return a symbol and could have security issues
+          since read-eval was not being unset)
+
+        * read-eval is now off for all cases
+
+        * centralized logic into a single case statement, hopefully making
+          this more readable and debuggable
+
+        * TODO: make these refactorings to the oracle backend (I cannot
+          test against oracle and am loathe to change without testing
+
 2013-06-19 Russ Tyndall <russ@acceleration.net>
         * sql/mysql-objects.lisp
         Found and refactored a way some more eql specified methods of

diff --git a/db-mysql/mysql-objects.lisp b/db-mysql/mysql-objects.lisp
index b3baf30c79a45dafdaa174f285118fbabde5b1d1..0a9e7b324e1c1bd8c46cc1f40dc8d15fdfaf1dd7 100644 (file)
--- a/db-mysql/mysql-objects.lisp
+++ b/db-mysql/mysql-objects.lisp
@@ -23,16 +23,3 @@
     (mediumint "MEDIUMINT")
     (t (call-next-method))))
 
-(defmethod read-sql-value (val (type (eql 'boolean)) database
-                           (db-type (eql :mysql)))
-  (declare (ignore database))
-  (etypecase val
-    (string (if (string= "0" val) nil t))
-    (integer (if (zerop val) nil t))))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
-                           (db-type (eql :mysql)))
-  (declare (ignore database))
-  (etypecase val
-    (string (if (string= "0" val) nil t))
-    (integer (if (zerop val) nil t))))

diff --git a/db-postgresql-socket3/sql.lisp b/db-postgresql-socket3/sql.lisp
index db3ba86e8942660c51e73779d5645a4a1251742e..01816379e71a68da3f7d82c0714bad974b756a19 100644 (file)
--- a/db-postgresql-socket3/sql.lisp
+++ b/db-postgresql-socket3/sql.lisp
@@ -325,12 +325,3 @@
   (clsql-sys:initialize-database-type :database-type :postgresql-socket3))
 
 
-;; Type munging functions
-
-(defmethod read-sql-value (val (type (eql 'boolean)) (database postgresql-socket3-database) db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type)
-  (declare (ignore database db-type))
-  val)

diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp
index d64db208b1b3a62b190b4773624ab67cd8adb12b..fd701a9ccd9aa8d35946f53e95365ecc871222f7 100644 (file)
--- a/sql/generic-odbc.lisp
+++ b/sql/generic-odbc.lisp
@@ -44,32 +44,6 @@
           (slot-value db 'list-all-table-columns-fn)
           (intern (symbol-name '#:list-all-table-columns) pkg))))
 
-;;; Object methods
-
-(defmethod read-sql-value (val (type (eql 'boolean))
-                           (database generic-odbc-database)
-                           (db-type (eql :postgresql)))
-  (if (string= "0" val) nil t))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean))
-                           (database generic-odbc-database)
-                           (db-type (eql :postgresql)))
-  (if (string= "0" val) nil t))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database
-                           (db-type (eql :mssql)))
-  (declare (ignore database))
-  (etypecase val
-    (string (if (string= "0" val) nil t))
-    (integer (if (zerop val) nil t))))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
-                           (db-type (eql :mssql)))
-  (declare (ignore database))
-  (etypecase val
-    (string (if (string= "0" val) nil t))
-    (integer (if (zerop val) nil t))))
-
 ;;; Type methods
 
 (defmethod database-get-type-specifier ((type symbol) args database

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index 4197ea23b7efaa70cafbc9317a9c302b41c3d715..1599f17e6fcf00b38cf15089811d23410e9c8fc9 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -576,119 +576,70 @@
               value))
            (otherwise (call-next-method)))))))
 
-(defmethod read-sql-value (val type database db-type)
+(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?
   (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 (eql 'string)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'varchar)) database db-type)
-  (declare (ignore database db-type))
-  val)
-
-(defmethod read-sql-value (val (type (eql 'char)) database db-type)
-  (declare (ignore database db-type))
-  (schar val 0))
-
-(defmethod read-sql-value (val (type (eql 'keyword)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (intern (symbol-name-default-case val)
-            (find-package '#:keyword))))
-
-(defmethod read-sql-value (val (type (eql 'symbol)) database db-type)
-  (declare (ignore database db-type))
-  (when (< 0 (length val))
-    (unless (string= val (symbol-name-default-case "NIL"))
-      (read-from-string val))))
-
-(defmethod read-sql-value (val (type (eql 'integer)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'smallint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'bigint)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (parse-integer val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float (read-from-string val)))
-    (float val)))
-
-(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
-  (declare (ignore database db-type))
-  ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
-  (etypecase val
-    (string (float
-            (let ((*read-default-float-format* 'double-float))
-              (read-from-string val))
-            1.0d0))
-    (double-float val)
-    (float (coerce val 'double-float))))
-
-(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database db-type)
-  (declare (ignore database db-type))
-  (equal "t" val))
-
-(defmethod read-sql-value (val (type (eql 'number)) database db-type)
-  (declare (ignore database db-type))
-  (etypecase val
-    (string
-     (unless (string-equal "NIL" val)
-       (read-from-string val)))
-    (number val)))
-
-(defmethod read-sql-value (val (type (eql 'universal-time)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (etypecase val
-      (string
-       (parse-integer val))
-      (number val))))
-
-(defmethod read-sql-value (val (type (eql 'wall-time)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (parse-timestring val)))
-
-(defmethod read-sql-value (val (type (eql 'date)) database db-type)
-  (declare (ignore database db-type))
-  (unless (eq 'NULL val)
-    (parse-datestring val)))
-
-(defmethod read-sql-value (val (type (eql 'duration)) database db-type)
-  (declare (ignore database db-type))
-  (unless (or (eq 'NULL val)
-              (equal "NIL" val))
-    (parse-timestring val)))
+(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
+         (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)))))
 
 ;; ------------------------------------------------------------
 ;; Logic for 'faulting in' :join slots