sql/fddl.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; The CLSQL Functional Data Definition Language (FDDL)
   5 ;;;; including functions for schema manipulation. Currently supported
   6 ;;;; SQL objects include tables, views, indexes, attributes and
   7 ;;;; sequences.
   8 ;;;;
   9 ;;;; This file is part of CLSQL.
  10 ;;;;
  11 ;;;; CLSQL users are granted the rights to distribute and use this software
  12 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  13 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  14 ;;;; *************************************************************************
  15
  16 (in-package #:clsql-sys)
  17
  18
  19 ;; Utilities
  20
  21 (defun database-identifier (name database)
  22   (sql-escape (etypecase name
  23                 ;; honor case of strings
  24                 (string name)
  25                 (sql-ident (sql-output name database))
  26                 (symbol (sql-output name database)))))
  27
  28
  29 ;; Truncate database
  30
  31 (defun truncate-database (&key (database *default-database*))
  32   "Drops all tables, views, indexes and sequences in DATABASE which
  33 defaults to *DEFAULT-DATABASE*."
  34   (unless (typep database 'database)
  35     (signal-no-database-error database))
  36   (unless (is-database-open database)
  37     (database-reconnect database))
  38   (when (eq :oracle (database-type database))
  39     (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
  40   (when (db-type-has-views? (database-underlying-type database))
  41     (dolist (view (list-views :database database))
  42       (drop-view view :database database)))
  43   (dolist (table (list-tables :database database))
  44     (drop-table table :database database))
  45   (dolist (index (list-indexes :database database))
  46     (drop-index index :database database))
  47   (dolist (seq (list-sequences :database database))
  48     (drop-sequence seq :database database))
  49   (when (eq :oracle (database-type database))
  50     (ignore-errors (execute-command "PURGE RECYCLEBIN" :database database)))
  51   (values))
  52
  53
  54 ;; Tables
  55
  56 (defun create-table (name description &key (database *default-database*)
  57                           (constraints nil) (transactions t))
  58   "Creates a table called NAME, which may be a string, symbol or
  59 SQL table identifier, in DATABASE which defaults to
  60 *DEFAULT-DATABASE*. DESCRIPTION is a list whose elements are
  61 lists containing the attribute names, types, and other
  62 constraints such as not-null or primary-key for each column in
  63 the table.  CONSTRAINTS is a string representing an SQL table
  64 constraint expression or a list of such strings. With MySQL
  65 databases, if TRANSACTIONS is t an InnoDB table is created which
  66 supports transactions."
  67   (execute-command
  68    (make-instance 'sql-create-table
  69                   :name name
  70                   :columns description
  71                   :modifiers constraints
  72                   :transactions transactions)
  73    :database database))
  74
  75 (defun drop-table (name &key (if-does-not-exist :error)
  76                              (database *default-database*)
  77                              (owner nil))
  78   "Drops the table called NAME from DATABASE which defaults to
  79 *DEFAULT-DATABASE*. If the table does not exist and
  80 IF-DOES-NOT-EXIST is :ignore then DROP-TABLE returns nil whereas
  81 an error is signalled if IF-DOES-NOT-EXIST is :error."
  82   (let ((table-name (database-identifier name database)))
  83     (ecase if-does-not-exist
  84       (:ignore
  85        (unless (table-exists-p table-name :database database
  86                                :owner owner)
  87          (return-from drop-table nil)))
  88       (:error
  89        t))
  90
  91     (let ((expr (etypecase name
  92                   ;; keep quotes for strings for mixed-case names
  93                   (string (format nil "DROP TABLE ~S" table-name))
  94                   ((or symbol sql-ident)
  95                    (concatenate 'string "DROP TABLE " table-name)))))
  96       ;; Fixme: move to clsql-oracle
  97       (when (and (find-package 'clsql-oracle)
  98                  (eq :oracle (database-type database))
  99                  (eql 10 (slot-value database
 100                                      (intern (symbol-name '#:major-server-version)
 101                                              (symbol-name '#:clsql-oracle)))))
 102         (setq expr (concatenate 'string expr " PURGE")))
 103
 104       (execute-command expr :database database))))
 105
 106 (defun list-tables (&key (owner nil) (database *default-database*))
 107   "Returns a list of strings representing table names in DATABASE
 108 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 109 which means that only tables owned by users are listed. If OWNER
 110 is a string denoting a user name, only tables owned by OWNER are
 111 listed. If OWNER is :all then all tables are listed."
 112   (database-list-tables database :owner owner))
 113
 114 (defmethod %table-exists-p (name (database T) &key owner )
 115   (unless database (setf database *default-database*))
 116   (let ((name (database-identifier name database))
 117         (tables (list-tables :owner owner :database database)))
 118     (when (member name tables :test #'string-equal)
 119       t)))
 120
 121 (defun table-exists-p (name &key (owner nil) (database *default-database*))
 122   "Tests for the existence of an SQL table called NAME in DATABASE
 123 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 124 which means that only tables owned by users are examined. If
 125 OWNER is a string denoting a user name, only tables owned by
 126 OWNER are examined. If OWNER is :all then all tables are
 127 examined."
 128   (%table-exists-p name database :owner owner))
 129
 130
 131 ;; Views
 132
 133 (defun create-view (name &key as column-list (with-check-option nil)
 134                          (database *default-database*))
 135   "Creates a view called NAME in DATABASE which defaults to
 136 *DEFAULT-DATABASE*. The view is created using the query AS and
 137 the columns of the view may be specified using the COLUMN-LIST
 138 parameter. The WITH-CHECK-OPTION is nil by default but if it has
 139 a non-nil value, then all insert/update commands on the view are
 140 checked to ensure that the new data satisfy the query AS."
 141   (let* ((view-name (etypecase name
 142                       (symbol (sql-expression :attribute name))
 143                       (string (sql-expression :attribute (make-symbol name)))
 144                       (sql-ident name)))
 145          (stmt (make-instance 'sql-create-view
 146                               :name view-name
 147                               :column-list column-list
 148                               :query as
 149                               :with-check-option with-check-option)))
 150     (execute-command stmt :database database)))
 151
 152 (defun drop-view (name &key (if-does-not-exist :error)
 153                        (database *default-database*))
 154   "Drops the view called NAME from DATABASE which defaults to
 155 *DEFAULT-DATABASE*. If the view does not exist and
 156 IF-DOES-NOT-EXIST is :ignore then DROP-VIEW returns nil whereas
 157 an error is signalled if IF-DOES-NOT-EXIST is :error."
 158   (let ((view-name (database-identifier name database)))
 159     (ecase if-does-not-exist
 160       (:ignore
 161        (unless (view-exists-p view-name :database database)
 162          (return-from drop-view)))
 163       (:error
 164        t))
 165     (let ((expr (concatenate 'string "DROP VIEW " view-name)))
 166       (execute-command expr :database database))))
 167
 168 (defun list-views (&key (owner nil) (database *default-database*))
 169   "Returns a list of strings representing view names in DATABASE
 170 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 171 which means that only views owned by users are listed. If OWNER
 172 is a string denoting a user name, only views owned by OWNER are
 173 listed. If OWNER is :all then all views are listed."
 174   (database-list-views database :owner owner))
 175
 176 (defun view-exists-p (name &key (owner nil) (database *default-database*))
 177   "Tests for the existence of an SQL view called NAME in DATABASE
 178 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 179 which means that only views owned by users are examined. If OWNER
 180 is a string denoting a user name, only views owned by OWNER are
 181 examined. If OWNER is :all then all views are examined."
 182   (when (member (database-identifier name database)
 183                 (list-views :owner owner :database database)
 184                 :test #'string-equal)
 185     t))
 186
 187
 188 ;; Indexes
 189
 190 (defun create-index (name &key on (unique nil) attributes
 191                           (database *default-database*))
 192   "Creates an index called NAME on the table specified by ON in
 193 DATABASE which default to *DEFAULT-DATABASE*. The table
 194 attributes to use in constructing the index NAME are specified by
 195 ATTRIBUTES. The UNIQUE argument is nil by default but if it has a
 196 non-nil value then the indexed attributes must have unique
 197 values."
 198   (let* ((index-name (database-identifier name database))
 199          (table-name (database-identifier on database))
 200          (attributes (mapcar #'(lambda (a) (database-identifier a database)) (listify attributes)))
 201          (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})"
 202                        (if unique "UNIQUE" "")
 203                        index-name table-name attributes)))
 204     (execute-command stmt :database database)))
 205
 206 (defun drop-index (name &key (if-does-not-exist :error)
 207                         (on nil)
 208                         (database *default-database*))
 209   "Drops the index called NAME in DATABASE which defaults to
 210 *DEFAULT-DATABASE*. If the index does not exist and
 211 IF-DOES-NOT-EXIST is :ignore then DROP-INDEX returns nil whereas
 212 an error is signalled if IF-DOES-NOT-EXIST is :error. The
 213 argument ON allows the optional specification of a table to drop
 214 the index from."
 215   (let ((index-name (database-identifier name database)))
 216     (ecase if-does-not-exist
 217       (:ignore
 218        (unless (index-exists-p index-name :database database)
 219          (return-from drop-index)))
 220       (:error t))
 221     (let* ((db-type (database-underlying-type database))
 222            (index-identifier (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
 223                                     (format nil "~A.~A" (database-identifier on database) index-name))
 224                                    ((db-type-use-column-on-drop-index? db-type)
 225                                     (format nil "~A ON ~A" index-name (database-identifier on database)))
 226                                    (t index-name))))
 227       (execute-command (format nil "DROP INDEX ~A" index-identifier)
 228                        :database database))))
 229
 230 (defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
 231   "Returns a list of strings representing index names in DATABASE
 232 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 233 which means that only indexes owned by users are listed. If OWNER
 234 is a string denoting a user name, only indexes owned by OWNER are
 235 listed. If OWNER is :all then all indexes are listed. The keyword
 236 argument ON limits the results to indexes on the specified
 237 tables. Meaningful values for ON are nil (the default) which
 238 means that all tables are considered, a string, symbol or SQL
 239 expression representing a table name in DATABASE or a list of
 240 such table identifiers."
 241   (if (null on)
 242       (database-list-indexes database :owner owner)
 243       (let ((tables (typecase on (cons on) (t (list on)))))
 244         (reduce #'append
 245                 (mapcar #'(lambda (table) (database-list-table-indexes
 246                                            (database-identifier table database)
 247                                            database :owner owner))
 248                         tables)))))
 249
 250 (defun index-exists-p (name &key (owner nil) (database *default-database*))
 251   "Tests for the existence of an SQL index called NAME in DATABASE
 252 which defaults to *DEFAULT-DATABASE*. OWNER is nil by default
 253 which means that only indexes owned by users are examined. If
 254 OWNER is a string denoting a user name, only indexes owned by
 255 OWNER are examined. If OWNER is :all then all indexes are
 256 examined."
 257   (when (member (database-identifier name database)
 258                 (list-indexes :owner owner :database database)
 259                 :test #'string-equal)
 260     t))
 261
 262 ;; Attributes
 263
 264 (defvar *cache-table-queries-default* nil
 265   "Specifies the default behaivour for caching of attribute
 266   types. Meaningful values are t, nil and :flush as described for
 267   the action argument to CACHE-TABLE-QUERIES.")
 268
 269 (defun cache-table-queries (table &key (action nil) (database *default-database*))
 270   "Controls the caching of attribute type information on the
 271 table specified by TABLE in DATABASE which defaults to
 272 *DEFAULT-DATABASE*. ACTION specifies the caching behaviour to
 273 adopt. If its value is t then attribute type information is
 274 cached whereas if its value is nil then attribute type
 275 information is not cached. If ACTION is :flush then all existing
 276 type information in the cache for TABLE is removed, but caching
 277 is still enabled. TABLE may be a string representing a table for
 278 which the caching action is to be taken while the caching action
 279 is applied to all tables if TABLE is t. Alternativly, when TABLE
 280 is :default, the default caching action specified by
 281 *CACHE-TABLE-QUERIES-DEFAULT* is applied to all table for which a
 282 caching action has not been explicitly set."
 283   (with-slots (attribute-cache) database
 284     (cond
 285       ((stringp table)
 286        (multiple-value-bind (val found) (gethash table attribute-cache)
 287          (cond
 288            ((and found (eq action :flush))
 289             (setf (gethash table attribute-cache) (list t nil)))
 290            ((and found (eq action t))
 291             (setf (gethash table attribute-cache) (list t (second val))))
 292            ((and found (null action))
 293             (setf (gethash table attribute-cache) (list nil nil)))
 294            ((not found)
 295             (setf (gethash table attribute-cache) (list action nil))))))
 296       ((eq table t)
 297        (maphash (lambda (k v)
 298                   (cond
 299                     ((eq action :flush)
 300                      (setf (gethash k attribute-cache) (list t nil)))
 301                     ((null action)
 302                      (setf (gethash k attribute-cache) (list nil nil)))
 303                     ((eq t action)
 304                      (setf (gethash k attribute-cache) (list t (second v))))))
 305                 attribute-cache))
 306       ((eq table :default)
 307        (maphash (lambda (k v)
 308                   (when (eq (first v) :unspecified)
 309                     (cond
 310                       ((eq action :flush)
 311                        (setf (gethash k attribute-cache) (list t nil)))
 312                       ((null action)
 313                        (setf (gethash k attribute-cache) (list nil nil)))
 314                       ((eq t action)
 315                        (setf (gethash k attribute-cache) (list t (second v)))))))
 316                 attribute-cache))))
 317   (values))
 318
 319
 320 (defun list-attributes (name &key (owner nil) (database *default-database*))
 321   "Returns a list of strings representing the attributes of table
 322 NAME in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is
 323 nil by default which means that only attributes owned by users
 324 are listed. If OWNER is a string denoting a user name, only
 325 attributes owned by OWNER are listed. If OWNER is :all then all
 326 attributes are listed."
 327   (database-list-attributes (database-identifier name database) database
 328                             :owner owner))
 329
 330 (defun attribute-type (attribute table &key (owner nil)
 331                                  (database *default-database*))
 332   "Returns a keyword representing the vendor-specific field type
 333 of the supplied attribute ATTRIBUTE in the table specified by
 334 TABLE in DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is
 335 nil by default which means that the attribute specified by
 336 ATTRIBUTE, if it exists, must be user owned else nil is
 337 returned. If OWNER is a string denoting a user name, the
 338 attribute, if it exists, must be owned by OWNER else nil is
 339 returned, whereas if OWNER is :all then the attribute, if it
 340 exists, will be returned regardless of its owner."
 341   (database-attribute-type (database-identifier attribute database)
 342                            (database-identifier table database)
 343                            database
 344                            :owner owner))
 345
 346 (defun list-attribute-types (table &key (owner nil)
 347                                    (database *default-database*))
 348   "Returns a list containing information about the SQL types of
 349 each of the attributes in the table specified by TABLE in
 350 DATABASE which has a default value of *DEFAULT-DATABASE*. OWNER
 351 is nil by default which means that only attributes owned by users
 352 are listed. If OWNER is a string denoting a user name, only
 353 attributes owned by OWNER are listed. If OWNER is :all then all
 354 attributes are listed. The elements of the returned list are
 355 lists where the first element is the name of the attribute, the
 356 second element is its SQL type, the third is the type precision,
 357 the fourth is the scale of the attribute and the fifth is 1 if
 358 the attribute accepts null values and otherwise 0."
 359   (with-slots (attribute-cache) database
 360     (let ((table-ident (database-identifier table database)))
 361       (multiple-value-bind (val found) (gethash table-ident attribute-cache)
 362         (if (and found (second val))
 363             (second val)
 364             (let ((types (mapcar #'(lambda (attribute)
 365                                      (cons attribute
 366                                            (multiple-value-list
 367                                             (database-attribute-type
 368                                              (database-identifier attribute
 369                                                                   database)
 370                                              table-ident
 371                                              database
 372                                              :owner owner))))
 373                                  (list-attributes table :database database
 374                                                   :owner owner))))
 375               (cond
 376                 ((and (not found) (eq t *cache-table-queries-default*))
 377                  (setf (gethash table-ident attribute-cache)
 378                        (list :unspecified types)))
 379                 ((and found (eq t (first val))
 380                       (setf (gethash table-ident attribute-cache)
 381                             (list t types)))))
 382               types))))))
 383
 384
 385 ;; Sequences
 386
 387 (defun create-sequence (name &key (database *default-database*))
 388   "Creates a sequence called NAME in DATABASE which defaults to
 389 *DEFAULT-DATABASE*."
 390   (let ((sequence-name (database-identifier name database)))
 391     (database-create-sequence sequence-name database))
 392   (values))
 393
 394 (defun drop-sequence (name &key (if-does-not-exist :error)
 395                            (database *default-database*))
 396   "Drops the sequence called NAME from DATABASE which defaults to
 397 *DEFAULT-DATABASE*. If the sequence does not exist and
 398 IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil
 399 whereas an error is signalled if IF-DOES-NOT-EXIST is :error."
 400   (let ((sequence-name (database-identifier name database)))
 401     (ecase if-does-not-exist
 402       (:ignore
 403        (unless (sequence-exists-p sequence-name :database database)
 404          (return-from drop-sequence)))
 405       (:error t))
 406     (database-drop-sequence sequence-name database))
 407   (values))
 408
 409 (defun list-sequences (&key (owner nil) (database *default-database*))
 410   "Returns a list of strings representing sequence names in
 411 DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
 412 default which means that only sequences owned by users are
 413 listed. If OWNER is a string denoting a user name, only sequences
 414 owned by OWNER are listed. If OWNER is :all then all sequences
 415 are listed."
 416   (database-list-sequences database :owner owner))
 417
 418 (defun sequence-exists-p (name &key (owner nil)
 419                                (database *default-database*))
 420   "Tests for the existence of an SQL sequence called NAME in
 421 DATABASE which defaults to *DEFAULT-DATABASE*. OWNER is nil by
 422 default which means that only sequences owned by users are
 423 examined. If OWNER is a string denoting a user name, only
 424 sequences owned by OWNER are examined. If OWNER is :all then all
 425 sequences are examined."
 426   (when (member (database-identifier name database)
 427                 (list-sequences :owner owner :database database)
 428                 :test #'string-equal)
 429     t))
 430
 431 (defun sequence-next (name &key (database *default-database*))
 432   "Increment and return the next value in the sequence called
 433   NAME in DATABASE which defaults to *DEFAULT-DATABASE*."
 434   (database-sequence-next (database-identifier name database) database))
 435
 436 (defun set-sequence-position (name position &key (database *default-database*))
 437   "Explicitly set the the position of the sequence called NAME in
 438 DATABASE, which defaults to *DEFAULT-DATABASE*, to POSITION which
 439 is returned."
 440   (database-set-sequence-position (database-identifier name database)
 441                                   position database))
 442
 443 (defun sequence-last (name &key (database *default-database*))
 444   "Return the last value allocated in the sequence called NAME in DATABASE
 445   which defaults to *DEFAULT-DATABASE*."
 446   (database-sequence-last (database-identifier name database) database))
 447