From 68290f0275c3193cd0413fb247a1395486747338 Mon Sep 17 00:00:00 2001 From: Marcus Pearce Date: Sun, 2 May 2004 18:24:48 +0000 Subject: [PATCH] r9203: Improved CommonSQL compatibility for SELECT. --- ChangeLog | 15 ++++++ sql/objects.lisp | 34 ++++++++----- tests/test-fdml.lisp | 115 ++++++++++++++++++++++++++---------------- tests/test-ooddl.lisp | 6 ++- tests/test-oodml.lisp | 43 ++++++++++------ 5 files changed, 139 insertions(+), 74 deletions(-) diff --git a/ChangeLog b/ChangeLog index 9fb8510..2c8c6c8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/objects.lisp: fix bug in FIND-ALL when SELECT called with 2 + or more View Classes. + * sql/objects.lisp: make the :flatp argument to SELECT work with + object queries. + * sql/objects.lisp: make SELECT accept a :result-types argument + (defaults to :auto) which is passed on to QUERY. + * sql/objects.lisp: SELECT returns field-names as a second value. + * tests/test-ooddl.lisp: add flatp arg to SELECT calls as appropriate. + * tests/test-fdml.lisp: add flatp/result-types arguments to calls + to SELECT and take only first value as appropriate. + * tests/test-fdml.lisp: add two new tests for query result coercion + and the field-names returned as a second value from SELECT. + * tests/test-oodml.lisp: add flatp arg to SELECT calls as appropriate. + 1 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.10.6-pre1 * sql/metaclasses.lisp: Add void-value slot diff --git a/sql/objects.lisp b/sql/objects.lisp index ef9c0db..ab1a7bc 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -408,7 +408,8 @@ superclass of the newly-defined View Class." (sels (generate-selection-list view-class)) (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table - :where view-qual))))) + :where view-qual) + (list :result-types nil))))) (when res (get-slot-values-from-view instance (mapcar #'car sels) (car res))))) @@ -420,7 +421,8 @@ superclass of the newly-defined View Class." (view-qual (key-qualifier-for-instance instance :database vd)) (slot-def (slotdef-for-slot-with-class slot view-class)) (att-ref (generate-attribute-reference view-class slot-def)) - (res (select att-ref :from view-table :where view-qual))) + (res (select att-ref :from view-table :where view-qual + :result-types nil))) (when res (get-slot-values-from-view instance (list slot-def) (car res))))) @@ -686,7 +688,7 @@ superclass of the newly-defined View Class." (jc (gethash :join-class dbi))) (let ((jq (join-qualifier class object slot-def))) (when jq - (select jc :where jq))))) + (select jc :where jq :flatp t :result-types nil))))) (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) @@ -745,11 +747,14 @@ superclass of the newly-defined View Class." (defun find-all (view-classes &rest args &key all set-operation distinct from where group-by having order-by order-by-descending offset limit - refresh (database *default-database*)) - "tweeze me apart someone pleeze" + refresh flatp (database *default-database*)) + "Called by SELECT to generate object query results when the + View Classes VIEW-CLASSES are passed as arguments to SELECT." (declare (ignore all set-operation group-by having offset limit) (optimize (debug 3) (speed 1))) (remf args :from) + (remf args :flatp) + (remf args :result-types) (labels ((table-sql-expr (table) (sql-expression :table (view-table table))) (ref-equal (ref1 ref2) @@ -771,9 +776,11 @@ superclass of the newly-defined View Class." obj)) (build-objects (vals sclasses sels) (let ((objects (mapcar #'(lambda (sclass sel) - (build-object vals sclass sel)) + (prog1 (build-object vals sclass sel) + (setf vals (nthcdr (list-length sel) + vals)))) sclasses sels))) - (if (= (length sclasses) 1) + (if (and flatp (= (length sclasses) 1)) (car objects) objects)))) (let* ((*db-deserializing* t) @@ -811,7 +818,9 @@ superclass of the newly-defined View Class." (append (mapcar #'cdr fullsels) (cons :from (list (append (when from (listify from)) - (listify tables)))) args))) + (listify tables)))) + (list :result-types nil) + args))) (mapcar #'(lambda (r) (build-objects r sclasses sels)) res)))) (defmethod instance-refreshed ((instance standard-db-object))) @@ -836,11 +845,10 @@ tuples." (apply #'find-all target-args qualifier-args) (let ((expr (apply #'make-query select-all-args))) (destructuring-bind (&key (flatp nil) + (result-types :auto) (database *default-database*) &allow-other-keys) qualifier-args - (let ((res (query expr :database database))) - (if (and flatp - (= (length (slot-value expr 'selections)) 1)) - (mapcar #'car res) - res)))))))) + (query expr :flatp flatp :result-types result-types + :database database))))))) + diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index f3b9d13..aaa6c2c 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -172,84 +172,113 @@ (let ((max (clsql:select [function "floor" [/ [* [max [height]] 100] 2.54]] :from [employee] + :result-types nil :flatp t)) (min (clsql:select [function "floor" [/ [* [min [height]] 100] 2.54]] :from [employee] + :result-types nil :flatp t)) (avg (clsql:select [function "floor" [avg [/ [* [height] 100] 2.54]]] :from [employee] + :result-types nil :flatp t))) (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (append min avg max)))) - t) + (append min avg max)))) + t) (deftest :fdml/select/2 - (clsql:select [first-name] :from [employee] :flatp t :distinct t - :order-by [first-name]) - ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir" - "Yuri")) + (values (clsql:select [first-name] :from [employee] :flatp t :distinct t + :result-types nil + :order-by [first-name])) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir" + "Yuri")) (deftest :fdml/select/3 - (clsql:select [first-name] [count [*]] :from [employee] - :group-by [first-name] - :order-by [first-name]) - (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") - ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1"))) + (values (clsql:select [first-name] [count [*]] :from [employee] + :result-types nil + :group-by [first-name] + :order-by [first-name])) + (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") + ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1"))) (deftest :fdml/select/4 - (clsql:select [last-name] :from [employee] :where [like [email] "%org"] - :order-by [last-name] - :flatp t) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) + (values (clsql:select [last-name] :from [employee] + :where [like [email] "%org"] + :order-by [last-name] + :result-types nil + :flatp t)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/5 - (clsql:select [email] :from [employee] :flatp t - :where [in [employee emplid] - [select [managerid] :from [employee]]]) - ("lenin@soviet.org")) + (values (clsql:select [email] :from [employee] :flatp t :result-types nil + :where [in [employee emplid] + [select [managerid] :from [employee]]])) + ("lenin@soviet.org")) (deftest :fdml/select/6 (if (db-type-has-fancy-math? *test-database-underlying-type*) (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (clsql:select [function "trunc" [height]] :from [employee] - :flatp t)) - (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) - (clsql:select [height] :from [employee] :flatp t))) - (1 1 1 1 1 1 1 1 1 1)) + (clsql:select [function "trunc" [height]] :from [employee] + :result-types nil + :flatp t)) + (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) + (clsql:select [height] :from [employee] :flatp t + :result-types nil))) + (1 1 1 1 1 1 1 1 1 1)) (deftest :fdml/select/7 - (clsql:select [max [emplid]] :from [employee] :flatp t) - ("10")) + (values + (clsql:select [max [emplid]] :from [employee] :flatp t :result-types nil)) + ("10")) (deftest :fdml/select/8 - (clsql:select [min [emplid]] :from [employee] :flatp t) - ("1")) + (values + (clsql:select [min [emplid]] :from [employee] :flatp t :result-types nil)) + ("1")) (deftest :fdml/select/9 - (subseq (car (clsql:select [avg [emplid]] :from [employee] :flatp t)) 0 3) - "5.5") + (subseq + (car + (clsql:select [avg [emplid]] :from [employee] :flatp t :result-types nil)) + 0 3) + "5.5") (deftest :fdml/select/10 - (clsql:select [last-name] :from [employee] - :where [not [in [emplid] - [select [managerid] :from [company]]]] - :flatp t - :order-by [last-name]) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" - "Trotsky" "Yeltsin")) + (values (clsql:select [last-name] :from [employee] + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :result-types nil + :flatp t + :order-by [last-name])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) (deftest :fdml/select/11 - (clsql:select [last-name] :from [employee] :where [married] :flatp t - :order-by [emplid]) - ("Lenin" "Stalin" "Trotsky")) + (values (clsql:select [last-name] :from [employee] :where [married] :flatp t + :order-by [emplid] :result-types nil)) + ("Lenin" "Stalin" "Trotsky")) (deftest :fdml/select/12 (let ((v 1)) - (clsql:select [last-name] :from [employee] :where [= [emplid] v])) - (("Lenin"))) + (values (clsql:select [last-name] :from [employee] :where [= [emplid] v] + :result-types nil))) + (("Lenin"))) + +(deftest :fdml/select/13 + (multiple-value-bind (results field-names) + (clsql:select [emplid] [last-name] [married] :from [employee] + :where [= [emplid] 1]) + (values results (mapcar #'string-downcase field-names))) + ((1 "Lenin" "t")) + ("emplid" "last_name" "married")) + +(deftest :fdml/select/14 + (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] + :flatp t))) + t) ;(deftest :fdml/select/11 ; (clsql:select [emplid] :from [employee] diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp index feb827b..3bbaa2d 100644 --- a/tests/test-ooddl.lisp +++ b/tests/test-ooddl.lisp @@ -67,7 +67,8 @@ (clsql:execute-command "set datestyle to 'iso'")) (clsql:update-records [employee] :av-pairs `((birthday ,now)) :where [= [emplid] 1]) - (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now])))) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) (values (slot-value dbobj 'last-name) (clsql-base:time= (slot-value dbobj 'birthday) now)))) @@ -81,7 +82,8 @@ (dotimes (x 40) (clsql:update-records [employee] :av-pairs `((birthday ,now)) :where [= [emplid] 1]) - (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now])))) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) (unless (clsql-base:time= (slot-value dbobj 'birthday) now) (setf fail-index x)) (setf now (clsql-base:roll now :day (* 10 x))))) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index c586726..797c84f 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -24,22 +24,23 @@ (deftest :oodml/select/1 (mapcar #'(lambda (e) (slot-value e 'last-name)) - (clsql:select 'employee :order-by [last-name])) + (clsql:select 'employee :order-by [last-name] :flatp t)) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :oodml/select/2 (mapcar #'(lambda (e) (slot-value e 'name)) - (clsql:select 'company)) + (clsql:select 'company :flatp t)) ("Widgets Inc.")) (deftest :oodml/select/3 (mapcar #'(lambda (e) (slot-value e 'companyid)) (clsql:select 'employee - :where [and [= [slot-value 'employee 'companyid] - [slot-value 'company 'companyid]] - [= [slot-value 'company 'name] - "Widgets Inc."]])) + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]] + :flatp t)) (1 1 1 1 1 1 1 1 1 1)) (deftest :oodml/select/4 @@ -49,12 +50,13 @@ (slot-value e 'last-name))) (clsql:select 'employee :where [= [slot-value 'employee 'first-name] "Vladamir"] + :flatp t :order-by [last-name])) ("Vladamir Lenin" "Vladamir Putin")) ;; sqlite fails this because it is typeless (deftest :oodml/select/5 - (length (clsql:select 'employee :where [married])) + (length (clsql:select 'employee :where [married] :flatp t)) 3) ;; tests update-records-from-instance @@ -63,7 +65,8 @@ (progn (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " @@ -77,7 +80,8 @@ (clsql:update-records-from-instance employee1) (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " @@ -91,7 +95,8 @@ (clsql:update-records-from-instance employee1) (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " @@ -107,19 +112,22 @@ (values (employee-email (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1]))) + :where [= [slot-value 'employee 'emplid] 1] + :flatp t))) (progn (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") (clsql:update-record-from-slot employee1 'email) (employee-email (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1])))) + :where [= [slot-value 'employee 'emplid] 1] + :flatp t)))) (progn (setf (slot-value employee1 'email) "lenin@soviet.org") (clsql:update-record-from-slot employee1 'email) (employee-email (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1]))))) + :where [= [slot-value 'employee 'emplid] 1] + :flatp t))))) "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") ;; tests update-record-from-slots @@ -127,7 +135,8 @@ (values (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " @@ -141,7 +150,8 @@ (clsql:update-record-from-slots employee1 '(first-name last-name email)) (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " @@ -155,7 +165,8 @@ (clsql:update-record-from-slots employee1 '(first-name last-name email)) (let ((lenin (car (clsql:select 'employee :where [= [slot-value 'employee 'emplid] - 1])))) + 1] + :flatp t)))) (concatenate 'string (first-name lenin) " " -- 2.34.1