;;;; -*- 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
(defun database-identifier (name database)
(sql-escape (etypecase name
- ;; honor case of strings
- (string name
- #+nil (convert-to-db-default-case name database))
+ ;; honor case of strings
+ (string name)
(sql-ident (sql-output name database))
(symbol (sql-output name database)))))
-;; Tables
+;; Truncate database
+
+(defun truncate-database (&key (database *default-database*))
+ "Drops all tables, views, indexes and sequences in DATABASE which
+defaults to *DEFAULT-DATABASE*."
+ (unless (typep database 'database)
+ (signal-no-database-error database))
+ (unless (is-database-open database)
+ (database-reconnect database))
+ (when (eq :oracle (database-type database))
+ (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
+ (when (db-type-has-views? (database-underlying-type database))
+ (dolist (view (list-views :database database))
+ (drop-view view :database database)))
+ (dolist (table (list-tables :database database))
+ (drop-table table :database database))
+ (dolist (index (list-indexes :database database))
+ (drop-index index :database database))
+ (dolist (seq (list-sequences :database database))
+ (drop-sequence seq :database database))
+ (when (eq :oracle (database-type database))
+ (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
+ (values))
+
+
+;; Tables
(defun create-table (name description &key (database *default-database*)
(constraints nil) (transactions t))
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*))
+ (database *default-database*)
+ (owner nil))
"Drops the table called NAME from DATABASE which defaults to
*DEFAULT-DATABASE*. If the table does not exist and
IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
(let ((table-name (database-identifier name database)))
(ecase if-does-not-exist
(:ignore
- (unless (table-exists-p table-name :database database)
+ (unless (table-exists-p table-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 (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)))))
+ ;; Fixme: move to clsql-oracle
(when (and (find-package 'clsql-oracle)
- (eq :oracle (database-type database))
- (eql 10 (slot-value database
- (intern (symbol-name '#:major-server-version)
- (symbol-name '#:clsql-oracle)))))
- (setq expr (concatenate 'string expr " PURGE")))
+ (eq :oracle (database-type database))
+ (eql 10 (slot-value database
+ (intern (symbol-name '#:major-server-version)
+ (symbol-name '#:clsql-oracle)))))
+ (setq expr (concatenate 'string expr " PURGE")))
(execute-command expr :database database))))
t))
-;; Views
+;; Views
(defun create-view (name &key as column-list (with-check-option 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
+ (let* ((view-name (etypecase name
(symbol (sql-expression :attribute name))
(string (sql-expression :attribute (make-symbol name)))
(sql-ident name)))
t))
-;; Indexes
+;; Indexes
(defun create-index (name &key on (unique nil) attributes
(database *default-database*))
(unless (index-exists-p index-name :database database)
(return-from drop-index)))
(:error t))
- (unless (db-type-use-column-on-drop-index?
- (database-underlying-type database))
- (setq on nil))
- (execute-command (format nil "DROP INDEX ~A~A" index-name
- (if (null on) ""
- (concatenate 'string " ON "
- (database-identifier on database))))
- :database database)))
+ (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))))
(defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
"Returns a list of strings representing index names in DATABASE
means that all tables are considered, a string, symbol or SQL
expression representing a table name in DATABASE or a list of
such table identifiers."
- (if (null on)
+ (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
+ (reduce #'append
+ (mapcar #'(lambda (table) (database-list-table-indexes
(database-identifier table database)
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
which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
:test #'string-equal)
t))
-;; Attributes
+;; Attributes
-(defvar *cache-table-queries-default* nil
+(defvar *cache-table-queries-default* nil
"Specifies the default behaivour for caching of attribute
types. Meaningful values are t, nil and :flush as described for
the action argument to CACHE-TABLE-QUERIES.")
(cond
((stringp table)
(multiple-value-bind (val found) (gethash table attribute-cache)
- (cond
- ((and found (eq action :flush))
- (setf (gethash table attribute-cache) (list t nil)))
- ((and found (eq action t))
- (setf (gethash table attribute-cache) (list t (second val))))
- ((and found (null action))
- (setf (gethash table attribute-cache) (list nil nil)))
- ((not found)
- (setf (gethash table attribute-cache) (list action nil))))))
+ (cond
+ ((and found (eq action :flush))
+ (setf (gethash table attribute-cache) (list t nil)))
+ ((and found (eq action t))
+ (setf (gethash table attribute-cache) (list t (second val))))
+ ((and found (null action))
+ (setf (gethash table attribute-cache) (list nil nil)))
+ ((not found)
+ (setf (gethash table attribute-cache) (list action nil))))))
((eq table t)
(maphash (lambda (k v)
- (cond
- ((eq action :flush)
- (setf (gethash k attribute-cache) (list t nil)))
- ((null action)
- (setf (gethash k attribute-cache) (list nil nil)))
- ((eq t action)
- (setf (gethash k attribute-cache) (list t (second v))))))
- attribute-cache))
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v))))))
+ attribute-cache))
((eq table :default)
(maphash (lambda (k v)
- (when (eq (first v) :unspecified)
- (cond
- ((eq action :flush)
- (setf (gethash k attribute-cache) (list t nil)))
- ((null action)
- (setf (gethash k attribute-cache) (list nil nil)))
- ((eq t action)
- (setf (gethash k attribute-cache) (list t (second v)))))))
- attribute-cache))))
+ (when (eq (first v) :unspecified)
+ (cond
+ ((eq action :flush)
+ (setf (gethash k attribute-cache) (list t nil)))
+ ((null action)
+ (setf (gethash k attribute-cache) (list nil nil)))
+ ((eq t action)
+ (setf (gethash k attribute-cache) (list t (second v)))))))
+ attribute-cache))))
(values))
-
+
(defun list-attributes (name &key (owner nil) (database *default-database*))
"Returns a list of strings representing the attributes of table
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 (database-identifier name database) database
:owner owner))
(defun attribute-type (attribute table &key (owner nil)
(with-slots (attribute-cache) database
(let ((table-ident (database-identifier table database)))
(multiple-value-bind (val found) (gethash table-ident attribute-cache)
- (if (and found (second val))
- (second val)
- (let ((types (mapcar #'(lambda (attribute)
- (cons attribute
- (multiple-value-list
- (database-attribute-type
- (database-identifier attribute
+ (if (and found (second val))
+ (second val)
+ (let ((types (mapcar #'(lambda (attribute)
+ (cons attribute
+ (multiple-value-list
+ (database-attribute-type
+ (database-identifier attribute
database)
- table-ident
- database
- :owner owner))))
- (list-attributes table :database database
+ table-ident
+ database
+ :owner owner))))
+ (list-attributes table :database database
:owner owner))))
- (cond
- ((and (not found) (eq t *cache-table-queries-default*))
- (setf (gethash table-ident attribute-cache)
+ (cond
+ ((and (not found) (eq t *cache-table-queries-default*))
+ (setf (gethash table-ident attribute-cache)
(list :unspecified types)))
- ((and found (eq t (first val))
- (setf (gethash table-ident attribute-cache)
+ ((and found (eq t (first val))
+ (setf (gethash table-ident attribute-cache)
(list t types)))))
- types))))))
-
+ types))))))
-;; Sequences
+
+;; Sequences
(defun create-sequence (name &key (database *default-database*))
"Creates a sequence called NAME in DATABASE which defaults to
(list-sequences :owner owner :database database)
:test #'string-equal)
t))
-
+
(defun sequence-next (name &key (database *default-database*))
"Increment and return the next value in the sequence called
NAME in DATABASE which defaults to *DEFAULT-DATABASE*."
"Explicitly set the the position of the sequence called NAME in
DATABASE, which defaults to *DEFAULT-DATABSE*, to POSITION which
is returned."
- (database-set-sequence-position (database-identifier name database)
+ (database-set-sequence-position (database-identifier name database)
position database))
(defun sequence-last (name &key (database *default-database*))