X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fpool.lisp;h=b0e228f2be7b297d57a714b5e028cb23b457c91c;hp=1a556d824bb18339c41370815ccba29bb7a48f3e;hb=e15b72fefebeee46a83d357db2813031edcc6fbd;hpb=7d50938ba2db52a713498e49aa1679deae6f0b6b diff --git a/sql/pool.lisp b/sql/pool.lisp index 1a556d8..b0e228f 100644 --- a/sql/pool.lisp +++ b/sql/pool.lisp @@ -2,62 +2,73 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: pool.cl +;;;; Name: pool.lisp ;;;; Purpose: Support function for connection pool ;;;; Programmers: Kevin M. Rosenberg, Marc Battyani ;;;; Date Started: Apr 2002 ;;;; -;;;; $Id: pool.lisp,v 1.1 2002/09/30 10:19:23 kevin Exp $ +;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 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. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) +(in-package #:clsql-sys) (defvar *db-pool* (make-hash-table :test #'equal)) +(defvar *db-pool-lock* (make-process-lock "DB Pool lock")) (defclass conn-pool () ((connection-spec :accessor connection-spec :initarg :connection-spec) - (database-type :accessor database-type :initarg :database-type) + (database-type :accessor pool-database-type :initarg :pool-database-type) (free-connections :accessor free-connections :initform (make-array 5 :fill-pointer 0 :adjustable t)) (all-connections :accessor all-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)))) + :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (lock :accessor conn-pool-lock + :initform (make-process-lock "Connection pool")))) (defun acquire-from-conn-pool (pool) - (if (zerop (length (free-connections pool))) - (let ((conn (connect (connection-spec pool) - :database-type (database-type pool) :if-exists :new))) - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool) - conn) - (vector-pop (free-connections pool)))) + (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (and (plusp (length (free-connections pool))) + (vector-pop (free-connections pool)))) + (let ((conn (connect (connection-spec pool) + :database-type (pool-database-type pool) + :if-exists :new))) + (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) - (vector-push-extend conn (free-connections (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))))) (defun clear-conn-pool (pool) - (loop for conn across (all-connections pool) - do (setf (conn-pool conn) nil) - (disconnect :database conn)) - (setf (fill-pointer (free-connections pool)) 0) - (setf (fill-pointer (all-connections pool)) 0)) + (with-process-lock ((conn-pool-lock pool) "Clear pool") + (loop for conn across (all-connections pool) + do (setf (conn-pool conn) nil) + (disconnect :database conn)) + (setf (fill-pointer (free-connections pool)) 0) + (setf (fill-pointer (all-connections pool)) 0)) + 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" - (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 - :database-type database-type)) - (setf (gethash key *db-pool*) conn-pool)) - conn-pool)) + "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))) (defun acquire-from-pool (connection-spec database-type &optional pool) (unless (typep pool 'conn-pool) @@ -68,12 +79,33 @@ (release-to-conn-pool database)) (defun disconnect-pooled (&optional clear) - "Disconnects all connections in the pool" - (maphash - #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) - *db-pool*) - (when clear (clrhash *db-pool*)) + "Disconnects all connections in the pool." + (with-process-lock (*db-pool-lock* "Disconnect pooled") + (maphash + #'(lambda (key conn-pool) + (declare (ignore key)) + (clear-conn-pool conn-pool)) + *db-pool*) + (when clear (clrhash *db-pool*))) t) +;(defun pool-start-sql-recording (pool &key (types :command)) +; "Start all stream in the pool recording actions of TYPES" +; (dolist (con (pool-connections pool)) +; (start-sql-recording :type types +; :database (connection-database con)))) + +;(defun pool-stop-sql-recording (pool &key (types :command)) +; "Start all stream in the pool recording actions of TYPES" +; (dolist (con (pool-connections pool)) +; (stop-sql-recording :type types +; :database (connection-database con)))) + +;(defmacro with-database-connection (pool &body body) +; `(let ((connection (obtain-connection ,pool)) +; (results nil)) +; (unwind-protect +; (with-database ((connection-database connection)) +; (setq results (multiple-value-list (progn ,@body)))) +; (release-connection connection)) +; (values-list results)))