+ "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)))))
+
+(defun clear-conn-pool (pool)
+ (with-process-lock ((conn-pool-lock pool) "Clear pool")
+ (mapc #'%pool-force-disconnect (all-connections pool))
+ (setf (all-connections pool) nil
+ (free-connections pool) nil))
+ nil)
+
+(defun find-or-create-connection-pool (connection-spec database-type)
+ "Find connection pool in hash table, creates a new connection pool
+if not found"
+ (with-process-lock (*db-pool-lock* "Find-or-create connection")
+ (let* ((key (list connection-spec database-type))
+ (conn-pool (gethash key *db-pool*)))
+ (unless conn-pool
+ (setq conn-pool (make-instance 'conn-pool
+ :connection-spec connection-spec
+ :pool-database-type database-type))
+ (setf (gethash key *db-pool*) conn-pool))
+ conn-pool)))