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 (setf (documentation 'database-name 'function)
  18       "Returns the name of a database.")
  19
  20 ;;; Database handling
  21
  22 (defvar *connect-if-exists* :error
  23   "Default value for the if-exists parameter of connect calls.")
  24
  25 (defvar *connected-databases* nil
  26   "List of active database objects.")
  27
  28 (defun connected-databases ()
  29   "Return the list of active database objects."
  30   *connected-databases*)
  31
  32 (defvar *default-database* nil
  33   "Specifies the default database to be used.")
  34
  35 (defun is-database-open (database)
  36   (eql (database-state database) :open))
  37
  38 (defun find-database (database &key (errorp t) (db-type nil))
  39   "The function FIND-DATABASE, given a string DATABASE, searches
  40 amongst the connected databases for one matching the name DATABASE. If
  41 there is exactly one such database, it is returned and the second
  42 return value count is 1. If more than one databases match and ERRORP
  43 is nil, then the most recently connected of the matching databases is
  44 returned and count is the number of matches. If no matching database
  45 is found and ERRORP is nil, then nil is returned. If none, or more
  46 than one, matching databases are found and ERRORP is true, then an
  47 error is signalled. If the argument database is a database, it is
  48 simply returned."
  49   (etypecase database
  50     (database
  51      (values database 1))
  52     (string
  53      (let* ((matches (remove-if
  54                       #'(lambda (db)
  55                           (not (and (string= (database-name db) database)
  56                                     (if db-type
  57                                         (equal (database-type db) db-type)
  58                                         t))))
  59                       (connected-databases)))
  60             (count (length matches)))
  61        (if (or (not errorp) (= count 1))
  62            (values (car matches) count)
  63            (cerror "Return nil."
  64                    'clsql-simple-error
  65                    :format-control "There exists ~A database called ~A."
  66                    :format-arguments
  67                    (list (if (zerop count) "no" "more than one")
  68                          database)))))))
  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 given database-type, using the
  77 type-specific connection-spec.  The value of if-exists determines what
  78 happens if a connection to that database is already established.  A
  79 value of :new means create a new connection.  A value of :warn-new
  80 means warn the user and create a new connect.  A value of :warn-old
  81 means warn the user and use the old connection.  A value of :error
  82 means fail, notifying the user.  A value of :old means return the old
  83 connection.  If make-default is true, then *default-database* is set
  84 to the new connection, otherwise *default-database is not changed. If
  85 pool is t the connection will be taken from the general pool, if pool
  86 is a conn-pool object the connection will be taken from this pool."
  87
  88   (unless database-type
  89     (error 'sql-database-error :message "Must specify a database-type."))
  90
  91   (when (stringp connection-spec)
  92     (setq connection-spec (string-to-list-connection-spec connection-spec)))
  93
  94   (unless (member database-type *loaded-database-types*)
  95     (asdf:operate 'asdf:load-op (ensure-keyword
  96                                  (concatenate 'string
  97                                               (symbol-name '#:clsql-)
  98                                               (symbol-name database-type)))))
  99
 100   (if pool
 101       (acquire-from-pool connection-spec database-type pool)
 102       (let* ((db-name (database-name-from-spec connection-spec database-type))
 103              (old-db (unless (eq if-exists :new)
 104                        (find-database db-name :db-type database-type
 105                                       :errorp nil)))
 106              (result nil))
 107         (if old-db
 108             (ecase if-exists
 109               (:warn-new
 110                (setq result
 111                      (database-connect connection-spec database-type))
 112                (warn 'sql-warning
 113                      :message
 114                      (format nil
 115                              "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
 116                              result (database-name result) old-db)))
 117               (:error
 118                (restart-case
 119                    (error 'sql-connection-error
 120                           :message
 121                           "There is an existing connection ~A to database ~A."
 122                           old-db
 123                           (database-name old-db))
 124                  (create-new ()
 125                    :report "Create a new connection."
 126                    (setq result
 127                          (database-connect connection-spec database-type)))
 128                  (use-old ()
 129                    :report "Use the existing connection."
 130                    (setq result old-db))))
 131               (:warn-old
 132                (setq result old-db)
 133                (warn 'sql-warning
 134                      :message
 135                      (format nil
 136                              "Using existing connection ~A to database ~A."
 137                              old-db
 138                              (database-name old-db))))
 139               (:old
 140                (setq result old-db)))
 141             (setq result
 142                   (database-connect connection-spec database-type)))
 143         (when result
 144           (setf (slot-value result 'state) :open)
 145           (pushnew result *connected-databases*)
 146           (when make-default (setq *default-database* result))
 147           result))))
 148
 149
 150 (defun disconnect (&key (database *default-database*) (error nil))
 151
 152   "Closes the connection to DATABASE and resets *default-database* if
 153 that database was disconnected. If database is a database object, then
 154 it is used directly. Otherwise, the list of connected databases is
 155 searched to find one with DATABASE as its connection
 156 specifications. If no such database is found, then if ERROR and
 157 DATABASE are both non-nil an error is signaled, otherwise DISCONNECT
 158 returns nil. If the database is from a pool it will be released to
 159 this pool."
 160   (let ((database (find-database database :errorp (and database error))))
 161     (when database
 162       (if (conn-pool database)
 163           (when (release-to-pool database)
 164             (setf *connected-databases* (delete database *connected-databases*))
 165             (when (eq database *default-database*)
 166               (setf *default-database* (car *connected-databases*)))
 167             t)
 168           (when (database-disconnect database)
 169             (setf *connected-databases* (delete database *connected-databases*))
 170             (when (eq database *default-database*)
 171               (setf *default-database* (car *connected-databases*)))
 172             (setf (slot-value database 'state) :closed)
 173             t)))))
 174
 175
 176 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 177
 178
 179 (defmacro check-connection-spec (connection-spec database-type template)
 180   "Check the connection specification against the provided template,
 181 and signal an sql-user-error if they don't match. This function
 182 is called by database backends."
 183   `(handler-case
 184     (destructuring-bind ,template ,connection-spec
 185       (declare (ignore ,@(remove '&optional template)))
 186       t)
 187     (error ()
 188      (error 'sql-user-error
 189       :message
 190       (format nil
 191               "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
 192               ,connection-spec
 193               ,database-type
 194               (quote ,template))))))
 195
 196 (defun reconnect (&key (database *default-database*) (error nil) (force t))
 197   "Reconnects DATABASE to its underlying RDBMS. If successful, returns
 198 t and the variable *default-database* is set to the newly reconnected
 199 database. The default value for DATABASE is *default-database*. If
 200 DATABASE is a database object, then it is used directly. Otherwise,
 201 the list of connected databases is searched to find one with database
 202 as its connection specifications (see CONNECT). If no such database is
 203 found, then if ERROR and DATABASE are both non-nil an error is
 204 signaled, otherwise RECONNECT returns nil. FORCE controls whether an
 205 error should be signaled if the existing database connection cannot be
 206 closed. When non-nil (this is the default value) the connection is
 207 closed without error checking. When FORCE is nil, an error is signaled
 208 if the database connection has been lost."
 209   (let ((db (etypecase database
 210               (database database)
 211               ((or string list)
 212                (let ((db (find-database database :errorp nil)))
 213                  (when (null db)
 214                    (if (and database error)
 215                        (error 'clsql-generic-error
 216                               :message
 217                               (format nil "Unable to find database with connection-spec ~A." database))
 218                        (return-from reconnect nil)))
 219                  db)))))
 220
 221     (when (is-database-open db)
 222       (if force
 223           (ignore-errors (disconnect :database db))
 224           (disconnect :database db :error nil)))
 225
 226     (connect (connection-spec db))))
 227
 228
 229 (defun status (&optional full)
 230   "The function STATUS prints status information to the standard
 231 output, for the connected databases and initialized database types. If
 232 full is T, detailed status information is printed. The default value
 233 of full is NIL."
 234   (flet ((get-data ()
 235            (let ((data '()))
 236              (dolist (db (connected-databases) data)
 237                (push
 238                 (append
 239                  (list (if (equal db *default-database*) "*" "")
 240                        (database-name db)
 241                        (string-downcase (string (database-type db)))
 242                        (cond ((and (command-recording-stream db)
 243                                    (result-recording-stream db))
 244                               "Both")
 245                              ((command-recording-stream db) "Commands")
 246                              ((result-recording-stream db) "Results")
 247                              (t "nil")))
 248                  (when full
 249                    (list
 250                     (if (conn-pool db) "t" "nil")
 251                     (format nil "~A" (length (database-list-tables db)))
 252                     (format nil "~A" (length (database-list-views db))))))
 253                 data))))
 254          (compute-sizes (data)
 255            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
 256                    (apply #'mapcar (cons #'list data))))
 257          (print-separator (size)
 258            (format t "~&~A" (make-string size :initial-element #\-))))
 259     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
 260     (let ((data (get-data)))
 261       (when data
 262         (let* ((titles (if full
 263                            (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
 264                                  "TABLES" "VIEWS")
 265                            (list "" "DATABASE" "TYPE" "RECORDING")))
 266                (sizes (compute-sizes (cons titles data)))
 267                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
 268                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))
 269           (print-separator total-size)
 270           (format t control-string titles)
 271           (print-separator total-size)
 272           (dolist (d data) (format t control-string d))
 273           (print-separator total-size))))
 274     (values)))
 275
 276 (defun create-database (connection-spec &key database-type)
 277   (when (stringp connection-spec)
 278     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 279   (database-create connection-spec database-type))
 280
 281 (defun probe-database (connection-spec &key database-type)
 282   (when (stringp connection-spec)
 283     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 284   (database-probe connection-spec database-type))
 285
 286 (defun destroy-database (connection-spec &key database-type)
 287   (when (stringp connection-spec)
 288     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 289   (database-destroy connection-spec database-type))
 290
 291 (defun list-databases (connection-spec &key database-type)
 292   (when (stringp connection-spec)
 293     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 294   (database-list connection-spec database-type))
 295
 296 (defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
 297   "Evaluate the body in an environment, where `db-var' is bound to the
 298 database connection given by `connection-spec' and `connect-args'.
 299 The connection is automatically closed or released to the pool on exit from the body."
 300   (let ((result (gensym "result-")))
 301     (unless db-var (setf db-var '*default-database*))
 302     `(let ((,db-var (connect ,connection-spec ,@connect-args))
 303            (,result nil))
 304       (unwind-protect
 305            (let ((,db-var ,db-var))
 306              (setf ,result (progn ,@body)))
 307         (disconnect :database ,db-var))
 308       ,result)))
 309
 310
 311 (defmacro with-default-database ((database) &rest body)
 312   "Perform BODY with DATABASE bound as *default-database*."
 313   `(progv '(*default-database*)
 314        (list ,database)
 315      ,@body))
 316