X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fclasses.lisp;h=bf74b6ecc3e4c8e6f01fee30820eaa91517421bf;hb=b2ff4969e20cce173d403de7542d5bf0e46938d7;hp=4e697caf0cfb7a51cfd402682d8d35dba733da1e;hpb=026988a3144e3ed7f48552b5567c34448fef51bc;p=clsql.git diff --git a/sql/classes.lisp b/sql/classes.lisp index 4e697ca..bf74b6e 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -119,10 +119,7 @@ :initform "NULL") (type :initarg :type - :initform "NULL") - (params - :initarg :params - :initform nil)) + :initform "NULL")) (:documentation "An SQL Attribute identifier.")) (defmethod collect-table-refs (sql) @@ -144,7 +141,7 @@ :type ',type))) (defmethod output-sql ((expr sql-ident-attribute) database) - (with-slots (qualifier name type params) + (with-slots (qualifier name type) expr (if (and (not qualifier) (not type)) (write-string (sql-escape (convert-to-db-default-case @@ -160,15 +157,18 @@ (convert-to-db-default-case (symbol-name type) database))) (format *sql-stream* "~@[~A.~]~A" (when qualifier - (convert-to-db-default-case (sql-escape qualifier) database)) + (typecase qualifier + (string (format nil "~s" qualifier)) + (t (convert-to-db-default-case (sql-escape qualifier) + database)))) (sql-escape (convert-to-db-default-case name database)))) t)) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) (declare (ignore database)) - (with-slots (qualifier name type params) + (with-slots (qualifier name type) expr - (list 'sql-ident-attribute qualifier name type params))) + (list 'sql-ident-attribute qualifier name type))) ;; For SQL Identifiers for tables (defclass sql-ident-table (sql-ident) @@ -436,6 +436,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) @@ -481,9 +484,6 @@ (order-by :initarg :order-by :initform nil) - (order-by-descending - :initarg :order-by-descending - :initform nil) (inner-join :initarg :inner-join :initform nil) @@ -514,8 +514,7 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit - :inner-join :on + :set-operation :where :offset :limit :inner-join :on ;; below keywords are not a SQL argument, but these keywords may terminate select :caching :refresh)) @@ -546,7 +545,7 @@ uninclusive, and the args from that keyword to the end." :flatp flatp :refresh refresh :exp arglist)) (destructuring-bind (&key all flatp set-operation distinct from where - group-by having order-by order-by-descending + group-by having order-by offset limit inner-join on &allow-other-keys) arglist (if (null selections) @@ -558,19 +557,20 @@ uninclusive, and the args from that keyword to the end." :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 :inner-join inner-join :on on)))))) (defvar *in-subselect* nil) (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) + 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*) @@ -581,7 +581,9 @@ uninclusive, and the args from that keyword to the end." (write-string " FROM " *sql-stream*) (typecase from (list (output-sql (apply #'vector from) database)) - (string (write-string from *sql-stream*)) + (string (write-string + (sql-escape + (convert-to-db-default-case from database)) *sql-stream*)) (t (output-sql from database)))) (when inner-join (write-string " INNER JOIN " *sql-stream*) @@ -604,20 +606,16 @@ 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*) - (if (listp order-by-descending) - (do ((order order-by-descending (cdr order))) - ((null order)) - (output-sql (car order) database) - (when (cdr order) - (write-char #\, *sql-stream*))) - (output-sql order-by-descending database)) - (write-string " DESC " *sql-stream*)) (when limit (write-string " LIMIT " *sql-stream*) (output-sql limit database)) @@ -625,7 +623,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) @@ -766,8 +767,11 @@ uninclusive, and the args from that keyword to the end." (if (stringp db-type) db-type ; override definition (database-get-type-specifier (car type) (cdr type) database)) *sql-stream*) - (let ((constraints - (database-constraint-statement constraints database))) + (let ((constraints (database-constraint-statement + (if (and db-type (symbolp db-type)) + (cons db-type constraints) + constraints) + database))) (when constraints (write-string " " *sql-stream*) (write-string constraints *sql-stream*))))))) @@ -820,7 +824,11 @@ uninclusive, and the args from that keyword to the end." (defparameter *constraint-types* (list (cons (symbol-name-default-case "NOT-NULL") "NOT NULL") - (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY"))) + (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY") + (cons (symbol-name-default-case "NOT") "NOT") + (cons (symbol-name-default-case "NULL") "NULL") + (cons (symbol-name-default-case "PRIMARY") "PRIMARY") + (cons (symbol-name-default-case "KEY") "KEY"))) ;; ;; Convert type spec to sql syntax @@ -831,9 +839,9 @@ uninclusive, and the args from that keyword to the end." (let ((output (assoc (symbol-name constraint) *constraint-types* :test #'equal))) (if (null output) - (error 'clsql-sql-syntax-error - :reason (format nil "unsupported column constraint '~a'" - constraint)) + (error 'sql-user-error + :message (format nil "unsupported column constraint '~A'" + constraint)) (cdr output)))) (defmethod database-constraint-statement (constraint-list database) @@ -849,9 +857,9 @@ uninclusive, and the args from that keyword to the end." *constraint-types* :test #'equal))) (if (null output) - (error 'clsql-sql-syntax-error - :reason (format nil "unsupported column constraint '~a'" - constraint)) + (error 'sql-user-error + :message (format nil "unsupported column constraint '~A'" + constraint)) (setq string (concatenate 'string string (cdr output)))) (if (< 1 (length constraint)) (setq string (concatenate 'string string " "))))))))