From: Russ Tyndall Date: Sun, 8 Jun 2014 19:13:39 +0000 (-0400) Subject: merged changelog X-Git-Tag: v6.6.0~12 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=39b6e9ac28542f8caed16d584446816db4184afa;hp=180b52cb686a87487e12e87b13bafe131e6c3bef merged changelog --- diff --git a/ChangeLog b/ChangeLog index 842aa27..99487fb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2014-04-24 Russ Tyndall + * oodml.lisp, test-oodml.lisp Better handling of view-slots of + type symbol/keyword. Better handling of printing and reading + bindings (per mailing list request, always read and write in base + 10) + 2014-03-04 Kevin Rosenberg * Version 6.5.0: New release * makefile.common: Check for /usr/bin/dpkg-buildflags diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 3ef9412..1969b96 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) + (continue () + :report "Continue using the unconverted value" + (values val t)) + (use-value (new-val) + :report "Use a different value instead of this failed conversion" + (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..169fa89 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -524,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*))) @@ -555,106 +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) - (*print-length* nil) - (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 diff --git a/tests/ds-employees.lisp b/tests/ds-employees.lisp index 1b1e36b..2611053 100644 --- a/tests/ds-employees.lisp +++ b/tests/ds-employees.lisp @@ -45,6 +45,10 @@ :db-constraints :not-null :type integer :initarg :groupid) + (title + :accessor title + :type symbol + :initarg :title) (first-name :accessor first-name :type (varchar 30) @@ -192,6 +196,7 @@ :emplid 1 :groupid 1 :married t + :title 'supplicant :height (1+ (random 1.00)) :bd-utime *test-start-utime* :birthday now-time @@ -202,6 +207,7 @@ employee2 (make-instance 'employee :emplid 2 :groupid 1 + :title :adherent :height (1+ (random 1.00)) :married t :bd-utime *test-start-utime* @@ -214,6 +220,7 @@ employee3 (make-instance 'employee :emplid 3 :groupid 1 + :title 'cl-user::novice :height (1+ (random 1.00)) :married t :bd-utime *test-start-utime* diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 953a604..042fd48 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)) @@ -275,6 +302,14 @@ (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil))) (10 10 nil nil nil nil)) +(deftest :oodm/retrieval/10-slot-columns + (with-dataset *ds-employees* + (mapcar #'title + (select 'employee :flatp t :caching nil + :where [<= [emplid] 3] + :order-by `((,[emplid] :asc))))) + (supplicant :adherent cl-user::novice)) + ;; tests update-records-from-instance (deftest :oodml/update-records/1 (with-dataset *ds-employees*