Suite of new tests for connection pool operations.

Also introduced dummy backend to aide running tests not about database backends.

diff --git a/clsql-tests.asd b/clsql-tests.asd
index 400e43d85221663d127c345a286272d3c6133783..f0280fc92510a84a1490f1c7fe38b7e3552da079 100644 (file)
--- 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 c3879b22ea71be587c2c315eed3d1fe1cc4d0dc2..1e299b949321ef412353e93ab91ed540090218c7 100644 (file)
--- a/doc/ref-connect.xml
+++ b/doc/ref-connect.xml
@@ -144,9 +144,10 @@
     </refsect1>
     <refsect1>
       <title>Description</title>
-      <para>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.</para>
+      <para>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.</para>
       <note>
         <para>This is not a hard limit, the number of connections in
         the pool may exceed this value.</para>

diff --git a/sql/pool.lisp b/sql/pool.lisp
index 820789f03eba1696f6c1d628fedd40c8e0ef348a..abe159b9988172caa3acd6a2f59dd8f24b753a4f 100644 (file)
--- 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 (file)
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)
+
+    ))