1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; Base database functions
6 ;;;; This file is part of CLSQL.
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 ;;;; *************************************************************************
13 (in-package #:clsql-sys)
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
21 (defvar *connected-databases* nil
22 "List of active database objects.")
24 (defun connected-databases ()
25 "Returns the list of active database objects."
26 *connected-databases*)
28 (defvar *default-database* nil
29 "Specifies the default database to be used.")
31 (defun is-database-open (database)
32 (eql (database-state database) :open))
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
49 (let* ((matches (remove-if
51 (not (and (string= (database-name db) database)
53 (equal (database-type db) db-type)
55 (connected-databases)))
56 (count (length matches)))
57 (if (or (not errorp) (= count 1))
58 (values (car matches) count)
62 (format nil "There exists ~A database called ~A."
63 (if (zerop count) "no" "more than one")
66 (error "A database must be specified rather than NIL."))))
69 (defun connect (connection-spec
70 &key (if-exists *connect-if-exists*)
73 (database-type *default-database-type*)
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."
92 (error 'sql-database-error :message "Must specify a database-type."))
94 (when (stringp connection-spec)
95 (setq connection-spec (string-to-list-connection-spec connection-spec)))
97 (unless (member database-type *loaded-database-types*)
98 (asdf:operate 'asdf:load-op (ensure-keyword
100 (symbol-name '#:clsql-)
101 (symbol-name database-type)))
105 (let ((conn (acquire-from-pool connection-spec database-type pool)))
106 (when make-default (setq *default-database* 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
117 (database-connect connection-spec database-type))
121 "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
122 result (database-name result) old-db)))
125 (error 'sql-connection-error
127 (format nil "There is an existing connection ~A to database ~A."
129 (database-name old-db)))
131 :report "Create a new connection."
133 (database-connect connection-spec database-type)))
135 :report "Use the existing connection."
136 (setq result old-db))))
142 "Using existing connection ~A to database ~A."
144 (database-name old-db))))
146 (setq result old-db)))
148 (database-connect connection-spec database-type)))
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)
157 (defun disconnect (&key (database *default-database*) (error nil))
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))))
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*)))
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)
184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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."
192 (destructuring-bind ,template ,connection-spec
193 (declare (ignore ,@(remove '&optional template)))
196 (error 'sql-user-error
199 "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
202 (quote ,template))))))
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
220 (let ((db (find-database database :errorp nil)))
222 (if (and database error)
223 (error 'sql-connection-error
225 (format nil "Unable to find database with connection-spec ~A." database))
226 (return-from reconnect nil)))
229 (when (is-database-open db)
231 (ignore-errors (disconnect :database db))
232 (disconnect :database db :error nil)))
234 (connect (connection-spec db))))
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."
244 (dolist (db (connected-databases) data)
247 (list (if (equal db *default-database*) "*" "")
249 (string-downcase (string (database-type db)))
250 (cond ((and (command-recording-stream db)
251 (result-recording-stream db))
253 ((command-recording-stream db) "Commands")
254 ((result-recording-stream db) "Results")
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))))))
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)))
270 (let* ((titles (if full
271 (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
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))))
284 (defun create-database (connection-spec &key (database-type *default-database-type*))
285 "This function creates a database in the database system specified
287 (when (stringp connection-spec)
288 (setq connection-spec (string-to-list-connection-spec connection-spec)))
289 (database-create connection-spec database-type))
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))
298 (defun destroy-database (connection-spec &key (database-type *default-database-type*))
299 "This function destroys a database in the database system specified
301 (when (stringp connection-spec)
302 (setq connection-spec (string-to-list-connection-spec connection-spec)))
303 (database-destroy connection-spec database-type))
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))
313 (when (typep db 'database)
314 (slot-value db 'encoding)))
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 db)
321 ;; FIXME: If database object is open then
322 ;; send command to SQL engine specifying the character
323 ;; encoding for the database
326 ((:postgresql :postgresql-socket)
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*)
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
343 :make-default ,make-default
344 :encoding ,encoding)))
346 (let ((,db-var ,db-var))
348 (disconnect :database ,db-var))))
350 (defmacro with-default-database ((database) &rest body)
351 "Perform BODY with DATABASE bound as *default-database*."
352 `(progv '(*default-database*)