"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,
- :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
- (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)))
- (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 pool) "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*)
(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
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)))))
- (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)
(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)))