X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fclasses.lisp;h=6848621aa387c6436a22907ce5863c0b59589580;hp=c6cf764ab9debdfea53a8c2494aa77883702f92d;hb=5148be446aee32ec705beac3fbba35f499df4fd4;hpb=cff8a2497b3f111a43d819476b55bfad2b447532 diff --git a/sql/classes.lisp b/sql/classes.lisp index c6cf764..6848621 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -100,8 +100,7 @@ (call-next-method))))) (defmethod output-sql ((expr sql-ident) database) - (with-slots (name) - expr + (with-slots (name) expr (write-string (convert-to-db-default-case (etypecase name @@ -119,10 +118,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,21 +140,39 @@ :type ',type))) (defmethod output-sql ((expr sql-ident-attribute) database) - (with-slots (qualifier name type params) - expr + (with-slots (qualifier name type) expr (if (and (not qualifier) (not type)) - (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) + (etypecase name + ;; Honor care of name + (string + (write-string name *sql-stream*)) + (symbol + (write-string (sql-escape (convert-to-db-default-case + (symbol-name name) database)) *sql-stream*))) + + ;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it + ;;; should not be output in SQL statements + #+ignore (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" - (if qualifier (sql-escape qualifier) qualifier) + (when qualifier + (convert-to-db-default-case (sql-escape qualifier) database)) (sql-escape (convert-to-db-default-case name database)) - type)) + (when type + (convert-to-db-default-case (symbol-name type) database))) + (format *sql-stream* "~@[~A.~]~A" + (when qualifier + (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) @@ -170,7 +184,7 @@ (declare (ignore environment)) (with-slots (alias name) sql - `(make-instance 'sql-ident-table :name name :alias ',alias))) + `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) (defun generate-sql (expr database) (let ((*sql-stream* (make-string-output-stream))) @@ -368,6 +382,75 @@ (when args (output-sql args database))) t) + +(defclass sql-between-exp (sql-function-exp) + () + (:documentation "An SQL between expression.")) + +(defmethod output-sql ((expr sql-between-exp) database) + (with-slots (name args) + expr + (output-sql (first args) database) + (write-string " BETWEEN " *sql-stream*) + (output-sql (second args) database) + (write-string " AND " *sql-stream*) + (output-sql (third args) database)) + t) + +(defclass sql-query-modifier-exp (%sql-expression) + ((modifier :initarg :modifier :initform nil) + (components :initarg :components :initform nil)) + (:documentation "An SQL query modifier expression.")) + +(defmethod output-sql ((expr sql-query-modifier-exp) database) + (with-slots (modifier components) + expr + (output-sql modifier database) + (write-string " " *sql-stream*) + (output-sql (car components) database) + (when components + (mapc #'(lambda (comp) + (write-string ", " *sql-stream*) + (output-sql comp database)) + (cdr components)))) + t) + +(defclass sql-set-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL set expression.")) + +(defmethod collect-table-refs ((sql sql-set-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + +(defmethod output-sql ((expr sql-set-exp) database) + (with-slots (operator sub-expressions) + expr + (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) + (write-char #\Space *sql-stream*) + (output-sql operator database) + (write-char #\Space *sql-stream*)))) + t) + (defclass sql-query (%sql-expression) ((selections :initarg :selections @@ -405,11 +488,28 @@ (order-by :initarg :order-by :initform nil) - (order-by-descending - :initarg :order-by-descending + (inner-join + :initarg :inner-join + :initform nil) + (on + :initarg :on :initform nil)) (:documentation "An SQL SELECT query.")) +(defclass sql-object-query (%sql-expression) + ((objects + :initarg :objects + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (exp + :initarg :exp + :initform nil) + (refresh + :initarg :refresh + :initform nil))) + (defmethod collect-table-refs ((sql sql-query)) (remove-duplicates (collect-table-refs (slot-value sql 'where)) :test (lambda (tab1 tab2) @@ -418,7 +518,9 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit)) + :set-operation :where :offset :limit :inner-join :on + ;; below keywords are not a SQL argument, but these keywords may terminate select + :caching :refresh)) (defun query-arg-p (sym) (member sym *select-arguments*)) @@ -433,43 +535,64 @@ 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) + (destructuring-bind (&key flatp refresh &allow-other-keys) arglist + (make-instance 'sql-object-query :objects selections + :flatp flatp :refresh refresh + :exp arglist)) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by + offset limit inner-join on &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 + :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) + 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*) (output-sql distinct database) (write-char #\Space *sql-stream*))) (output-sql (apply #'vector selections) database) - (write-string " FROM " *sql-stream*) - (if (listp from) - (output-sql (apply #'vector from) database) - (output-sql from database)) + (when from + (write-string " FROM " *sql-stream*) + (typecase from + (list (output-sql (apply #'vector from) database)) + (string (write-string from *sql-stream*)) + (t (output-sql from database)))) + (when inner-join + (write-string " INNER JOIN " *sql-stream*) + (output-sql inner-join database)) + (when on + (write-string " ON " *sql-stream*) + (output-sql on database)) (when where (write-string " WHERE " *sql-stream*) (let ((*in-subselect* t)) @@ -485,20 +608,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)) @@ -506,9 +625,20 @@ 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) + (declare (ignore database)) + (with-slots (objects) + query + (when objects + (format *sql-stream* "(~{~A~^ ~})" objects)))) + + ;; INSERT (defclass sql-insert (%sql-expression) @@ -622,6 +752,7 @@ uninclusive, and the args from that keyword to the end." ;; Here's a real warhorse of a function! +(declaim (inline listify)) (defun listify (x) (if (atom x) (list x) @@ -636,10 +767,14 @@ uninclusive, and the args from that keyword to the end." (write-char #\Space *sql-stream*) (write-string (if (stringp db-type) db-type ; override definition - (database-get-type-specifier (car type) (cdr type) database)) + (database-get-type-specifier (car type) (cdr type) database + (database-underlying-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*))))))) @@ -690,8 +825,13 @@ uninclusive, and the args from that keyword to the end." ;; Column constraint types ;; (defparameter *constraint-types* - '(("NOT-NULL" . "NOT NULL") - ("PRIMARY-KEY" . "PRIMARY KEY"))) + (list + (cons (symbol-name-default-case "NOT-NULL") "NOT NULL") + (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 @@ -702,9 +842,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) @@ -720,9 +860,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 " "))))))))