cleaning up patches, and fixing missing pkey bugs in sqlite3

[clsql.git] / sql / expressions.lisp

diff --git a/sql/expressions.lisp b/sql/expressions.lisp
index 983d4a526bb5667e1eb6fa17f2c6090c15f93823..10bdb5ec0b2a0dd23e7d85032da5f180e1b45315 100644 (file)
--- a/sql/expressions.lisp
+++ b/sql/expressions.lisp
@@ -249,6 +249,10 @@
   (declare (ignore sql))
   nil)
 
+(defmethod collect-table-refs ((sql list))
+  (loop for i in sql
+        appending (listify (collect-table-refs i))))
+
 (defmethod collect-table-refs ((sql sql-ident-attribute))
   (let ((qual (slot-value sql 'qualifier)))
     (when qual
@@ -286,6 +290,9 @@
     sql
     `(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
 
+(defmethod collect-table-refs ((sql sql-ident-table))
+  (list sql))
+
 (defmethod output-sql ((expr sql-ident-table) database)
   (with-slots (name alias) expr
     (flet ((p (s) ;; the etypecase is in sql-escape too
@@ -1086,45 +1093,40 @@ uninclusive, and the args from that keyword to the end."
 ;;
 ;; Column constraint types and conversion to SQL
 ;;
-
-(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 "NOT") "NOT")
-   (cons (symbol-name-default-case "NULL") "NULL")
-   (cons (symbol-name-default-case "PRIMARY") "PRIMARY")
-   (cons (symbol-name-default-case "KEY") "KEY")
-   (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED")
-   (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL")
-   (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT")
-   (cons (symbol-name-default-case "DEFAULT") "DEFAULT")
-   (cons (symbol-name-default-case "UNIQUE") "UNIQUE")
-   (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;; added for sql-server support
-   ))
-
 (defmethod database-constraint-statement (constraint-list database)
-  (declare (ignore database))
-  (make-constraints-description constraint-list))
-
-(defun make-constraints-description (constraint-list)
-  (if constraint-list
-      (let ((string ""))
-        (do ((constraint constraint-list (cdr constraint)))
-            ((null constraint) string)
-          (let ((output (assoc (symbol-name (car constraint))
-                               *constraint-types*
-                               :test #'equal)))
-            (if (null output)
-                (error 'sql-user-error
-                       :message (format nil "unsupported column constraint '~A'"
-                                        constraint))
-                (setq string (concatenate 'string string (cdr output))))
-           (when (equal (symbol-name (car constraint)) "DEFAULT")
-             (setq constraint (cdr constraint))
-             (setq string (concatenate 'string string " " (car constraint))))
-            (if (< 1 (length constraint))
-                (setq string (concatenate 'string string " "))))))))
+  (make-constraints-description constraint-list database))
+
+;; KEEP THIS SYNCED WITH database-translate-constraint
+(defparameter +auto-increment-names+
+  '(:auto-increment :auto_increment :autoincrement :identity))
+
+(defmethod database-translate-constraint (constraint database)
+  (case constraint
+    (:not-null "NOT NULL")
+    (:primary-key "PRIMARY KEY")
+    ((:auto-increment :auto_increment :autoincrement :identity)
+     (ecase (database-underlying-type database)
+       (:mssql "IDENTITY (1,1)")
+       ((:sqlite :sqlite3) "PRIMARY KEY AUTOINCREMENT")
+       (:mysql "AUTO_INCREMENT")))
+    ;; everything else just get the name
+    (T (string-upcase (symbol-name constraint)))))
+
+(defun make-constraints-description (constraint-list database
+                                     &aux (rest constraint-list) constraint)
+  (when constraint-list
+    (flet ((next ()
+             (setf constraint (first rest)
+                   rest (rest rest))
+             constraint))
+      (with-output-to-string (s)
+        (loop while (next)
+              do (unless (keywordp constraint)
+                   (setf constraint (intern (symbol-name constraint) :keyword)))
+                 (write-string (database-translate-constraint constraint database) s)
+                 (when (eql :default constraint) (princ (next) s))
+                 (write-char #\space s)
+              )))))
 
 (defmethod database-identifier ( name  &optional database find-class-p
                                  &aux cls)
@@ -1182,3 +1184,51 @@ uninclusive, and the args from that keyword to the end."
       (%sql-expression (flatten-id name))
       )))
 
+(defun %clsql-subclauses (clauses)
+  "a helper for dealing with lists of sql clauses"
+  (loop for c in clauses
+        when c
+        collect (typecase c
+                  (string (clsql-sys:sql-expression :string c))
+                  (T c))))
+
+(defun clsql-ands (clauses)
+  "Correctly creates a sql 'and' expression for the clauses
+    ignores any nil clauses
+    returns a single child expression if there is only one
+    returns an 'and' expression if there are many
+    returns nil if there are no children"
+  (let ((ex (%clsql-subclauses clauses)))
+    (when ex
+      (case (length ex)
+        (1 (first ex))
+        (t (apply #'clsql-sys:sql-and ex))))))
+
+(defun clsql-and (&rest clauses)
+  "Correctly creates a sql 'and' expression for the clauses
+    ignores any nil clauses
+    returns a single child expression if there is only one
+    returns an 'and' expression if there are many
+    returns nil if there are no children"
+  (clsql-ands clauses))
+
+(defun clsql-ors (clauses)
+  "Correctly creates a sql 'or' expression for the clauses
+    ignores any nil clauses
+    returns a single child expression if there is only one
+    returns an 'or' expression if there are many
+    returns nil if there are no children"
+  (let ((ex (%clsql-subclauses clauses)))
+    (when ex
+      (case (length ex)
+        (1 (first ex))
+        (t (apply #'clsql-sys:sql-or ex))))))
+
+(defun clsql-or (&rest clauses)
+  "Correctly creates a sql 'or' expression for the clauses
+    ignores any nil clauses
+    returns a single child expression if there is only one
+    returns an 'or' expression if there are many
+    returns nil if there are no children"
+  (clsql-ors clauses))
+