sql/database.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; Base database functions
   7 ;;;;
   8 ;;;; This file is part of CLSQL.
   9 ;;;;
  10 ;;;; CLSQL users are granted the rights to distribute and use this software
  11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  13 ;;;; *************************************************************************
  14
  15 (in-package #:clsql-sys)
  16
  17
  18 (defvar *connect-if-exists* :error
  19   "Default value for the if-exists keyword argument in calls to
  20 CONNECT. Meaningful values are :new, :warn-new, :error, :warn-old
  21 and :old.")
  22
  23 (defvar *connected-databases* nil
  24   "List of active database objects.")
  25
  26 (defun connected-databases ()
  27   "Returns the list of active database objects."
  28   *connected-databases*)
  29
  30 (defvar *default-database* nil
  31   "Specifies the default database to be used.")
  32
  33 (defun is-database-open (database)
  34   (eql (database-state database) :open))
  35
  36 (defun find-database (database &key (errorp t) (db-type nil))
  37   "Returns the connected databases of type DB-TYPE whose names
  38 match the string DATABASE. If DATABASE is a database object, it
  39 is returned. If DB-TYPE is nil all databases matching the string
  40 DATABASE are considered.  If no matching databases are found and
  41 ERRORP is nil then nil is returned. If ERRORP is nil and one or
  42 more matching databases are found, then the most recently
  43 connected database is returned as a first value and the number of
  44 matching databases is returned as a second value. If no, or more
  45 than one, matching databases are found and ERRORP is true, an
  46 error is signalled."
  47   (etypecase database
  48     (database
  49      (values database 1))
  50     (string
  51      (let* ((matches (remove-if
  52                       #'(lambda (db)
  53                           (not (and (string= (database-name db) database)
  54                                     (if db-type
  55                                         (equal (database-type db) db-type)
  56                                         t))))
  57                       (connected-databases)))
  58             (count (length matches)))
  59        (if (or (not errorp) (= count 1))
  60            (values (car matches) count)
  61            (cerror "Return nil."
  62                    'sql-database-error
  63                    :message
  64                    (format nil "There exists ~A database called ~A."
  65                            (if (zerop count) "no" "more than one")
  66                            database)))))
  67     (null
  68      (error "A database must be specified rather than NIL."))))
  69
  70
  71 (defun connect (connection-spec
  72                 &key (if-exists *connect-if-exists*)
  73                 (make-default t)
  74                 (pool nil)
  75                 (database-type *default-database-type*))
  76   "Connects to a database of the supplied DATABASE-TYPE which
  77 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
  78 connection specification CONNECTION-SPEC. The value of IF-EXISTS,
  79 which defaults to *CONNECT-IF-EXISTS*, determines what happens if
  80 a connection to the database specified by CONNECTION-SPEC is
  81 already established.  A value of :new means create a new
  82 connection.  A value of :warn-new means warn the user and create
  83 a new connect.  A value of :warn-old means warn the user and use
  84 the old connection.  A value of :error means fail, notifying the
  85 user.  A value of :old means return the old connection.
  86 MAKE-DEFAULT is t by default which means that *DEFAULT-DATABASE*
  87 is set to the new connection, otherwise *DEFAULT-DATABASE* is not
  88 changed. If POOL is t the connection will be taken from the
  89 general pool, if POOL is a CONN-POOL object the connection will
  90 be taken from this pool."
  91
  92   (unless database-type
  93     (error 'sql-database-error :message "Must specify a database-type."))
  94
  95   (when (stringp connection-spec)
  96     (setq connection-spec (string-to-list-connection-spec connection-spec)))
  97
  98   (unless (member database-type *loaded-database-types*)
  99     (asdf:operate 'asdf:load-op (ensure-keyword
 100                                  (concatenate 'string
 101                                               (symbol-name '#:clsql-)
 102                                               (symbol-name database-type)))))
 103
 104   (if pool
 105       (acquire-from-pool connection-spec database-type pool)
 106       (let* ((db-name (database-name-from-spec connection-spec database-type))
 107              (old-db (unless (eq if-exists :new)
 108                        (find-database db-name :db-type database-type
 109                                       :errorp nil)))
 110              (result nil))
 111         (if old-db
 112             (ecase if-exists
 113               (:warn-new
 114                (setq result
 115                      (database-connect connection-spec database-type))
 116                (warn 'sql-warning
 117                      :message
 118                      (format nil
 119                              "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
 120                              result (database-name result) old-db)))
 121               (:error
 122                (restart-case
 123                    (error 'sql-connection-error
 124                           :message
 125                           (format nil "There is an existing connection ~A to database ~A."
 126                           old-db
 127                           (database-name old-db)))
 128                  (create-new ()
 129                    :report "Create a new connection."
 130                    (setq result
 131                          (database-connect connection-spec database-type)))
 132                  (use-old ()
 133                    :report "Use the existing connection."
 134                    (setq result old-db))))
 135               (:warn-old
 136                (setq result old-db)
 137                (warn 'sql-warning
 138                      :message
 139                      (format nil
 140                              "Using existing connection ~A to database ~A."
 141                              old-db
 142                              (database-name old-db))))
 143               (:old
 144                (setq result old-db)))
 145             (setq result
 146                   (database-connect connection-spec database-type)))
 147         (when result
 148           (setf (slot-value result 'state) :open)
 149           (pushnew result *connected-databases*)
 150           (when make-default (setq *default-database* result))
 151           result))))
 152
 153
 154 (defun disconnect (&key (database *default-database*) (error nil))
 155
 156   "Closes the connection to DATABASE and resets
 157 *DEFAULT-DATABASE* if that database was disconnected. If DATABASE
 158 is a database instance, this object is closed. If DATABASE is a
 159 string, then a connected database whose name matches DATABASE is
 160 sought in the list of connected databases. If no matching
 161 database is found and ERROR and DATABASE are both non-nil an
 162 error is signaled, otherwise nil is returned. If the database is
 163 from a pool it will be released to this pool."
 164   (let ((database (find-database database :errorp (and database error))))
 165     (when database
 166       (if (conn-pool database)
 167           (when (release-to-pool database)
 168             (setf *connected-databases* (delete database *connected-databases*))
 169             (when (eq database *default-database*)
 170               (setf *default-database* (car *connected-databases*)))
 171             t)
 172           (when (database-disconnect database)
 173             (setf *connected-databases* (delete database *connected-databases*))
 174             (when (eq database *default-database*)
 175               (setf *default-database* (car *connected-databases*)))
 176             (setf (slot-value database 'state) :closed)
 177             t)))))
 178
 179
 180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 181
 182
 183 (defmacro check-connection-spec (connection-spec database-type template)
 184   "Check the connection specification against the provided template,
 185 and signal an sql-user-error if they don't match. This function
 186 is called by database backends."
 187   `(handler-case
 188     (destructuring-bind ,template ,connection-spec
 189       (declare (ignore ,@(remove '&optional template)))
 190       t)
 191     (error ()
 192      (error 'sql-user-error
 193       :message
 194       (format nil
 195               "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
 196               ,connection-spec
 197               ,database-type
 198               (quote ,template))))))
 199
 200 (defun reconnect (&key (database *default-database*) (error nil) (force t))
 201   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to
 202 the underlying database management system. On success, t is
 203 returned and the variable *DEFAULT-DATABASE* is set to the newly
 204 reconnected database. If DATABASE is a database instance, this
 205 object is closed. If DATABASE is a string, then a connected
 206 database whose name matches DATABASE is sought in the list of
 207 connected databases. If no matching database is found and ERROR
 208 and DATABASE are both non-nil an error is signaled, otherwise nil
 209 is returned. When the current database connection cannot be
 210 closed, if FORCE is non-nil, as it is by default, the connection
 211 is closed and errors are suppressed. If force is nil and the
 212 database connection cannot be closed, an error is signalled."
 213   (let ((db (etypecase database
 214               (database database)
 215               ((or string list)
 216                (let ((db (find-database database :errorp nil)))
 217                  (when (null db)
 218                    (if (and database error)
 219                        (error 'sql-connection-error
 220                               :message
 221                               (format nil "Unable to find database with connection-spec ~A." database))
 222                        (return-from reconnect nil)))
 223                  db)))))
 224
 225     (when (is-database-open db)
 226       (if force
 227           (ignore-errors (disconnect :database db))
 228           (disconnect :database db :error nil)))
 229
 230     (connect (connection-spec db))))
 231
 232
 233 (defun status (&optional full)
 234   "Prints information about the currently connected databases to
 235 *STANDARD-OUTPUT*. The argument FULL is nil by default and a
 236 value of t means that more detailed information about each
 237 database is printed."
 238   (flet ((get-data ()
 239            (let ((data '()))
 240              (dolist (db (connected-databases) data)
 241                (push
 242                 (append
 243                  (list (if (equal db *default-database*) "*" "")
 244                        (database-name db)
 245                        (string-downcase (string (database-type db)))
 246                        (cond ((and (command-recording-stream db)
 247                                    (result-recording-stream db))
 248                               "Both")
 249                              ((command-recording-stream db) "Commands")
 250                              ((result-recording-stream db) "Results")
 251                              (t "nil")))
 252                  (when full
 253                    (list
 254                     (if (conn-pool db) "t" "nil")
 255                     (format nil "~A" (length (database-list-tables db)))
 256                     (format nil "~A" (length (database-list-views db))))))
 257                 data))))
 258          (compute-sizes (data)
 259            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
 260                    (apply #'mapcar (cons #'list data))))
 261          (print-separator (size)
 262            (format t "~&~A" (make-string size :initial-element #\-))))
 263     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
 264     (let ((data (get-data)))
 265       (when data
 266         (let* ((titles (if full
 267                            (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
 268                                  "TABLES" "VIEWS")
 269                            (list "" "DATABASE" "TYPE" "RECORDING")))
 270                (sizes (compute-sizes (cons titles data)))
 271                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
 272                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))
 273           (print-separator total-size)
 274           (format t control-string titles)
 275           (print-separator total-size)
 276           (dolist (d data) (format t control-string d))
 277           (print-separator total-size))))
 278     (values)))
 279
 280 (defun create-database (connection-spec &key database-type)
 281   "This function creates a database in the database system specified
 282 by DATABASE-TYPE."
 283   (when (stringp connection-spec)
 284     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 285   (database-create connection-spec database-type))
 286
 287 (defun probe-database (connection-spec &key database-type)
 288   "This function tests for the existence of a database in the database
 289 system specified by DATABASE-TYPE."
 290   (when (stringp connection-spec)
 291     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 292   (database-probe connection-spec database-type))
 293
 294 (defun destroy-database (connection-spec &key database-type)
 295   "This function destroys a database in the database system specified
 296 by DATABASE-TYPE."
 297   (when (stringp connection-spec)
 298     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 299   (database-destroy connection-spec database-type))
 300
 301 (defun list-databases (connection-spec &key database-type)
 302   "This function returns a list of databases existing in the database
 303 system specified by DATABASE-TYPE."
 304   (when (stringp connection-spec)
 305     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 306   (database-list connection-spec database-type))
 307
 308 (defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
 309   "Evaluate the body in an environment, where DB-VAR is bound to the
 310 database connection given by CONNECTION-SPEC and CONNECT-ARGS.  The
 311 connection is automatically closed or released to the pool on exit
 312 from the body."
 313   (let ((result (gensym "result-")))
 314     (unless db-var (setf db-var '*default-database*))
 315     `(let ((,db-var (connect ,connection-spec ,@connect-args))
 316            (,result nil))
 317       (unwind-protect
 318            (let ((,db-var ,db-var))
 319              (setf ,result (progn ,@body)))
 320         (disconnect :database ,db-var))
 321       ,result)))
 322
 323
 324 (defmacro with-default-database ((database) &rest body)
 325   "Perform BODY with DATABASE bound as *default-database*."
 326   `(progv '(*default-database*)
 327        (list ,database)
 328      ,@body))
 329