- pconn e)
- (ignore-errors (database-disconnect :database pconn))
- nil)
- (:no-error (res fields)
- (declare (ignore res fields))
- pconn)))
- (t
- pconn)))))
- (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) "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)))))
+ 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)))))