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 ;;TODO: this variable appears to be global, not thread specific and is
  22 ;; not protected when modifying the list.
  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                 (encoding nil))
  77   "Connects to a database of the supplied DATABASE-TYPE which
  78 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
  79 connection specification CONNECTION-SPEC. The value of IF-EXISTS,
  80 which defaults to *CONNECT-IF-EXISTS*, determines what happens if
  81 a connection to the database specified by CONNECTION-SPEC is
  82 already established.  A value of :new means create a new
  83 connection.  A value of :warn-new means warn the user and create
  84 a new connect.  A value of :warn-old means warn the user and use
  85 the old connection.  A value of :error means fail, notifying the
  86 user.  A value of :old means return the old connection.
  87 MAKE-DEFAULT is t by default which means that *DEFAULT-DATABASE*
  88 is set to the new connection, otherwise *DEFAULT-DATABASE* is not
  89 changed. If POOL is t the connection will be taken from the
  90 general pool, if POOL is a CONN-POOL object the connection will
  91 be taken from this pool."
  92
  93   (unless database-type
  94     (error 'sql-database-error :message "Must specify a database-type."))
  95
  96   (when (stringp connection-spec)
  97     (setq connection-spec (string-to-list-connection-spec connection-spec)))
  98
  99   (unless (member database-type *loaded-database-types*)
 100     (asdf:operate 'asdf:load-op (ensure-keyword
 101                                  (concatenate 'string
 102                                               (symbol-name '#:clsql-)
 103                                               (symbol-name database-type)))
 104                   :verbose nil))
 105
 106   (if pool
 107       (let ((conn (acquire-from-pool connection-spec database-type pool encoding)))
 108         (when make-default (setq *default-database* conn))
 109         conn)
 110       (let* ((db-name (database-name-from-spec connection-spec database-type))
 111              (old-db (unless (eq if-exists :new)
 112                        (find-database db-name :db-type database-type
 113                                       :errorp nil)))
 114              (result nil))
 115         (if old-db
 116             (ecase if-exists
 117               (:warn-new
 118                (setq result
 119                      (database-connect connection-spec database-type))
 120                (warn 'sql-warning
 121                      :message
 122                      (format nil
 123                              "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
 124                              result (database-name result) old-db)))
 125               (:error
 126                (restart-case
 127                    (error 'sql-connection-error
 128                           :message
 129                           (format nil "There is an existing connection ~A to database ~A."
 130                           old-db
 131                           (database-name old-db)))
 132                  (create-new ()
 133                    :report "Create a new connection."
 134                    (setq result
 135                          (database-connect connection-spec database-type)))
 136                  (use-old ()
 137                    :report "Use the existing connection."
 138                    (setq result old-db))))
 139               (:warn-old
 140                (setq result old-db)
 141                (warn 'sql-warning
 142                      :message
 143                      (format nil
 144                              "Using existing connection ~A to database ~A."
 145                              old-db
 146                              (database-name old-db))))
 147               (:old
 148                (setq result old-db)))
 149             (setq result
 150                   (database-connect connection-spec database-type)))
 151         (when result
 152           (setf (slot-value result 'state) :open)
 153           (pushnew result *connected-databases*)
 154           (when make-default (setq *default-database* result))
 155           (setf (encoding result) encoding)
 156           result))))
 157
 158
 159 (defun disconnect (&key (database *default-database*) (error nil))
 160
 161   "Closes the connection to DATABASE and resets
 162 *DEFAULT-DATABASE* if that database was disconnected. If DATABASE
 163 is a database instance, this object is closed. If DATABASE is a
 164 string, then a connected database whose name matches DATABASE is
 165 sought in the list of connected databases. If no matching
 166 database is found and ERROR and DATABASE are both non-nil an
 167 error is signaled, otherwise nil is returned. If the database is
 168 from a pool it will be released to this pool."
 169   (let ((database (find-database database :errorp (and database error))))
 170     (when database
 171       (if (conn-pool database)
 172           (with-process-lock ((conn-pool-lock (conn-pool database)) "Delete from pool")
 173             (when (release-to-pool database)
 174               (setf *connected-databases* (delete database *connected-databases*))
 175               (when (eq database *default-database*)
 176                 (setf *default-database* (car *connected-databases*)))
 177               t))
 178           (when (database-disconnect database)
 179             ;;TODO: RACE COND: 2 threads disconnecting could stomp on *connected-databases*
 180             (setf *connected-databases* (delete database *connected-databases*))
 181             (when (eq database *default-database*)
 182               (setf *default-database* (car *connected-databases*)))
 183             (setf (slot-value database 'state) :closed)
 184             t)))))
 185
 186
 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188
 189
 190 (defmacro check-connection-spec (connection-spec database-type template)
 191   "Check the connection specification against the provided template,
 192 and signal an sql-user-error if they don't match. This function
 193 is called by database backends."
 194   `(handler-case
 195     (destructuring-bind ,template ,connection-spec
 196       (declare (ignore ,@(remove-if
 197                           (lambda (x) (member x '(&key &rest &optional)))
 198                           template)))
 199       t)
 200     (error ()
 201      (error 'sql-user-error
 202       :message
 203       (format nil
 204               "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
 205               ,connection-spec
 206               ,database-type
 207               (quote ,template))))))
 208
 209 (defun reconnect (&key (database *default-database*) (error nil) (force t))
 210   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to
 211 the underlying database management system. On success, t is
 212 returned and the variable *DEFAULT-DATABASE* is set to the newly
 213 reconnected database. If DATABASE is a database instance, this
 214 object is closed. If DATABASE is a string, then a connected
 215 database whose name matches DATABASE is sought in the list of
 216 connected databases. If no matching database is found and ERROR
 217 and DATABASE are both non-nil an error is signaled, otherwise nil
 218 is returned. When the current database connection cannot be
 219 closed, if FORCE is non-nil, as it is by default, the connection
 220 is closed and errors are suppressed. If force is nil and the
 221 database connection cannot be closed, an error is signalled."
 222   (let ((db (etypecase database
 223               (database database)
 224               ((or string list)
 225                (let ((db (find-database database :errorp nil)))
 226                  (when (null db)
 227                    (if (and database error)
 228                        (error 'sql-connection-error
 229                               :message
 230                               (format nil "Unable to find database with connection-spec ~A." database))
 231                        (return-from reconnect nil)))
 232                  db)))))
 233
 234     (when (is-database-open db)
 235       (if force
 236           (ignore-errors (disconnect :database db))
 237           (disconnect :database db :error nil)))
 238
 239     (connect (connection-spec db) :encoding (encoding db))))
 240
 241
 242 (defun status (&optional full)
 243   "Prints information about the currently connected databases to
 244 *STANDARD-OUTPUT*. The argument FULL is nil by default and a
 245 value of t means that more detailed information about each
 246 database is printed."
 247   (flet ((get-data ()
 248            (let ((data '()))
 249              (dolist (db (connected-databases) data)
 250                (push
 251                 (append
 252                  (list (if (equal db *default-database*) "*" "")
 253                        (database-name db)
 254                        (string-downcase (string (database-type db)))
 255                        (cond ((and (command-recording-stream db)
 256                                    (result-recording-stream db))
 257                               "Both")
 258                              ((command-recording-stream db) "Commands")
 259                              ((result-recording-stream db) "Results")
 260                              (t "nil")))
 261                  (when full
 262                    (list
 263                     (if (conn-pool db) "t" "nil")
 264                     (format nil "~A" (length (database-list-tables db)))
 265                     (format nil "~A" (length (database-list-views db))))))
 266                 data))))
 267          (compute-sizes (data)
 268            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
 269                    (apply #'mapcar (cons #'list data))))
 270          (print-separator (size)
 271            (format t "~&~A" (make-string size :initial-element #\-))))
 272     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
 273     (let ((data (get-data)))
 274       (when data
 275         (let* ((titles (if full
 276                            (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
 277                                  "TABLES" "VIEWS")
 278                            (list "" "DATABASE" "TYPE" "RECORDING")))
 279                (sizes (compute-sizes (cons titles data)))
 280                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
 281                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))
 282           (print-separator total-size)
 283           (format t control-string titles)
 284           (print-separator total-size)
 285           (dolist (d data) (format t control-string d))
 286           (print-separator total-size))))
 287     (values)))
 288
 289 (defun create-database (connection-spec &key (database-type *default-database-type*))
 290   "This function creates a database in the database system specified
 291 by DATABASE-TYPE."
 292   (when (stringp connection-spec)
 293     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 294   (database-create connection-spec database-type))
 295
 296 (defun probe-database (connection-spec &key (database-type *default-database-type*))
 297   "This function tests for the existence of a database in the database
 298 system specified by DATABASE-TYPE."
 299   (when (stringp connection-spec)
 300     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 301   (database-probe connection-spec database-type))
 302
 303 (defun destroy-database (connection-spec &key (database-type *default-database-type*))
 304   "This function destroys a database in the database system specified
 305 by DATABASE-TYPE."
 306   (when (stringp connection-spec)
 307     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 308   (database-destroy connection-spec database-type))
 309
 310 (defun list-databases (connection-spec &key (database-type *default-database-type*))
 311   "This function returns a list of databases existing in the database
 312 system specified by DATABASE-TYPE."
 313   (when (stringp connection-spec)
 314     (setq connection-spec (string-to-list-connection-spec connection-spec)))
 315   (database-list connection-spec database-type))
 316
 317 (defun encoding (db)
 318   (when (typep db 'database)
 319     (slot-value db 'encoding)))
 320
 321 (defun (setf encoding) (encoding db)
 322   (when (typep db 'database)
 323     (setf (slot-value db 'encoding) encoding)
 324     (when (eql (slot-value db 'state) :open)
 325       (case (database-type db)
 326         ;; FIXME: If database object is open then
 327         ;; send command to SQL engine specifying the character
 328         ;; encoding for the database
 329         (:mysql
 330          )
 331         ((:postgresql :postgresql-socket)
 332          )))))
 333
 334 (defmacro with-database ((db-var connection-spec
 335                                  &key make-default pool
 336                                  (if-exists *connect-if-exists*)
 337                                  (database-type *default-database-type*)
 338                                  (encoding nil))
 339                                  &body body)
 340   "Evaluate the body in an environment, where DB-VAR is bound to the
 341 database connection given by CONNECTION-SPEC and CONNECT-ARGS.  The
 342 connection is automatically closed or released to the pool on exit
 343 from the body. MAKE-DEFAULT has a default value of NIL."
 344   `(let ((,db-var (connect ,connection-spec
 345                            :database-type ,database-type
 346                            :if-exists ,if-exists
 347                            :pool ,pool
 348                            :make-default ,make-default
 349                            :encoding ,encoding)))
 350      (unwind-protect
 351       (let ((,db-var ,db-var))
 352         (progn ,@body))
 353        (disconnect :database ,db-var))))
 354
 355 (defmacro with-default-database ((database) &rest body)
 356   "Perform BODY with DATABASE bound as *default-database*."
 357   `(progv '(*default-database*)
 358        (list ,database)
 359      ,@body))