From: Russ Tyndall Date: Wed, 23 Apr 2014 20:22:10 +0000 (-0400) Subject: initial patch for symbol storage refactoring X-Git-Tag: v6.6.0~14 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=31ae82f1e0aefcdd11a25239b6fb21c13d38d9f2 initial patch for symbol storage refactoring --- diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 3ef9412..6fc1af5 100644 --- a/sql/conditions.lisp +++ b/sql/conditions.lisp @@ -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))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index 44c3e9e..f2ed8c9 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -555,6 +555,10 @@ 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) @@ -573,11 +577,8 @@ (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)) @@ -591,70 +592,76 @@ 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 diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 953a604..63e1d50 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -21,6 +21,33 @@ (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))