r9361: Support for qualified sql identifiers with aliased table names.

[clsql.git] / sql / classes.lisp

diff --git a/sql/classes.lisp b/sql/classes.lisp
index 1be0e0b3d9f0728b53192ecd79b1eb506b30673a..872830f7ebf1bba5e39e66fb5e568a73c77eb35a 100644 (file)
--- 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,72 @@
     (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)))
+      (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
@@ -426,6 +495,20 @@
     :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)
@@ -435,7 +518,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))
+    :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*))
@@ -459,7 +544,10 @@ uninclusive, and the args from that keyword to the end."
     (multiple-value-bind (selections arglist)
        (query-get-selections args)
       (if (select-objects selections) 
-         (apply #'select args)
+         (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)
@@ -494,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))
@@ -542,6 +633,14 @@ uninclusive, and the args from that keyword to the end."
       (write-string ")" *sql-stream*)))
   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)
@@ -655,6 +754,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)