X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=91a46d7fb2c6c30592056c6ea98c2c25e260aee7;hp=cd1a6d397bc9a2665bf0472a80d5d14aa563e602;hb=5ed1f05543cbd24b3f2bb735f2cfc03ea85e51ec;hpb=159a4ba88b6ed66a27968df60d91c6b284401d2b diff --git a/sql/expressions.lisp b/sql/expressions.lisp index cd1a6d3..91a46d7 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." @@ -112,11 +112,9 @@ (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 +135,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 +149,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 (sql-escape qualifier)))) + (typecase name + (string (format nil "~s" (sql-escape name))) + (t (sql-escape name))))) t)) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) @@ -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) @@ -390,7 +381,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 +403,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 +535,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 @@ -596,7 +587,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 @@ -687,7 +678,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 +786,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 +800,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 +817,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 +849,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 +859,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 +885,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 +915,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 +942,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))))) ;; @@ -982,7 +983,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 " "))))))))