From dbe4489008ed9048fcadb135e5a38a0f839afbc0 Mon Sep 17 00:00:00 2001 From: Ryan Davis Date: Mon, 27 Jun 2011 15:04:20 -0400 Subject: [PATCH] Suite of new tests for connection pool operations. Also introduced dummy backend to aide running tests not about database backends. --- clsql-tests.asd | 1 + doc/ref-connect.xml | 7 ++-- sql/pool.lisp | 50 +++++++++++++------------- tests/test-pool.lisp | 84 ++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 115 insertions(+), 27 deletions(-) create mode 100644 tests/test-pool.lisp diff --git a/clsql-tests.asd b/clsql-tests.asd index 400e43d..f0280fc 100644 --- a/clsql-tests.asd +++ b/clsql-tests.asd @@ -49,6 +49,7 @@ (:file "test-ooddl") (:file "test-oodml") (:file "test-syntax") + (:file "test-pool") ; #-uffi:no-i18n (:file "test-i18n") )))) diff --git a/doc/ref-connect.xml b/doc/ref-connect.xml index c3879b2..1e299b9 100644 --- a/doc/ref-connect.xml +++ b/doc/ref-connect.xml @@ -144,9 +144,10 @@ Description - Threshold of free-connections in the pool before we disconnect a - database rather than returning it to the pool. This is really a heuristic -that should, on avg keep the free connections about this size. + Threshold of free-connections in the pool before we + disconnect a database rather than returning it to the pool. NIL for + no limit. This is really a heuristic that should, on avg keep the + free connections about this size. This is not a hard limit, the number of connections in the pool may exceed this value. diff --git a/sql/pool.lisp b/sql/pool.lisp index 820789f..abe159b 100644 --- a/sql/pool.lisp +++ b/sql/pool.lisp @@ -17,9 +17,9 @@ (in-package #:clsql-sys) (defparameter *db-pool-max-free-connections* 4 - "Threshold of free-connections in the pool before we disconnect a - database rather than returning it to the pool. This is really a heuristic -that should, on avg keep the free connections about this size.") + "Threshold of free-connections in the pool before we disconnect a database + rather than returning it to the pool. NIL for no limit. This is really a + heuristic that should, on avg keep the free connections about this size.") (defvar *db-pool* (make-hash-table :test #'equal)) (defvar *db-pool-lock* (make-process-lock "DB Pool lock")) @@ -33,6 +33,8 @@ that should, on avg keep the free connections about this size.") :initform (make-process-lock "Connection pool")))) + + (defun acquire-from-pool (connection-spec database-type &optional pool encoding) "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 @@ -75,29 +77,29 @@ Disconnecting.~%" (setf (conn-pool conn) pool)) conn))) -(defun release-to-pool (database) +(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." - (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))))))) + (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)))))) (defmethod database-acquire-from-conn-pool (database) (case (database-underlying-type database) diff --git a/tests/test-pool.lisp b/tests/test-pool.lisp new file mode 100644 index 0000000..ececcd6 --- /dev/null +++ b/tests/test-pool.lisp @@ -0,0 +1,84 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: test-pool.lisp +;;;; Purpose: Tests for connection pools +;;;; Author: Ryan Davis +;;;; Created: June 27 2011 +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2004-2010 by Kevin M. Rosenberg +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* +(in-package #:clsql-tests) + +;; setup a dummy database for the pool to use +(pushnew :dummy clsql-sys:*loaded-database-types*) +(defclass dummy-database (clsql-sys:database) () + (:default-initargs :database-type :dummy)) +(defmethod clsql-sys:database-connect (connection-spec (database-type (eql :dummy))) + (let ((db (make-instance 'dummy-database :connection-spec connection-spec))) + (setf (slot-value db 'clsql-sys::state) :open) + db)) +(defmethod clsql-sys::database-name-from-spec (connection-spec (database-type (eql :dummy))) + "dummy") +(defmethod clsql-sys::database-acquire-from-conn-pool ((db dummy-database)) T) + +(setq *rt-pool* + '( + (deftest :pool/acquire + (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy)) + dbx res) + (clsql-sys::clear-conn-pool pool) + (flet ((test-result (x) (push x res))) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + + (clsql-sys:with-database (db nil :database-type :dummy :pool T) + (test-result (not (null db))) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + (setf dbx db)) + (test-result (length (clsql-sys::all-connections pool))) + (test-result (length (clsql-sys::free-connections pool))) + (clsql-sys:with-database (db nil :database-type :dummy :pool T) + (test-result (eq db dbx))) + ) + (nreverse res)) + (0 0 T 1 0 1 1 T) + ) + + (deftest :pool/max-free-connections + (let ((pool (clsql-sys::find-or-create-connection-pool nil :dummy))) + (flet ((run (max-free dbs-to-release) + (let ((clsql-sys:*db-pool-max-free-connections* max-free) + dbs) + (clsql-sys::clear-conn-pool pool) + (dotimes (i dbs-to-release dbs) + (push (clsql-sys:connect nil :database-type :dummy + :pool T :if-exists :new) + dbs)) + (list (length (clsql-sys::all-connections pool)) + (progn + (dolist (db dbs) (clsql-sys:disconnect :database db)) + (length (clsql-sys::free-connections pool)) + ))))) + (append + (run 5 10) + (run nil 10)))) + (10 5 10 10) + ) + + + + (deftest :pool/find-or-create-connection-pool + (let ((p (clsql-sys::find-or-create-connection-pool nil :dummy))) + (values (null p) + (eq p (clsql-sys::find-or-create-connection-pool nil :dummy)) + (eq p (clsql-sys::find-or-create-connection-pool :spec :dummy)))) + nil T nil) + + )) -- 2.34.1