X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fclasses.lisp;h=f33a236769d83df592eedf0835d338858bd8d96a;hp=a2ca8577727d6ac81a996514b935a30cb4b09639;hb=8a8ee2d7d791b7a3efaed06420802a925d16fca3;hpb=8071212edc91e628c70a628515ae893bfd85f2e3 diff --git a/sql/classes.lisp b/sql/classes.lisp index a2ca857..f33a236 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -22,14 +22,6 @@ (defvar *sql-stream* nil "stream which accumulates SQL output") -(defvar *default-schema* "UNCOMMONSQL") - -(defvar *object-schemas* (make-hash-table :test #'equal) - "Hash of schema name to class constituent lists.") - -(defun in-schema (schemaname) - (setf *default-schema* schemaname)) - (defun sql-output (sql-expr &optional database) (progv '(*sql-stream*) `(,(make-string-output-stream)) @@ -40,8 +32,7 @@ (defclass %sql-expression () ()) -(defmethod output-sql ((expr %sql-expression) &optional - (database *default-database*)) +(defmethod output-sql ((expr %sql-expression) database) (declare (ignore database)) (write-string +null-string+ *sql-stream*)) @@ -64,7 +55,7 @@ sql `(make-instance 'sql :string ',text))) -(defmethod output-sql ((expr sql) &optional (database *default-database*)) +(defmethod output-sql ((expr sql) database) (declare (ignore database)) (write-string (slot-value expr 'text) *sql-stream*) t) @@ -72,7 +63,7 @@ (defmethod print-object ((ident sql) stream) (format stream "#<~S \"~A\">" (type-of ident) - (sql-output ident))) + (sql-output ident nil))) ;; For SQL Identifiers of generic type (defclass sql-ident (%sql-expression) @@ -89,13 +80,13 @@ (defvar *output-hash* (make-hash-table :test #'equal)) -(defmethod output-sql-hash-key (expr &optional (database *default-database*)) +(defmethod output-sql-hash-key (expr database) (declare (ignore expr database)) nil) -(defmethod output-sql :around ((sql t) &optional (database *default-database*)) - (declare (ignore database)) - (let* ((hash-key (output-sql-hash-key sql)) +#+ignore +(defmethod output-sql :around ((sql t) database) + (let* ((hash-key (output-sql-hash-key sql database)) (hash-value (when hash-key (gethash hash-key *output-hash*)))) (cond ((and hash-key hash-value) (write-string hash-value *sql-stream*)) @@ -108,17 +99,17 @@ (t (call-next-method))))) -(defmethod output-sql ((expr sql-ident) &optional - (database *default-database*)) - (declare (ignore database)) +(defmethod output-sql ((expr sql-ident) database) (with-slots (name) - expr - (etypecase name - (string - (write-string name *sql-stream*)) - (symbol - (write-string (symbol-name name) *sql-stream*))) - t)) + expr + (write-string + (convert-to-db-default-case + (etypecase name + (string name) + (symbol (symbol-name name))) + database) + *sql-stream*)) + t) ;; For SQL Identifiers for attributes @@ -152,21 +143,28 @@ :qualifier ',qualifier :type ',type))) -(defmethod output-sql ((expr sql-ident-attribute) &optional - (database *default-database*)) - (declare (ignore database)) +(defmethod output-sql ((expr sql-ident-attribute) database) (with-slots (qualifier name type params) - expr - (if (and name (not qualifier) (not type)) - (write-string (sql-escape (symbol-name name)) *sql-stream*) - (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" - (if qualifier (sql-escape qualifier) qualifier) - (sql-escape name) - type)) + expr + (if (and (not qualifier) (not type)) + (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 + (convert-to-db-default-case (sql-escape qualifier) database)) + (sql-escape (convert-to-db-default-case name database)))) t)) -(defmethod output-sql-hash-key ((expr sql-ident-attribute) &optional - (database *default-database*)) +(defmethod output-sql-hash-key ((expr sql-ident-attribute) database) (declare (ignore database)) (with-slots (qualifier name type params) expr @@ -182,22 +180,20 @@ (declare (ignore environment)) (with-slots (alias name) sql - `(make-instance 'sql-ident-table :name name :alias ',alias))) + `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) -(defun generate-sql (expr) +(defun generate-sql (expr database) (let ((*sql-stream* (make-string-output-stream))) - (output-sql expr) + (output-sql expr database) (get-output-stream-string *sql-stream*))) -(defmethod output-sql ((expr sql-ident-table) &optional - (database *default-database*)) - (declare (ignore database)) +(defmethod output-sql ((expr sql-ident-table) database) (with-slots (name alias) expr (if (null alias) - (write-string (sql-escape (symbol-name name)) *sql-stream*) + (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) (progn - (write-string (sql-escape (symbol-name name)) *sql-stream*) + (write-string (sql-escape (convert-to-db-default-case (symbol-name name) database)) *sql-stream*) (write-char #\Space *sql-stream*) (format *sql-stream* "~s" alias)))) t) @@ -212,8 +208,7 @@ |# -(defmethod output-sql-hash-key ((expr sql-ident-table) &optional - (database *default-database*)) +(defmethod output-sql-hash-key ((expr sql-ident-table) database) (declare (ignore database)) (with-slots (name alias) expr @@ -244,8 +239,7 @@ ;; Write SQL for relational operators (like 'AND' and 'OR'). ;; should do arity checking of subexpressions -(defmethod output-sql ((expr sql-relational-exp) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-relational-exp) database) (with-slots (operator sub-expressions) expr (let ((subs (if (consp (car sub-expressions)) @@ -268,8 +262,7 @@ ;; Write SQL for relational operators (like 'AND' and 'OR'). ;; should do arity checking of subexpressions -(defmethod output-sql ((expr sql-upcase-like) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-upcase-like) database) (flet ((write-term (term) (write-string "upper(" *sql-stream*) (output-sql term database) @@ -292,8 +285,7 @@ (:documentation "An SQL Assignment expression.")) -(defmethod output-sql ((expr sql-assignment-exp) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-assignment-exp) database) (with-slots (operator sub-expressions) expr (do ((sub sub-expressions (cdr sub))) @@ -330,8 +322,7 @@ -(defmethod output-sql ((expr sql-value-exp) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-value-exp) database) (with-slots (modifier components) expr (if modifier @@ -347,8 +338,7 @@ () (:documentation "An SQL typecast expression.")) -(defmethod output-sql ((expr sql-typecast-exp) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-typecast-exp) database) (database-output-sql expr database)) (defmethod database-output-sql ((expr sql-typecast-exp) database) @@ -381,14 +371,79 @@ (equal (slot-value tab1 'name) (slot-value tab2 'name)))))) -(defmethod output-sql ((expr sql-function-exp) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-function-exp) database) (with-slots (name args) expr (output-sql name database) (when args (output-sql args database))) t) + +(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 + (output-sql (first args) database) + (write-string " BETWEEN " *sql-stream*) + (output-sql (second args) database) + (write-string " AND " *sql-stream*) + (output-sql (third args) database)) + t) + +(defclass sql-query-modifier-exp (%sql-expression) + ((modifier :initarg :modifier :initform nil) + (components :initarg :components :initform nil)) + (:documentation "An SQL query modifier expression.")) + +(defmethod output-sql ((expr sql-query-modifier-exp) database) + (with-slots (modifier components) + expr + (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)))) + t) + +(defclass sql-set-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL set expression.")) + +(defmethod collect-table-refs ((sql sql-set-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + +(defmethod output-sql ((expr sql-set-exp) database) + (with-slots (operator sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (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*)))) + t) + (defclass sql-query (%sql-expression) ((selections :initarg :selections @@ -428,9 +483,29 @@ :initform nil) (order-by-descending :initarg :order-by-descending + :initform nil) + (inner-join + :initarg :inner-join + :initform nil) + (on + :initarg :on :initform nil)) (:documentation "An SQL SELECT query.")) +(defclass sql-object-query (%sql-expression) + ((objects + :initarg :objects + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (exp + :initarg :exp + :initform nil) + (refresh + :initarg :refresh + :initform nil))) + (defmethod collect-table-refs ((sql sql-query)) (remove-duplicates (collect-table-refs (slot-value sql 'where)) :test (lambda (tab1 tab2) @@ -439,7 +514,10 @@ (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit)) + :order-by-descending :set-operation :where :offset :limit + :inner-join :on + ;; below keywords are not a SQL argument, but these keywords may terminate select + :caching :refresh)) (defun query-arg-p (sym) (member sym *select-arguments*)) @@ -453,30 +531,41 @@ uninclusive, and the args from that keyword to the end." (subseq select-args first-key-arg)) select-args))) -(defmethod make-query (&rest args) - (multiple-value-bind (selections arglist) - (query-get-selections args) - (destructuring-bind (&key all flatp set-operation distinct from where - group-by having order-by order-by-descending - offset limit &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 - :order-by-descending order-by-descending)))) +(defun make-query (&rest args) + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (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 order-by-descending + 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 + :order-by-descending order-by-descending + :inner-join inner-join :on on)))))) (defvar *in-subselect* nil) -(defmethod output-sql ((query sql-query) &optional - (database *default-database*)) +(defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by - order-by-descending limit offset) + order-by-descending limit offset inner-join on) query (when *in-subselect* (write-string "(" *sql-stream*)) @@ -488,10 +577,17 @@ uninclusive, and the args from that keyword to the end." (output-sql distinct database) (write-char #\Space *sql-stream*))) (output-sql (apply #'vector selections) database) - (write-string " FROM " *sql-stream*) - (if (listp from) - (output-sql (apply #'vector from) database) - (output-sql from database)) + (when from + (write-string " FROM " *sql-stream*) + (if (listp from) + (output-sql (apply #'vector from) database) + (output-sql from database))) + (when inner-join + (write-string " INNER JOIN " *sql-stream*) + (output-sql inner-join database)) + (when on + (write-string " ON " *sql-stream*) + (output-sql on database)) (when where (write-string " WHERE " *sql-stream*) (let ((*in-subselect* t)) @@ -531,6 +627,13 @@ uninclusive, and the args from that keyword to the end." (write-string ")" *sql-stream*))) t) +(defmethod output-sql ((query sql-object-query) database) + (with-slots (objects) + query + (when objects + (format *sql-stream* "(~{~A~^ ~})" objects)))) + + ;; INSERT (defclass sql-insert (%sql-expression) @@ -549,8 +652,7 @@ uninclusive, and the args from that keyword to the end." (:documentation "An SQL INSERT statement.")) -(defmethod output-sql ((ins sql-insert) &optional - (database *default-database*)) +(defmethod output-sql ((ins sql-insert) database) (with-slots (into attributes values query) ins (write-string "INSERT INTO " *sql-stream*) @@ -578,8 +680,7 @@ uninclusive, and the args from that keyword to the end." (:documentation "An SQL DELETE statement.")) -(defmethod output-sql ((stmt sql-delete) &optional - (database *default-database*)) +(defmethod output-sql ((stmt sql-delete) database) (with-slots (from where) stmt (write-string "DELETE FROM " *sql-stream*) @@ -608,8 +709,7 @@ uninclusive, and the args from that keyword to the end." :initform nil)) (:documentation "An SQL UPDATE statement.")) -(defmethod output-sql ((expr sql-update) &optional - (database *default-database*)) +(defmethod output-sql ((expr sql-update) database) (with-slots (table where attributes values) expr (flet ((update-assignments () @@ -638,34 +738,38 @@ uninclusive, and the args from that keyword to the end." :initform nil) (modifiers :initarg :modifiers + :initform nil) + (transactions + :initarg :transactions :initform nil)) (:documentation "An SQL CREATE TABLE statement.")) ;; Here's a real warhorse of a function! +(declaim (inline listify)) (defun listify (x) (if (atom x) (list x) x)) -(defmethod output-sql ((stmt sql-create-table) &optional - (database *default-database*)) +(defmethod output-sql ((stmt sql-create-table) database) (flet ((output-column (column-spec) - (destructuring-bind (name type &rest constraints) + (destructuring-bind (name type &optional db-type &rest constraints) column-spec (let ((type (listify type))) (output-sql name database) (write-char #\Space *sql-stream*) (write-string - (database-get-type-specifier (car type) (cdr type) database) + (if (stringp db-type) db-type ; override definition + (database-get-type-specifier (car type) (cdr type) database)) *sql-stream*) (let ((constraints (database-constraint-statement constraints database))) (when constraints (write-string " " *sql-stream*) (write-string constraints *sql-stream*))))))) - (with-slots (name columns modifiers) + (with-slots (name columns modifiers transactions) stmt (write-string "CREATE TABLE " *sql-stream*) (output-sql name database) @@ -680,7 +784,11 @@ uninclusive, and the args from that keyword to the end." ((null modifier)) (write-string ", " *sql-stream*) (write-string (car modifier) *sql-stream*))) - (write-char #\) *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*)))) t) @@ -693,7 +801,7 @@ uninclusive, and the args from that keyword to the end." (with-check-option :initarg :with-check-option :initform nil)) (:documentation "An SQL CREATE VIEW statement.")) -(defmethod output-sql ((stmt sql-create-view) &optional database) +(defmethod output-sql ((stmt sql-create-view) database) (with-slots (name column-list query with-check-option) stmt (write-string "CREATE VIEW " *sql-stream*) (output-sql name database) @@ -708,8 +816,9 @@ uninclusive, and the args from that keyword to the end." ;; Column constraint types ;; (defparameter *constraint-types* - '(("NOT-NULL" . "NOT NULL") - ("PRIMARY-KEY" . "PRIMARY KEY"))) + (list + (cons (symbol-name-default-case "NOT-NULL") "NOT NULL") + (cons (symbol-name-default-case "PRIMARY-KEY") "PRIMARY KEY"))) ;; ;; Convert type spec to sql syntax