From 1785177d3364ad0ad8917193b5b00310ef88105e Mon Sep 17 00:00:00 2001 From: Marc Battyani Date: Wed, 1 May 2002 20:22:16 +0000 Subject: [PATCH] r1857: Completed connection pool. Added with-db-from-pool macro. --- ChangeLog | 8 +++ sql/classes.cl | 5 +- sql/package.cl | 162 +------------------------------------------------ sql/pool.cl | 85 +++++++++++++++++--------- sql/sql.cl | 12 ++-- 5 files changed, 75 insertions(+), 197 deletions(-) diff --git a/ChangeLog b/ChangeLog index fb92c48..3813416 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +01 May 2002 Marc Battyani (marc.battyani@fractalconcept.com) + * sql/sql.cl: + * sql/pool.cl: + * sql/classes.cl: + * sql/package.cl: + Completed connection pool. + Added with-db-from-pool macro. + 27 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * Multiple files: Added initial support for connection pool diff --git a/sql/classes.cl b/sql/classes.cl index 0a195a8..c83b200 100644 --- a/sql/classes.cl +++ b/sql/classes.cl @@ -8,7 +8,7 @@ ;;;; original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: classes.cl,v 1.4 2002/04/28 00:50:17 kevin Exp $ +;;;; $Id: classes.cl,v 1.5 2002/05/01 20:22:16 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -26,7 +26,8 @@ ((name :initarg :name :reader database-name) (connection-spec :initarg :connection-spec :reader connection-spec :documentation "Require to use connection pool") - (transaction-level :initarg :transaction-level :accessor transaction-level)) + (transaction-level :initarg :transaction-level :accessor transaction-level) + (conn-pool :initarg :conn-pool :accessor conn-pool :initform nil)) (:default-initargs :name nil :connection-spec nil :transaction-level 0) (:documentation "This class is the supertype of all databases handled by CLSQL.")) diff --git a/sql/package.cl b/sql/package.cl index 166e42a..cb85943 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -1,161 +1 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.cl -;;;; Purpose: Package definition for high-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id: package.cl,v 1.10 2002/04/28 00:50:17 kevin Exp $ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; and Copyright (c) 1999-2001 by Pierre R. Mai -;;;; -;;;; 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 :cl-user) - -;;;; This file makes the required package definitions for CLSQL's -;;;; core packages. -;;;; - -(eval-when (:compile-toplevel :load-toplevel :execute) -(defpackage :clsql-sys - (:use :common-lisp) - (:export - ;; "Private" exports for use by interface packages - #:check-connection-spec - #:database-type-load-foreign - #:database-type-library-loaded ;; KMR - Tests if foreign library okay - #:database-initialize-database-type - #:database-connect - #:database-disconnect - #:database-query - #:database-execute-command - #:database-query-result-set - #:database-dump-result-set - #:database-store-next-row - - ;; For UncommonSQL support - #:database-list-tables - #:database-list-attributes - #:database-attribute-type - #:database-create-sequence - #:database-drop-sequence - #:database-sequence-next - - #:sql-escape - - ;; Support for pooled connections - #:database-type - - ;; Large objects (Marc B) - #:database-create-large-object - #:database-write-large-object - #:database-read-large-object - #:database-delete-large-object - - ;; Shared exports for re-export by CLSQL - . - #1=(#:clsql-condition - #:clsql-error - #:clsql-simple-error - #:clsql-warning - #:clsql-simple-warning - #:clsql-invalid-spec-error - #:clsql-invalid-spec-error-connection-spec - #:clsql-invalid-spec-error-database-type - #:clsql-invalid-spec-error-template - #:clsql-connect-error - #:clsql-connect-error-database-type - #:clsql-connect-error-connection-spec - #:clsql-connect-error-errno - #:clsql-connect-error-error - #:clsql-sql-error - #:clsql-sql-error-database - #:clsql-sql-error-expression - #:clsql-sql-error-errno - #:clsql-sql-error-error - #:clsql-database-warning - #:clsql-database-warning-database - #:clsql-database-warning-message - #:clsql-exists-condition - #:clsql-exists-condition-new-db - #:clsql-exists-condition-old-db - #:clsql-exists-warning - #:clsql-exists-error - #:clsql-closed-error - #:clsql-closed-error-database - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - #:*connect-if-exists* - #:*default-database* - #:connected-databases - #:database - #:database-name - #:closed-database - #:find-database - #:database-name-from-spec - #:connect - #:disconnect - #:query - #:execute-command - #:map-query - #:do-query - - ;; functional.cl - - #:insert-records - #:delete-records - #:update-records - #:with-database - - ;; utils.cl - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - - ;; For UncommonSQL support - #:sql-ident - #:list-tables - #:list-attributes - #:attribute-type - #:create-sequence - #:drop-sequence - #:sequence-next - #:transaction-start - #:transaction-commit - #:transaction-abort - - ;; Pooled connections - #:disconnect-pooled - - ;; Transactions - #:with-transaction - - ;; Large objects (Marc B) - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - )) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) - -(defpackage #:clsql - (:import-from #:clsql-sys . #1#) - (:export . #1#) - (:documentation "This is the SQL-Interface package of CLSQL.")) -);eval-when - -(defpackage #:clsql-user - (:use #:common-lisp #:clsql) - (:documentation "This is the user package for experimenting with CLSQL.")) +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-;;;; *************************************************************************;;;; FILE IDENTIFICATION;;;;;;;; Name: package.cl;;;; Purpose: Package definition for high-level SQL interface;;;; Programmers: Kevin M. Rosenberg based on;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002;;;;;;;; $Id: package.cl,v 1.11 2002/05/01 20:22:16 marc.battyani Exp $;;;;;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg;;;; and Copyright (c) 1999-2001 by Pierre R. Mai;;;;;;;; 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 :cl-user);;;; This file makes the required package definitions for CLSQL's;;;; core packages.;;;; (eval-when (:compile-toplevel :load-toplevel :execute)(defpackage :clsql-sys (:use :common-lisp) (:export ;; "Private" exports for use by interface packages #:check-connection-spec #:database-type-load-foreign #:database-type-library-loaded ;; KMR - Tests if foreign library okay #:database-initialize-database-type #:database-connect #:database-disconnect #:database-query #:database-execute-command #:database-query-result-set #:database-dump-result-set #:database-store-next-row ;; For UncommonSQL support #:database-list-tables #:database-list-attributes #:database-attribute-type #:database-create-sequence #:database-drop-sequence #:database-sequence-next #:sql-escape ;; Support for pooled connections #:database-type ;; Large objects (Marc B) #:database-create-large-object #:database-write-large-object #:database-read-large-object #:database-delete-large-object ;; Shared exports for re-export by CLSQL . #1=(#:clsql-condition #:clsql-error #:clsql-simple-error #:clsql-warning #:clsql-simple-warning #:clsql-invalid-spec-error #:clsql-invalid-spec-error-connection-spec #:clsql-invalid-spec-error-database-type #:clsql-invalid-spec-error-template #:clsql-connect-error #:clsql-connect-error-database-type #:clsql-connect-error-connection-spec #:clsql-connect-error-errno #:clsql-connect-error-error #:clsql-sql-error #:clsql-sql-error-database #:clsql-sql-error-expression #:clsql-sql-error-errno #:clsql-sql-error-error #:clsql-database-warning #:clsql-database-warning-database #:clsql-database-warning-message #:clsql-exists-condition #:clsql-exists-condition-new-db #:clsql-exists-condition-old-db #:clsql-exists-warning #:clsql-exists-error #:clsql-closed-error #:clsql-closed-error-database #:*loaded-database-types* #:reload-database-types #:*default-database-type* #:*initialized-database-types* #:initialize-database-type #:*connect-if-exists* #:*default-database* #:connected-databases #:database #:database-name #:closed-database #:find-database #:database-name-from-spec #:connect #:disconnect #:query #:execute-command #:map-query #:do-query ;; functional.cl #:insert-records #:delete-records #:update-records #:with-database ;; utils.cl #:number-to-sql-string #:float-to-sql-string #:sql-escape-quotes ;; For UncommonSQL support #:sql-ident #:list-tables #:list-attributes #:attribute-type #:create-sequence #:drop-sequence #:sequence-next #:transaction-start #:transaction-commit #:transaction-abort ;; Pooled connections #:disconnect-pooled #:with-db-from-pool ;; Transactions #:with-transaction ;; Large objects (Marc B) #:create-large-object #:write-large-object #:read-large-object #:delete-large-object )) (:documentation "This is the INTERNAL SQL-Interface package of CLSQL."))(defpackage #:clsql (:import-from #:clsql-sys . #1#) (:export . #1#) (:documentation "This is the SQL-Interface package of CLSQL.")));eval-when(defpackage #:clsql-user (:use #:common-lisp #:clsql) (:documentation "This is the user package for experimenting with CLSQL.")) \ No newline at end of file diff --git a/sql/pool.cl b/sql/pool.cl index 14efa23..bf790a4 100644 --- a/sql/pool.cl +++ b/sql/pool.cl @@ -4,10 +4,10 @@ ;;;; ;;;; Name: pool.cl ;;;; Purpose: Support function for connection pool -;;;; Programmers: Kevin M. Rosenberg +;;;; Programmers: Kevin M. Rosenberg, Marc Battyani ;;;; Date Started: Apr 2002 ;;;; -;;;; $Id: pool.cl,v 1.2 2002/04/28 00:50:17 kevin Exp $ +;;;; $Id: pool.cl,v 1.3 2002/05/01 20:22:16 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -21,39 +21,70 @@ (defvar *db-pool* (make-hash-table :test #'equal)) -(defun make-conn-vector () - "Creates an empty connection vector" - (make-array 5 :fill-pointer 0 :adjustable t)) +(defclass conn-pool () + ((connection-spec :accessor connection-spec :initarg :connection-spec) + (database-type :accessor database-type :initarg :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)))) -(defun find-or-create-conn-vector (connection-spec database-type) +(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)))) + +(defun release-to-conn-pool (conn) + (vector-push-extend conn (free-connections (conn-pool conn)))) + +(defun clear-conn-pool (pool) + (loop for conn across (all-connections pool) + do (disconnect :database conn)) + (setf (fill-pointer (free-connections pool)) 0) + (setf (fill-pointer (all-connections pool)) 0)) + +(defun find-or-create-conn-pool (connection-spec database-type) "Find connection vector in hash table, creates a new conn-vector if not found" (let* ((key (list connection-spec database-type)) - (conn-vector (gethash key *db-pool*))) - (unless conn-vector - (setq conn-vector (make-conn-vector)) - (setf (gethash key *db-pool*) conn-vector)) - conn-vector)) - -(defun acquire-from-pool (connection-spec database-type) - (let ((conn-vector (find-or-create-conn-vector connection-spec database-type))) - (when (zerop (length conn-vector)) - (vector-push-extend - (connect connection-spec :database-type database-type :if-exists :new) - conn-vector)) - (vector-pop conn-vector))) + (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)) + +(defun acquire-from-pool (connection-spec database-type &optional pool) + (unless pool (setf pool (find-or-create-conn-pool connection-spec database-type))) + (acquire-from-conn-pool pool)) (defun release-to-pool (database) - (let ((conn-vector (find-or-create-conn-vector (connection-spec database) - (database-type database)))) - (vector-push-extend database conn-vector))) + (release-to-conn-pool database)) -(defun disconnect-pooled () +(defun disconnect-pooled (&optional clear) "Disconnects all connections in the pool" (maphash - #'(lambda (key conn-vector) + #'(lambda (key conn-pool) (declare (ignore key)) - (dotimes (i (length conn-vector)) - (disconnect (aref conn-vector i))) - (setf (fill-pointer conn-vector) 0)) + (clear-conn-pool conn-pool)) *db-pool*) + (when clear (clrhash *db-pool*)) t) + +;;; with-db-from-pool is the macro you should use if you want to use pooled connections. +;;; You can use it with a connection spec and database type or directly with a conn-pool. +;;; When you give a conn-pool the connection spec and database type are ignored + +(defmacro with-db-from-pool ((db-var connection-spec database-type &optional conn-pool) &body body) + "Evaluate the body in an environment, where `db-var' is bound to a +database connection acquired from the connection pool +The connection is automatically released to the connection pool on exit from the body. +If a pool is given then the connection-spec database-type are ignored." + `(let ((,db-var (acquire-from-pool ,connection-spec ,database-type ,conn-pool))) + (unwind-protect + (let ((,db-var ,db-var)) ,@body) + (release-to-pool ,db-var)))) diff --git a/sql/sql.cl b/sql/sql.cl index f5eebd7..6d2d8bb 100644 --- a/sql/sql.cl +++ b/sql/sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: sql.cl,v 1.13 2002/04/27 20:58:11 kevin Exp $ +;;;; $Id: sql.cl,v 1.14 2002/05/01 20:22:16 marc.battyani Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -76,8 +76,6 @@ initialized, as indicated by `*initialized-database-types*'." (defvar *default-database* nil "Specifies the default database to be used.") - - (defun find-database (database &optional (errorp t)) (etypecase database (database @@ -100,15 +98,15 @@ initialized, as indicated by `*initialized-database-types*'." "Connects to a database of the given database-type, using the type-specific connection-spec. if-exists is currently ignored." (let* ((db-name (database-name-from-spec connection-spec database-type)) - (old-db (find-database db-name nil)) + (old-db (unless (eq if-exists :new) (find-database db-name nil))) (result nil)) (if pool (setq result (acquire-from-pool connection-spec database-type)) (if old-db (case if-exists - (:new - (setq result - (database-connect connection-spec database-type))) +; (:new +; (setq result +; (database-connect connection-spec database-type))) (:warn-new (setq result (database-connect connection-spec database-type)) -- 2.34.1