X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=983d4a526bb5667e1eb6fa17f2c6090c15f93823;hb=30f8208b28a5cbc1a8f8ed759e9c9ac531c93089;hp=ef58af7d06ed62d4a4b2d2447eafb3053b389ca1;hpb=7c5e205e6323991c72e19e910c1a68bb3acc0fc5;p=clsql.git diff --git a/sql/expressions.lisp b/sql/expressions.lisp index ef58af7..983d4a5 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*) @@ -139,11 +149,9 @@ (defvar *output-hash* - #+sbcl - (make-hash-table :test #'equal :synchronized T :weakness :key-and-value) - #-sbcl - (make-hash-table :test #'equal ) - "For caching generated SQL strings.") + (make-weak-hash-table :test #'equal) + "For caching generated SQL strings, set to NIL to disable." + ) (defmethod output-sql :around ((sql t) database) (if (null *output-hash*) @@ -337,6 +345,12 @@ ;; Write SQL for relational operators (like 'AND' and 'OR'). ;; should do arity checking of subexpressions +(defun %write-operator (operator database) + (typecase operator + (string (write-string operator *sql-stream*)) + (symbol (write-string (symbol-name operator) *sql-stream*)) + (T (output-sql operator database)))) + (defmethod output-sql ((expr sql-relational-exp) database) (with-slots (operator sub-expressions) expr ;; we do this as two runs so as not to emit confusing superflous parentheses @@ -361,7 +375,9 @@ (loop for str-sub in (rest str-subs) do (write-char #\Space *sql-stream*) - (output-sql operator database) + ;; do this so that symbols can be output as database identifiers + ;; rather than allowing symbols to inject sql + (%write-operator operator database) (write-char #\Space *sql-stream*) (write-string str-sub *sql-stream*)) (write-char #\) *sql-stream*)) @@ -402,7 +418,7 @@ ((null (cdr sub)) (output-sql (car sub) database)) (output-sql (car sub) database) (write-char #\Space *sql-stream*) - (output-sql operator database) + (%write-operator operator database) (write-char #\Space *sql-stream*))) t) @@ -435,7 +451,14 @@ (if modifier (progn (write-char #\( *sql-stream*) - (output-sql modifier database) + (cond + ((sql-operator modifier) + (%write-operator modifier database)) + ((or (stringp modifier) (symbolp modifier)) + (write-string + (escaped-database-identifier modifier) + *sql-stream*)) + (t (output-sql modifier database))) (write-char #\Space *sql-stream*) (output-sql components database) (write-char #\) *sql-stream*)) @@ -475,7 +498,10 @@ (defmethod output-sql ((expr sql-function-exp) database) (with-slots (name args) expr - (output-sql name database) + (typecase name + ((or string symbol) + (write-string (escaped-database-identifier name) *sql-stream*)) + (t (output-sql name database))) (let ((*in-subselect* nil)) ;; aboid double parens (when args (output-sql args database)))) t) @@ -505,7 +531,7 @@ expr (%write-operator modifier database) (write-string " " *sql-stream*) - (output-sql (car components) database) + (%write-operator (car components) database) (when components (mapc #'(lambda (comp) (write-string ", " *sql-stream*) @@ -536,13 +562,13 @@ (car sub-expressions) sub-expressions))) (when (= (length subs) 1) - (output-sql operator database) + (%write-operator 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-operator operator database) (write-char #\Space *sql-stream*)))) t) @@ -657,6 +683,20 @@ uninclusive, and the args from that keyword to the end." :group-by group-by :having having :order-by order-by :inner-join inner-join :on on)))))) +(defun output-sql-where-clause (where database) + "ensure that we do not output a \"where\" sql keyword when we will + not output a clause. Also sets *in-subselect* to use SQL + parentheticals as needed." + (when where + (let ((where-out (string-trim + '(#\newline #\space #\tab #\return) + (with-output-to-string (*sql-stream*) + (let ((*in-subselect* t)) + (output-sql where database)))))) + (when (> (length where-out) 0) + (write-string " WHERE " *sql-stream*) + (write-string where-out *sql-stream*))))) + (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by limit offset inner-join on all set-operation) @@ -696,15 +736,7 @@ uninclusive, and the args from that keyword to the end." (when on (write-string " ON " *sql-stream*) (output-sql on database)) - (when where - (let ((where-out (string-trim - '(#\newline #\space #\tab #\return) - (with-output-to-string (*sql-stream*) - (let ((*in-subselect* t)) - (output-sql where database)))))) - (when (> (length where-out) 0) - (write-string " WHERE " *sql-stream*) - (write-string where-out *sql-stream*)))) + (output-sql-where-clause where database) (when group-by (write-string " GROUP BY " *sql-stream*) (if (listp group-by) @@ -791,7 +823,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))) @@ -816,9 +849,7 @@ uninclusive, and the args from that keyword to the end." (typecase from ((or symbol string) (write-string (sql-escape from) *sql-stream*)) (t (output-sql from database))) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database))) + (output-sql-where-clause where database)) t) ;; UPDATE @@ -850,10 +881,9 @@ 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) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database)))) + (let ((clsql-sys::*in-subselect* t)) + (output-sql (apply #'vector (update-assignments)) database)) + (output-sql-where-clause where database))) t) ;; CREATE TABLE @@ -921,7 +951,7 @@ uninclusive, and the args from that keyword to the end." (when (and (eq :mysql (database-underlying-type database)) transactions (db-type-transaction-capable? :mysql database)) - (write-string " Type=InnoDB" *sql-stream*)))) + (write-string " ENGINE=innodb" *sql-stream*)))) t) @@ -987,9 +1017,9 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((sym symbol) database) (if (null sym) +null-string+ - (if (equal (symbol-package sym) keyword-package) - (concatenate 'string "'" (string sym) "'") - (symbol-name sym))))) + (if (equal (symbol-package sym) keyword-package) + (database-output-sql (symbol-name sym) database) + (escaped-database-identifier sym))))) (defmethod database-output-sql ((tee (eql t)) database) (if database @@ -1098,7 +1128,7 @@ uninclusive, and the args from that keyword to the end." (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 @@ -1121,6 +1151,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))