#\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\>
#\{ #\}))))
+(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."
(symbol
(let ((s (sql-escape inp)))
(if (and (not (eql '* inp)) (special-char-p s))
- (%escape-identifier (convert-to-db-default-case s database) inp)
- (make-instance '%database-identifier :escaped s :unescaped inp)))))))
+ (%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)
"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))
(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)))
(when qual
(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
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
(flet ((p (s) ;; the etypecase is in sql-escape too
(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
;; 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
;; we do this as two runs so as not to emit confusing superflous parentheses
(loop for str-sub in (rest str-subs)
do
(write-char #\Space *sql-stream*)
- (output-sql operator database)
+ ;; 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*))
((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)
(remove-duplicates tabs :test #'database-identifier-equal))
nil)))
-
-
(defmethod output-sql ((expr sql-value-exp) database)
(with-slots (modifier components)
expr
(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*))
(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)
expr
(%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*)
(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)
: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
limit offset inner-join on all set-operation)
(when on
(write-string " ON " *sql-stream*)
(output-sql on database))
- (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*))))
+ (output-sql-where-clause where database)
(when group-by
(write-string " GROUP BY " *sql-stream*)
(if (listp group-by)
(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)))
(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
(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
(when (and (eq :mysql (database-underlying-type database))
transactions
(db-type-transaction-capable? :mysql database))
- (write-string " Type=InnoDB" *sql-stream*))))
+ (write-string " ENGINE=innodb" *sql-stream*))))
t)
(defmethod database-output-sql ((sym symbol) database)
(if (null sym)
+null-string+
- (if (equal (symbol-package sym) keyword-package)
- (concatenate 'string "'" (string sym) "'")
- (symbol-name sym)))))
+ (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
;;
;; 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 "DEFAULT") "DEFAULT")
- (cons (symbol-name-default-case "UNIQUE") "UNIQUE")
- (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;; added for sql-server support
- ))
-
(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))))
- (when (equal (symbol-name (car constraint)) "DEFAULT")
- (setq constraint (cdr constraint))
- (setq string (concatenate 'string string " " (car constraint))))
- (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")
+ ;; this is modeled as a datatype instead of a constraint
+ (:postgresql "")))
+ ;; 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, recurively coerces it,
+ "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
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))
(%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))
+
+
+(defclass sql-escape-string-exp (%sql-expression)
+ ((string
+ :initarg :string
+ :initform nil))
+ (:documentation
+ "An escaped string string expression (postgresql E'stuff') ."))
+
+(defmethod output-sql ((exp sql-escape-string-exp) database)
+ (with-slots (string) exp
+ (when string
+ (write-char #\E *sql-stream*)
+ (output-sql string database))))