r11859: Canonicalize whitespace

[clsql.git] / sql / database.lisp

diff --git a/sql/database.lisp b/sql/database.lisp
index 706ccbf7cc1c323448a2c8732ddf8e4a2647d6a9..9b716444f0256b51c13c98a2a4ffd0a57588561a 100644 (file)
--- a/sql/database.lisp
+++ b/sql/database.lisp
@@ -48,7 +48,7 @@ error is signalled."
     (database
      (values database 1))
     (string
     (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
                       #'(lambda (db)
                           (not (and (string= (database-name db) database)
                                     (if db-type


@@ -61,16 +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
 
 
 (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,


@@ -89,18 +91,20 @@ be taken from this pool."
 
   (unless database-type
     (error 'sql-database-error :message "Must specify a database-type."))
 
   (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)))
   (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
   (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
 
   (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
       (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


@@ -112,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


@@ -133,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))))


@@ -183,17 +187,17 @@ 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
 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)
       (declare (ignore ,@(remove '&optional template)))
       t)

-    (error () 
+    (error ()

      (error 'sql-user-error
       :message
      (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))))))
+      (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))))))

 
 (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


@@ -209,25 +213,25 @@ 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))))
 

-  
+

 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a
 (defun status (&optional full)
   "Prints information about the currently connected databases to
 *STANDARD-OUTPUT*. The argument FULL is nil by default and a


@@ -236,24 +240,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)


@@ -261,10 +265,10 @@ database is printed."
     (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time)))
     (let ((data (get-data)))
       (when data
     (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")))
+        (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)))
                (sizes (compute-sizes (cons titles data)))
                (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles)))))
                (control-string (format nil "~~&~~{~{~~~AA  ~}~~}" sizes)))


@@ -303,21 +307,24 @@ 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."
-  (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)))
-
+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))
+       (disconnect :database ,db-var))))

 
 (defmacro with-default-database ((database) &rest body)
   "Perform BODY with DATABASE bound as *default-database*."
 
 (defmacro with-default-database ((database) &rest body)
   "Perform BODY with DATABASE bound as *default-database*."