"stream which accumulates SQL output")
(defun sql-output (sql-expr &optional 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*)))
+(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.")
+
+(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)))))
+
+(defmethod output-sql-hash-key (expr database)
+ (declare (ignore expr database))
+ nil)
+
(defclass %sql-expression ()
())
(defmethod print-object ((self %sql-expression) stream)
(print-unreadable-object
(self stream :type t)
- (write-string (sql-output self) stream)))
+ (write-string (sql-output self) stream))
+ self)
;; For straight up strings
(defmethod print-object ((ident sql) stream)
(format stream "#<~S \"~A\">"
(type-of ident)
- (sql-output ident nil)))
+ (sql-output ident nil))
+ ident)
;; For SQL Identifiers of generic type
+
(defclass sql-ident (%sql-expression)
((name
:initarg :name
- :initform "NULL"))
+ :initform +null-string+))
(:documentation "An SQL identifer."))
(defmethod make-load-form ((sql sql-ident) &optional environment)
sql
`(make-instance 'sql-ident :name ',name)))
-(defvar *output-hash* (make-hash-table :test #'equal))
-
-(defmethod output-sql-hash-key (expr database)
- (declare (ignore expr database))
- nil)
-
-#+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*))
- (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 ((expr sql-ident) database)
(with-slots (name) expr
(write-string
(defclass sql-ident-attribute (sql-ident)
((qualifier
:initarg :qualifier
- :initform "NULL")
+ :initform +null-string+)
(type
:initarg :type
- :initform "NULL"))
+ :initform +null-string+))
(:documentation "An SQL Attribute identifier."))
(defmethod collect-table-refs (sql)
t))
(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
- (declare (ignore database))
(with-slots (qualifier name type)
- expr
- (list 'sql-ident-attribute qualifier name type)))
+ expr
+ (list (and database (database-underlying-type database))
+ 'sql-ident-attribute qualifier name type)))
;; For SQL Identifiers for tables
+
(defclass sql-ident-table (sql-ident)
((alias
:initarg :table-alias :initform nil))
(format *sql-stream* "~s" alias))))
t)
-#|
-(defmethod database-output-sql ((self duration) database)
- (declare (ignore database))
- (format nil "'~a'" (duration-timestring self)))
-
-(defmethod database-output-sql ((self money) database)
- (database-output-sql (slot-value self 'odcl::units) database))
-|#
-
-
(defmethod output-sql-hash-key ((expr sql-ident-table) database)
- (declare (ignore database))
(with-slots (name alias)
- expr
- (list 'sql-ident-table name alias)))
+ expr
+ (list (and database (database-underlying-type database))
+ 'sql-ident-table name alias)))
(defclass sql-relational-exp (%sql-expression)
((operator
()
(:documentation "An SQL 'like' that upcases its arguments."))
-;; Write SQL for relational operators (like 'AND' and 'OR').
-;; should do arity checking of subexpressions
-
(defmethod output-sql ((expr sql-upcase-like) database)
(flet ((write-term (term)
(write-string "upper(" *sql-stream*)
(:documentation "An SQL typecast expression."))
(defmethod output-sql ((expr sql-typecast-exp) database)
- (database-output-sql expr database))
-
-(defmethod database-output-sql ((expr sql-typecast-exp) database)
(with-slots (components)
expr
(output-sql components database)))
-
(defmethod collect-table-refs ((sql sql-typecast-exp))
(when (slot-value sql 'components)
(collect-table-refs (slot-value sql 'components))))
(defmethod collect-table-refs ((sql sql-function-exp))
(let ((tabs nil))
- (dolist (exp (slot-value sql 'components))
+ (dolist (exp (slot-value sql 'args))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
(remove-duplicates tabs
;;
-;; Column constraint types
+;; DATABASE-OUTPUT-SQL
+;;
+
+(defmethod database-output-sql ((str string) database)
+ (declare (optimize (speed 3) (safety 1)
+ #+cmu (extensions:inhibit-warnings 3))
+ (simple-string str))
+ (let ((len (length str)))
+ (declare (type fixnum len))
+ (cond ((zerop len)
+ +empty-string+)
+ ((and (null (position #\' str))
+ (null (position #\\ str)))
+ (concatenate 'string "'" str "'"))
+ (t
+ (let ((buf (make-string (+ (* len 2) 2) :initial-element #\')))
+ (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))
+ (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)
+ '(:postgresql :mysql)
+ :test #'eq))
+ (setf (aref buf j) #\\)
+ (incf j)
+ (setf (aref buf j) #\\))
+ (t
+ (setf (aref buf j) char))))))))))
+
+(let ((keyword-package (symbol-package :foo)))
+ (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))))
+
+(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))
+
+(defmethod database-output-sql ((arg list) database)
+ (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)))
+
+(defmethod output-sql-hash-key ((arg vector) database)
+ (list 'vector (map 'list (lambda (arg)
+ (or (output-sql-hash-key arg database)
+ (return-from output-sql-hash-key nil)))
+ arg)))
+
+(defmethod database-output-sql ((self wall-time) database)
+ (declare (ignore database))
+ (db-timestring self))
+
+(defmethod database-output-sql ((self duration) database)
+ (declare (ignore database))
+ (format nil "'~a'" (duration-timestring self)))
+
+#+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))
+ +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)))))
+
+
;;
+;; 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 "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")))
-;;
-;; Convert type spec to sql syntax
-;;
-
(defmethod database-constraint-statement (constraint-list database)
(declare (ignore database))
(make-constraints-description constraint-list))
projects / clsql.git / blobdiff