;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; The CLSQL Functional Data Definition Language (FDDL)
;;;; including functions for schema manipulation. Currently supported
;;;; SQL objects include tables, views, indexes, attributes and
(in-package #:clsql-sys)
-;; Utilities
-
-(defun database-identifier (name database)
- (sql-escape (etypecase name
- ;; honor case of strings
- (string name
- #+nil (convert-to-db-default-case name database))
- (sql-ident (sql-output name database))
- (symbol (sql-output name database)))))
-
-
;; Truncate database
(defun truncate-database (&key (database *default-database*))
constraint expression or a list of such strings. With MySQL
databases, if TRANSACTIONS is t an InnoDB table is created which
supports transactions."
- (let* ((table-name (etypecase name
- (symbol (sql-expression :attribute name))
- (string (sql-expression :attribute name))
- (sql-ident name)))
- (stmt (make-instance 'sql-create-table
- :name table-name
- :columns description
- :modifiers constraints
- :transactions transactions)))
- (execute-command stmt :database database)))
+ (execute-command
+ (make-instance 'sql-create-table
+ :name name
+ :columns description
+ :modifiers constraints
+ :transactions transactions)
+ :database database))
(defun drop-table (name &key (if-does-not-exist :error)
(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))
-
- ;; Fixme: move to clsql-oracle
- (let ((expr (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))
(eql 10 (slot-value 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
listed. If OWNER is :all then all tables are listed."
(database-list-tables database :owner owner))
+(defmethod %table-exists-p (name (database T) &key owner )
+ (unless database (setf database *default-database*))
+ (let ((name (database-identifier name database))
+ (tables (list-tables :owner owner :database database)))
+ (when (member name tables :test #'database-identifier-equal)
+ t)))
+
(defun table-exists-p (name &key (owner nil) (database *default-database*))
"Tests for the existence of an SQL table called NAME in DATABASE
which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
OWNER is a string denoting a user name, only tables owned by
OWNER are examined. If OWNER is :all then all tables are
examined."
- (when (member (database-identifier name database)
- (list-tables :owner owner :database database)
- :test #'string-equal)
- t))
+ (%table-exists-p name database :owner owner))
;; Views
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
- :owner owner))
+ (database-list-attributes
+ (database-identifier name database)
+ database
+ :owner owner))
(defun attribute-type (attribute table &key (owner nil)
(database *default-database*))
the attribute accepts null values and otherwise 0."
(with-slots (attribute-cache) database
(let ((table-ident (database-identifier table database)))
- (multiple-value-bind (val found) (gethash table-ident attribute-cache)
+ (multiple-value-bind (val found)
+ (gethash table attribute-cache)
(if (and found (second val))
(second val)
(let ((types (mapcar #'(lambda (attribute)
:owner owner))))
(cond
((and (not found) (eq t *cache-table-queries-default*))
- (setf (gethash table-ident attribute-cache)
+ (setf (gethash table attribute-cache)
(list :unspecified types)))
((and found (eq t (first val))
- (setf (gethash table-ident attribute-cache)
+ (setf (gethash table attribute-cache)
(list t types)))))
types))))))
*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
(defun set-sequence-position (name position &key (database *default-database*))
"Explicitly set the the position of the sequence called NAME in
-DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION which
+DATABASE, which defaults to *DEFAULT-DATABASE*, to POSITION which
is returned."
(database-set-sequence-position (database-identifier name database)
position database))
projects / clsql.git / blobdiff