(defpackage #:clsql-mysql
(:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi)
(:export #:mysql-database)
+ (:import-from :clsql-sys
+ :escaped :unescaped :combine-database-identifiers
+ :escaped-database-identifier :unescaped-database-identifier :database-identifier
+ :%sequence-name-to-table :%table-name-to-sequence-name)
(:documentation "This is the CLSQL interface to MySQL."))
(in-package #:clsql-mysql)
(declare (ignore owner))
(do ((results nil)
(rows (database-query
- (format nil "SHOW INDEX FROM ~A" table)
+ (format nil "SHOW INDEX FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)
(cdr rows)))
((null rows) (nreverse results))
(declare (ignore owner))
(mapcar #'car
(database-query
- (format nil "SHOW COLUMNS FROM ~A" table)
+ (format nil "SHOW COLUMNS FROM ~A" (escaped-database-identifier
+ table database))
database nil nil)))
(defmethod database-attribute-type (attribute (table string)
(declare (ignore owner))
(let ((row (car (database-query
(format nil
- "SHOW COLUMNS FROM ~A LIKE '~A'" table attribute)
+ "SHOW COLUMNS FROM ~A LIKE '~A'"
+ (escaped-database-identifier
+ table database)
+ (unescaped-database-identifier
+ attribute database))
database nil nil))))
(let* ((raw-type (second row))
(null (third row))
;;; Sequence functions
-(defun %sequence-name-to-table (sequence-name)
- (concatenate 'string "_CLSQL_SEQ_" (sql-escape sequence-name)))
-
-(defun %table-name-to-sequence-name (table-name)
- (and (>= (length table-name) 11)
- (string-equal (subseq table-name 0 11) "_CLSQL_SEQ_")
- (subseq table-name 11)))
-
(defmethod database-create-sequence (sequence-name
(database mysql-database))
- (let ((table-name (%sequence-name-to-table sequence-name)))
+ (let ((table-name (%sequence-name-to-table sequence-name database)))
(database-execute-command
(concatenate 'string "CREATE TABLE " table-name
" (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
(defmethod database-drop-sequence (sequence-name
(database mysql-database))
(database-execute-command
- (concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name))
+ (concatenate 'string "DROP TABLE "
+ (%sequence-name-to-table sequence-name database))
database))
(defmethod database-list-sequences ((database mysql-database)
(declare (ignore owner))
(mapcan #'(lambda (s)
(let ((sn (%table-name-to-sequence-name (car s))))
- (and sn (list sn))))
+ (and sn (list (car s) sn))))
(database-query "SHOW TABLES" database nil nil)))
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database mysql-database))
(database-execute-command
- (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
+ (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name database)
position)
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database)))
(defmethod database-sequence-next (sequence-name (database mysql-database))
(without-interrupts
(database-execute-command
- (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name)
+ (concatenate 'string "UPDATE " (%sequence-name-to-table sequence-name database)
" SET id=LAST_INSERT_ID(id+1)")
database)
(mysql:mysql-insert-id (clsql-mysql::database-mysql-ptr database))))
(without-interrupts
(caar (database-query
(concatenate 'string "SELECT id from "
- (%sequence-name-to-table sequence-name))
+ (%sequence-name-to-table sequence-name database))
database :auto nil))))
(defmethod database-last-auto-increment-id ((database mysql-database) table column)
(defmethod read-sql-value (val (type (eql 'generalized-boolean)) (database postgresql-socket3-database) db-type)
(declare (ignore database db-type))
val)
-
"While accessing database ~A~% Warning: ~A~% has occurred."
(sql-warning-database c)
(sql-warning-message c)))))
+
+(define-condition database-too-strange (sql-user-error)
+ ()
+ (:documentation "Used to signal cases where CLSQL is going to fail at
+ mapping your database correctly"))
+
+(defun signal-database-too-strange (message)
+ (error 'database-too-strange :message message))
(defvar *sql-stream* nil
"stream which accumulates SQL output")
+(defclass %database-identifier ()
+ ((escaped :accessor escaped :initarg :escaped :initform nil)
+ (unescaped :accessor unescaped :initarg :unescaped :initform nil))
+ (:documentation
+ "A database identifier represents a string/symbol ready to be spliced
+ into a sql string. It keeps references to both the escaped and
+ unescaped versions so that unescaped versions can be compared to the
+ results of list-tables/views/attributes etc. It also allows you to be
+ sure that an identifier is escaped only once.
+
+ (escaped-database-identifiers *any-reasonable-object*) should be called to
+ produce a string that is safe to splice directly into sql strings.
+
+ (unescaped-database-identifier *any-reasonable-object*) is generally what
+ you pass to it with the exception that symbols have been
+ clsql-sys:sql-escape which converts to a string and changes - to _ (so
+ that unescaped can be compared to the results of eg: list-tables)
+ "))
+
+(defmethod escaped ((it null)) it)
+(defmethod unescaped ((it null)) it)
+
+(defun database-identifier-equal (i1 i2 &optional (database clsql-sys:*default-database*))
+ (setf i1 (database-identifier i1 database)
+ i2 (database-identifier i2 database))
+ (flet ((cast (i)
+ (if (symbolp (unescaped i))
+ (sql-escape (unescaped i))
+ (unescaped i))))
+ (or ;; check for an exact match
+ (equal (escaped-database-identifier i1)
+ (escaped-database-identifier i2))
+ ;; check for an inexact match if we had symbols in the mix
+ (string-equal (cast i1) (cast i2)))))
+
+(defun delistify-dsd (list)
+ "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
+ (if (and (listp list) (null (cdr list)))
+ (car list)
+ list))
+
+(defun special-char-p (s)
+ "Check if a string has any special characters"
+ (loop for char across s
+ thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\% #\' #\"
+ #\^ #\& #\* #\| #\( #\) #\- #\+ #\< #\>
+ #\{ #\}))))
+
+(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."
+ (labels ((%escape-identifier (inp &optional orig)
+ "Quote an identifier unless it is already quoted"
+ (cond
+ ;; already quoted
+ ((and (eql #\" (elt inp 0))
+ (eql #\" (elt inp (- (length inp) 1))))
+ (make-instance '%database-identifier :unescaped (or orig inp) :escaped inp))
+ (T (make-instance
+ '%database-identifier :unescaped (or orig inp) :escaped
+ (concatenate
+ 'string "\"" (replace-all inp "\"" "\\\"") "\""))))))
+ (typecase inp
+ (string (%escape-identifier inp))
+ (%database-identifier inp)
+ (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)))))))
+
+(defun combine-database-identifiers (ids &optional (database clsql-sys:*default-database*)
+ &aux res all-sym? pkg)
+ "Create a new database identifier by combining parts in a reasonable way
+ "
+ (setf ids (mapcar #'database-identifier ids)
+ all-sym? (every (lambda (i) (symbolp (unescaped i))) ids)
+ pkg (when all-sym? (symbol-package (unescaped (first ids)))))
+ (labels ((cast ( i )
+ (typecase i
+ (null nil)
+ (%database-identifier (cast (unescaped i)))
+ (symbol
+ (if all-sym?
+ (sql-escape i)
+ (convert-to-db-default-case (sql-escape i) database)))
+ (string i)))
+ (comb (i1 i2)
+ (setf i1 (cast i1)
+ i2 (cast i2))
+ (if (and i1 i2)
+ (concatenate 'string (cast i1) "_" (cast i2))
+ (or i1 i2))))
+ (setf res (reduce #'comb ids))
+ (database-identifier
+ (if all-sym? (intern res pkg) res)
+ database)))
+
+(defun escaped-database-identifier (name &optional database find-class-p)
+ (escaped (database-identifier name database find-class-p)))
+
+(defun unescaped-database-identifier (name &optional database find-class-p)
+ (unescaped (database-identifier name database find-class-p)))
+
(defun sql-output (sql-expr &optional (database *default-database*))
"Top-level call for generating SQL strings. Returns an SQL
string appropriate for DATABASE which corresponds to the
sql
`(make-instance 'sql-ident :name ',name)))
+(defmethod output-sql ((expr %database-identifier) database)
+ (write-string (escaped expr) *sql-stream*))
+
(defmethod output-sql ((expr sql-ident) database)
(with-slots (name) expr
- (write-string
- (etypecase name
- (string name)
- (symbol (symbol-name name)))
- *sql-stream*))
+ (write-string (escaped-database-identifier name database) *sql-stream*))
t)
;; For SQL Identifiers for attributes
(defmethod collect-table-refs ((sql sql-ident-attribute))
(let ((qual (slot-value sql 'qualifier)))
(when qual
- (list (make-instance 'sql-ident-table :name qual)))))
+ ;; going to be used as a table, search classes
+ (list (make-instance
+ 'sql-ident-table
+ :name (database-identifier qual nil t))))))
(defmethod make-load-form ((sql sql-ident-attribute) &optional environment)
(declare (ignore environment))
:qualifier ',qualifier
: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 (sql-escape qualifier))))
- (typecase name
- (string (format nil "~s" (sql-escape name)))
- (t (sql-escape name)))))
- t))
-
(defmethod output-sql-hash-key ((expr sql-ident-attribute) database)
(with-slots (qualifier name type)
expr
sql
`(make-instance 'sql-ident-table :name ',name :table-alias ',alias)))
-(defun special-char-p (s)
- "Check if a string has any special characters"
- (loop for char across s
- thereis (find char '(#\space #\, #\. #\! #\@ #\# #\$ #\%
- #\^ #\& #\* #\| #\( #\) #\- #\+))))
-
(defmethod output-sql ((expr sql-ident-table) database)
(with-slots (name alias) expr
(flet ((p (s) ;; the etypecase is in sql-escape too
- (let ((sym? (symbolp s))
- (s (sql-escape s)))
- (format *sql-stream*
- (if (and sym? (not (special-char-p s)))
- "~a" "~s")
- s))))
+ (write-string
+ (escaped-database-identifier s database)
+ *sql-stream*)))
(p name)
(when alias
(princ #\space *sql-stream*)
(p alias))))
t)
+(defmethod output-sql ((expr sql-ident-attribute) database)
+;;; KMR: The TYPE field is used by CommonSQL for type conversion -- it
+;;; should not be output in SQL statements
+ (let ((*print-pretty* nil))
+ (with-slots (qualifier name type) expr
+ (format *sql-stream* "~@[~a.~]~a"
+ (when qualifier
+ ;; check for classes
+ (escaped-database-identifier qualifier database T))
+ (escaped-database-identifier name database))
+ t)))
+
(defmethod output-sql-hash-key ((expr sql-ident-table) database)
(with-slots (name alias)
expr
(dolist (exp (slot-value sql 'sub-expressions))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
(dolist (exp (slot-value sql 'components))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name)))))
+ (remove-duplicates tabs :test #'database-identifier-equal))
nil)))
(dolist (exp (slot-value sql 'args))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
(defvar *in-subselect* nil)
(defmethod output-sql ((expr sql-function-exp) database)
(dolist (exp (slot-value sql 'sub-expressions))
(let ((refs (collect-table-refs exp)))
(if refs (setf tabs (append refs tabs)))))
- (remove-duplicates tabs
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name))))))
+ (remove-duplicates tabs :test #'database-identifier-equal)))
(defmethod output-sql ((expr sql-set-exp) database)
(with-slots (operator sub-expressions)
:initform nil)))
(defmethod collect-table-refs ((sql sql-query))
- (remove-duplicates (collect-table-refs (slot-value sql 'where))
- :test (lambda (tab1 tab2)
- (equal (slot-value tab1 'name)
- (slot-value tab2 'name)))))
+ (remove-duplicates
+ (collect-table-refs (slot-value sql 'where))
+ :test #'database-identifier-equal))
(defvar *select-arguments*
'(:all :database :distinct :flatp :from :group-by :having :order-by
(output-sql (apply #'vector selections) database))
(when from
(write-string " FROM " *sql-stream*)
- (labels ((ident-string-val (a)
- (typecase a
- (sql-ident
- (or (ignore-errors (slot-value a 'alias))
- (ignore-errors (slot-value a 'name))))
- (string a)))
- (ident-table-equal (a b)
- ;; The things should be type compatable
- (string-equal (ident-string-val a)
- (ident-string-val b))))
- (typecase from
- (list (output-sql (apply #'vector
- (remove-duplicates from
- :test #'ident-table-equal))
- database))
- (string (format *sql-stream* "~s" (sql-escape from)))
- (t (let ((*in-subselect* t))
- (output-sql from database))))))
+ (typecase from
+ (list (output-sql
+ (apply #'vector
+ (remove-duplicates from :test #'database-identifier-equal))
+ database))
+ (string (write-string
+ (escaped-database-identifier from database)
+ *sql-stream*))
+ (t (let ((*in-subselect* t))
+ (output-sql from database)))))
(when inner-join
(write-string " INNER JOIN " *sql-stream*)
(output-sql inner-join database))
(with-slots (name columns modifiers transactions)
stmt
(write-string "CREATE TABLE " *sql-stream*)
- (etypecase name
- (string (format *sql-stream* "~s" (sql-escape name)))
- (symbol (write-string (sql-escape name) *sql-stream*))
- (sql-ident (output-sql name database)))
+ (write-string (escaped-database-identifier name database) *sql-stream*)
(write-string " (" *sql-stream*)
(do ((column columns (cdr column)))
((null (cdr column))
(if (< 1 (length constraint))
(setq string (concatenate 'string string " "))))))))
+(defmethod database-identifier ( name &optional database find-class-p
+ &aux cls)
+ "A function that takes whatever you give it, recurively coerces it,
+ and returns a database-identifier.
+
+ (escaped-database-identifiers *any-reasonable-object*) should be called to
+ produce a string that is safe to splice directly into sql strings.
+
+ This function should NOT throw errors when database is nil
+
+ find-class-p should be T if we want to search for classes
+ and check their use their view table. Should be used
+ on symbols we are sure indicate tables
+
+
+ ;; metaclasses has further typecases of this, so that it will
+ ;; load less painfully (try-recompiles) in SBCL
+
+ "
+ (flet ((flatten-id (id)
+ "if we have multiple pieces that we need to represent as
+ db-id lets do that by rendering out the id, then creating
+ a new db-id with that string as escaped"
+ (let ((s (sql-output id database)))
+ (make-instance '%database-identifier :escaped s :unescaped s))))
+ (etypecase name
+ (null nil)
+ (string (%make-database-identifier name database))
+ (symbol
+ ;; if this is being used as a table, we should check
+ ;; for a class with this name and use the identifier specified
+ ;; on it
+ (if (and find-class-p (setf cls (find-standard-db-class name)))
+ (database-identifier cls)
+ (%make-database-identifier name database)))
+ (%database-identifier name)
+ ;; we know how to deref this without further escaping
+ (sql-ident-table
+ (with-slots ((inner-name name) alias) name
+ (if alias
+ (flatten-id name)
+ (database-identifier inner-name))))
+ ;; if this is a single name we can derefence it
+ (sql-ident-attribute
+ (with-slots (qualifier (inner-name name)) name
+ (if qualifier
+ (flatten-id name)
+ (database-identifier inner-name))))
+ (sql-ident
+ (with-slots ((inner-name name)) name
+ (database-identifier inner-name)))
+ ;; dont know how to handle this really :/
+ (%sql-expression (flatten-id name))
+ )))
+
(in-package #:clsql-sys)
-;; Utilities
-
-(defun database-identifier (name database)
- (sql-escape (etypecase name
- ;; honor case of strings
- (string name)
- (sql-ident (sql-output name database))
- (symbol (sql-output name database)))))
-
-
;; Truncate database
(defun truncate-database (&key (database *default-database*))
*DEFAULT-DATABASE*. If the table does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((table-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
- (unless (table-exists-p table-name :database database
- :owner owner)
+ (unless (table-exists-p name :database database :owner owner)
(return-from drop-table nil)))
(:error
t))
-
- (let ((expr (etypecase name
- ;; keep quotes for strings for mixed-case names
- (string (format nil "DROP TABLE ~S" table-name))
- ((or symbol sql-ident)
- (concatenate 'string "DROP TABLE " table-name)))))
+
+ (let ((expr (concatenate 'string "DROP TABLE " (escaped-database-identifier name database))))
;; Fixme: move to clsql-oracle
(when (and (find-package 'clsql-oracle)
(eq :oracle (database-type database))
(symbol-name '#:clsql-oracle)))))
(setq expr (concatenate 'string expr " PURGE")))
- (execute-command expr :database database))))
+ (execute-command expr :database database)))
(defun list-tables (&key (owner nil) (database *default-database*))
"Returns a list of strings representing table names in DATABASE
(unless database (setf database *default-database*))
(let ((name (database-identifier name database))
(tables (list-tables :owner owner :database database)))
- (when (member name tables :test #'string-equal)
+ (when (member name tables :test #'database-identifier-equal)
t)))
(defun table-exists-p (name &key (owner nil) (database *default-database*))
parameter. The WITH-CHECK-OPTION is nil by default but if it has
a non-nil value, then all insert/update commands on the view are
checked to ensure that the new data satisfy the query AS."
- (let* ((view-name (etypecase name
- (symbol (sql-expression :attribute name))
- (string (sql-expression :attribute (make-symbol name)))
- (sql-ident name)))
+ (let* ((view-name (database-identifier name))
(stmt (make-instance 'sql-create-view
:name view-name
:column-list column-list
*DEFAULT-DATABASE*. If the view does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas
an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((view-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
- (unless (view-exists-p view-name :database database)
+ (unless (view-exists-p name :database database)
(return-from drop-view)))
(:error
t))
- (let ((expr (concatenate 'string "DROP VIEW " view-name)))
- (execute-command expr :database database))))
+ (let ((expr (concatenate 'string "DROP VIEW " (escaped-database-identifier name database))))
+ (execute-command expr :database database)))
(defun list-views (&key (owner nil) (database *default-database*))
"Returns a list of strings representing view names in DATABASE
examined. If OWNER is :all then all views are examined."
(when (member (database-identifier name database)
(list-views :owner owner :database database)
- :test #'string-equal)
+ :test #'database-identifier-equal)
t))
ATTRIBUTES. The UNIQUE argument is nil by default but if it has a
non-nil value then the indexed attributes must have unique
values."
- (let* ((index-name (database-identifier name database))
- (table-name (database-identifier on database))
- (attributes (mapcar #'(lambda (a) (database-identifier a database)) (listify attributes)))
+ (let* ((index-name (escaped-database-identifier name database))
+ (table-name (escaped-database-identifier on database))
+ (attributes (mapcar #'(lambda (a) (escaped-database-identifier a database))
+ (listify attributes)))
(stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
(if unique "UNIQUE" "")
index-name table-name attributes)))
an error is signalled if IF-DOES-NOT-EXIST is :error. The
argument ON allows the optional specification of a table to drop
the index from."
- (let ((index-name (database-identifier name database)))
- (ecase if-does-not-exist
- (:ignore
- (unless (index-exists-p index-name :database database)
- (return-from drop-index)))
- (:error t))
- (let* ((db-type (database-underlying-type database))
- (index-identifier (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
- (format nil "~A.~A" (database-identifier on database) index-name))
- ((db-type-use-column-on-drop-index? db-type)
- (format nil "~A ON ~A" index-name (database-identifier on database)))
- (t index-name))))
- (execute-command (format nil "DROP INDEX ~A" index-identifier)
- :database database))))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (index-exists-p name :database database)
+ (return-from drop-index)))
+ (:error t))
+ (let* ((db-type (database-underlying-type database))
+ (on (when on (escaped-database-identifier on database)))
+ (index-name (escaped-database-identifier name database))
+ (index-identifier
+ (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
+ (format nil "~A.~A" on index-name))
+ ((db-type-use-column-on-drop-index? db-type)
+ (format nil "~A ON ~A" index-name on))
+ (t index-name))))
+ (execute-command (format nil "DROP INDEX ~A" index-identifier)
+ :database database)))
(defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
"Returns a list of strings representing index names in DATABASE
such table identifiers."
(if (null on)
(database-list-indexes database :owner owner)
- (let ((tables (typecase on (cons on) (t (list on)))))
- (reduce #'append
- (mapcar #'(lambda (table) (database-list-table-indexes
- (database-identifier table database)
- database :owner owner))
- tables)))))
+ (let ((tables (typecase on
+ (cons on)
+ (t (list on)))))
+ (reduce
+ #'append
+ (mapcar #'(lambda (table)
+ (database-list-table-indexes table database :owner owner))
+ tables)))))
(defun index-exists-p (name &key (owner nil) (database *default-database*))
"Tests for the existence of an SQL index called NAME in DATABASE
examined."
(when (member (database-identifier name database)
(list-indexes :owner owner :database database)
- :test #'string-equal)
+ :test #'database-identifier-equal)
t))
;; Attributes
are listed. If OWNER is a string denoting a user name, only
attributes owned by OWNER are listed. If OWNER is :all then all
attributes are listed."
- (database-list-attributes (database-identifier name database) database
+ (database-list-attributes (escaped-database-identifier name database) database
:owner owner))
(defun attribute-type (attribute table &key (owner nil)
attribute, if it exists, must be owned by OWNER else nil is
returned, whereas if OWNER is :all then the attribute, if it
exists, will be returned regardless of its owner."
- (database-attribute-type (database-identifier attribute database)
- (database-identifier table database)
+ (database-attribute-type (escaped-database-identifier attribute database)
+ (escaped-database-identifier table database)
database
:owner owner))
the fourth is the scale of the attribute and the fifth is 1 if
the attribute accepts null values and otherwise 0."
(with-slots (attribute-cache) database
- (let ((table-ident (database-identifier table database)))
+ (let ((table-ident (escaped-database-identifier table database)))
(multiple-value-bind (val found) (gethash table-ident attribute-cache)
(if (and found (second val))
(second val)
(cons attribute
(multiple-value-list
(database-attribute-type
- (database-identifier attribute
+ (escaped-database-identifier attribute
database)
table-ident
database
*DEFAULT-DATABASE*. If the sequence does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil
whereas an error is signalled if IF-DOES-NOT-EXIST is :error."
- (let ((sequence-name (database-identifier name database)))
- (ecase if-does-not-exist
- (:ignore
- (unless (sequence-exists-p sequence-name :database database)
- (return-from drop-sequence)))
- (:error t))
- (database-drop-sequence sequence-name database))
+ (ecase if-does-not-exist
+ (:ignore
+ (unless (sequence-exists-p name :database database)
+ (return-from drop-sequence)))
+ (:error t))
+ (database-drop-sequence name database)
(values))
(defun list-sequences (&key (owner nil) (database *default-database*))
examined. If OWNER is a string denoting a user name, only
sequences owned by OWNER are examined. If OWNER is :all then all
sequences are examined."
- (when (member (database-identifier name database)
- (list-sequences :owner owner :database database)
- :test #'string-equal)
- t))
+ (let ((seqs (list-sequences :owner owner :database database))
+ ;; handle symbols, we know the db will return strings
+ (n1 (database-identifier name database))
+ (n2 (%sequence-name-to-table name database)))
+ (when (or (member n1 seqs :test #'database-identifier-equal)
+ (member n2 seqs :test #'database-identifier-equal))
+ t)))
(defun sequence-next (name &key (database *default-database*))
"Increment and return the next value in the sequence called
(subquery nil))
(unless into
(error 'sql-user-error :message ":into keyword not supplied"))
- (let ((insert (make-instance 'sql-insert :into into)))
+ (let ((insert (make-instance 'sql-insert :into (database-identifier into nil))))
(with-slots (attributes values query)
insert
"Deletes records satisfying the SQL expression WHERE from the
table specified by FROM in DATABASE specifies a database which
defaults to *DEFAULT-DATABASE*."
- (let ((stmt (make-instance 'sql-delete :from from :where where)))
+ (let ((stmt (make-instance 'sql-delete :from (database-identifier from database) :where where)))
(execute-command stmt :database database)))
(defun update-records (table &key (attributes nil)
(when av-pairs
(setf attributes (mapcar #'car av-pairs)
values (mapcar #'cadr av-pairs)))
- (let ((stmt (make-instance 'sql-update :table table
+ (let ((stmt (make-instance 'sql-update :table (database-identifier table database)
:attributes attributes
:values values
:where where)))
(database-query
(format
nil
- "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where relname='~A'~A)"
- (string-downcase table)
+ "select indexrelid from pg_index where indrelid=(select relfilenode from pg_class where LOWER(relname)='~A'~A)"
+ (string-downcase (unescaped-database-identifier table))
(owner-clause owner))
database :auto nil))
(result nil))
(defmethod database-create-sequence (sequence-name
(database generic-postgresql-database))
- (database-execute-command
- (concatenate 'string "CREATE SEQUENCE " (sql-escape sequence-name))
- database))
+ (let ((cmd (concatenate
+ 'string "CREATE SEQUENCE " (escaped-database-identifier sequence-name database))))
+ (database-execute-command cmd database)))
(defmethod database-drop-sequence (sequence-name
(database generic-postgresql-database))
(database-execute-command
- (concatenate 'string "DROP SEQUENCE " (sql-escape sequence-name)) database))
+ (concatenate 'string "DROP SEQUENCE " (escaped-database-identifier sequence-name database))
+ database))
(defmethod database-list-sequences ((database generic-postgresql-database)
&key (owner nil))
(parse-integer
(caar
(database-query
- (format nil "SELECT SETVAL ('~A', ~A)" name position)
+ (format nil "SELECT SETVAL ('~A', ~A)" (escaped-database-identifier name) position)
database nil nil)))))
(defmethod database-sequence-next (sequence-name
(parse-integer
(caar
(database-query
- (concatenate 'string "SELECT NEXTVAL ('" (sql-escape sequence-name) "')")
+ (concatenate 'string "SELECT NEXTVAL ('" (escaped-database-identifier sequence-name) "')")
database nil nil)))))
(defmethod database-sequence-last (sequence-name (database generic-postgresql-database))
(parse-integer
(caar
(database-query
- (concatenate 'string "SELECT LAST_VALUE FROM " sequence-name)
+ (concatenate 'string "SELECT LAST_VALUE FROM " (escaped-database-identifier sequence-name))
database nil nil)))))
+(defmethod auto-increment-sequence-name (table column (database generic-postgresql-database))
+ (let* ((sequence-name (or (database-identifier (slot-value column 'autoincrement-sequence))
+ (combine-database-identifiers
+ (list table column 'seq)
+ database))))
+ (when (search "'" (escaped-database-identifier sequence-name)
+ :test #'string-equal)
+ (signal-database-too-strange
+ "PG Sequence names shouldnt contain single quotes for the sake of sanity"))
+ sequence-name))
+
(defmethod database-last-auto-increment-id ((database generic-postgresql-database) table column)
- (let (column-helper seq-name)
- (typecase table
- (sql-ident (setf table (slot-value table 'name)))
- (standard-db-class (setf table (view-table table))))
- (typecase column
- (sql-ident (setf column-helper (slot-value column 'name)))
- (view-class-slot-definition-mixin
- (setf column-helper (view-class-slot-column column))))
- (setq seq-name (or (view-class-slot-autoincrement-sequence column)
- (convert-to-db-default-case (format nil "~a_~a_seq" table column-helper) database)))
- (first (clsql:query (format nil "SELECT currval ('~a')" seq-name)
+ (let ((seq-name (auto-increment-sequence-name table column database)))
+ (first (clsql:query (format nil "SELECT currval ('~a')"
+ (escaped-database-identifier seq-name))
:flatp t
:database database
:result-types '(:int)))))
-(defmethod database-generate-column-definition (class slotdef (database generic-postgresql-database))
- ; handle autoincr slots special
- (when (or (and (listp (view-class-slot-db-constraints slotdef))
- (member :auto-increment (view-class-slot-db-constraints slotdef)))
- (eql :auto-increment (view-class-slot-db-constraints slotdef))
- (slot-value slotdef 'autoincrement-sequence))
- (let ((sequence-name (database-make-autoincrement-sequence class slotdef database)))
- (setf (view-class-slot-autoincrement-sequence slotdef) sequence-name)
- (cond ((listp (view-class-slot-db-constraints slotdef))
- (setf (view-class-slot-db-constraints slotdef)
- (remove :auto-increment
- (view-class-slot-db-constraints slotdef)))
- (unless (member :default (view-class-slot-db-constraints slotdef))
- (setf (view-class-slot-db-constraints slotdef)
- (append
- (list :default (format nil "nextval('~a')" sequence-name))
- (view-class-slot-db-constraints slotdef)))))
- (t
- (setf (view-class-slot-db-constraints slotdef)
- (list :default (format nil "nextval('~a')" sequence-name)))))))
- (call-next-method class slotdef database))
-
-(defmethod database-make-autoincrement-sequence (table column (database generic-postgresql-database))
- (let* ((table-name (view-table table))
- (column-name (view-class-slot-column column))
- (sequence-name (or (slot-value column 'autoincrement-sequence)
- (convert-to-db-default-case
- (format nil "~a_~a_SEQ" table-name column-name) database))))
- (unless (sequence-exists-p sequence-name :database database)
- (database-create-sequence sequence-name database))
- sequence-name))
+(defmethod database-generate-column-definition
+ (class slotdef (database generic-postgresql-database))
+ (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (let ((cdef
+ (list (sql-expression :attribute (database-identifier slotdef database))
+ (specified-type slotdef)
+ (view-class-slot-db-type slotdef)))
+ (const (listify (view-class-slot-db-constraints slotdef)))
+ (seq (auto-increment-sequence-name class slotdef database)))
+ (when seq
+ (setf const (remove :auto-increment const))
+ (unless (member :default const)
+ (let* ((next (format nil "nextval('~a')" (escaped-database-identifier seq))))
+ (setf const (append const (list :default next))))))
+ (append cdef const))))
+
+(defmethod database-add-autoincrement-sequence
+ ((self standard-db-class) (database generic-postgresql-database))
+ (let ((ordered-slots (if (normalizedp self)
+ (ordered-class-direct-slots self)
+ (ordered-class-slots self))))
+ (dolist (slotdef ordered-slots)
+
+ ;; ensure that referenceed sequences actually exist before referencing them
+ (let ((sequence-name (auto-increment-sequence-name self slotdef database)))
+ (when (and sequence-name
+ (not (sequence-exists-p sequence-name :database database)))
+ (create-sequence sequence-name :database database))))))
+
+(defmethod database-remove-autoincrement-sequence
+ ((table standard-db-class)
+ (database generic-postgresql-database))
+ (let ((ordered-slots
+ (if (normalizedp table)
+ (ordered-class-direct-slots table)
+ (ordered-class-slots table))))
+ (dolist (slotdef ordered-slots)
+ ;; ensure that referenceed sequences are dropped with the table
+ (let ((sequence-name (auto-increment-sequence-name table slotdef database)))
+ (when sequence-name (drop-sequence sequence-name))))))
(defun postgresql-database-list (connection-spec type)
(destructuring-bind (host name &rest other-args) connection-spec
)
(defgeneric read-sql-value (val type database db-type)
)
-(defgeneric database-make-autoincrement-sequence (class slotdef database)
- )
+(defgeneric database-add-autoincrement-sequence (class database)
+ (:method (class database) nil)
+ (:documentation "If a database needs to add a sequence for its
+ autoincrement to work, this is where it should go. Default is
+ that it doesnt so just return nil"))
+(defgeneric database-remove-autoincrement-sequence (class database)
+ (:method (class database) nil)
+ (:documentation "If a database needs to add a sequence for its
+ autoincrement to work, this is where it should go. Default is
+ that it doesnt so just return nil"))
+(defgeneric auto-increment-sequence-name (class slotdef database)
+ (:documentation "The sequence name to create for this autoincremnt column on this class
+ if returns nil, there is no associated sequence "))
+
+(defmethod auto-increment-sequence-name :around (class slot database)
+ (when (auto-increment-column-p slot database)
+ (call-next-method)))
(defgeneric database-last-auto-increment-id (database table column)
)
+
+
;; Generation of SQL strings from lisp expressions
(defgeneric output-sql (expr database)
((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 ()))
list))
(declaim (inline delistify-dsd))
-(defun delistify-dsd (list)
- "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
- (if (and (listp list) (null (cdr list)))
- (car list)
- list))
-
+;; there is an :after method below too
(defmethod initialize-instance :around
((obj view-class-direct-slot-definition)
&rest initargs &key db-constraints db-kind type &allow-other-keys)
type db-constraints))
initargs))
+(defun compute-column-name (arg)
+ (database-identifier arg nil))
+
+(defmethod initialize-instance :after
+ ((obj view-class-direct-slot-definition)
+ &key &allow-other-keys)
+ (setf (view-class-slot-column obj) (compute-column-name obj)))
+
(defmethod compute-effective-slot-definition ((class standard-db-class)
#+kmr-normal-cesd slot-name
direct-slots)
(let ((esd (call-next-method)))
(typecase dsd
(view-class-slot-definition-mixin
- ;; Use the specified :column argument if it is supplied, otherwise
- ;; 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))))))
+ (setf (slot-value esd 'column) (compute-column-name dsd))
(setf (slot-value esd 'db-type)
(when (slot-boundp dsd 'db-type)
#+openmcl (setf (slot-value esd 'ccl::type-predicate)
type-predicate)))
- (setf (slot-value esd 'column)
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))
-
+ ;; has no column name if it is not a database column
+ (setf (slot-value esd 'column) nil)
(setf (slot-value esd 'db-info) nil)
(setf (slot-value esd 'db-kind) :virtual)
(setf (specified-type esd) (slot-definition-type dsd)))
#+kmr-normal-esdc
(setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
)
+
+(defmethod database-identifier ( (name standard-db-class)
+ &optional database find-class-p)
+ "the majority of this function is in expressions.lisp
+ this is here to make loading be less painful (try-recompiles) in SBCL"
+ (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+ &optional database find-class-p)
+ (database-identifier
+ (if (slot-boundp name 'column)
+ (delistify-dsd (view-class-slot-column name))
+ (slot-definition-name name))
+ database))
+
+(defun find-standard-db-class (name &aux cls)
+ (and (setf cls (ignore-errors (find-class name)))
+ (typep cls 'standard-db-class)
+ cls))
(if tclass
(let ((*default-database* database)
(pclass (car (class-direct-superclasses tclass))))
- (when (and (normalizedp tclass) (not (table-exists-p (view-table pclass))))
+ (when (and (normalizedp tclass) (not (table-exists-p pclass)))
(create-view-from-class (class-name pclass)
:database database :transactions transactions))
(%install-class tclass database :transactions transactions))
(error "Class ~s not found." view-class-name)))
(values))
+(defmethod auto-increment-column-p (slotdef &optional (database clsql-sys:*default-database*))
+ (declare (ignore database))
+ (or (member :auto-increment (listify (view-class-slot-db-constraints slotdef)))
+ (slot-value slotdef 'autoincrement-sequence)))
(defmethod %install-class ((self standard-db-class) database
&key (transactions t))
(ordered-class-direct-slots self)
(ordered-class-slots self))))
(dolist (slotdef ordered-slots)
- (let ((res (database-generate-column-definition self
- slotdef database)))
+ (let ((res (database-generate-column-definition self slotdef database)))
(when res
(push res schemadef))))
(if (not schemadef)
(unless (normalizedp self)
(error "Class ~s has no :base slots" self))
(progn
- (create-table (sql-expression :table (view-table self)) (nreverse schemadef)
+ (database-add-autoincrement-sequence self database)
+ (create-table (sql-expression :table (database-identifier self database))
+ (nreverse schemadef)
:database database
:transactions transactions
:constraints (database-pkey-constraint self database))
t)
(defmethod database-pkey-constraint ((class standard-db-class) database)
- (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))
- (table (view-table class)))
+ ;; Keylist will always be a list of escaped-indentifier
+ (let ((keylist (mapcar #'(lambda (x) (escaped-database-identifier x database))
+ (keyslots-for-class class)))
+ (table (escaped (combine-database-identifiers
+ (list class 'PK)
+ database))))
(when keylist
- (etypecase table
- (string
- (format nil "CONSTRAINT \"~APK\" PRIMARY KEY~A" table
- (sql-output keylist database)))
- ((or symbol sql-ident)
- (format nil "CONSTRAINT ~APK PRIMARY KEY~A" table
- (sql-output keylist database)))))))
+ (format nil "CONSTRAINT ~A PRIMARY KEY (~{~A~^,~})" table
+ keylist))))
(defmethod database-generate-column-definition (class slotdef database)
- (declare (ignore database class))
+ (declare (ignore class))
(when (member (view-class-slot-db-kind slotdef) '(:base :key))
(let ((cdef
- (list (sql-expression :attribute (view-class-slot-column slotdef))
+ (list (sql-expression :attribute (database-identifier slotdef database))
(specified-type slotdef))))
(setf cdef (append cdef (list (view-class-slot-db-type slotdef))))
(let ((const (view-class-slot-db-constraints slotdef)))
(defun %uninstall-class (self &key
(database *default-database*)
(owner nil))
- (drop-table (sql-expression :table (view-table self))
+ (drop-table (sql-expression :table (database-identifier self database))
:if-does-not-exist :ignore
:database database
:owner owner)
+ (database-remove-autoincrement-sequence self database)
(setf (database-view-classes database)
(remove self (database-view-classes database))))
(flet ((qfk (k)
(sql-operation '==
(sql-expression :attribute
- (view-class-slot-column k)
+ (database-identifier k database)
:table tb)
(db-value-from-slot
k
(defun generate-attribute-reference (vclass slotdef)
(cond
((eq (view-class-slot-db-kind slotdef) :base)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
(t nil)))
;;
(let* ((vct (view-table view-class))
(sd (slotdef-for-slot-with-class slot view-class)))
(check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
+ (let* ((att (database-identifier sd database))
(val (db-value-from-slot sd (slot-value obj slot) database)))
(cond ((and vct sd (view-database obj))
(update-records (sql-expression :table vct)
obj (slot-definition-name s))))
(check-slot-type s val)
(list (sql-expression
- :attribute (view-class-slot-column s))
+ :attribute (database-identifier s database))
(db-value-from-slot s val database))))
sds)))
(cond ((and avps (view-database obj))
(slot-value-list (slot)
(let ((value (slot-value obj (slot-definition-name slot))))
(check-slot-type slot value)
- (list (sql-expression :attribute (view-class-slot-column slot))
+ (list (sql-expression :attribute (database-identifier slot database))
(db-value-from-slot slot value database)))))
(let* ((view-class (or this-class (class-of obj)))
(pk-slot (car (keyslots-for-class view-class)))
:database database)
(when (and pk-slot (not pk))
- (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot)))
- (not (null (view-class-slot-autoincrement-sequence pk-slot))))
- (setf (slot-value obj (slot-definition-name pk-slot))
- (database-last-auto-increment-id database
- view-class-table
- pk-slot)))))
+ (setf pk
+ (when (auto-increment-column-p pk-slot database)
+ (setf (slot-value obj (slot-definition-name pk-slot))
+ (database-last-auto-increment-id
+ database view-class-table pk-slot)))))
(when pk-slot
(setf pk (or pk
(slot-value
(sld (slotdef-for-slot-with-class slot class)))
(if sld
(if (eq value +no-slot-value+)
- (sql-expression :attribute (view-class-slot-column sld)
+ (sql-expression :attribute (database-identifier sld database)
:table (view-table class))
(db-value-from-slot
sld
(symbol
(sql-expression
:attribute
- (view-class-slot-column
- (slotdef-for-slot-with-class fk sc))
+ (database-identifier
+ (slotdef-for-slot-with-class fk sc) nil)
:table (view-table sc)))
(t fk))
(typecase hk
(symbol
(sql-expression
:attribute
- (view-class-slot-column fksd)
- :table (view-table jc)))
+ (database-identifier fksd nil)
+ :table (database-identifier jc nil)))
(t fk))
(typecase hk
(symbol
(declare (ignore all set-operation group-by having offset limit inner-join on))
(flet ((ref-equal (ref1 ref2)
(string= (sql-output ref1 database)
- (sql-output ref2 database)))
- (tables-equal (table-a table-b)
- (when (and table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name))))))
+ (sql-output ref2 database))))
(remf args :from)
(remf args :where)
(remf args :flatp)
jc-list))
immediate-join-classes)
sel-tables)
- :test #'tables-equal)))
+ :test #'database-identifier-equal)))
(order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
(listify order-by)))
(join-where nil))
;;; Sequence functions
(defun %sequence-name-to-table (sequence-name database)
- (concatenate 'string
- (convert-to-db-default-case "_CLSQL_SEQ_" database)
- (sql-escape sequence-name)))
-
-(defun %table-name-to-sequence-name (table-name database)
- (and (>= (length table-name) 11)
- (string-equal (subseq table-name 0 11)
- (convert-to-db-default-case "_CLSQL_SEQ_" database))
- (subseq table-name 11)))
+ (escaped
+ (combine-database-identifiers
+ (list sequence-name 'CLSQL_SEQ)
+ database)))
(defmethod database-create-sequence (sequence-name database)
(let ((table-name (%sequence-name-to-table sequence-name database)))
(concatenate 'string "DROP TABLE " (%sequence-name-to-table sequence-name database))
database))
+(defun %table-name-to-sequence-name (table-name)
+ ;; if this was escaped it still should be,
+ ;; if it wasnt it still shouldnt-be
+ (check-type table-name string)
+ (replace-all table-name "_CLSQL_SEQ" ""))
+
(defmethod database-list-sequences (database &key (owner nil))
(declare (ignore owner))
(mapcan #'(lambda (s)
- (let ((sn (%table-name-to-sequence-name s database)))
- (and sn (list sn))))
+ (and (search "_CLSQL_SEQ" s :test #'string-equal)
+ (list (%table-name-to-sequence-name s))))
(database-list-tables-and-sequences database)))
(defmethod database-set-sequence-position (sequence-name position database)
(string
(make-instance 'sql :string string))
(attribute
- (make-instance 'sql-ident-attribute :name attribute
+ (make-instance 'sql-ident-attribute :name attribute
:qualifier (or table alias)
:type type))
((and table (not attribute))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq cl:*features* (delete :clsql-lowercase-reader cl:*features*)))
+(defun replace-all (string part replacement &key (test #'char=) stream)
+ "Returns a new string in which all the occurences of the part
+is replaced with replacement. [FROM http://cl-cookbook.sourceforge.net/strings.html#manip]"
+ (let ((out (or stream (make-string-output-stream))))
+ (loop with part-length = (length part)
+ for old-pos = 0 then (+ pos part-length)
+ for pos = (search part string
+ :start2 old-pos
+ :test test)
+ do (write-string string out
+ :start old-pos
+ :end (or pos (length string)))
+ when pos do (write-string replacement out)
+ while pos)
+ (unless stream
+ (get-output-stream-string out))))
+
(defun %dataset-init (name)
"Run initialization code and fill database for given dataset."
- (handler-bind
- ((error #'generic-error))
- ;;find items that looks like '(:setup ...),
+ ;;find items that looks like '(:setup ...),
;; dispatch the rest.
(let ((setup (rest (find :setup name :key #'first)))
(sqldata (rest (find :sqldata name :key #'first)))
;;presumed to be view-class objects, force them to insert.
(dolist (o objdata)
(setf (slot-value o 'clsql-sys::view-database) nil)
- (clsql-sys:update-records-from-instance o))))))
+ (clsql-sys:update-records-from-instance o)))))
(defun %dataset-cleanup (name)
"Run cleanup code associated with the given dataset."
projects / clsql.git / commitdiff