X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=5967f24e941c707d14a175fb7de02db7365506df;hb=814ef0649edf23f0136d5cad2d7738ae72e79871;hp=df9cfc08b55da8a5195310172e23402a8ea29c43;hpb=e567409d9fff3f7231c2a0bb69b345e19de2b246;p=clsql.git diff --git a/sql/expressions.lisp b/sql/expressions.lisp index df9cfc0..5967f24 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -110,13 +110,12 @@ `(make-instance 'sql-ident :name ',name))) (defmethod output-sql ((expr sql-ident) database) + (with-slots (name) expr (write-string - (convert-to-db-default-case - (etypecase name - (string name) - (symbol (symbol-name name))) - database) + (etypecase name + (string name) + (symbol (symbol-name name) database)) *sql-stream*)) t) @@ -137,9 +136,8 @@ (defmethod collect-table-refs ((sql sql-ident-attribute)) (let ((qual (slot-value sql 'qualifier))) - (if (and qual (symbolp (slot-value sql 'qualifier))) - (list (make-instance 'sql-ident-table :name - (slot-value sql 'qualifier)))))) + (when qual + (list (make-instance 'sql-ident-table :name qual))))) (defmethod make-load-form ((sql sql-ident-attribute) &optional environment) (declare (ignore environment)) @@ -150,33 +148,32 @@ :type ',type))) (defmethod output-sql ((expr sql-ident-attribute) database) - (with-slots (qualifier name type) expr - (if (and (not qualifier) (not type)) - (etypecase name - ;; Honor care of name - (string - (write-string name *sql-stream*)) - (symbol - (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~]" - (when qualifier - (convert-to-db-default-case (sql-escape qualifier) database)) - (sql-escape (convert-to-db-default-case name database)) - (when type - (convert-to-db-default-case (symbol-name type) database))) - (format *sql-stream* "~@[~A.~]~A" - (when qualifier - (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)) +;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it +;;; should not be output in SQL statements + (let ((*print-pretty* nil)) + (labels ((quoted-string-p (inp) + (and (char-equal #\" (elt inp 0)) + (char-equal #\" (elt inp (1- (length inp)))))) + (safety-first (inp) + "do our best not to output sql that we can guarantee is invalid. + if the ident has a space or quote in it, instead output a quoted + identifier containing those chars" + (when (and (not (quoted-string-p inp)) + (find-if + (lambda (x) (member x '(#\space #\' #\") + :test #'char-equal)) inp)) + (setf inp (format nil "~s" (substitute "\\\"" "\"" inp :test #'string-equal)))) + inp)) + (with-slots (qualifier name type) expr + (format *sql-stream* "~@[~a.~]~a" + (typecase qualifier + (null nil) ; nil is a symbol + (string (format nil "~s" qualifier)) + (symbol (safety-first (sql-escape qualifier)))) + (typecase name ;; could never get this to be nil without getting another error first + (string (format nil "~s" name)) + (symbol (safety-first (sql-escape name))))) + t)))) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) (with-slots (qualifier name type) @@ -199,19 +196,13 @@ (defmethod output-sql ((expr sql-ident-table) database) (with-slots (name alias) expr - (let ((namestr (if (symbolp name) - (symbol-name name) - name))) - (if (null alias) - (write-string - (sql-escape (convert-to-db-default-case namestr database)) - *sql-stream*) - (progn - (write-string - (sql-escape (convert-to-db-default-case namestr database)) - *sql-stream*) - (write-char #\Space *sql-stream*) - (format *sql-stream* "~s" alias))))) + (etypecase name + (string + (format *sql-stream* "~s" (sql-escape name))) + (symbol + (write-string (sql-escape name) *sql-stream*))) + (when alias + (format *sql-stream* " ~s" alias))) t) (defmethod output-sql-hash-key ((expr sql-ident-table) database) @@ -251,18 +242,42 @@ ;; should do arity checking of subexpressions (defmethod output-sql ((expr sql-relational-exp) database) + (with-slots (operator sub-expressions) + expr + (when sub-expressions + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *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-char #\Space *sql-stream*)) + (write-char #\) *sql-stream*)))) + t) + +(defclass sql-array-exp (sql-relational-exp) + () + (:documentation "An SQL relational expression.")) + +(defmethod output-sql ((expr sql-array-exp) database) (with-slots (operator sub-expressions) expr (let ((subs (if (consp (car sub-expressions)) (car sub-expressions) sub-expressions))) (write-char #\( *sql-stream*) + (output-sql operator database) + (write-char #\[ *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-char #\, *sql-stream*) (write-char #\Space *sql-stream*)) + (write-char #\] *sql-stream*) (write-char #\) *sql-stream*))) t) @@ -574,13 +589,17 @@ uninclusive, and the args from that keyword to the end." (write-string "SELECT " *sql-stream*) (when all (write-string "ALL " *sql-stream*)) + (when (and limit (eq :odbc (database-type database))) + (write-string " TOP " *sql-stream*) + (output-sql limit database)) (when (and distinct (not all)) (write-string "DISTINCT " *sql-stream*) (unless (eql t distinct) (write-string "ON " *sql-stream*) (output-sql distinct database) (write-char #\Space *sql-stream*))) - (output-sql (apply #'vector selections) database) + (let ((*in-subselect* t)) + (output-sql (apply #'vector selections) database)) (when from (write-string " FROM " *sql-stream*) (flet ((ident-table-equal (a b) @@ -596,7 +615,7 @@ uninclusive, and the args from that keyword to the end." (remove-duplicates from :test #'ident-table-equal)) database)) - (string (write-string from *sql-stream*)) + (string (format *sql-stream* "~s" (sql-escape from))) (t (let ((*in-subselect* t)) (output-sql from database)))))) (when inner-join @@ -606,9 +625,13 @@ uninclusive, and the args from that keyword to the end." (write-string " ON " *sql-stream*) (output-sql on database)) (when where - (write-string " WHERE " *sql-stream*) - (let ((*in-subselect* t)) - (output-sql where database))) + (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*)))) (when group-by (write-string " GROUP BY " *sql-stream*) (if (listp group-by) @@ -642,7 +665,7 @@ uninclusive, and the args from that keyword to the end." (when (cdr order) (write-char #\, *sql-stream*)))) (output-sql order-by database))) - (when limit + (when (and limit (not (eq :odbc (database-type database)))) (write-string " LIMIT " *sql-stream*) (output-sql limit database)) (when offset @@ -687,7 +710,7 @@ uninclusive, and the args from that keyword to the end." (write-string "INSERT INTO " *sql-stream*) (output-sql (typecase into - (string (sql-expression :attribute into)) + (string (sql-expression :table into)) (t into)) database) (when attributes @@ -809,7 +832,10 @@ uninclusive, and the args from that keyword to the end." (with-slots (name columns modifiers transactions) stmt (write-string "CREATE TABLE " *sql-stream*) - (output-sql name database) + (etypecase name + (string (format *sql-stream* "~s" (sql-escape name))) + (symbol (write-string (sql-escape name) *sql-stream*)) + (sql-ident (output-sql name database))) (write-string " (" *sql-stream*) (do ((column columns (cdr column))) ((null (cdr column)) @@ -891,11 +917,9 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((sym symbol) database) (if (null sym) +null-string+ - (convert-to-db-default-case - (if (equal (symbol-package sym) keyword-package) - (concatenate 'string "'" (string sym) "'") - (symbol-name sym)) - database)))) + (if (equal (symbol-package sym) keyword-package) + (concatenate 'string "'" (string sym) "'") + (symbol-name sym))))) (defmethod database-output-sql ((tee (eql t)) database) (if database @@ -974,7 +998,9 @@ uninclusive, and the args from that keyword to the end." (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 "UNIQUE") "UNIQUE"))) + (cons (symbol-name-default-case "UNIQUE") "UNIQUE") + (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;Added Identity for MS-SQLServer support + )) (defmethod database-constraint-statement (constraint-list database) (declare (ignore database))