+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;;
-;;;; $Id$
-;;;;
-;;;; Base database functions
-;;;;
-;;;; This file is part of CLSQL.
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package #:clsql-base)
-
-(setf (documentation 'database-name 'function)
- "Returns the name of a database.")
-
-;;; Database handling
-
-(defvar *connect-if-exists* :error
- "Default value for the if-exists parameter of connect calls.")
-
-(defvar *connected-databases* nil
- "List of active database objects.")
-
-(defun connected-databases ()
- "Return the list of active database objects."
- *connected-databases*)
-
-(defvar *default-database* nil
- "Specifies the default database to be used.")
-
-(defun is-database-open (database)
- (eql (database-state database) :open))
-
-(defun find-database (database &key (errorp t) (db-type nil))
- "The function FIND-DATABASE, given a string DATABASE, searches
-amongst the connected databases for one matching the name DATABASE. If
-there is exactly one such database, it is returned and the second
-return value count is 1. If more than one databases match and ERRORP
-is nil, then the most recently connected of the matching databases is
-returned and count is the number of matches. If no matching database
-is found and ERRORP is nil, then nil is returned. If none, or more
-than one, matching databases are found and ERRORP is true, then an
-error is signalled. If the argument database is a database, it is
-simply returned."
- (etypecase database
- (database
- (values database 1))
- (string
- (let* ((matches (remove-if
- #'(lambda (db)
- (not (and (string= (database-name db) database)
- (if db-type
- (equal (database-type db) db-type)
- t))))
- (connected-databases)))
- (count (length matches)))
- (if (or (not errorp) (= count 1))
- (values (car matches) count)
- (cerror "Return nil."
- 'clsql-simple-error
- :format-control "There exists ~A database called ~A."
- :format-arguments
- (list (if (zerop count) "no" "more than one")
- database)))))))
-
-
-(defun connect (connection-spec
- &key (if-exists *connect-if-exists*)
- (make-default t)
- (pool nil)
- (database-type *default-database-type*))
- "Connects to a database of the given database-type, using the
-type-specific connection-spec. The value of if-exists determines what
-happens if a connection to that database is already established. A
-value of :new means create a new connection. A value of :warn-new
-means warn the user and create a new connect. A value of :warn-old
-means warn the user and use the old connection. A value of :error
-means fail, notifying the user. A value of :old means return the old
-connection. If make-default is true, then *default-database* is set
-to the new connection, otherwise *default-database is not changed. If
-pool is t the connection will be taken from the general pool, if pool
-is a conn-pool object the connection will be taken from this pool."
-
- (unless database-type
- (error "Must specify a database-type."))
-
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
-
- (unless (member database-type *loaded-database-types*)
- (asdf:operate 'asdf:load-op (ensure-keyword
- (concatenate 'string
- (symbol-name '#:clsql-)
- (symbol-name database-type)))))
-
- (if pool
- (acquire-from-pool connection-spec database-type pool)
- (let* ((db-name (database-name-from-spec connection-spec database-type))
- (old-db (unless (eq if-exists :new)
- (find-database db-name :db-type database-type
- :errorp nil)))
- (result nil))
- (if old-db
- (ecase if-exists
- (:warn-new
- (setq result
- (database-connect connection-spec database-type))
- (warn 'clsql-exists-warning :old-db old-db :new-db result))
- (:error
- (restart-case
- (error 'clsql-exists-error :old-db old-db)
- (create-new ()
- :report "Create a new connection."
- (setq result
- (database-connect connection-spec database-type)))
- (use-old ()
- :report "Use the existing connection."
- (setq result old-db))))
- (:warn-old
- (setq result old-db)
- (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
- (:old
- (setq result old-db)))
- (setq result
- (database-connect connection-spec database-type)))
- (when result
- (setf (slot-value result 'state) :open)
- (pushnew result *connected-databases*)
- (when make-default (setq *default-database* result))
- result))))
-
-
-(defun disconnect (&key (database *default-database*) (error nil))
-
- "Closes the connection to DATABASE and resets *default-database* if
-that database was disconnected. If database is a database object, then
-it is used directly. Otherwise, the list of connected databases is
-searched to find one with DATABASE as its connection
-specifications. If no such database is found, then if ERROR and
-DATABASE are both non-nil an error is signaled, otherwise DISCONNECT
-returns nil. If the database is from a pool it will be released to
-this pool."
- (let ((database (find-database database :errorp (and database error))))
- (when database
- (if (conn-pool database)
- (when (release-to-pool database)
- (setf *connected-databases* (delete database *connected-databases*))
- (when (eq database *default-database*)
- (setf *default-database* (car *connected-databases*)))
- t)
- (when (database-disconnect database)
- (setf *connected-databases* (delete database *connected-databases*))
- (when (eq database *default-database*)
- (setf *default-database* (car *connected-databases*)))
- (setf (slot-value database 'state) :closed)
- t)))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-
-
-(defun reconnect (&key (database *default-database*) (error nil) (force t))
- "Reconnects DATABASE to its underlying RDBMS. If successful, returns
-t and the variable *default-database* is set to the newly reconnected
-database. The default value for DATABASE is *default-database*. If
-DATABASE is a database object, then it is used directly. Otherwise,
-the list of connected databases is searched to find one with database
-as its connection specifications (see CONNECT). If no such database is
-found, then if ERROR and DATABASE are both non-nil an error is
-signaled, otherwise RECONNECT returns nil. FORCE controls whether an
-error should be signaled if the existing database connection cannot be
-closed. When non-nil (this is the default value) the connection is
-closed without error checking. When FORCE is nil, an error is signaled
-if the database connection has been lost."
- (let ((db (etypecase database
- (database database)
- ((or string list)
- (let ((db (find-database database :errorp nil)))
- (when (null db)
- (if (and database error)
- (error 'clsql-generic-error
- :message
- (format nil "Unable to find database with connection-spec ~A." database))
- (return-from reconnect nil)))
- db)))))
-
- (when (is-database-open db)
- (if force
- (ignore-errors (disconnect :database db))
- (disconnect :database db :error nil)))
-
- (connect (connection-spec db))))
-
-
-(defun status (&optional full)
- "The function STATUS prints status information to the standard
-output, for the connected databases and initialized database types. If
-full is T, detailed status information is printed. The default value
-of full is NIL."
- (flet ((get-data ()
- (let ((data '()))
- (dolist (db (connected-databases) data)
- (push
- (append
- (list (if (equal db *default-database*) "*" "")
- (database-name db)
- (string-downcase (string (database-type db)))
- (cond ((and (command-recording-stream db)
- (result-recording-stream db))
- "Both")
- ((command-recording-stream db) "Commands")
- ((result-recording-stream db) "Results")
- (t "nil")))
- (when full
- (list
- (if (conn-pool db) "t" "nil")
- (format nil "~A" (length (database-list-tables db)))
- (format nil "~A" (length (database-list-views db))))))
- data))))
- (compute-sizes (data)
- (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
- (apply #'mapcar (cons #'list data))))
- (print-separator (size)
- (format t "~&~A" (make-string size :initial-element #\-))))
- (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
- (let ((data (get-data)))
- (when data
- (let* ((titles (if full
- (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
- "TABLES" "VIEWS")
- (list "" "DATABASE" "TYPE" "RECORDING")))
- (sizes (compute-sizes (cons titles data)))
- (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
- (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes)))
- (print-separator total-size)
- (format t control-string titles)
- (print-separator total-size)
- (dolist (d data) (format t control-string d))
- (print-separator total-size))))
- (values)))
-
-(defun create-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-create connection-spec database-type))
-
-(defun probe-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-probe connection-spec database-type))
-
-(defun destroy-database (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-destroy connection-spec database-type))
-
-(defun list-databases (connection-spec &key database-type)
- (when (stringp connection-spec)
- (setq connection-spec (string-to-list-connection-spec connection-spec)))
- (database-list connection-spec database-type))
-
-(defmacro with-database ((db-var connection-spec &rest connect-args) &body body)
- "Evaluate the body in an environment, where `db-var' is bound to the
-database connection given by `connection-spec' and `connect-args'.
-The connection is automatically closed or released to the pool on exit from the body."
- (let ((result (gensym "result-")))
- (unless db-var (setf db-var '*default-database*))
- `(let ((,db-var (connect ,connection-spec ,@connect-args))
- (,result nil))
- (unwind-protect
- (let ((,db-var ,db-var))
- (setf ,result (progn ,@body)))
- (disconnect :database ,db-var))
- ,result)))
-
-
-(defmacro with-default-database ((database) &rest body)
- "Perform BODY with DATABASE bound as *default-database*."
- `(progv '(*default-database*)
- (list ,database)
- ,@body))
-
projects / clsql.git / blobdiff