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