From 4f756ab532ff033a34597a1c8030379e252952ca Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Thu, 20 Jun 2013 15:12:31 -0400 Subject: [PATCH] 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 --- ChangeLog | 17 ++++ db-mysql/mysql-objects.lisp | 13 --- db-postgresql-socket3/sql.lisp | 9 -- sql/generic-odbc.lisp | 26 ------ sql/oodml.lisp | 163 ++++++++++++--------------------- 5 files changed, 74 insertions(+), 154 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8dbbf35..5cf44bc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2013-06-19 Russ Tyndall + * 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 * 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 b3baf30..0a9e7b3 100644 --- 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 db3ba86..0181637 100644 --- 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 d64db20..fd701a9 100644 --- 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 4197ea2..1599f17 100644 --- 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 -- 2.34.1