X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=10bdb5ec0b2a0dd23e7d85032da5f180e1b45315;hp=1479e67afa80d2edba6e5f4dc8d3bf339599640d;hb=374df8f34a7214e08fc4cfc5d734d024acdbf9ca;hpb=49b3604f1b86ad2de1487f2da3b3b53c904eaf4a diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 1479e67..10bdb5e 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -68,6 +68,14 @@ #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\> #\{ #\})))) +(defun special-cased-symbol-p (sym) + "Should the symbols case be preserved, or should we convert to default casing" + (let ((name (symbol-name sym))) + (case (readtable-case *readtable*) + (:upcase (not (string= (string-upcase name) name))) + (:downcase (not (string= (string-downcase name) name))) + (t t)))) + (defun %make-database-identifier (inp &optional database) "We want to quote an identifier if it came to us as a string or if it has special characters in it." @@ -88,8 +96,12 @@ (symbol (let ((s (sql-escape inp))) (if (and (not (eql '* inp)) (special-char-p s)) - (%escape-identifier (convert-to-db-default-case s database) inp) - (make-instance '%database-identifier :escaped s :unescaped inp))))))) + (%escape-identifier + (if (special-cased-symbol-p inp) + s + (convert-to-db-default-case s database)) inp) + (make-instance '%database-identifier :escaped s :unescaped inp)) + ))))) (defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*) &aux res all-sym? pkg) @@ -128,10 +140,8 @@ "Top-level call for generating SQL strings. Returns an SQL string appropriate for DATABASE which corresponds to the supplied lisp expression SQL-EXPR." - (progv '(*sql-stream*) - `(,(make-string-output-stream)) - (output-sql sql-expr database) - (get-output-stream-string *sql-stream*))) + (with-output-to-string (*sql-stream*) + (output-sql sql-expr database))) (defmethod output-sql (expr database) (write-string (database-output-sql expr database) *sql-stream*) @@ -239,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 @@ -276,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 @@ -813,7 +830,8 @@ uninclusive, and the args from that keyword to the end." (output-sql attributes database)) (when values (write-string " VALUES " *sql-stream*) - (output-sql values database)) + (let ((clsql-sys::*in-subselect* t)) + (output-sql values database))) (when query (write-char #\Space *sql-stream*) (output-sql query database))) @@ -870,7 +888,8 @@ uninclusive, and the args from that keyword to the end." (write-string "UPDATE " *sql-stream*) (output-sql table database) (write-string " SET " *sql-stream*) - (output-sql (apply #'vector (update-assignments)) database) + (let ((clsql-sys::*in-subselect* t)) + (output-sql (apply #'vector (update-assignments)) database)) (output-sql-where-clause where database))) t) @@ -1074,49 +1093,44 @@ 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) - "A function that takes whatever you give it, recurively coerces it, + "A function that takes whatever you give it, recursively coerces it, and returns a database-identifier. (escaped-database-identifiers *any-reasonable-object*) should be called to @@ -1139,6 +1153,7 @@ uninclusive, and the args from that keyword to the end." a new db-id with that string as escaped" (let ((s (sql-output id database))) (make-instance '%database-identifier :escaped s :unescaped s)))) + (setf name (dequote name)) (etypecase name (null nil) (string (%make-database-identifier name database)) @@ -1169,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)) +