X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=80fffc5277f66d8c8673abc4f56d99d694032508;hb=6bf69ed2c616ea75e5402bd95853adee5551743b;hp=cd1a6d397bc9a2665bf0472a80d5d14aa563e602;hpb=159a4ba88b6ed66a27968df60d91c6b284401d2b;p=clsql.git diff --git a/sql/expressions.lisp b/sql/expressions.lisp index cd1a6d3..80fffc5 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -22,7 +22,7 @@ (defvar *sql-stream* nil "stream which accumulates SQL output") -(defun sql-output (sql-expr &optional database) +(defun sql-output (sql-expr &optional (database *default-database*)) "Top-level call for generating SQL strings. Returns an SQL string appropriate for DATABASE which corresponds to the supplied lisp expression SQL-EXPR." @@ -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)) @@ -152,30 +150,30 @@ (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 + (etypecase name + (string + (write-string name *sql-stream*)) + (symbol + (write-string + (sql-escape (symbol-name name)) *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))) + (when qualifier + (sql-escape qualifier)) + (sql-escape name) + (when type + (symbol-name type))) (format *sql-stream* "~@[~A.~]~A" - (when qualifier + (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 (format nil "~s" (sql-escape qualifier))))) + (typecase name + (string (format nil "~s" (sql-escape name))) + (t (format nil "~s" (sql-escape name)))))) t)) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) @@ -199,19 +197,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) @@ -266,6 +258,28 @@ (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 #\, *sql-stream*) + (write-char #\Space *sql-stream*)) + (write-char #\] *sql-stream*) + (write-char #\) *sql-stream*))) + t) + (defclass sql-upcase-like (sql-relational-exp) () (:documentation "An SQL 'like' that upcases its arguments.")) @@ -390,7 +404,7 @@ (:documentation "An SQL between expression.")) (defmethod output-sql ((expr sql-between-exp) database) - (with-slots (name args) + (with-slots (args) expr (output-sql (first args) database) (write-string " BETWEEN " *sql-stream*) @@ -412,9 +426,9 @@ (output-sql (car components) database) (when components (mapc #'(lambda (comp) - (write-string ", " *sql-stream*) - (output-sql comp database)) - (cdr components)))) + (write-string ", " *sql-stream*) + (output-sql comp database)) + (cdr components)))) t) (defclass sql-set-exp (%sql-expression) @@ -544,26 +558,26 @@ uninclusive, and the args from that keyword to the end." (find-class arg nil))) target-args)))) (multiple-value-bind (selections arglist) - (query-get-selections args) + (query-get-selections args) (if (select-objects selections) - (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 - offset limit inner-join on &allow-other-keys) - arglist - (if (null selections) - (error "No target columns supplied to select statement.")) - (if (null from) - (error "No source tables supplied to select statement.")) - (make-instance 'sql-query :selections selections - :all all :flatp flatp :set-operation set-operation - :distinct distinct :from from :where where - :limit limit :offset offset - :group-by group-by :having having :order-by order-by - :inner-join inner-join :on on)))))) + (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 + offset limit inner-join on &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :inner-join inner-join :on on)))))) (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by @@ -574,13 +588,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 +614,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 @@ -642,7 +660,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 +705,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 @@ -795,8 +813,8 @@ uninclusive, and the args from that keyword to the end." (write-char #\Space *sql-stream*) (write-string (if (stringp db-type) db-type ; override definition - (database-get-type-specifier (car type) (cdr type) database - (database-underlying-type database))) + (database-get-type-specifier (car type) (cdr type) database + (database-underlying-type database))) *sql-stream*) (let ((constraints (database-constraint-statement (if (and db-type (symbolp db-type)) @@ -809,7 +827,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)) @@ -823,9 +844,9 @@ uninclusive, and the args from that keyword to the end." (write-string (car modifier) *sql-stream*))) (write-char #\) *sql-stream*) (when (and (eq :mysql (database-underlying-type database)) - transactions - (db-type-transaction-capable? :mysql database)) - (write-string " Type=InnoDB" *sql-stream*)))) + transactions + (db-type-transaction-capable? :mysql database)) + (write-string " Type=InnoDB" *sql-stream*)))) t) @@ -855,7 +876,7 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((str string) database) (declare (optimize (speed 3) (safety 1) - #+cmu (extensions:inhibit-warnings 3))) + #+cmu (extensions:inhibit-warnings 3))) (let ((len (length str))) (declare (type fixnum len)) (cond ((zerop len) @@ -865,13 +886,13 @@ uninclusive, and the args from that keyword to the end." (concatenate 'string "'" str "'")) (t (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) - (declare (simple-string buf)) - (do* ((i 0 (incf i)) + (declare (simple-string buf)) + (do* ((i 0 (incf i)) (j 1 (incf j))) ((= i len) (subseq buf 0 (1+ j))) (declare (type fixnum i j)) (let ((char (aref str i))) - (declare (character char)) + (declare (character char)) (cond ((char= char #\') (setf (aref buf j) #\') (incf j) @@ -891,13 +912,20 @@ 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 + (let ((val (database-output-sql-as-type 'boolean t database (database-type database)))) + (when val + (typecase val + (string (format nil "'~A'" val)) + (integer (format nil "~A" val))))) + "'Y'")) + +#+nil(defmethod database-output-sql ((tee (eql t)) database) (declare (ignore database)) "'Y'") @@ -914,8 +942,8 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql ((arg vector) database) (format nil "~{~A~^,~}" (map 'list #'(lambda (val) - (sql-output val database)) - arg))) + (sql-output val database)) + arg))) (defmethod output-sql-hash-key ((arg vector) database) (list 'vector (map 'list (lambda (arg) @@ -941,13 +969,13 @@ uninclusive, and the args from that keyword to the end." (defmethod database-output-sql (thing database) (if (or (null thing) - (eq 'null thing)) + (eq 'null thing)) +null-string+ (error 'sql-user-error :message - (format nil - "No type conversion to SQL for ~A is defined for DB ~A." - (type-of thing) (type-of database))))) + (format nil + "No type conversion to SQL for ~A is defined for DB ~A." + (type-of thing) (type-of database))))) ;; @@ -965,7 +993,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)) @@ -982,7 +1012,7 @@ uninclusive, and the args from that keyword to the end." (if (null output) (error 'sql-user-error :message (format nil "unsupported column constraint '~A'" - constraint)) + constraint)) (setq string (concatenate 'string string (cdr output)))) (if (< 1 (length constraint)) (setq string (concatenate 'string string " "))))))))