X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fclasses.lisp;h=62033591985db4e4ab3e64a4b100e81c89e7fc4b;hp=9e2338cb9731bfd292713afcb4bb38f8d1727299;hb=155c60b5195d618ef93541699694d57a21be3246;hpb=279b34c9e8e28545c8f2a0959acb01d90138eeda diff --git a/sql/classes.lisp b/sql/classes.lisp index 9e2338c..6203359 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -13,7 +13,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (defvar +empty-string+ "''") @@ -160,7 +160,10 @@ (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)) @@ -378,6 +381,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 @@ -415,9 +487,6 @@ (order-by :initarg :order-by :initform nil) - (order-by-descending - :initarg :order-by-descending - :initform nil) (inner-join :initarg :inner-join :initform nil) @@ -448,8 +517,9 @@ (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)) (defun query-arg-p (sym) (member sym *select-arguments*)) @@ -478,7 +548,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) @@ -490,19 +560,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*) @@ -511,9 +582,12 @@ uninclusive, and the args from that keyword to the end." (output-sql (apply #'vector selections) database) (when from (write-string " FROM " *sql-stream*) - (if (listp from) - (output-sql (apply #'vector from) database) - (output-sql from database))) + (typecase from + (list (output-sql (apply #'vector from) database)) + (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*) (output-sql inner-join database)) @@ -535,20 +609,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)) @@ -556,10 +626,14 @@ 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 @@ -679,6 +753,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)