sql/database.lisp

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