:type ',type)))
(defmethod output-sql ((expr sql-ident-attribute) database)
- (with-slots (qualifier name type) expr
- (if (and (not qualifier) (not type))
- (etypecase name
- (string
- (write-string name *sql-stream*))
- (symbol
- (write-string
- (sql-escape (symbol-name name)) *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
- (sql-escape qualifier))
- (sql-escape name)
- (when type
- (symbol-name type)))
- (format *sql-stream* "~@[~A.~]~A"
- (when qualifier
- (typecase qualifier
- (string (format nil "~s" qualifier))
- (t (format nil "~s" (sql-escape qualifier)))))
- (typecase name
- (string (format nil "~s" (sql-escape name)))
- (t (format nil "~s" (sql-escape name))))))
- t))
+;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
+;;; should not be output in SQL statements
+ (let ((*print-pretty* nil))
+ (labels ((quoted-string-p (inp)
+ (and (char-equal #\" (elt inp 0))
+ (char-equal #\" (elt inp (1- (length inp))))))
+ (safety-first (inp)
+ "do our best not to output sql that we can guarantee is invalid.
+ if the ident has a space or quote in it, instead output a quoted
+ identifier containing those chars"
+ (when (and (not (quoted-string-p inp))
+ (find-if
+ (lambda (x) (member x '(#\space #\' #\")
+ :test #'char-equal)) inp))
+ (setf inp (format nil "~s" (substitute "\\\"" "\"" inp :test #'string-equal))))
+ inp))
+ (with-slots (qualifier name type) expr
+ (format *sql-stream* "~@[~a.~]~a"
+ (typecase qualifier
+ (null nil) ; nil is a symbol
+ (string (format nil "~s" qualifier))
+ (symbol (safety-first (sql-escape qualifier))))
+ (typecase name ;; could never get this to be nil without getting another error first
+ (string (format nil "~s" name))
+ (symbol (safety-first (sql-escape name)))))
+ t))))
(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
(with-slots (qualifier name type)
((stringp arg)
(sql-escape arg))))
-(defun column-name-from-arg (arg)
- (cond ((symbolp arg)
- arg)
- ((typep arg 'sql-ident)
- (slot-value arg 'name))
- ((stringp arg)
- (intern (symbol-name-default-case arg)))))
-
-
(defun remove-keyword-arg (arglist akey)
(let ((mylist arglist)
(newlist ()))
;; the column slot is filled in with the slot-name, but transformed
;; to be sql safe, - to _ and such.
(setf (slot-value esd 'column)
- (column-name-from-arg
- (if (slot-boundp dsd 'column)
- (delistify-dsd (view-class-slot-column dsd))
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))))
-
+ (if (slot-boundp dsd 'column)
+ (delistify-dsd (view-class-slot-column dsd))
+ (slot-definition-name dsd)))
(setf (slot-value esd 'db-type)
(when (slot-boundp dsd 'db-type)
(delistify-dsd
type-predicate)))
(setf (slot-value esd 'column)
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))
+ (slot-definition-name dsd))
(setf (slot-value esd 'db-info) nil)
(setf (slot-value esd 'db-kind) :virtual)
(defun sql-escape (identifier)
"Change hyphens to underscores, ensure string"
- (let ((unescaped (etypecase identifier
- (symbol (symbol-name identifier))
- (string identifier))))
- (substitute #\_ #\- unescaped)))
+ (etypecase identifier
+ (symbol (substitute #\_ #\- (symbol-name identifier)))
+ (string identifier)))
(defmacro without-interrupts (&body body)
#+allegro `(mp:without-scheduling ,@body)