X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fexpressions.lisp;h=10bdb5ec0b2a0dd23e7d85032da5f180e1b45315;hp=57afac1b391084aaf658ec4d3511d6573ceaeb2e;hb=374df8f34a7214e08fc4cfc5d734d024acdbf9ca;hpb=26533896461bb09509b5df14c767afe85dce324d diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 57afac1..10bdb5e 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -1,8 +1,6 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ -;;;; ;;;; Classes defining SQL expressions and methods for formatting the ;;;; appropriate SQL commands. ;;;; @@ -22,35 +20,154 @@ (defvar *sql-stream* nil "stream which accumulates SQL output") -(defun sql-output (sql-expr &optional database) +(defclass %database-identifier () + ((escaped :accessor escaped :initarg :escaped :initform nil) + (unescaped :accessor unescaped :initarg :unescaped :initform nil)) + (:documentation + "A database identifier represents a string/symbol ready to be spliced + into a sql string. It keeps references to both the escaped and + unescaped versions so that unescaped versions can be compared to the + results of list-tables/views/attributes etc. It also allows you to be + sure that an identifier is escaped only once. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + (unescaped-database-identifier *any-reasonable-object*) is generally what + you pass to it with the exception that symbols have been + clsql-sys:sql-escape which converts to a string and changes - to _ (so + that unescaped can be compared to the results of eg: list-tables) + ")) + +(defmethod escaped ((it null)) it) +(defmethod unescaped ((it null)) it) + +(defun database-identifier-equal (i1 i2 &optional (database clsql-sys:*default-database*)) + (setf i1 (database-identifier i1 database) + i2 (database-identifier i2 database)) + (flet ((cast (i) + (if (symbolp (unescaped i)) + (sql-escape (unescaped i)) + (unescaped i)))) + (or ;; check for an exact match + (equal (escaped-database-identifier i1) + (escaped-database-identifier i2)) + ;; check for an inexact match if we had symbols in the mix + (string-equal (cast i1) (cast i2))))) + +(defun delistify-dsd (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (and (listp list) (null (cdr list))) + (car list) + list)) + +(defun special-char-p (s) + "Check if a string has any special characters" + (loop for char across s + thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% #\' #\" + #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\> + #\{ #\})))) + +(defun special-cased-symbol-p (sym) + "Should the symbols case be preserved, or should we convert to default casing" + (let ((name (symbol-name sym))) + (case (readtable-case *readtable*) + (:upcase (not (string= (string-upcase name) name))) + (:downcase (not (string= (string-downcase name) name))) + (t t)))) + +(defun %make-database-identifier (inp &optional database) + "We want to quote an identifier if it came to us as a string or if it has special characters + in it." + (labels ((%escape-identifier (inp &optional orig) + "Quote an identifier unless it is already quoted" + (cond + ;; already quoted + ((and (eql #\" (elt inp 0)) + (eql #\" (elt inp (- (length inp) 1)))) + (make-instance '%database-identifier :unescaped (or orig inp) :escaped inp)) + (T (make-instance + '%database-identifier :unescaped (or orig inp) :escaped + (concatenate + 'string "\"" (replace-all inp "\"" "\\\"") "\"")))))) + (typecase inp + (string (%escape-identifier inp)) + (%database-identifier inp) + (symbol + (let ((s (sql-escape inp))) + (if (and (not (eql '* inp)) (special-char-p s)) + (%escape-identifier + (if (special-cased-symbol-p inp) + s + (convert-to-db-default-case s database)) inp) + (make-instance '%database-identifier :escaped s :unescaped inp)) + ))))) + +(defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*) + &aux res all-sym? pkg) + "Create a new database identifier by combining parts in a reasonable way + " + (setf ids (mapcar #'database-identifier ids) + all-sym? (every (lambda (i) (symbolp (unescaped i))) ids) + pkg (when all-sym? (symbol-package (unescaped (first ids))))) + (labels ((cast ( i ) + (typecase i + (null nil) + (%database-identifier (cast (unescaped i))) + (symbol + (if all-sym? + (sql-escape i) + (convert-to-db-default-case (sql-escape i) database))) + (string i))) + (comb (i1 i2) + (setf i1 (cast i1) + i2 (cast i2)) + (if (and i1 i2) + (concatenate 'string (cast i1) "_" (cast i2)) + (or i1 i2)))) + (setf res (reduce #'comb ids)) + (database-identifier + (if all-sym? (intern res pkg) res) + database))) + +(defun escaped-database-identifier (name &optional database find-class-p) + (escaped (database-identifier name database find-class-p))) + +(defun unescaped-database-identifier (name &optional database find-class-p) + (unescaped (database-identifier name database find-class-p))) + +(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." - (progv '(*sql-stream*) - `(,(make-string-output-stream)) - (output-sql sql-expr database) - (get-output-stream-string *sql-stream*))) + (with-output-to-string (*sql-stream*) + (output-sql sql-expr database))) (defmethod output-sql (expr database) (write-string (database-output-sql expr database) *sql-stream*) (values)) -(defvar *output-hash* (make-hash-table :test #'equal) - "For caching generated SQL strings.") + +(defvar *output-hash* + (make-weak-hash-table :test #'equal) + "For caching generated SQL strings, set to NIL to disable." + ) (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*)) - (hash-key - (let ((*sql-stream* (make-string-output-stream))) - (call-next-method) - (setf hash-value (get-output-stream-string *sql-stream*)) - (setf (gethash hash-key *output-hash*) hash-value)) - (write-string hash-value *sql-stream*)) - (t - (call-next-method))))) + (if (null *output-hash*) + (call-next-method) + (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*)) + (hash-key + (let ((*sql-stream* (make-string-output-stream))) + (call-next-method) + (setf hash-value (get-output-stream-string *sql-stream*)) + (setf (gethash hash-key *output-hash*) hash-value)) + (write-string hash-value *sql-stream*)) + (t + (call-next-method)))))) (defmethod output-sql-hash-key (expr database) (declare (ignore expr database)) @@ -109,15 +226,12 @@ sql `(make-instance 'sql-ident :name ',name))) +(defmethod output-sql ((expr %database-identifier) database) + (write-string (escaped expr) *sql-stream*)) + (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) - *sql-stream*)) + (write-string (escaped-database-identifier name database) *sql-stream*)) t) ;; For SQL Identifiers for attributes @@ -135,11 +249,17 @@ (declare (ignore sql)) nil) +(defmethod collect-table-refs ((sql list)) + (loop for i in sql + appending (listify (collect-table-refs i)))) + (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 + ;; going to be used as a table, search classes + (list (make-instance + 'sql-ident-table + :name (database-identifier qual nil t)))))) (defmethod make-load-form ((sql sql-ident-attribute) &optional environment) (declare (ignore environment)) @@ -149,40 +269,13 @@ :qualifier ',qualifier :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)) - (defmethod output-sql-hash-key ((expr sql-ident-attribute) database) (with-slots (qualifier name type) expr (list (and database (database-underlying-type database)) - 'sql-ident-attribute qualifier name type))) + 'sql-ident-attribute + (unescaped-database-identifier qualifier) + (unescaped-database-identifier name) type))) ;; For SQL Identifiers for tables @@ -197,28 +290,40 @@ sql `(make-instance 'sql-ident-table :name ',name :table-alias ',alias))) +(defmethod collect-table-refs ((sql sql-ident-table)) + (list sql)) + (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))))) + (flet ((p (s) ;; the etypecase is in sql-escape too + (write-string + (escaped-database-identifier s database) + *sql-stream*))) + (p name) + (when alias + (princ #\space *sql-stream*) + (p alias)))) t) +(defmethod output-sql ((expr sql-ident-attribute) database) +;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it +;;; should not be output in SQL statements + (let ((*print-pretty* nil)) + (with-slots (qualifier name type) expr + (format *sql-stream* "~@[~a.~]~a" + (when qualifier + ;; check for classes + (escaped-database-identifier qualifier database T)) + (escaped-database-identifier name database)) + t))) + (defmethod output-sql-hash-key ((expr sql-ident-table) database) (with-slots (name alias) expr (list (and database (database-underlying-type database)) - 'sql-ident-table name alias))) + 'sql-ident-table + (unescaped-database-identifier name) + (unescaped-database-identifier alias)))) (defclass sql-relational-exp (%sql-expression) ((operator @@ -239,10 +344,7 @@ (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)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) @@ -250,20 +352,43 @@ ;; Write SQL for relational operators (like 'AND' and 'OR'). ;; should do arity checking of subexpressions +(defun %write-operator (operator database) + (typecase operator + (string (write-string operator *sql-stream*)) + (symbol (write-string (symbol-name operator) *sql-stream*)) + (T (output-sql operator database)))) + (defmethod output-sql ((expr sql-relational-exp) database) - (with-slots (operator sub-expressions) - expr - (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*))) + (with-slots (operator sub-expressions) expr + ;; we do this as two runs so as not to emit confusing superflous parentheses + ;; The first loop renders all the child outputs so that we can skip anding with + ;; empty output (which causes sql errors) + ;; the next loop simply emits each sub-expression with the appropriate number of + ;; parens and operators + (flet ((trim (sub) + (string-trim +whitespace-chars+ + (with-output-to-string (*sql-stream*) + (output-sql sub database))))) + (let ((str-subs (loop for sub in sub-expressions + for str-sub = (trim sub) + when (and str-sub (> (length str-sub) 0)) + collect str-sub))) + (case (length str-subs) + (0 nil) + (1 (write-string (first str-subs) *sql-stream*)) + (t + (write-char #\( *sql-stream*) + (write-string (first str-subs) *sql-stream*) + (loop for str-sub in (rest str-subs) + do + (write-char #\Space *sql-stream*) + ;; do this so that symbols can be output as database identifiers + ;; rather than allowing symbols to inject sql + (%write-operator operator database) + (write-char #\Space *sql-stream*) + (write-string str-sub *sql-stream*)) + (write-char #\) *sql-stream*)) + )))) t) (defclass sql-upcase-like (sql-relational-exp) @@ -300,7 +425,7 @@ ((null (cdr sub)) (output-sql (car sub) database)) (output-sql (car sub) database) (write-char #\Space *sql-stream*) - (output-sql operator database) + (%write-operator operator database) (write-char #\Space *sql-stream*))) t) @@ -322,10 +447,7 @@ (dolist (exp (slot-value sql 'components)) (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))))) + (remove-duplicates tabs :test #'database-identifier-equal)) nil))) @@ -336,7 +458,14 @@ (if modifier (progn (write-char #\( *sql-stream*) - (output-sql modifier database) + (cond + ((sql-operator modifier) + (%write-operator modifier database)) + ((or (stringp modifier) (symbolp modifier)) + (write-string + (escaped-database-identifier modifier) + *sql-stream*)) + (t (output-sql modifier database))) (write-char #\Space *sql-stream*) (output-sql components database) (write-char #\) *sql-stream*)) @@ -370,16 +499,16 @@ (dolist (exp (slot-value sql 'args)) (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)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) (defvar *in-subselect* nil) (defmethod output-sql ((expr sql-function-exp) database) (with-slots (name args) expr - (output-sql name database) + (typecase name + ((or string symbol) + (write-string (escaped-database-identifier name) *sql-stream*)) + (t (output-sql name database))) (let ((*in-subselect* nil)) ;; aboid double parens (when args (output-sql args database)))) t) @@ -390,7 +519,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*) @@ -407,14 +536,14 @@ (defmethod output-sql ((expr sql-query-modifier-exp) database) (with-slots (modifier components) expr - (output-sql modifier database) + (%write-operator modifier database) (write-string " " *sql-stream*) - (output-sql (car components) database) + (%write-operator (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) @@ -431,10 +560,7 @@ (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)))))) + (remove-duplicates tabs :test #'database-identifier-equal))) (defmethod output-sql ((expr sql-set-exp) database) (with-slots (operator sub-expressions) @@ -443,13 +569,13 @@ (car sub-expressions) sub-expressions))) (when (= (length subs) 1) - (output-sql operator database) + (%write-operator operator database) (write-char #\Space *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-operator operator database) (write-char #\Space *sql-stream*)))) t) @@ -513,10 +639,9 @@ :initform nil))) (defmethod collect-table-refs ((sql sql-query)) - (remove-duplicates (collect-table-refs (slot-value sql 'where)) - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name))))) + (remove-duplicates + (collect-table-refs (slot-value sql 'where)) + :test #'database-identifier-equal)) (defvar *select-arguments* '(:all :database :distinct :flatp :from :group-by :having :order-by @@ -544,26 +669,40 @@ 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)))))) + +(defun output-sql-where-clause (where database) + "ensure that we do not output a \"where\" sql keyword when we will + not output a clause. Also sets *in-subselect* to use SQL + parentheticals as needed." + (when where + (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*))))) (defmethod output-sql ((query sql-query) database) (with-slots (distinct selections from where group-by having order-by @@ -573,42 +712,38 @@ uninclusive, and the args from that keyword to the end." (write-string "(" *sql-stream*)) (write-string "SELECT " *sql-stream*) (when all - (write-string "ALL " *sql-stream*)) + (write-string " ALL " *sql-stream*)) (when (and distinct (not all)) - (write-string "DISTINCT " *sql-stream*) + (write-string " DISTINCT " *sql-stream*) (unless (eql t distinct) - (write-string "ON " *sql-stream*) + (write-string " ON " *sql-stream*) (output-sql distinct database) (write-char #\Space *sql-stream*))) - (output-sql (apply #'vector selections) database) + (when (and limit (eql :mssql (database-underlying-type database))) + (write-string " TOP " *sql-stream*) + (output-sql limit database) + (write-string " " *sql-stream*)) + (let ((*in-subselect* t)) + (output-sql (apply #'vector selections) database)) (when from (write-string " FROM " *sql-stream*) - (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 - :test #'ident-table-equal)) - database)) - (string (write-string from *sql-stream*)) - (t (let ((*in-subselect* t)) - (output-sql from database)))))) + (typecase from + (list (output-sql + (apply #'vector + (remove-duplicates from :test #'database-identifier-equal)) + database)) + (string (write-string + (escaped-database-identifier from database) + *sql-stream*)) + (t (let ((*in-subselect* t)) + (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)) - (output-sql where database))) + (output-sql-where-clause where database) (when group-by (write-string " GROUP BY " *sql-stream*) (if (listp group-by) @@ -642,7 +777,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 (eql :mssql (database-underlying-type database)))) (write-string " LIMIT " *sql-stream*) (output-sql limit database)) (when offset @@ -687,7 +822,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 @@ -695,7 +830,8 @@ uninclusive, and the args from that keyword to the end." (output-sql attributes database)) (when values (write-string " VALUES " *sql-stream*) - (output-sql values database)) + (let ((clsql-sys::*in-subselect* t)) + (output-sql values database))) (when query (write-char #\Space *sql-stream*) (output-sql query database))) @@ -720,9 +856,7 @@ uninclusive, and the args from that keyword to the end." (typecase from ((or symbol string) (write-string (sql-escape from) *sql-stream*)) (t (output-sql from database))) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database))) + (output-sql-where-clause where database)) t) ;; UPDATE @@ -754,10 +888,9 @@ uninclusive, and the args from that keyword to the end." (write-string "UPDATE " *sql-stream*) (output-sql table database) (write-string " SET " *sql-stream*) - (output-sql (apply #'vector (update-assignments)) database) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database)))) + (let ((clsql-sys::*in-subselect* t)) + (output-sql (apply #'vector (update-assignments)) database)) + (output-sql-where-clause where database))) t) ;; CREATE TABLE @@ -782,9 +915,9 @@ uninclusive, and the args from that keyword to the end." (declaim (inline listify)) (defun listify (x) - (if (atom x) - (list x) - x)) + (if (listp x) + x + (list x))) (defmethod output-sql ((stmt sql-create-table) database) (flet ((output-column (column-spec) @@ -795,8 +928,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 +942,7 @@ 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) + (write-string (escaped-database-identifier name database) *sql-stream*) (write-string " (" *sql-stream*) (do ((column columns (cdr column))) ((null (cdr column)) @@ -823,9 +956,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 " ENGINE=innodb" *sql-stream*)))) t) @@ -855,7 +988,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 +998,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 +1024,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) + (database-output-sql (symbol-name sym) database) + (escaped-database-identifier 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 +1054,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,49 +1081,154 @@ 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))))) ;; ;; Column constraint types and conversion to SQL ;; - -(defparameter *constraint-types* - (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 "KEY") "KEY") - (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 "")) - (do ((constraint constraint-list (cdr constraint))) - ((null constraint) string) - (let ((output (assoc (symbol-name (car constraint)) - *constraint-types* - :test #'equal))) - (if (null output) - (error 'sql-user-error - :message (format nil "unsupported column constraint '~A'" - constraint)) - (setq string (concatenate 'string string (cdr output)))) - (if (< 1 (length constraint)) - (setq string (concatenate 'string string " ")))))))) + (make-constraints-description constraint-list database)) + +;; KEEP THIS SYNCED WITH database-translate-constraint +(defparameter +auto-increment-names+ + '(:auto-increment :auto_increment :autoincrement :identity)) + +(defmethod database-translate-constraint (constraint database) + (case constraint + (:not-null "NOT NULL") + (:primary-key "PRIMARY KEY") + ((:auto-increment :auto_increment :autoincrement :identity) + (ecase (database-underlying-type database) + (:mssql "IDENTITY (1,1)") + ((:sqlite :sqlite3) "PRIMARY KEY AUTOINCREMENT") + (:mysql "AUTO_INCREMENT"))) + ;; everything else just get the name + (T (string-upcase (symbol-name constraint))))) + +(defun make-constraints-description (constraint-list database + &aux (rest constraint-list) constraint) + (when constraint-list + (flet ((next () + (setf constraint (first rest) + rest (rest rest)) + constraint)) + (with-output-to-string (s) + (loop while (next) + do (unless (keywordp constraint) + (setf constraint (intern (symbol-name constraint) :keyword))) + (write-string (database-translate-constraint constraint database) s) + (when (eql :default constraint) (princ (next) s)) + (write-char #\space s) + ))))) + +(defmethod database-identifier ( name &optional database find-class-p + &aux cls) + "A function that takes whatever you give it, recursively coerces it, + and returns a database-identifier. + + (escaped-database-identifiers *any-reasonable-object*) should be called to + produce a string that is safe to splice directly into sql strings. + + This function should NOT throw errors when database is nil + + find-class-p should be T if we want to search for classes + and check their use their view table. Should be used + on symbols we are sure indicate tables + + + ;; metaclasses has further typecases of this, so that it will + ;; load less painfully (try-recompiles) in SBCL + + " + (flet ((flatten-id (id) + "if we have multiple pieces that we need to represent as + db-id lets do that by rendering out the id, then creating + a new db-id with that string as escaped" + (let ((s (sql-output id database))) + (make-instance '%database-identifier :escaped s :unescaped s)))) + (setf name (dequote name)) + (etypecase name + (null nil) + (string (%make-database-identifier name database)) + (symbol + ;; if this is being used as a table, we should check + ;; for a class with this name and use the identifier specified + ;; on it + (if (and find-class-p (setf cls (find-standard-db-class name))) + (database-identifier cls) + (%make-database-identifier name database))) + (%database-identifier name) + ;; we know how to deref this without further escaping + (sql-ident-table + (with-slots ((inner-name name) alias) name + (if alias + (flatten-id name) + (database-identifier inner-name)))) + ;; if this is a single name we can derefence it + (sql-ident-attribute + (with-slots (qualifier (inner-name name)) name + (if qualifier + (flatten-id name) + (database-identifier inner-name)))) + (sql-ident + (with-slots ((inner-name name)) name + (database-identifier inner-name))) + ;; dont know how to handle this really :/ + (%sql-expression (flatten-id name)) + ))) + +(defun %clsql-subclauses (clauses) + "a helper for dealing with lists of sql clauses" + (loop for c in clauses + when c + collect (typecase c + (string (clsql-sys:sql-expression :string c)) + (T c)))) + +(defun clsql-ands (clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-and ex)))))) + +(defun clsql-and (&rest clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (clsql-ands clauses)) + +(defun clsql-ors (clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-or ex)))))) + +(defun clsql-or (&rest clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (clsql-ors clauses))