X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fclasses.lisp;h=9e2338cb9731bfd292713afcb4bb38f8d1727299;hb=f246c3c7b48792a869cb1bae0637a2f00a0920bd;hp=c2cd651317291031fb6b82fcc59646db951bc6d0;hpb=967266c94b00f91e5967b8330fe2b9134b0c0447;p=clsql.git diff --git a/sql/classes.lisp b/sql/classes.lisp index c2cd651..9e2338c 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-sys) +(in-package #:clsql) (defvar +empty-string+ "''") @@ -147,11 +147,21 @@ (with-slots (qualifier name type params) expr (if (and (not qualifier) (not type)) - (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) + (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 + (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) @@ -170,7 +180,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))) @@ -407,9 +417,29 @@ :initform nil) (order-by-descending :initarg :order-by-descending + :initform nil) + (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 +448,8 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit)) + :order-by-descending :set-operation :where :offset :limit + :inner-join :on)) (defun query-arg-p (sym) (member sym *select-arguments*)) @@ -432,29 +463,41 @@ uninclusive, and the args from that keyword to the end." (subseq select-args first-key-arg)) select-args))) -(defmethod 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)))) +(defun make-query (&rest args) + (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 order-by-descending + 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 + :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) + order-by-descending limit offset inner-join on) query (when *in-subselect* (write-string "(" *sql-stream*)) @@ -466,10 +509,17 @@ uninclusive, and the args from that keyword to the end." (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*) + (if (listp from) + (output-sql (apply #'vector from) database) + (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)) @@ -509,6 +559,13 @@ uninclusive, and the args from that keyword to the end." (write-string ")" *sql-stream*))) t) +(defmethod output-sql ((query sql-object-query) database) + (with-slots (objects) + query + (when objects + (format *sql-stream* "(~{~A~^ ~})" objects)))) + + ;; INSERT (defclass sql-insert (%sql-expression) @@ -690,8 +747,9 @@ 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"))) ;; ;; Convert type spec to sql syntax