From c1d990950afa607b9d7e428da384b057fd5c74f3 Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Thu, 24 Apr 2014 14:12:52 -0400 Subject: [PATCH] Added tests for symbols valued slots, and better printer/reader bindings --- ChangeLog | 6 ++++ sql/conditions.lisp | 8 +++--- sql/oodml.lisp | 63 ++++++++++++++++++++--------------------- tests/ds-employees.lisp | 7 +++++ tests/test-oodml.lisp | 16 ++++++++--- 5 files changed, 60 insertions(+), 40 deletions(-) diff --git a/ChangeLog b/ChangeLog index 61d09c1..44b0567 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-02-24 Russ Tyndall * oodml.lisp bind *print-length* to nil before printing lists/arrays to the database. diff --git a/sql/conditions.lisp b/sql/conditions.lisp index 6fc1af5..1969b96 100644 --- a/sql/conditions.lisp +++ b/sql/conditions.lisp @@ -153,11 +153,11 @@ connection is no longer usable.")) (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 - (lambda (stream) - (write-sequence - "Use a different value instead of this failed conversion" stream)) + :report "Use a different value instead of this failed conversion" (values new-val t) ))) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index f2ed8c9..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*))) @@ -559,43 +559,44 @@ (*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) - -(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 - ((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) - (let* ((*print-circle* t) - (*print-array* t) - (*print-length* nil) - (value (prin1-to-string val))) - value)) - (otherwise (call-next-method))))))) + ((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 - &aux *read-eval*) + ;; never eval while reading values, always read base 10 + &aux *read-eval* (*read-base* #10r10)) (declare (ignore db-type)) (cond ;; null value or type @@ -621,9 +622,7 @@ (maybe-error-converting-value res val type database))))) -(defmethod read-sql-value (val type database db-type - ;; never eval while reading values - &aux *read-eval*) +(defmethod read-sql-value (val type database db-type) ;; errors, nulls and preconverted types are already handled in around (typecase type (symbol 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 63e1d50..042fd48 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -25,19 +25,19 @@ (clsql-sys::read-sql-value (clsql-sys::database-output-sql-as-type 'symbol 'clsql-tests::foo nil nil) 'symbol nil nil) - '(clsql-tests::foo)) + 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)) + 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)) + :foo) (deftest :oodml/read-symbol-value/4-keyword-error (handler-case @@ -46,7 +46,7 @@ 'keyword nil nil) (clsql-sys::sql-value-conversion-error (c) (declare (ignore c)) :error)) - '(:error)) + :error) (deftest :oodml/select/1 (with-dataset *ds-employees* @@ -302,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* -- 2.34.1