base/database.lisp

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