From e303385b84c6246c7d60ebd95d764a282a181a23 Mon Sep 17 00:00:00 2001 From: Marcus Pearce Date: Sun, 16 May 2004 01:05:48 +0000 Subject: [PATCH] r9364: Various fixes from CommonSQL Tutorial. --- ChangeLog | 38 ++++-- TODO | 9 +- .../postgresql-socket-sql.lisp | 19 ++- db-postgresql/postgresql-sql.lisp | 19 ++- sql/classes.lisp | 27 +++- sql/operations.lisp | 29 +++-- sql/sql.lisp | 115 +++++++++++------- tests/test-basic.lisp | 6 +- tests/test-fdml.lisp | 5 + tests/test-syntax.lisp | 21 +++- 10 files changed, 183 insertions(+), 105 deletions(-) diff --git a/ChangeLog b/ChangeLog index ada36bd..c555bdc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,11 +1,35 @@ 15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) - * sql/classes.lisp: SELECT now accepts table identifiers as strings - for CommonSQL compliance. Add support for qualified sql identifiers - with aliased table names. - * tests/test-fdml.lisp: added tests for table identifiers as strings - in SELECT and for aliased definitions. - * tests/test-syntax.lisp: added tests for alias definitions. - + * sql/operations.lisp: make MINUS operator a synonym for EXCEPT. Add + COALESCE operator and make NVL a synonym for this. Make ANY, SOME, + ALL and EXISTS generate function expressions so they output the + correct SQL. + * sql/classes.lisp: SELECT now generates appropriate SQL when + passed the SET-OPERATION and ALL keyword arguments. + * sql/classes.lisp: the ORDER-BY keyword argument to SELECT now + accepts ordering constraints as pairs of the form (column direction) + where direction may be :ASC or :DESC. + * tests/test-syntax.lisp: added tests for MINUS and COALESCE/NVL. + Correct tests for ANY, SOME, ALL and EXISTS. + * tests/test-fdml.lisp: added test for COALESCE. + * sql/sql.lisp: MAP-QUERY now applies FUNCTION to QUERY-EXPRESSION + using funcall unless QUERY-EXPRESSION returns one column and its + FLATP slot is not nil in which case apply is used. + * tests/test-basic.lisp: modified calls to MAP-QUERY to reflect the + changes. + * TODO: remove items done. + * db-postgresql/postgresql-sql.lisp: no need to reverse results in + DATABASE-LIST-ATTRIBUTES. + * db-postgresql-socket/postgresql-socket-sql.lisp: no need to reverse + results in DATABASE-LIST-ATTRIBUTES. + +15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) + * sql/classes.lisp: SELECT now accepts table identifiers as strings + for CommonSQL compliance. Add support for qualified sql identifiers + with aliased table names. + * tests/test-fdml.lisp: added tests for table identifiers as strings + in SELECT and for aliased definitions. + * tests/test-syntax.lisp: added tests for alias definitions. + 15 May 2004 Marcus Pearce (m.t.pearce@city.ac.uk) * sql/sql.lisp: PRINT-QUERY now calls QUERY with result-types and field-names set to nil. diff --git a/TODO b/TODO index 8f59a61..bf7884a 100644 --- a/TODO +++ b/TODO @@ -22,14 +22,7 @@ COMMONSQL SPEC >> Symbolic SQL syntax - o Complete sql expressions (see operations.lisp) - - nvl (Oracle specific) - userenv (Oracle specific) - minus (Oracle specific: does the same as EXCEPT) - - o variables (e.g., table identifiers) should be instantiated at runtime - + o userenv (Oracle specific but deprecated in Oracle 9) VARIANCES FROM COMMONSQL diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index ebda22c..a0a534a 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -392,16 +392,15 @@ doesn't depend on UFFI." owner-clause) database nil nil)))) (if result - (reverse - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result))))) + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result)))) (defmethod database-attribute-type (attribute (table string) (database postgresql-socket-database) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 2bb7fb1..0dc3f57 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -444,16 +444,15 @@ owner-clause) database nil nil)))) (if result - (reverse - (remove-if #'(lambda (it) (member it '("cmin" - "cmax" - "xmax" - "xmin" - "oid" - "ctid" - ;; kmr -- added tableoid - "tableoid") :test #'equal)) - result))))) + (remove-if #'(lambda (it) (member it '("cmin" + "cmax" + "xmax" + "xmin" + "oid" + "ctid" + ;; kmr -- added tableoid + "tableoid") :test #'equal)) + result)))) (defmethod database-attribute-type (attribute (table string) (database postgresql-database) diff --git a/sql/classes.lisp b/sql/classes.lisp index 872830f..af3ca8d 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -439,6 +439,9 @@ (let ((subs (if (consp (car sub-expressions)) (car sub-expressions) sub-expressions))) + (when (= (length subs) 1) + (output-sql operator database) + (write-char #\Space *sql-stream*)) (do ((sub subs (cdr sub))) ((null (cdr sub)) (output-sql (car sub) database)) (output-sql (car sub) database) @@ -568,12 +571,15 @@ uninclusive, and the args from that keyword to the end." (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by - order-by-descending limit offset inner-join on) + order-by-descending limit offset inner-join on + all set-operation) query (when *in-subselect* (write-string "(" *sql-stream*)) (write-string "SELECT " *sql-stream*) - (when distinct + (when all + (write-string "ALL " *sql-stream*)) + (when (and distinct (not all)) (write-string "DISTINCT " *sql-stream*) (unless (eql t distinct) (write-string "ON " *sql-stream*) @@ -609,9 +615,15 @@ uninclusive, and the args from that keyword to the end." (if (listp order-by) (do ((order order-by (cdr order))) ((null order)) - (output-sql (car order) database) - (when (cdr order) - (write-char #\, *sql-stream*))) + (let ((item (car order))) + (typecase item + (cons + (output-sql (car item) database) + (format *sql-stream* " ~A" (cadr item))) + (t + (output-sql item database))) + (when (cdr order) + (write-char #\, *sql-stream*)))) (output-sql order-by database))) (when order-by-descending (write-string " ORDER BY " *sql-stream*) @@ -630,7 +642,10 @@ uninclusive, and the args from that keyword to the end." (write-string " OFFSET " *sql-stream*) (output-sql offset database)) (when *in-subselect* - (write-string ")" *sql-stream*))) + (write-string ")" *sql-stream*)) + (when set-operation + (write-char #\Space *sql-stream*) + (output-sql set-operation database))) t) (defmethod output-sql ((query sql-object-query) database) diff --git a/sql/operations.lisp b/sql/operations.lisp index bdbb929..bc99d2a 100644 --- a/sql/operations.lisp +++ b/sql/operations.lisp @@ -37,16 +37,16 @@ (apply #'make-query args)) (defsql sql-any (:symbol "any") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'any :components rest)) + (make-instance 'sql-function-exp + :name 'any :args rest)) (defsql sql-some (:symbol "some") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'some :components rest)) + (make-instance 'sql-function-exp + :name 'some :args rest)) (defsql sql-all (:symbol "all") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'all :components rest)) + (make-instance 'sql-function-exp + :name 'all :args rest)) (defsql sql-not (:symbol "not") (&rest rest) (make-instance 'sql-value-exp @@ -65,8 +65,8 @@ :operator 'except :sub-expressions rest)) (defsql sql-minus (:symbol "minus") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'minus :components rest)) + (make-instance 'sql-set-exp + :operator 'except :sub-expressions rest)) (defsql sql-limit (:symbol "limit") (&rest rest) (make-instance 'sql-query-modifier-exp @@ -95,8 +95,8 @@ :components '|NOT NULL|)) (defsql sql-exists (:symbol "exists") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'exists :components rest)) + (make-instance 'sql-function-exp + :name 'exists :args rest)) (defsql sql-* (:symbol "*") (&rest rest) (if (zerop (length rest)) @@ -137,7 +137,7 @@ (defsql sql-in (:symbol "in") (&rest rest) (make-instance 'sql-relational-exp - :operator 'in :sub-expressions rest)) + :operator 'in :sub-expressions rest)) (defsql sql-concat (:symbol "concat") (&rest rest) (make-instance 'sql-relational-exp @@ -219,3 +219,10 @@ (make-instance 'sql-query-modifier-exp :modifier 'distinct :components rest)) +(defsql sql-coalesce (:symbol "coalesce") (&rest rest) + (make-instance 'sql-function-exp + :name 'coalesce :args rest)) + +(defsql sql-nvl (:symbol "nvl") (&rest rest) + (make-instance 'sql-function-exp + :name 'coalesce :args rest)) diff --git a/sql/sql.lisp b/sql/sql.lisp index 0a733aa..6bc4547 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -361,62 +361,85 @@ MAP." (multiple-value-bind (result-set columns) (database-query-result-set query-expression database :full-set nil :result-types result-types) - (when result-set - (unwind-protect - (do ((row (make-list columns))) - ((not (database-store-next-row result-set database row)) - nil) - (apply function row)) - (database-dump-result-set result-set database))))) + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (if flatp + (apply function row) + (funcall function row))) + (database-dump-result-set result-set database)))))) (defun map-query-to-list (function query-expression database result-types) (multiple-value-bind (result-set columns) (database-query-result-set query-expression database :full-set nil :result-types result-types) - (when result-set - (unwind-protect - (let ((result (list nil))) - (do ((row (make-list columns)) - (current-cons result (cdr current-cons))) - ((not (database-store-next-row result-set database row)) - (cdr result)) - (rplacd current-cons (list (apply function row))))) - (database-dump-result-set result-set database))))) - + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons + (list (if flatp + (apply function row) + (funcall function (copy-list row))))))) + (database-dump-result-set result-set database)))))) (defun map-query-to-simple (output-type-spec function query-expression database result-types) (multiple-value-bind (result-set columns rows) (database-query-result-set query-expression database :full-set t :result-types result-types) - (when result-set - (unwind-protect - (if rows - ;; We know the row count in advance, so we allocate once - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec rows)) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - result) - (declare (fixnum index)) - (setf (aref result index) - (apply function row))) - ;; Database can't report row count in advance, so we have - ;; to grow and shrink our vector dynamically - (do ((result - (cmucl-compat:make-sequence-of-type output-type-spec 100)) - (allocated-length 100) - (row (make-list columns)) - (index 0 (1+ index))) - ((not (database-store-next-row result-set database row)) - (cmucl-compat:shrink-vector result index)) - (declare (fixnum allocated-length index)) - (when (>= index allocated-length) - (setq allocated-length (* allocated-length 2) - result (adjust-array result allocated-length))) - (setf (aref result index) - (apply function row)))) - (database-dump-result-set result-set database))))) + (let ((flatp (and (= columns 1) + (typecase query-expression + (string t) + (sql-query + (slot-value query-expression 'flatp)))))) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (if flatp + (apply function row) + (funcall function (copy-list row))))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setq allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (if flatp + (apply function row) + (funcall function (copy-list row)))))) + (database-dump-result-set result-set database)))))) ;;; Row processing macro from CLSQL diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index 6a27fdd..598879b 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -109,7 +109,7 @@ (deftest :BASIC/MAP/1 (let ((results '()) - (rows (map-query 'vector #'list "select * from TYPE_TABLE" + (rows (map-query 'vector #'identity "select * from TYPE_TABLE" :result-types nil))) (declare (type (simple-array list (*)) rows)) (dotimes (i (length rows) results) @@ -128,7 +128,7 @@ (deftest :BASIC/MAP/2 (let ((results '()) - (rows (map-query 'list #'list "select * from TYPE_TABLE" + (rows (map-query 'list #'identity "select * from TYPE_TABLE" :result-types nil))) (dotimes (i (length rows) results) (push @@ -146,7 +146,7 @@ (deftest :BASIC/MAP/3 (let ((results '()) - (rows (map-query 'list #'list "select * from TYPE_TABLE" + (rows (map-query 'list #'identity "select * from TYPE_TABLE" :result-types :auto))) (dotimes (i (length rows) results) (push diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index 33267a5..f764e73 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -392,6 +392,11 @@ :order-by '(["table" last-name]) :result-types nil :field-names nil) (("Vladamir" "Lenin") ("Vladamir" "Putin"))) + +(deftest :fdml/select/27 + (clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid] + :field-names nil :result-types nil :flatp t) + ("10" "1" "1" "1" "1" "1" "1" "1" "1" "1")) ;(deftest :fdml/select/11 ; (clsql:select [emplid] :from [employee] diff --git a/tests/test-syntax.lisp b/tests/test-syntax.lisp index 8d1a863..8591817 100644 --- a/tests/test-syntax.lisp +++ b/tests/test-syntax.lisp @@ -73,7 +73,7 @@ (deftest :syntax/subquery/1 (clsql:sql [any '(3 4)]) - "(ANY ((3,4)))") + "ANY((3,4))") (deftest :syntax/subquery/2 (clsql:sql [in [foo] '(foo bar baz)]) @@ -81,15 +81,15 @@ (deftest :syntax/subquery/3 (clsql:sql [all '(foo bar baz)]) - "(ALL ((FOO,BAR,BAZ)))") + "ALL((FOO,BAR,BAZ))") (deftest :syntax/subquery/4 (clsql:sql [exists '(foo bar baz)]) - "(EXISTS ((FOO,BAR,BAZ)))") + "EXISTS((FOO,BAR,BAZ))") (deftest :syntax/subquery/5 (clsql:sql [some '(foo bar baz)]) - "(SOME ((FOO,BAR,BAZ)))") + "SOME((FOO,BAR,BAZ))") (deftest :syntax/aggregate/1 @@ -241,6 +241,15 @@ "GROUP BY FOO") +(deftest :syntax/coalesce/1 + (clsql:sql [coalesce [foo] [bar] "not specified"]) + "COALESCE(FOO,BAR,'not specified')") + +(deftest :syntax/coalesce/2 + (clsql:sql [nvl [foo] "not specified"]) + "COALESCE(FOO,'not specified')") + + (deftest :syntax/sets/1 (clsql:sql [union [select [foo] :from [bar]] [select [baz] :from [bar]]]) "SELECT FOO FROM BAR UNION SELECT BAZ FROM BAR") @@ -253,6 +262,10 @@ (clsql:sql [except [select [foo] :from [bar]] [select [baz] :from [bar]]]) "SELECT FOO FROM BAR EXCEPT SELECT BAZ FROM BAR") +(deftest :syntax/sets/4 + (clsql:sql [minus [select [foo] :from [bar]] [select [baz] :from [bar]]]) + "SELECT FOO FROM BAR EXCEPT SELECT BAZ FROM BAR") + (deftest :syntax/function/1 (clsql:sql [function "COS" [age]]) -- 2.34.1