X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=base%2Fdatabase.lisp;fp=base%2Fdatabase.lisp;h=839204f3c57de01fde008441a32a6b1d858cf2f3;hb=ce0e343835a040406678dff74a62d1b0cb56f317;hp=0000000000000000000000000000000000000000;hpb=edd1963395a5b5e5f91ef975fcd329975ae367e2;p=clsql.git diff --git a/base/database.lisp b/base/database.lisp new file mode 100644 index 0000000..839204f --- /dev/null +++ b/base/database.lisp @@ -0,0 +1,217 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: $ + +(in-package #:clsql-base-sys) + +(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.") + +;;; usql +(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." + (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 + (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*))) + (change-class database 'closed-database) + 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." + ;; TODO: just a placeholder + (declare (ignore database error force))) + + + +(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." + (declare (ignore full)) + ;; TODO: table details if full is true? + (flet ((get-data () + (let ((data '())) + (dolist (db (connected-databases) data) + (push (list (database-name db) + (string (database-type db)) + (when (conn-pool db) "T" "NIL") + (format nil "~A" (length (database-list-tables db))) + (format nil "~A" (length (database-list-views db))) + (if (equal db *default-database*) " *" "")) + 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 #\-)))) + (let ((data (get-data))) + (when data + (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT")) + (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))) + + +(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))