X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fdatabase.lisp;h=faa384dd44a91013704b02dcdff4395ed5339bfb;hp=d59218176370e8c2ce1ac272242d4c4dffad9233;hb=9ba5ee2647740aca7777ac12a21db32837f3f2b6;hpb=4c89485f5cdb21a334de9c35adfded30db0c75e7 diff --git a/sql/database.lisp b/sql/database.lisp index d592181..faa384d 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -14,10 +14,6 @@ (in-package #:clsql-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 keyword argument in calls to @@ -52,7 +48,7 @@ error is signalled." (database (values database 1)) (string - (let* ((matches (remove-if + (let* ((matches (remove-if #'(lambda (db) (not (and (string= (database-name db) database) (if db-type @@ -67,7 +63,9 @@ error is signalled." :message (format nil "There exists ~A database called ~A." (if (zerop count) "no" "more than one") - database))))))) + database))))) + (null + (error "A database must be specified rather than NIL.")))) (defun connect (connection-spec @@ -93,18 +91,20 @@ be taken from this pool." (unless database-type (error 'sql-database-error :message "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 + (concatenate 'string (symbol-name '#:clsql-) (symbol-name database-type))))) (if pool - (acquire-from-pool connection-spec database-type pool) + (let ((conn (acquire-from-pool connection-spec database-type pool))) + (when make-default (setq *default-database* conn)) + conn) (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 @@ -124,9 +124,9 @@ be taken from this pool." (restart-case (error 'sql-connection-error :message - "There is an existing connection ~A to database ~A." + (format nil "There is an existing connection ~A to database ~A." old-db - (database-name old-db)) + (database-name old-db))) (create-new () :report "Create a new connection." (setq result @@ -187,13 +187,13 @@ from a pool it will be released to this pool." and signal an sql-user-error if they don't match. This function is called by database backends." `(handler-case - (destructuring-bind ,template ,connection-spec + (destructuring-bind ,template ,connection-spec (declare (ignore ,@(remove '&optional template))) t) - (error () + (error () (error 'sql-user-error :message - (format nil + (format nil "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" ,connection-spec ,database-type @@ -218,20 +218,20 @@ database connection cannot be closed, an error is signalled." (let ((db (find-database database :errorp nil))) (when (null db) (if (and database error) - (error 'clsql-generic-error + (error 'sql-connection-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) "Prints information about the currently connected databases to *STANDARD-OUTPUT*. The argument FULL is nil by default and a @@ -240,19 +240,19 @@ database is printed." (flet ((get-data () (let ((data '())) (dolist (db (connected-databases) data) - (push - (append - (list (if (equal db *default-database*) "*" "") + (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)) + (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 + (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)))))) @@ -265,8 +265,8 @@ database is printed." (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time))) (let ((data (get-data))) (when data - (let* ((titles (if full - (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" + (let* ((titles (if full + (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" "TABLES" "VIEWS") (list "" "DATABASE" "TYPE" "RECORDING"))) (sizes (compute-sizes (cons titles data))) @@ -280,29 +280,38 @@ database is printed." (values))) (defun create-database (connection-spec &key database-type) + "This function creates a database in the database system specified +by 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) + "This function tests for the existence of a database in the database +system specified by 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) + "This function destroys a database in the database system specified +by 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) + "This function returns a list of databases existing in the database +system specified by 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." + "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))