1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; Base database functions
8 ;;;; This file is part of CLSQL.
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 ;;;; *************************************************************************
15 (in-package #:clsql-base-sys)
17 (setf (documentation 'database-name 'function)
18 "Returns the name of a database.")
22 (defvar *connect-if-exists* :error
23 "Default value for the if-exists parameter of connect calls.")
25 (defvar *connected-databases* nil
26 "List of active database objects.")
28 (defun connected-databases ()
29 "Return the list of active database objects."
30 *connected-databases*)
32 (defvar *default-database* nil
33 "Specifies the default database to be used.")
35 (defun is-database-open (database)
36 (eql (database-state database) :open))
38 (defun find-database (database &key (errorp t) (db-type nil))
39 "The function FIND-DATABASE, given a string DATABASE, searches
40 amongst the connected databases for one matching the name DATABASE. If
41 there is exactly one such database, it is returned and the second
42 return value count is 1. If more than one databases match and ERRORP
43 is nil, then the most recently connected of the matching databases is
44 returned and count is the number of matches. If no matching database
45 is found and ERRORP is nil, then nil is returned. If none, or more
46 than one, matching databases are found and ERRORP is true, then an
47 error is signalled. If the argument database is a database, it is
53 (let* ((matches (remove-if
55 (not (and (string= (database-name db) database)
57 (equal (database-type db) db-type)
59 (connected-databases)))
60 (count (length matches)))
61 (if (or (not errorp) (= count 1))
62 (values (car matches) count)
65 :format-control "There exists ~A database called ~A."
67 (list (if (zerop count) "no" "more than one")
71 (defun connect (connection-spec
72 &key (if-exists *connect-if-exists*)
75 (database-type *default-database-type*))
76 "Connects to a database of the given database-type, using the
77 type-specific connection-spec. The value of if-exists determines what
78 happens if a connection to that database is already established. A
79 value of :new means create a new connection. A value of :warn-new
80 means warn the user and create a new connect. A value of :warn-old
81 means warn the user and use the old connection. A value of :error
82 means fail, notifying the user. A value of :old means return the old
83 connection. If make-default is true, then *default-database* is set
84 to the new connection, otherwise *default-database is not changed. If
85 pool is t the connection will be taken from the general pool, if pool
86 is a conn-pool object the connection will be taken from this pool."
88 (when (stringp connection-spec)
89 (setq connection-spec (string-to-list-connection-spec connection-spec)))
91 (unless (member database-type *loaded-database-types*)
92 (asdf:operate 'asdf:load-op (ensure-keyword
94 (symbol-name '#:clsql-)
95 (symbol-name database-type)))))
98 (acquire-from-pool connection-spec database-type pool)
99 (let* ((db-name (database-name-from-spec connection-spec database-type))
100 (old-db (unless (eq if-exists :new)
101 (find-database db-name :db-type database-type
108 (database-connect connection-spec database-type))
109 (warn 'clsql-exists-warning :old-db old-db :new-db result))
112 (error 'clsql-exists-error :old-db old-db)
114 :report "Create a new connection."
116 (database-connect connection-spec database-type)))
118 :report "Use the existing connection."
119 (setq result old-db))))
122 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
124 (setq result old-db)))
126 (database-connect connection-spec database-type)))
128 (setf (slot-value result 'state) :open)
129 (pushnew result *connected-databases*)
130 (when make-default (setq *default-database* result))
134 (defun disconnect (&key (database *default-database*) (error nil))
136 "Closes the connection to DATABASE and resets *default-database* if
137 that database was disconnected. If database is a database object, then
138 it is used directly. Otherwise, the list of connected databases is
139 searched to find one with DATABASE as its connection
140 specifications. If no such database is found, then if ERROR and
141 DATABASE are both non-nil an error is signaled, otherwise DISCONNECT
142 returns nil. If the database is from a pool it will be released to
144 (let ((database (find-database database :errorp (and database error))))
146 (if (conn-pool database)
147 (when (release-to-pool database)
148 (setf *connected-databases* (delete database *connected-databases*))
149 (when (eq database *default-database*)
150 (setf *default-database* (car *connected-databases*)))
152 (when (database-disconnect database)
153 (setf *connected-databases* (delete database *connected-databases*))
154 (when (eq database *default-database*)
155 (setf *default-database* (car *connected-databases*)))
156 (setf (slot-value database 'state) :closed)
160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
166 (defun reconnect (&key (database *default-database*) (error nil) (force t))
167 "Reconnects DATABASE to its underlying RDBMS. If successful, returns
168 t and the variable *default-database* is set to the newly reconnected
169 database. The default value for DATABASE is *default-database*. If
170 DATABASE is a database object, then it is used directly. Otherwise,
171 the list of connected databases is searched to find one with database
172 as its connection specifications (see CONNECT). If no such database is
173 found, then if ERROR and DATABASE are both non-nil an error is
174 signaled, otherwise RECONNECT returns nil. FORCE controls whether an
175 error should be signaled if the existing database connection cannot be
176 closed. When non-nil (this is the default value) the connection is
177 closed without error checking. When FORCE is nil, an error is signaled
178 if the database connection has been lost."
179 ;; TODO: Support all backends. Perhaps integrate with pools
180 ;; Handle error and force keywords
181 (declare (ignore database error force)))
184 (defun status (&optional full)
185 "The function STATUS prints status information to the standard
186 output, for the connected databases and initialized database types. If
187 full is T, detailed status information is printed. The default value
189 (declare (ignore full))
190 ;; TODO: table details if full is true?
193 (dolist (db (connected-databases) data)
194 (push (list (database-name db)
195 (string (database-type db))
196 (when (conn-pool db) "T" "NIL")
197 (format nil "~A" (length (database-list-tables db)))
198 (format nil "~A" (length (database-list-views db)))
199 (if (equal db *default-database*) " *" ""))
201 (compute-sizes (data)
202 (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
203 (apply #'mapcar (cons #'list data))))
204 (print-separator (size)
205 (format t "~&~A" (make-string size :initial-element #\-))))
206 (let ((data (get-data)))
208 (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT"))
209 (sizes (compute-sizes (cons titles data)))
210 (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
211 (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes)))
212 (print-separator total-size)
213 (format t control-string titles)
214 (print-separator total-size)
215 (dolist (d data) (format t control-string d))
216 (print-separator total-size))))
219 (defun create-database (connection-spec &key database-type)
220 (when (stringp connection-spec)
221 (setq connection-spec (string-to-list-connection-spec connection-spec)))
222 (database-create connection-spec database-type))
224 (defun probe-database (connection-spec &key database-type)
225 (when (stringp connection-spec)
226 (setq connection-spec (string-to-list-connection-spec connection-spec)))
227 (database-probe connection-spec database-type))
229 (defun destroy-database (connection-spec &key database-type)
230 (when (stringp connection-spec)
231 (setq connection-spec (string-to-list-connection-spec connection-spec)))
232 (database-destroy connection-spec database-type))
235 (defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
236 "Evaluate the body in an environment, where `db-var' is bound to the
237 database connection given by `connection-spec' and `connect-args'.
238 The connection is automatically closed or released to the pool on exit from the body."
239 (let ((result (gensym "result-")))
240 (unless db-var (setf db-var '*default-database*))
241 `(let ((,db-var (connect ,connection-spec ,@connect-args))
244 (let ((,db-var ,db-var))
245 (setf ,result (progn ,@body)))
246 (disconnect :database ,db-var))
250 (defmacro with-default-database ((database) &rest body)
251 "Perform BODY with DATABASE bound as *default-database*."
252 `(progv '(*default-database*)