base/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-base-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 find-database (database &key (errorp t) (db-type nil))
  36   "The function FIND-DATABASE, given a string DATABASE, searches
  37 amongst the connected databases for one matching the name DATABASE. If
  38 there is exactly one such database, it is returned and the second
  39 return value count is 1. If more than one databases match and ERRORP
  40 is nil, then the most recently connected of the matching databases is
  41 returned and count is the number of matches. If no matching database
  42 is found and ERRORP is nil, then nil is returned. If none, or more
  43 than one, matching databases are found and ERRORP is true, then an
  44 error is signalled. If the argument database is a database, it is
  45 simply returned."
  46   (etypecase database
  47     (database
  48      (values database 1))
  49     (string
  50      (let* ((matches (remove-if
  51                       #'(lambda (db)
  52                           (not (and (string= (database-name db) database)
  53                                     (if db-type
  54                                         (equal (database-type db) db-type)
  55                                         t))))
  56                       (connected-databases)))
  57             (count (length matches)))
  58        (if (or (not errorp) (= count 1))
  59            (values (car matches) count)
  60            (cerror "Return nil."
  61                    'clsql-simple-error
  62                    :format-control "There exists ~A database called ~A."
  63                    :format-arguments
  64                    (list (if (zerop count) "no" "more than one")
  65                          database)))))))
  66
  67
  68 (defun connect (connection-spec
  69                 &key (if-exists *connect-if-exists*)
  70                 (make-default t)
  71                 (pool nil)
  72                 (database-type *default-database-type*))
  73   "Connects to a database of the given database-type, using the
  74 type-specific connection-spec.  The value of if-exists determines what
  75 happens if a connection to that database is already established.  A
  76 value of :new means create a new connection.  A value of :warn-new
  77 means warn the user and create a new connect.  A value of :warn-old
  78 means warn the user and use the old connection.  A value of :error
  79 means fail, notifying the user.  A value of :old means return the old
  80 connection.  If make-default is true, then *default-database* is set
  81 to the new connection, otherwise *default-database is not changed. If
  82 pool is t the connection will be taken from the general pool, if pool
  83 is a conn-pool object the connection will be taken from this pool."
  84
  85   (when (stringp connection-spec)
  86     (setq connection-spec (string-to-list-connection-spec connection-spec)))
  87
  88   (if pool
  89       (acquire-from-pool connection-spec database-type pool)
  90       (let* ((db-name (database-name-from-spec connection-spec database-type))
  91              (old-db (unless (eq if-exists :new)
  92                        (find-database db-name :db-type database-type
  93                                       :errorp nil)))
  94              (result nil))
  95         (if old-db
  96             (ecase if-exists
  97               (:warn-new
  98                (setq result
  99                      (database-connect connection-spec database-type))
 100                (warn 'clsql-exists-warning :old-db old-db :new-db result))
 101               (:error
 102                (restart-case
 103                    (error 'clsql-exists-error :old-db old-db)
 104                  (create-new ()
 105                    :report "Create a new connection."
 106                    (setq result
 107                          (database-connect connection-spec database-type)))
 108                  (use-old ()
 109                    :report "Use the existing connection."
 110                    (setq result old-db))))
 111               (:warn-old
 112                (setq result old-db)
 113                (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
 114               (:old
 115                (setq result old-db)))
 116             (setq result
 117                   (database-connect connection-spec database-type)))
 118         (when result
 119           (pushnew result *connected-databases*)
 120           (when make-default (setq *default-database* result))
 121           result))))
 122
 123
 124 (defun disconnect (&key (database *default-database*) (error nil))
 125
 126   "Closes the connection to DATABASE and resets *default-database* if
 127 that database was disconnected. If database is a database object, then
 128 it is used directly. Otherwise, the list of connected databases is
 129 searched to find one with DATABASE as its connection
 130 specifications. If no such database is found, then if ERROR and
 131 DATABASE are both non-nil an error is signaled, otherwise DISCONNECT
 132 returns nil. If the database is from a pool it will be released to
 133 this pool."
 134   (let ((database (find-database database :errorp (and database error))))
 135     (when database
 136       (if (conn-pool database)
 137           (when (release-to-pool database)
 138             (setf *connected-databases* (delete database *connected-databases*))
 139             (when (eq database *default-database*)
 140               (setf *default-database* (car *connected-databases*)))
 141             t)
 142           (when (database-disconnect database)
 143             (setf *connected-databases* (delete database *connected-databases*))
 144             (when (eq database *default-database*)
 145               (setf *default-database* (car *connected-databases*)))
 146             (change-class database 'closed-database)
 147             t)))))
 148
 149
 150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 151
 152
 153
 154
 155
 156 (defun reconnect (&key (database *default-database*) (error nil) (force t))
 157   "Reconnects DATABASE to its underlying RDBMS. If successful, returns
 158 t and the variable *default-database* is set to the newly reconnected
 159 database. The default value for DATABASE is *default-database*. If
 160 DATABASE is a database object, then it is used directly. Otherwise,
 161 the list of connected databases is searched to find one with database
 162 as its connection specifications (see CONNECT). If no such database is
 163 found, then if ERROR and DATABASE are both non-nil an error is
 164 signaled, otherwise RECONNECT returns nil. FORCE controls whether an
 165 error should be signaled if the existing database connection cannot be
 166 closed. When non-nil (this is the default value) the connection is
 167 closed without error checking. When FORCE is nil, an error is signaled
 168 if the database connection has been lost."
 169   ;; TODO: just a placeholder
 170   (declare (ignore database error force)))
 171
 172
 173
 174 (defun status (&optional full)
 175   "The function STATUS prints status information to the standard
 176 output, for the connected databases and initialized database types. If
 177 full is T, detailed status information is printed. The default value
 178 of full is NIL."
 179   (declare (ignore full))
 180   ;; TODO: table details if full is true?
 181   (flet ((get-data ()
 182            (let ((data '()))
 183              (dolist (db (connected-databases) data)
 184                (push (list (database-name db)
 185                            (string (database-type db))
 186                            (when (conn-pool db) "T" "NIL")
 187                            (format nil "~A" (length (database-list-tables db)))
 188                            (format nil "~A" (length (database-list-views db)))
 189                            (if (equal db *default-database*) "   *" ""))
 190                      data))))
 191          (compute-sizes (data)
 192            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
 193                    (apply #'mapcar (cons #'list data))))
 194          (print-separator (size)
 195            (format t "~&~A" (make-string size :initial-element #\-))))
 196     (let ((data (get-data)))
 197       (when data
 198         (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT"))
 199                (sizes (compute-sizes (cons titles data)))
 200                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
 201                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))
 202           (print-separator total-size)
 203           (format t control-string titles)
 204           (print-separator total-size)
 205           (dolist (d data) (format t control-string d))
 206           (print-separator total-size))))
 207     (values)))
 208
 209 (defun create-database (connection-spec &key database-type)
 210   (when (stringp connection-spec)
 211     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 212   (database-create connection-spec database-type))
 213
 214 (defun probe-database (connection-spec &key database-type)
 215   (when (stringp connection-spec)
 216     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 217   (database-probe connection-spec database-type))
 218
 219 (defun destroy-database (connection-spec &key database-type)
 220   (when (stringp connection-spec)
 221     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 222   (database-destroy connection-spec database-type))
 223
 224
 225 (defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
 226   "Evaluate the body in an environment, where `db-var' is bound to the
 227 database connection given by `connection-spec' and `connect-args'.
 228 The connection is automatically closed or released to the pool on exit from the body."
 229   (let ((result (gensym "result-")))
 230     (unless db-var (setf db-var '*default-database*))
 231     `(let ((,db-var (connect ,connection-spec ,@connect-args))
 232            (,result nil))
 233       (unwind-protect
 234            (let ((,db-var ,db-var))
 235              (setf ,result (progn ,@body)))
 236         (disconnect :database ,db-var))
 237       ,result)))
 238
 239
 240 (defmacro with-default-database ((database) &rest body)
 241   "Perform BODY with DATABASE bound as *default-database*."
 242   `(progv '(*default-database*)
 243        (list ,database)
 244      ,@body))
 245