Version 4.0.6

[clsql.git] / sql / database.lisp

diff --git a/sql/database.lisp b/sql/database.lisp
index 3e8912deff3e59da943cc2b8645c041b414b4b44..f23eea2dbb5f5bf366d364f1d2655de692fd9540 100644 (file)
--- a/sql/database.lisp
+++ b/sql/database.lisp
@@ -61,18 +61,18 @@ error is signalled."
            (cerror "Return nil."
                    'sql-database-error
                    :message
            (cerror "Return nil."
                    'sql-database-error
                    :message

-                  (format nil "There exists ~A database called ~A."
-                          (if (zerop count) "no" "more than one")
-                          database)))))
+                   (format nil "There exists ~A database called ~A."
+                           (if (zerop count) "no" "more than one")
+                           database)))))

     (null
      (error "A database must be specified rather than NIL."))))
 
 
 (defun connect (connection-spec
     (null
      (error "A database must be specified rather than NIL."))))
 
 
 (defun connect (connection-spec

-               &key (if-exists *connect-if-exists*)
-               (make-default t)
+                &key (if-exists *connect-if-exists*)
+                (make-default t)

                 (pool nil)
                 (pool nil)

-               (database-type *default-database-type*))
+                (database-type *default-database-type*))

   "Connects to a database of the supplied DATABASE-TYPE which
 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
 connection specification CONNECTION-SPEC. The value of IF-EXISTS,
   "Connects to a database of the supplied DATABASE-TYPE which
 defaults to *DEFAULT-DATABASE-TYPE*, using the type-specific
 connection specification CONNECTION-SPEC. The value of IF-EXISTS,


@@ -97,9 +97,9 @@ be taken from this pool."
 
   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword
 
   (unless (member database-type *loaded-database-types*)
     (asdf:operate 'asdf:load-op (ensure-keyword

-                                (concatenate 'string
-                                             (symbol-name '#:clsql-)
-                                             (symbol-name database-type)))))
+                                 (concatenate 'string
+                                              (symbol-name '#:clsql-)
+                                              (symbol-name database-type)))))

 
   (if pool
       (let ((conn (acquire-from-pool connection-spec database-type pool)))
 
   (if pool
       (let ((conn (acquire-from-pool connection-spec database-type pool)))


@@ -116,17 +116,17 @@ be taken from this pool."
                (setq result
                      (database-connect connection-spec database-type))
                (warn 'sql-warning
                (setq result
                      (database-connect connection-spec database-type))
                (warn 'sql-warning

-                    :message
-                    (format nil
-                            "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
-                            result (database-name result) old-db)))
-             (:error
+                     :message
+                     (format nil
+                             "Created new connection ~A to database ~A~%, although there is an existing connection (~A)."
+                             result (database-name result) old-db)))
+              (:error

                (restart-case
                (restart-case

-                  (error 'sql-connection-error
-                         :message
-                         (format nil "There is an existing connection ~A to database ~A."
-                         old-db
-                         (database-name old-db)))
+                   (error 'sql-connection-error
+                          :message
+                          (format nil "There is an existing connection ~A to database ~A."
+                          old-db
+                          (database-name old-db)))

                  (create-new ()
                    :report "Create a new connection."
                    (setq result
                  (create-new ()
                    :report "Create a new connection."
                    (setq result


@@ -137,17 +137,17 @@ be taken from this pool."
               (:warn-old
                (setq result old-db)
                (warn 'sql-warning
               (:warn-old
                (setq result old-db)
                (warn 'sql-warning

-                    :message
-                    (format nil
-                            "Using existing connection ~A to database ~A."
-                            old-db
-                            (database-name old-db))))
+                     :message
+                     (format nil
+                             "Using existing connection ~A to database ~A."
+                             old-db
+                             (database-name old-db))))

               (:old
                (setq result old-db)))
             (setq result
                   (database-connect connection-spec database-type)))
         (when result
               (:old
                (setq result old-db)))
             (setq result
                   (database-connect connection-spec database-type)))
         (when result

-         (setf (slot-value result 'state) :open)
+          (setf (slot-value result 'state) :open)

           (pushnew result *connected-databases*)
           (when make-default (setq *default-database* result))
           result))))
           (pushnew result *connected-databases*)
           (when make-default (setq *default-database* result))
           result))))


@@ -166,11 +166,12 @@ 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)
   (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)
+          (with-process-lock ((conn-pool-lock (conn-pool database)) "Delete from pool")
+            (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*)
           (when (database-disconnect database)
             (setf *connected-databases* (delete database *connected-databases*))
             (when (eq database *default-database*)


@@ -194,10 +195,10 @@ is called by database backends."
      (error 'sql-user-error
       :message
       (format nil
      (error 'sql-user-error
       :message
       (format nil

-             "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
-             ,connection-spec
-             ,database-type
-             (quote ,template))))))
+              "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
+              ,connection-spec
+              ,database-type
+              (quote ,template))))))

 
 (defun reconnect (&key (database *default-database*) (error nil) (force t))
   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to
 
 (defun reconnect (&key (database *default-database*) (error nil) (force t))
   "Reconnects DATABASE which defaults to *DEFAULT-DATABASE* to


@@ -213,21 +214,21 @@ closed, if FORCE is non-nil, as it is by default, the connection
 is closed and errors are suppressed. If force is nil and the
 database connection cannot be closed, an error is signalled."
   (let ((db (etypecase database
 is closed and errors are suppressed. If force is nil and the
 database connection cannot be closed, an error is signalled."
   (let ((db (etypecase database

-             (database database)
-             ((or string list)
-              (let ((db (find-database database :errorp nil)))
-                (when (null db)
-                  (if (and database error)
-                      (error 'sql-connection-error
-                             :message
-                             (format nil "Unable to find database with connection-spec ~A." database))
-                      (return-from reconnect nil)))
-                db)))))
+              (database database)
+              ((or string list)
+               (let ((db (find-database database :errorp nil)))
+                 (when (null db)
+                   (if (and database 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
 
     (when (is-database-open db)
       (if force

-         (ignore-errors (disconnect :database db))
-         (disconnect :database db :error nil)))
+          (ignore-errors (disconnect :database db))
+          (disconnect :database db :error nil)))

 
     (connect (connection-spec db))))
 
 
     (connect (connection-spec db))))
 


@@ -240,24 +241,24 @@ database is printed."
   (flet ((get-data ()
            (let ((data '()))
              (dolist (db (connected-databases) data)
   (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)
+               (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)
            (mapcar #'(lambda (x) (apply #'max (mapcar #'length x)))
                    (apply #'mapcar (cons #'list data))))
          (print-separator (size)


@@ -266,9 +267,9 @@ database is printed."
     (let ((data (get-data)))
       (when data
         (let* ((titles (if full
     (let ((data (get-data)))
       (when data
         (let* ((titles (if full

-                          (list "" "DATABASE" "TYPE" "RECORDING" "POOLED"
-                                "TABLES" "VIEWS")
-                          (list "" "DATABASE" "TYPE" "RECORDING")))
+                           (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)))
                (sizes (compute-sizes (cons titles data)))
                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))


@@ -307,13 +308,20 @@ system specified by DATABASE-TYPE."
     (setq connection-spec (string-to-list-connection-spec connection-spec)))
   (database-list connection-spec database-type))
 
     (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)
+(defmacro with-database ((db-var connection-spec
+                                 &key make-default pool
+                                 (if-exists *connect-if-exists*)
+                                 (database-type *default-database-type*))
+                                 &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
   "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."
-  (unless db-var (setf db-var '*default-database*))
-  `(let ((,db-var (connect ,connection-spec ,@connect-args)))
+from the body. MAKE-DEFAULT has a default value of NIL."
+  `(let ((,db-var (connect ,connection-spec
+                           :database-type ,database-type
+                           :if-exists ,if-exists
+                           :pool ,pool
+                           :make-default ,make-default)))

      (unwind-protect
       (let ((,db-var ,db-var))
         (progn ,@body))
      (unwind-protect
       (let ((,db-var ,db-var))
         (progn ,@body))