#\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\>
#\{ #\}))))
+(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*)
(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
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
(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 "AUTOINCREMENT") "AUTOINCREMENT")
(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))
+ (make-constraints-description constraint-list database))
+
+(defmethod database-translate-constraint (constraint database)
+ (assoc (symbol-name constraint)
+ *constraint-types*
+ :test #'equal))
-(defun make-constraints-description (constraint-list)
+(defun make-constraints-description (constraint-list database)
(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)))
+ (let ((output (database-translate-constraint (car constraint)
+ database)))
(if (null output)
(error 'sql-user-error
:message (format nil "unsupported column constraint '~A'"
(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))
+
projects / clsql.git / blobdiff