(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))
(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
(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)
(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)
(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