From 1751e5245c270bd1ee854a98dfe6caa665abe34e Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 3 May 2004 01:58:23 +0000 Subject: [PATCH] r9204: Get DO-QUERY and MAP-QUERY working with object queries and add :field-names argument to SELECT. --- ChangeLog | 17 +++++++++ TODO | 22 ++++++------ base/basic-sql.lisp | 83 ++++++++++++++++++++++++++----------------- sql/classes.lisp | 40 ++++++++++++--------- sql/generics.lisp | 32 +++++++++++++++++ sql/objects.lisp | 5 +-- sql/sql.lisp | 4 +-- tests/test-basic.lisp | 4 +-- tests/test-fdml.lisp | 71 +++++++++++++++++++----------------- tests/test-oodml.lisp | 37 ++++++++++++++----- tests/utils.lisp | 1 + 11 files changed, 207 insertions(+), 109 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2c8c6c8..4cdb54f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,20 @@ +2 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/generics.lisp: add generic function for SELECT. + * sql/objects.lisp: make SELECT a method specialisation. + * sql/classes.lisp: MAKE-QUERY now calls SELECT if the selections + referred to are View Classes. + * base/basic-sql.lisp: in DO-QUERY and MAP-QUERY, if the + query-expression arg evaluates to a list, then we have an object + query. + * tests/test-oodml.lisp: add tests for DO-QUERY and MAP-QUERY with + object queries. + * TODO: remove items done and add a todo for SELECT. + * sql/objects.lisp: SELECT takes a :field-names arg to pass on to + QUERY. + * sql/sql.lisp: add :field-names arg to QUERY. + * tests/test-fdml.lisp: minor rework to use :field-names arg to + SELECT. + 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. diff --git a/TODO b/TODO index 1aca8f2..6b6e144 100644 --- a/TODO +++ b/TODO @@ -2,14 +2,16 @@ GENERAL * port Oracle backend to UFFI. * consider adding large object support to mysql and odbc +* add support for prepared statements. TESTS TO ADD * CACHE-TABLE-QUERIES -* :VOID-VALUE, use a new view-class with several fields with different void-values -* :db-kind :key adds an index for that key, complicated by different - backends show autogenerated primary key in different ways. -* New universal and bigint types, add tests for other types +* :VOID-VALUE attribute, use a new view-class with several fields with different void-values +* :COLUMN attribute +* Test that ":db-kind :key" adds an index for that key. This is complicated by different + backends showing autogenerated primary key in different ways. +* Test New universal and bigint types, add tests for other types such as duration and money * Large object testing COMMONSQL SPEC @@ -24,12 +26,9 @@ COMMONSQL SPEC SELECT o keyword arg :refresh should function as advertised - o should return (values result-list field-names) - o should coerce values returned as strings to appropriate lisp type - - QUERY - o should coerce values returned as strings to appropriate lisp type - for SQLite backend + o should accept type-modified database identifiers (e.g., + [foo :string] which means that the values in column foo are returned + as Lisp strings) >> The object-oriented sql interface @@ -37,10 +36,9 @@ COMMONSQL SPEC o get :target-slot working o implement :retrieval :immediate - DO-QUERY,MAP-QUERY,LOOP + LOOP o should work with object queries as well as functional ones - >> Symbolic SQL syntax o Complete sql expressions (see operations.lisp) diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 86f8267..b0a2dad 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -63,47 +63,64 @@ pair.")) (defmacro do-query (((&rest args) query-expression &key (database '*default-database*) (result-types nil)) &body body) - "Repeatedly executes BODY within a binding of ARGS on the attributes -of each record resulting from QUERY. The return value is determined by -the result of executing BODY. The default value of DATABASE is -*DEFAULT-DATABASE*." + "Repeatedly executes BODY within a binding of ARGS on the +attributes of each record resulting from QUERY-EXPRESSION. The +return value is determined by the result of executing BODY. The +default value of DATABASE is *DEFAULT-DATABASE*." (let ((result-set (gensym)) (columns (gensym)) (row (gensym)) (db (gensym))) - `(let ((,db ,database)) - (multiple-value-bind (,result-set ,columns) - (database-query-result-set ,query-expression ,db - :full-set nil :result-types ,result-types) - (when ,result-set - (unwind-protect - (do ((,row (make-list ,columns))) - ((not (database-store-next-row ,result-set ,db ,row)) - nil) - (destructuring-bind ,args ,row - ,@body)) - (database-dump-result-set ,result-set ,db))))))) + `(if (listp ,query-expression) + ;; Object query + (dolist (,row ,query-expression) + (destructuring-bind ,args + ,row + ,@body)) + ;; Functional query + (let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,query-expression ,db + :full-set nil + :result-types ,result-types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db)))))))) (defun map-query (output-type-spec function query-expression &key (database *default-database*) (result-types nil)) - "Map the function over all tuples that are returned by the query in -query-expression. The results of the function are collected as -specified in output-type-spec and returned like in MAP." - (macrolet ((type-specifier-atom (type) - `(if (atom ,type) ,type (car ,type)))) - (case (type-specifier-atom output-type-spec) - ((nil) - (map-query-for-effect function query-expression database result-types)) - (list - (map-query-to-list function query-expression database result-types)) - ((simple-vector simple-string vector string array simple-array - bit-vector simple-bit-vector base-string - simple-base-string) - (map-query-to-simple output-type-spec function query-expression database result-types)) - (t - (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t) - function query-expression :database database :result-types result-types))))) + "Map the function over all tuples that are returned by the +query in QUERY-EXPRESSION. The results of the function are +collected as specified in OUTPUT-TYPE-SPEC and returned like in +MAP." + (if (listp query-expression) + ;; Object query + (map output-type-spec #'(lambda (x) (apply function x)) query-expression) + ;; Functional query + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database + result-types)) + (list + (map-query-to-list function query-expression database result-types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression + database result-types)) + (t + (funcall #'map-query + (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database + :result-types result-types)))))) (defun map-query-for-effect (function query-expression database result-types) (multiple-value-bind (result-set columns) diff --git a/sql/classes.lisp b/sql/classes.lisp index df84cd4..b7cd0c6 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -436,22 +436,30 @@ uninclusive, and the args from that keyword to the end." select-args))) (defun make-query (&rest args) - (multiple-value-bind (selections arglist) - (query-get-selections args) - (destructuring-bind (&key all flatp set-operation distinct from where - group-by having order-by order-by-descending - offset limit &allow-other-keys) - arglist - (if (null selections) - (error "No target columns supplied to select statement.")) - (if (null from) - (error "No source tables supplied to select statement.")) - (make-instance 'sql-query :selections selections - :all all :flatp flatp :set-operation set-operation - :distinct distinct :from from :where where - :limit limit :offset offset - :group-by group-by :having having :order-by order-by - :order-by-descending order-by-descending)))) + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)))) + (multiple-value-bind (selections arglist) + (query-get-selections args) + (if (select-objects selections) + (apply #'select args) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by order-by-descending + offset limit &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :order-by-descending order-by-descending)))))) (defvar *in-subselect* nil) diff --git a/sql/generics.lisp b/sql/generics.lisp index a7c8be1..f38b80b 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -18,6 +18,38 @@ (in-package #:clsql-sys) +(defgeneric select (&rest args) + (:documentation + "The function SELECT selects data from DATABASE, which has a +default value of *DEFAULT-DATABASE*, given the constraints +specified by the rest of the ARGS. It returns a list of objects +as specified by SELECTIONS. By default, the objects will each be +represented as lists of attribute values. The argument SELECTIONS +consists either of database identifiers, type-modified database +identifiers or literal strings. A type-modifed database +identifier is an expression such as [foo :string] which means +that the values in column foo are returned as Lisp strings. The +FLATP argument, which has a default value of nil, specifies if +full bracketed results should be returned for each matched +entry. If FLATP is nil, the results are returned as a list of +lists. If FLATP is t, the results are returned as elements of a +list, only if there is only one result per row. The arguments +ALL, SET-OPERATION, DISTINCT, FROM, WHERE, GROUP-BY, HAVING and +ORDER-by have the same function as the equivalent SQL expression. +The SELECT function is common across both the functional and +object-oriented SQL interfaces. If selections refers to View +Classes then the select operation becomes object-oriented. This +means that SELECT returns a list of View Class instances, and +SLOT-VALUE becomes a valid SQL operator for use within the where +clause. In the View Class case, a second equivalent select call +will return the same View Class instance objects. If REFRESH is +true, then existing instances are updated if necessary, and in +this case you might need to extend the hook INSTANCE-REFRESHED. +The default value of REFRESH is nil. SQL expressions used in the +SELECT function are specified using the square bracket syntax, +once this syntax has been enabled using +ENABLE-SQL-READER-SYNTAX.")) + (defgeneric update-record-from-slot (object slot &key database) (:documentation "The generic function UPDATE-RECORD-FROM-SLOT updates an individual diff --git a/sql/objects.lisp b/sql/objects.lisp index ab1a7bc..a995c22 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -825,7 +825,7 @@ superclass of the newly-defined View Class." (defmethod instance-refreshed ((instance standard-db-object))) -(defun select (&rest select-all-args) +(defmethod select (&rest select-all-args) "Selects data from database given the constraints specified. Returns a list of lists of record values as specified by select-all-args. By default, the records are each represented as lists of attribute @@ -846,9 +846,10 @@ tuples." (let ((expr (apply #'make-query select-all-args))) (destructuring-bind (&key (flatp nil) (result-types :auto) + (field-names t) (database *default-database*) &allow-other-keys) qualifier-args (query expr :flatp flatp :result-types result-types - :database database))))))) + :field-names field-names :database database))))))) diff --git a/sql/sql.lisp b/sql/sql.lisp index 8107bd9..c1133b4 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -29,9 +29,9 @@ (defmethod query ((expr %sql-expression) &key (database *default-database*) - (result-types nil) (flatp nil)) + (result-types nil) (flatp nil) (field-names t)) (query (sql-output expr database) :database database :flatp flatp - :result-types result-types)) + :result-types result-types :field-names field-names)) (defun truncate-database (&key (database *default-database*)) (unless (typep database 'database) diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index a6a501e..37639e3 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -45,9 +45,7 @@ (destructuring-bind (int float bigint str) row (push (list (integerp int) (typep float 'double-float) - (if (member *test-database-type* '(:odbc :aodbc)) - t - (integerp bigint)) + (integerp bigint) (stringp str)) results)))) ((t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t) (t t t t))) diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index aaa6c2c..39aac72 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -189,83 +189,90 @@ t) (deftest :fdml/select/2 - (values (clsql:select [first-name] :from [employee] :flatp t :distinct t - :result-types nil - :order-by [first-name])) + (clsql:select [first-name] :from [employee] :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name]) ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir" "Yuri")) (deftest :fdml/select/3 - (values (clsql:select [first-name] [count [*]] :from [employee] + (clsql:select [first-name] [count [*]] :from [employee] :result-types nil :group-by [first-name] - :order-by [first-name])) + :order-by [first-name] + :field-names nil) (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1"))) (deftest :fdml/select/4 - (values (clsql:select [last-name] :from [employee] + (clsql:select [last-name] :from [employee] :where [like [email] "%org"] :order-by [last-name] + :field-names nil :result-types nil - :flatp t)) + :flatp t) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/5 - (values (clsql:select [email] :from [employee] :flatp t :result-types nil + (clsql:select [email] :from [employee] :flatp t :result-types nil :where [in [employee emplid] - [select [managerid] :from [employee]]])) - ("lenin@soviet.org")) + [select [managerid] :from [employee]]] + :field-names nil) + ("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] :result-types nil + :field-names nil :flatp t)) (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) (clsql:select [height] :from [employee] :flatp t - :result-types nil))) + :field-names nil :result-types nil))) (1 1 1 1 1 1 1 1 1 1)) (deftest :fdml/select/7 - (values - (clsql:select [max [emplid]] :from [employee] :flatp t :result-types nil)) - ("10")) + (clsql:select [max [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil) + ("10")) (deftest :fdml/select/8 - (values - (clsql:select [min [emplid]] :from [employee] :flatp t :result-types nil)) - ("1")) + (clsql:select [min [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil) + ("1")) (deftest :fdml/select/9 (subseq (car - (clsql:select [avg [emplid]] :from [employee] :flatp t :result-types nil)) + (clsql:select [avg [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)) 0 3) - "5.5") + "5.5") (deftest :fdml/select/10 - (values (clsql:select [last-name] :from [employee] - :where [not [in [emplid] - [select [managerid] :from [company]]]] - :result-types nil - :flatp t - :order-by [last-name])) + (clsql:select [last-name] :from [employee] + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :result-types nil + :field-names nil + :flatp t + :order-by [last-name]) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/11 - (values (clsql:select [last-name] :from [employee] :where [married] :flatp t - :order-by [emplid] :result-types nil)) - ("Lenin" "Stalin" "Trotsky")) + (clsql:select [last-name] :from [employee] :where [married] :flatp t + :field-names nil :order-by [emplid] :result-types nil) + ("Lenin" "Stalin" "Trotsky")) (deftest :fdml/select/12 (let ((v 1)) - (values (clsql:select [last-name] :from [employee] :where [= [emplid] v] - :result-types nil))) - (("Lenin"))) + (clsql:select [last-name] :from [employee] :where [= [emplid] v] + :field-names nil :result-types nil)) + (("Lenin"))) (deftest :fdml/select/13 (multiple-value-bind (results field-names) @@ -278,7 +285,7 @@ (deftest :fdml/select/14 (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] :flatp t))) - t) + t) ;(deftest :fdml/select/11 ; (clsql:select [emplid] :from [employee] diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 797c84f..6ea820a 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -235,16 +235,35 @@ "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") -;(deftest :oodml/iteration/1 -; (clsql:do-query ((e) [select 'clsql-tests::employee :where [married] -; :order-by [emplid]]) -; (slot-value e last-name)) -; ("Lenin" "Stalin" "Trotsky")) +(deftest :oodml/do-query/1 + (let ((result '())) + (clsql:do-query ((e) [select 'employee :order-by [emplid]]) + (push (slot-value e 'last-name) result)) + result) + ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" + "Trotsky" "Stalin" "Lenin")) -;(deftest :oodml/iteration/2 -; (clsql:map-query 'list #'last-name [select 'employee :where [married] -; :order-by [emplid]]) -; ("Lenin" "Stalin" "Trotsky")) +(deftest :oodml/do-query/2 + (let ((result '())) + (clsql:do-query ((e c) [select 'employee 'company + :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (push (list (slot-value e 'last-name) (slot-value c 'name)) + result)) + result) + (("Lenin" "Widgets Inc."))) + +(deftest :oodml/map-query/1 + (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]]) + ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" + "Gorbachev" "Yeltsin" "Putin")) + +(deftest :oodml/map-query/2 + (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) + (slot-value c 'name))) + [select 'employee 'company :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (("Lenin" "Widgets Inc."))) ;(deftest :oodml/iteration/3 ; (loop for (e) being the tuples in diff --git a/tests/utils.lisp b/tests/utils.lisp index 1928bf4..fd94021 100644 --- a/tests/utils.lisp +++ b/tests/utils.lisp @@ -79,6 +79,7 @@ impl-version machine-type) form + (declare (ignoreable utime impl-version)) (if failed-tests (format output "~&~A: ~D of ~D tests failed (~A, ~A).~&" (db-title db-type underlying-db-type) -- 2.34.1