-(defun acquire-from-conn-pool (pool)
- (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
- (and (plusp (length (free-connections pool)))
- (vector-pop (free-connections pool))))
- (let ((conn (connect (connection-spec pool)
- :database-type (database-type pool)
- :if-exists :new)))
- (with-process-lock ((conn-pool-lock pool) "Acquire from pool")
- (vector-push-extend conn (all-connections pool))
- (setf (conn-pool conn) pool))
- conn)))
-
-(defun release-to-conn-pool (conn)
- (let ((pool (conn-pool conn)))
- (with-process-lock ((conn-pool-lock pool) "Release to pool")
- (vector-push-extend conn (free-connections pool)))))
+
+(defun acquire-from-pool (connection-spec database-type &optional pool)
+ "Try to find a working database connection in the pool or create a new
+one if needed. This performs 1 query against the DB to ensure it's still
+valid. When possible (postgres, mssql) that query will be a reset
+command to put the connection back into its default state."
+ (unless (typep pool 'conn-pool)
+ (setf pool (find-or-create-connection-pool connection-spec database-type)))
+ (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)))
+ (with-process-lock ((conn-pool-lock pool) "new conection")
+ (push conn (all-connections pool))
+ (setf (conn-pool conn) pool))
+ conn)))
+
+(defun release-to-pool (database)
+ "Release a database connection to the pool. The backend will have a
+chance to do cleanup."
+ (let ((pool (conn-pool database)))
+ (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.
+ ((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)))))))
+
+(defmethod database-acquire-from-conn-pool (database)
+ (case (database-underlying-type database)
+ (:postgresql
+ (database-execute-command "RESET ALL" database))
+ (:mysql
+ (database-query "SHOW ERRORS LIMIT 1" database nil nil))
+ (:mssql
+ ;; rpc escape sequence since this can't be called as a normal sp.
+ ;;http://msdn.microsoft.com/en-us/library/aa198358%28SQL.80%29.aspx
+ (database-execute-command "{rpc sp_reset_connection}" database))
+ (T
+ (database-query "SELECT 1;" database '(integer) nil))))
+
+(defmethod database-release-to-conn-pool (database)
+ (case (database-underlying-type database)
+ (:postgresql
+ (ignore-errors
+ ;;http://www.postgresql.org/docs/current/static/sql-discard.html
+ ;;this was introduced relatively recently, wrap in ignore-errors
+ ;;so that it doesn't choke older versions.
+ (database-execute-command "DISCARD ALL" database)))))