X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fpool.lisp;h=a153c916707aba2a31ff2b7b0ceabc5f248a6939;hp=66cbaf76125d10b2a0ee600ae8044148635d3a44;hb=326e9dc298298431a7122ed57d14a60bccd95923;hpb=06f8ade4128c181776b8018fc73b0b9e1f383a25

diff --git a/sql/pool.lisp b/sql/pool.lisp
index 66cbaf7..a153c91 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,7 +33,9 @@ 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)
+
+
+(defun acquire-from-pool (connection-spec database-type &optional pool (encoding *default-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
 valid. When possible (postgres, mssql) that query will be a reset
@@ -68,35 +70,37 @@ Disconnecting.~%"
    (let ((conn (connect (connection-spec pool)
 			:database-type (pool-database-type pool)
 			:if-exists :new
-			:make-default nil)))
+			:make-default nil
+                        :encoding encoding)))
+     (setf (conn-pool conn) pool)
      (with-process-lock ((conn-pool-lock pool) "new conection")
-       (push conn (all-connections pool))
-       (setf (conn-pool conn) pool))
+       (push conn (all-connections 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)
@@ -121,6 +125,8 @@ chance to do cleanup."
 	 (database-execute-command "DISCARD ALL" database)))))
 
 (defun clear-conn-pool (pool)
+  "Be careful this function will disconnect connections without regard
+to whether another thread is actively using them."
   (with-process-lock ((conn-pool-lock pool) "Clear pool")
     (mapc #'%pool-force-disconnect (all-connections pool))
     (setf (all-connections pool) nil
@@ -130,15 +136,13 @@ chance to do cleanup."
 (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)))
+  (let ((key (list connection-spec database-type)))
+    (with-process-lock (*db-pool-lock* "Find-or-create connection")
+      (or (gethash key *db-pool*)
+          (setf (gethash key *db-pool*)
+                (make-instance 'conn-pool
+                               :connection-spec connection-spec
+                               :pool-database-type database-type))))))
 
 (defun disconnect-pooled (&optional clear)
   "Disconnects all connections in the pool. When clear, also deletes