X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=df9cfc08b55da8a5195310172e23402a8ea29c43;hp=67fc6fa0b3c40a47312c8fd90e76c791f580e8a3;hb=refs%2Ftags%2Fv3.8.6;hpb=767faaefa5855710da1e5212bf69f262150c04e7 diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 67fc6fa..df9cfc0 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,10 +112,10 @@ (defmethod output-sql ((expr sql-ident) database) (with-slots (name) expr (write-string - (convert-to-db-default-case + (convert-to-db-default-case (etypecase name - (string name) - (symbol (symbol-name name))) + (string name) + (symbol (symbol-name name))) database) *sql-stream*)) t) @@ -152,30 +152,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 + ;; 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))) + (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 + (when qualifier + (typecase qualifier (string (format nil "~s" qualifier)) - (t (convert-to-db-default-case (sql-escape qualifier) + (t (convert-to-db-default-case (sql-escape qualifier) database)))) - (sql-escape (convert-to-db-default-case name database)))) + (sql-escape (convert-to-db-default-case name database)))) t)) (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) @@ -269,7 +269,7 @@ (defclass sql-upcase-like (sql-relational-exp) () (:documentation "An SQL 'like' that upcases its arguments.")) - + (defmethod output-sql ((expr sql-upcase-like) database) (flet ((write-term (term) (write-string "upper(" *sql-stream*) @@ -386,12 +386,12 @@ (defclass sql-between-exp (sql-function-exp) - () + () (:documentation "An SQL between expression.")) (defmethod output-sql ((expr sql-between-exp) database) - (with-slots (name args) - expr + (with-slots (args) + expr (output-sql (first args) database) (write-string " BETWEEN " *sql-stream*) (output-sql (second args) database) @@ -399,7 +399,7 @@ (output-sql (third args) database)) t) -(defclass sql-query-modifier-exp (%sql-expression) +(defclass sql-query-modifier-exp (%sql-expression) ((modifier :initarg :modifier :initform nil) (components :initarg :components :initform nil)) (:documentation "An SQL query modifier expression.")) @@ -410,11 +410,11 @@ (output-sql modifier database) (write-string " " *sql-stream*) (output-sql (car components) database) - (when components - (mapc #'(lambda (comp) - (write-string ", " *sql-stream*) - (output-sql comp database)) - (cdr components)))) + (when components + (mapc #'(lambda (comp) + (write-string ", " *sql-stream*) + (output-sql comp database)) + (cdr components)))) t) (defclass sql-set-exp (%sql-expression) @@ -544,35 +544,35 @@ 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) - (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)))))) + (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)))))) (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) + limit offset inner-join on all set-operation) query (when *in-subselect* (write-string "(" *sql-stream*)) (write-string "SELECT " *sql-stream*) - (when all + (when all (write-string "ALL " *sql-stream*)) (when (and distinct (not all)) (write-string "DISTINCT " *sql-stream*) @@ -583,21 +583,22 @@ uninclusive, and the args from that keyword to the end." (output-sql (apply #'vector selections) database) (when from (write-string " FROM " *sql-stream*) - (flet ((ident-table-equal (a b) + (flet ((ident-table-equal (a b) (and (if (and (eql (type-of a) 'sql-ident-table) (eql (type-of b) 'sql-ident-table)) (string-equal (slot-value a 'alias) (slot-value b 'alias)) t) - (string-equal (symbol-name (slot-value a 'name)) - (symbol-name (slot-value b 'name)))))) - (typecase from - (list (output-sql (apply #'vector - (remove-duplicates from + (string-equal (sql-escape (slot-value a 'name)) + (sql-escape (slot-value b 'name)))))) + (typecase from + (list (output-sql (apply #'vector + (remove-duplicates from :test #'ident-table-equal)) database)) (string (write-string from *sql-stream*)) - (t (output-sql from database))))) + (t (let ((*in-subselect* t)) + (output-sql from database)))))) (when inner-join (write-string " INNER JOIN " *sql-stream*) (output-sql inner-join database)) @@ -610,7 +611,19 @@ uninclusive, and the args from that keyword to the end." (output-sql where database))) (when group-by (write-string " GROUP BY " *sql-stream*) - (output-sql group-by database)) + (if (listp group-by) + (do ((order group-by (cdr order))) + ((null order)) + (let ((item (car order))) + (typecase item + (cons + (output-sql (car item) database) + (format *sql-stream* " ~A" (cadr item))) + (t + (output-sql item database))) + (when (cdr order) + (write-char #\, *sql-stream*)))) + (output-sql group-by database))) (when having (write-string " HAVING " *sql-stream*) (output-sql having database)) @@ -620,11 +633,11 @@ uninclusive, and the args from that keyword to the end." (do ((order order-by (cdr order))) ((null order)) (let ((item (car order))) - (typecase item - (cons + (typecase item + (cons (output-sql (car item) database) (format *sql-stream* " ~A" (cadr item))) - (t + (t (output-sql item database))) (when (cdr order) (write-char #\, *sql-stream*)))) @@ -637,7 +650,7 @@ uninclusive, and the args from that keyword to the end." (output-sql offset database)) (when *in-subselect* (write-string ")" *sql-stream*)) - (when set-operation + (when set-operation (write-char #\Space *sql-stream*) (output-sql set-operation database))) t) @@ -672,10 +685,10 @@ uninclusive, and the args from that keyword to the end." (with-slots (into attributes values query) ins (write-string "INSERT INTO " *sql-stream*) - (output-sql + (output-sql (typecase into (string (sql-expression :attribute into)) - (t into)) + (t into)) database) (when attributes (write-char #\Space *sql-stream*) @@ -782,10 +795,10 @@ 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 + (let ((constraints (database-constraint-statement (if (and db-type (symbolp db-type)) (cons db-type constraints) constraints) @@ -810,9 +823,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) @@ -837,12 +850,12 @@ uninclusive, and the args from that keyword to the end." ;; -;; DATABASE-OUTPUT-SQL -;; +;; DATABASE-OUTPUT-SQL +;; (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) @@ -852,20 +865,20 @@ 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) (setf (aref buf j) #\')) ((and (char= char #\\) - ;; MTP: only escape backslash with pgsql/mysql - (member (database-underlying-type database) + ;; MTP: only escape backslash with pgsql/mysql + (member (database-underlying-type database) '(:postgresql :mysql) :test #'eq)) (setf (aref buf j) #\\) @@ -876,8 +889,8 @@ uninclusive, and the args from that keyword to the end." (let ((keyword-package (symbol-package :foo))) (defmethod database-output-sql ((sym symbol) database) - (if (null sym) - +null-string+ + (if (null sym) + +null-string+ (convert-to-db-default-case (if (equal (symbol-package sym) keyword-package) (concatenate 'string "'" (string sym) "'") @@ -885,24 +898,33 @@ uninclusive, and the args from that keyword to the end." database)))) (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'") (defmethod database-output-sql ((num number) database) (declare (ignore database)) - (princ-to-string num)) + (number-to-sql-string num)) (defmethod database-output-sql ((arg list) database) - (if (null arg) - +null-string+ + (if (null arg) + +null-string+ (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) (sql-output val database)) arg)))) (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) @@ -922,42 +944,42 @@ uninclusive, and the args from that keyword to the end." (declare (ignore database)) (format nil "'~a'" (duration-timestring self))) -#+ignore +#+ignore (defmethod database-output-sql ((self money) database) (database-output-sql (slot-value self 'odcl::units) database)) (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))))) ;; -;; Column constraint types and conversion to SQL +;; Column constraint types and conversion to SQL ;; (defparameter *constraint-types* - (list - (cons (symbol-name-default-case "NOT-NULL") "NOT NULL") + (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 "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 "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"))) (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 "")) @@ -969,7 +991,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 " "))))))))