+ (or
+ (loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire")
+ (pop (free-connections pool)))
+ always pconn
+ thereis
+ ;; test if connection still valid.
+ ;; (e.g. db reboot -> invalid connection )
+ (handler-case
+ (progn (database-acquire-from-conn-pool pconn)
+ pconn)
+ (sql-database-error (e)
+ ;; we could check for a specific error,
+ ;; but, it's safer just to disconnect the pooled conn for any error ?
+ (warn "Database connection ~S had an error while acquiring from the pool:
+ ~S
+Disconnecting.~%"
+ pconn e)
+ ;;run database disconnect to give chance for cleanup
+ ;;there, then remove it from the lists of connected
+ ;;databases.
+ (%pool-force-disconnect pconn)
+ (with-process-lock ((conn-pool-lock pool) "remove dead conn")
+ (setf (all-connections pool)
+ (delete pconn (all-connections pool))))
+ nil)))
+ (let ((conn (connect (connection-spec pool)
+ :database-type (pool-database-type pool)
+ :if-exists :new
+ :make-default nil
+ :encoding encoding)))
+ (setf (conn-pool conn) pool)
+ (with-process-lock ((conn-pool-lock pool) "new conection")
+ (push conn (all-connections pool)))
+ conn)))
+
+(defun release-to-pool (database &optional (pool (conn-pool database)))
+ "Release a database connection to the pool. The backend will have a
+chance to do cleanup."
+ (unless (conn-pool database) (setf (conn-pool database) pool))
+ (cond
+ ;;We read the list of free-connections outside the lock. This
+ ;;should be fine as long as that list is never dealt with
+ ;;destructively (push and pop destructively modify the place,
+ ;;not the list). Multiple threads getting to this test at the
+ ;;same time might result in the free-connections getting
+ ;;longer... meh.
+ ((or (and *db-pool-max-free-connections*
+ (>= (length (free-connections pool))
+ *db-pool-max-free-connections*)))
+ (%pool-force-disconnect database)
+
+ (with-process-lock ((conn-pool-lock pool) "Remove extra Conn")
+ (setf (all-connections pool)
+ (delete database (all-connections pool)))))
+ (t
+ ;;let it do cleanup
+ (database-release-to-conn-pool database)
+ (with-process-lock ((conn-pool-lock pool) "Release to pool")
+ (push database (free-connections pool))))))