From: Kevin M. Rosenberg Date: Sat, 27 Apr 2002 20:58:11 +0000 (+0000) Subject: r1798: Initial support for pooled connections X-Git-Tag: v3.8.6~1140 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=f8478421f5a0440246f70aa4234ff25f416be7e3 r1798: Initial support for pooled connections --- diff --git a/ChangeLog b/ChangeLog index b8b7f3d..5c9411c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) + * Multiple files: + Added initial support for connection pool + 23 Apr 2002 Kevin Rosenberg (kevin@rosenberg.net) * interfaces/postgresql/postgresql-sql.cl: Fix keyword typo in database-read-large-object diff --git a/Makefile b/Makefile index 01d6ee9..131c689 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.14 2002/04/23 21:32:25 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.15 2002/04/27 20:58:11 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -17,19 +17,19 @@ PKG=clsql .PHONY: all libs clean distclean doc tagcvs dist wwwdist -SUBDIRS=interfaces/mysql interfaces/clsql-uffi -.PHONY: subdirs $(SUBDIRS) +LIBSUBDIRS=interfaces/mysql interfaces/clsql-uffi +.PHONY: subdirs $(LIBSUBDIRS) -all: $(SUBDIRS) +all: $(LIBSUBDIRS) -$(SUBDIRS): +$(LIBSUBDIRS): $(MAKE) -C $@ clean: @rm -f $(PKG)-*.tar.gz $(PKG)-*.zip @find . -type d -name .bin |xargs rm -rf @find . -type f -name "#*" -or -name \*~ -exec rm {} \; - @for i in $(SUBDIRS) ; do $(MAKE) -C $$i $@ ; done + @for i in $(LIBSUBDIRS) ; do $(MAKE) -C $$i $@ ; done distclean: clean diff --git a/VERSION b/VERSION index e83707c..671a34c 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -0.6.8 +0.7.0 diff --git a/clsql.system b/clsql.system index 41ba9f2..82e6d53 100644 --- a/clsql.system +++ b/clsql.system @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: clsql.system,v 1.5 2002/04/01 05:27:55 kevin Exp $ +;;;; $Id: clsql.system,v 1.6 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -40,7 +40,8 @@ (:file "classes") (:file "conditions" :depends-on ("classes")) (:file "db-interface" :depends-on ("conditions")) - (:file "sql" :depends-on ("db-interface")) + (:file "pool" :depends-on ("db-interface")) + (:file "sql" :depends-on ("pool")) (:file "utils" :depends-on ("package")) (:file "functional" :depends-on ("sql")) (:file "usql" :depends-on ("sql"))) diff --git a/doc/Makefile b/doc/Makefile index 85a9f02..3b6f584 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.7 2002/04/23 21:32:25 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.8 2002/04/27 20:58:11 kevin Exp $ # # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -95,7 +95,7 @@ clean: @rm -f ${PSFILE} ${PDFFILE} ${DVIFILE} ${TEXFILE} @rm -f ${TMPFILES} -realclean: clean - @rm -f *~ +distclean: clean + @rm -f *~ .#* *.bak *.orig diff --git a/doc/ref.sgml b/doc/ref.sgml index a24ae22..89113a8 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -10,7 +10,7 @@ &clsql;. - + CLSQL-CONDITION the super-type of all @@ -22,7 +22,7 @@ Class Precedence List - maisql-condition + clsql-condition condition t @@ -37,7 +37,7 @@ initialization arguments nor any accessors. - + CLSQL-ERROR the super-type of all @@ -49,10 +49,10 @@ Class Precedence List - maisql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -68,7 +68,7 @@ initialization arguments nor any accessors. - + CLSQL-SIMPLE-ERROR Unspecific simple @@ -79,12 +79,12 @@ Class Precedence List - maisql-simple-error + clsql-simple-error simple-condition - maisql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -99,7 +99,7 @@ simple-condition. - + CLSQL-WARNING the super-type of all @@ -111,9 +111,9 @@ Class Precedence List - maisql-warning + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -129,7 +129,7 @@ initialization arguments nor any accessors. - + CLSQL-SIMPLE-WARNING Unspecific simple @@ -140,11 +140,11 @@ Class Precedence List - maisql-simple-warning + clsql-simple-warning simple-condition - maisql-warning + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -161,7 +161,7 @@ - + CLSQL-INVALID-SPEC-ERROR condition representing errors because of invalid @@ -172,11 +172,11 @@ Class Precedence List - maisql-invalid-spec-error - maisql-error + clsql-invalid-spec-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -195,24 +195,24 @@ Description :connection-spec - maisql-invalid-spec-error-connection-spec + clsql-invalid-spec-error-connection-spec The invalid connection specification used. :database-type - maisql-invalid-spec-error-database-type + clsql-invalid-spec-error-database-type The Database type used in the attempt. :template - maisql-invalid-spec-error-template + clsql-invalid-spec-error-template An argument describing the template that a valid connection specification must match for this database type. - + CLSQL-CONNECT-ERROR condition representing errors during @@ -223,11 +223,11 @@ Class Precedence List - maisql-connect-error - maisql-error + clsql-connect-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -244,32 +244,32 @@ Description :database-type - maisql-connect-error-database-type + clsql-connect-error-database-type Database type for the connection attempt :connection-spec - maisql-connect-error-connection-spec + clsql-connect-error-connection-spec The connection specification used in the connection attempt. :errno - maisql-connect-error-errno + clsql-connect-error-errno The numeric or symbolic error specification returned by the database back-end. The values and semantics of this are interface specific. :error - maisql-connect-error-error + clsql-connect-error-error A string describing the problem that occurred, possibly one returned by the database back-end. - + CLSQL-SQL-ERROR condition representing errors during query or @@ -280,11 +280,11 @@ Class Precedence List - maisql-sql-error - maisql-error + clsql-sql-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -303,32 +303,32 @@ Description :database - maisql-sql-error-database + clsql-sql-error-database The database object that was involved in the incident. :expression - maisql-sql-error-expression + clsql-sql-error-expression The SQL expression whose execution caused the error. :errno - maisql-sql-error-errno + clsql-sql-error-errno The numeric or symbolic error specification returned by the database back-end. The values and semantics of this are interface specific. :error - maisql-sql-error-error + clsql-sql-error-error A string describing the problem that occurred, possibly one returned by the database back-end. - + CLSQL-EXISTS-CONDITION condition indicating situations arising because of @@ -339,8 +339,8 @@ Class Precedence List - maisql-exists-condition - maisql-condition + clsql-exists-condition + clsql-condition condition t @@ -356,13 +356,13 @@ connect, either a warning, an error or no condition at all is signalled. If a warning or error is signalled, either - maisql-exists-warning or - maisql-exists-error is signalled, + clsql-exists-warning or + clsql-exists-error is signalled, which are subtypes of - maisql-exists-condition and - maisql-warning or - maisql-error. - maisql-exists-condition is never + clsql-exists-condition and + clsql-warning or + clsql-error. + clsql-exists-condition is never signalled itself. The following initialization arguments and accessors exist: @@ -372,13 +372,13 @@ Description :old-db - maisql-exists-condition-old-db + clsql-exists-condition-old-db The database object that represents the existing connection. This slot is always filled. :new-db - maisql-exists-condition-new-db + clsql-exists-condition-new-db The database object that will be used and returned by this call to connect, if execution continues normally. This can be either nil, indicating that @@ -392,7 +392,7 @@ - + CLSQL-EXISTS-WARNING condition representing warnings arising because of @@ -403,11 +403,11 @@ Class Precedence List - maisql-exists-warning - maisql-exists-condition - maisql-warning + clsql-exists-warning + clsql-exists-condition + clsql-warning warning - maisql-condition + clsql-condition condition t @@ -416,7 +416,7 @@ Description This condition is a subtype of - maisql-exists-condition, and is + clsql-exists-condition, and is signalled during calls to connect when there is an existing connection, and if-exists is either @@ -426,10 +426,10 @@ the existing old database object. The initialization arguments and accessors are the same as - for maisql-exists-condition. + for clsql-exists-condition. - + CLSQL-EXISTS-ERROR condition representing errors arising because of @@ -440,12 +440,12 @@ Class Precedence List - maisql-exists-error - maisql-exists-condition - maisql-error + clsql-exists-error + clsql-exists-condition + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -454,7 +454,7 @@ Description This condition is a subtype of - maisql-exists-condition, and is + clsql-exists-condition, and is signalled during calls to connect when there is an existing connection, and if-exists is :error. @@ -464,10 +464,10 @@ action in continuing from this correctable error. The initialization arguments and accessors are the same as - for maisql-exists-condition. + for clsql-exists-condition. - + CLSQL-CLOSED-ERROR condition representing errors because the database @@ -478,11 +478,11 @@ Class Precedence List - maisql-closed-error - maisql-error + clsql-closed-error + clsql-error error serious-condition - maisql-condition + clsql-condition condition t @@ -507,7 +507,7 @@ Description :database - maisql-closed-error-database + clsql-closed-error-database The database object that was involved in the incident. @@ -674,7 +674,7 @@ already present. If initialization fails, the function returns nil, and/or signals an error of type - maisql-error. The kind of action + clsql-error. The kind of action taken depends on the back-end and the cause of the problem. @@ -724,7 +724,7 @@ Exceptional Situations If an error is encountered during the initialization attempt, the back-end may signal errors of kind - maisql-error. + clsql-error. See Also @@ -1036,7 +1036,7 @@ disconnect. All functions and generic functions that take database objects as arguments will signal errors of type - maisql-closed-error when they are + clsql-closed-error when they are called on instances of closed-database, with the exception of database-name, which will continue to work as for instances of @@ -1208,7 +1208,7 @@ database. If it succeeds, it returns the first database found. If it fails to find a matching database, it will signal - an error of type maisql-error if + an error of type clsql-error if errorp is true. If errorp is nil, it will return nil instead. @@ -1258,7 +1258,7 @@ Exceptional Situations Will signal an error of type - maisql-error if no matching database + clsql-error if no matching database can be found, and errorp is true. Will signal an error if the value of database is neither an object of type @@ -1280,6 +1280,7 @@ None. + CONNECT @@ -1288,7 +1289,7 @@ Syntax - connect connection-spec &key if-exists database-type => database + connect connection-spec &key if-exists database-type pool => database Arguments and Values @@ -1316,6 +1317,14 @@ *default-database-type* + + pool + + A boolean flag. If &t;, acquire connection from a + pool of open connections. If the pool is empty, a new + connection is created. The default is &nil;. + + database @@ -1350,7 +1359,7 @@ This is just like :new, but also signals a warning of type - maisql-exists-warning, + clsql-exists-warning, indicating the old and newly created databases. @@ -1360,7 +1369,7 @@ This will cause connect to signal a correctable error of type - maisql-exists-error. The + clsql-exists-error. The user may choose to proceed, either by indicating that a new connection shall be created, via the restart create-new, or by @@ -1381,7 +1390,7 @@ This is just like :old, but also signals a warning of type - maisql-exists-warning, + clsql-exists-warning, indicating the old database used, via the slots old-db and new-db @@ -1448,11 +1457,11 @@ Exceptional Situations If the connection specification is not syntactically or semantically correct for the given database type, an error - of type maisql-invalid-spec-error is + of type clsql-invalid-spec-error is signalled. If during the connection attempt an error is detected (e.g. because of permission problems, network trouble or any other cause), an error of type - maisql-connect-error is + clsql-connect-error is signalled. If a connection to the database specified by connection-spec exists already, @@ -1474,6 +1483,7 @@ None. + DISCONNECT @@ -1482,11 +1492,21 @@ Syntax - disconnect &key database => t + disconnect &key database pool => t Arguments and Values + + pool + + A boolean flag indicating whether to put the database into a +pool of opened databases. If &t;, rather than terminating the database connection, the +connection is left open and the connection is placed into a pool of connections. Subsequent +calls to connect can then reuse this connection. +The default is &nil;. + + database @@ -1508,7 +1528,7 @@ with the exception of database-name. If the user does pass a closed database object to any other &clsql; function, an error of type - maisql-closed-error is + clsql-closed-error is signalled. @@ -1545,7 +1565,65 @@ Exceptional Situations If during the disconnection attempt an error is detected (e.g. because of network trouble or any other - cause), an error of type maisql-error + cause), an error of type clsql-error + might be signalled. + + + See Also + + + connect + closed-database + + + + + Notes + None. + + + + + + DISCONNECT-POOLED + closes all pooled database connections + Function + + + Syntax + disconnect-pool => t + + + Description + This function disconnects all database connections + that have been placed into the pool. Connections are placed + in the pool by calling + disconnection. + + + Examples + +(disconnect-pool) +=> T + + + + Side Effects + Database connections will be closed and entries in the pool are removed. + + + Affected by + + + disconnect + + + + + Exceptional Situations + If during the disconnection attempt an error is + detected (e.g. because of network trouble or any other + cause), an error of type clsql-error might be signalled. @@ -1562,6 +1640,7 @@ None. + DATABASE-NAME-FROM-SPEC @@ -1654,7 +1733,7 @@ If the value of connection-spec is not a valid connection specification for the given database type, an error of type - maisql-invalid-spec-error might be + clsql-invalid-spec-error might be signalled. @@ -1710,7 +1789,7 @@ sql-expression in the database specified. If the execution succeeds it will return t, otherwise an - error of type maisql-sql-error will + error of type clsql-sql-error will be signalled. @@ -1756,7 +1835,7 @@ Exceptional Situations If the execution of the SQL statement leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. See Also @@ -1863,7 +1942,7 @@ database specified. If the execution succeeds it will return the result set returned by the database, otherwise an error of type - maisql-sql-error will + clsql-sql-error will be signalled. @@ -1906,7 +1985,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. See Also @@ -2067,7 +2146,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. An error of type type-error must be signaled if the output-type-spec is not a recognizable subtype of list, not a @@ -2201,7 +2280,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. If the number of variable names in args and the number of attributes in the tuples in the result set don't match up, an error is @@ -2338,7 +2417,7 @@ Exceptional Situations If the execution of the SQL query leads to any errors, an error of type - maisql-sql-error is signalled. + clsql-sql-error is signalled. Otherwise, any of the exceptional situations of loop applies. @@ -2416,7 +2495,7 @@ initialization by returning t from their method, and nil otherwise. Methods for this generic function are allowed to signal errors of type - maisql-error or subtypes thereof. + clsql-error or subtypes thereof. They may also signal other types of conditions, if appropriate, but have to document this. @@ -2435,7 +2514,7 @@ Exceptional Situations - Conditions of type maisql-error + Conditions of type clsql-error or other conditions may be signalled, depending on the database back-end. diff --git a/interfaces/mysql/mysql-sql.cl b/interfaces/mysql/mysql-sql.cl index b88e054..264c71b 100644 --- a/interfaces/mysql/mysql-sql.cl +++ b/interfaces/mysql/mysql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: mysql-sql.cl,v 1.18 2002/03/30 05:07:02 kevin Exp $ +;;;; $Id: mysql-sql.cl,v 1.19 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -90,6 +90,9 @@ ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr :type mysql-mysql-ptr-def))) +(defmethod database-type ((database mysql-database)) + :mysql) + (defmethod database-name-from-spec (connection-spec (database-type (eql :mysql))) (check-connection-spec connection-spec database-type (host db user password)) (destructuring-bind (host db user password) connection-spec @@ -129,6 +132,7 @@ (make-instance 'mysql-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :mysql-ptr mysql-ptr)) (when error-occurred (mysql-close mysql-ptr))))))))) diff --git a/interfaces/postgresql-socket/postgresql-socket-sql.cl b/interfaces/postgresql-socket/postgresql-socket-sql.cl index 3a0d491..777a095 100644 --- a/interfaces/postgresql-socket/postgresql-socket-sql.cl +++ b/interfaces/postgresql-socket/postgresql-socket-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-socket-sql.cl,v 1.10 2002/03/29 09:37:24 kevin Exp $ +;;;; $Id: postgresql-socket-sql.cl,v 1.11 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -137,16 +137,19 @@ doesn't depend on UFFI." ;; KMR - removed double @@ ,@body)))) -(defmethod database-initialize-database-type - ((database-type (eql :postgresql-socket))) +(defmethod database-initialize-database-type ((database-type + (eql :postgresql-socket))) t) (defclass postgresql-socket-database (database) ((connection :accessor database-connection :initarg :connection :type postgresql-connection))) -(defmethod database-name-from-spec - (connection-spec (database-type (eql :postgresql-socket))) +(defmethod database-type ((database postgresql-socket-database)) + :postgresql-socket) + +(defmethod database-name-from-spec (connection-spec + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional port options tty) @@ -154,8 +157,8 @@ doesn't depend on UFFI." (declare (ignore password options tty)) (concatenate 'string host (if port ":") (if port port) "/" db "/" user))) -(defmethod database-connect - (connection-spec (database-type (eql :postgresql-socket))) +(defmethod database-connect (connection-spec + (database-type (eql :postgresql-socket))) (check-connection-spec connection-spec database-type (host db user password &optional port options tty)) (destructuring-bind (host db user password &optional @@ -178,6 +181,7 @@ doesn't depend on UFFI." (make-instance 'postgresql-socket-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :connection connection)) (postgresql-error (c) ;; Connect failed diff --git a/interfaces/postgresql/postgresql-sql.cl b/interfaces/postgresql/postgresql-sql.cl index 4104afa..809507c 100644 --- a/interfaces/postgresql/postgresql-sql.cl +++ b/interfaces/postgresql/postgresql-sql.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: postgresql-sql.cl,v 1.14 2002/04/23 18:28:02 kevin Exp $ +;;;; $Id: postgresql-sql.cl,v 1.15 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -87,6 +87,9 @@ ((conn-ptr :accessor database-conn-ptr :initarg :conn-ptr :type pgsql-conn-def))) +(defmethod database-type ((database postgresql-database)) + :postgresql) + (defmethod database-name-from-spec (connection-spec (database-type (eql :postgresql))) (check-connection-spec connection-spec database-type @@ -125,6 +128,7 @@ (make-instance 'postgresql-database :name (database-name-from-spec connection-spec database-type) + :connection-spec connection-spec :conn-ptr connection))))) diff --git a/sql/classes.cl b/sql/classes.cl index 8ba8c26..7a3f336 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.1 2002/03/29 08:13:02 kevin Exp $ +;;;; $Id: classes.cl,v 1.2 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -23,7 +23,9 @@ (defclass database () - ((name :initarg :name :reader database-name)) + ((name :initarg :name :reader database-name) + (connection-spec :initarg :connection-spec :reader connection-spec + :documentation "Require to use connection pool")) (:documentation "This class is the supertype of all databases handled by CLSQL.")) diff --git a/sql/db-interface.cl b/sql/db-interface.cl index 1ce8681..b2dd41e 100644 --- a/sql/db-interface.cl +++ b/sql/db-interface.cl @@ -9,7 +9,7 @@ ;;;; onShoreD to support UncommonSQL front-end ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: db-interface.cl,v 1.6 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: db-interface.cl,v 1.7 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai, and onShoreD @@ -31,6 +31,14 @@ "The internal generic implementation for checking if database type library loaded successfully.")) +(defgeneric database-type (database-type) + (:documentation + "Returns database type") + (:method (database-type) + (declare (ignore database-type)) + (signal-nodb-error database))) + + (defgeneric database-initialize-database-type (database-type) (:documentation "The internal generic implementation of initialize-database-type.")) diff --git a/sql/package.cl b/sql/package.cl index 2db3c44..3624819 100644 --- a/sql/package.cl +++ b/sql/package.cl @@ -8,7 +8,7 @@ ;;;; Original code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: package.cl,v 1.7 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: package.cl,v 1.8 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -58,6 +58,9 @@ #:database-read-large-object #:database-delete-large-object + ;; Pooled connections + #:disconnect-pooled + ;; Shared exports for re-export by CLSQL . #1=(#:clsql-condition diff --git a/sql/pool.cl b/sql/pool.cl new file mode 100644 index 0000000..298f1e3 --- /dev/null +++ b/sql/pool.cl @@ -0,0 +1,59 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pool.cl +;;;; Purpose: Support function for connection pool +;;;; Programmers: Kevin M. Rosenberg +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id: pool.cl,v 1.1 2002/04/27 20:58:11 kevin Exp $ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002 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) + +(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)) + +(defun find-or-create-conn-vector (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 *db-pool* key))) + (unless conn-vector + (setq conn-vector (make-conn-vector)) + (setf (gethash *db-pool* key) 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))) + +(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))) + +(defun disconnect-pooled () + "Disconnects all connections in the pool" + (maphash + #'(lambda (key conn-vector) + (declare (ignore key)) + (dotimes (i (length conn-vector)) + (disconnect (aref conn-vector i))) + (setf (fill-pointer conn-vector) 0)) + *db-pool*) + t) diff --git a/sql/sql.cl b/sql/sql.cl index 4b88fd5..f5eebd7 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.12 2002/04/19 20:25:20 marc.battyani Exp $ +;;;; $Id: sql.cl,v 1.13 2002/04/27 20:58:11 kevin Exp $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai @@ -95,56 +95,59 @@ initialized, as indicated by `*initialized-database-types*'." (defun connect (connection-spec &key (if-exists *connect-if-exists*) - (database-type *default-database-type*)) + (database-type *default-database-type*) + (pool nil)) "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)) (result nil)) - (if old-db - (case if-exists - (:new - (setq result - (database-connect connection-spec database-type))) - (:warn-new - (setq result - (database-connect connection-spec database-type)) - (warn 'clsql-exists-warning :old-db old-db :new-db result)) - (:error - (restart-case - (error 'clsql-exists-error :old-db old-db) - (create-new () - :report "Create a new connection." - (setq result - (database-connect connection-spec database-type))) - (use-old () - :report "Use the existing connection." - (setq result old-db)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) + (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))) + (:warn-new + (setq result + (database-connect connection-spec database-type)) + (warn 'clsql-exists-warning :old-db old-db :new-db result)) + (:error + (restart-case + (error 'clsql-exists-error :old-db old-db) + (create-new () + :report "Create a new connection." + (setq result + (database-connect connection-spec database-type))) + (use-old () + :report "Use the existing connection." + (setq result old-db)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) (setq result - (database-connect connection-spec database-type))) + (database-connect connection-spec database-type)))) (when result (pushnew result *connected-databases*) (setq *default-database* result) result))) - -(defun disconnect (&key (database *default-database*)) +(defun disconnect (&key (database *default-database*) + (pool nil)) "Closes the connection to database. Resets *default-database* if that database was disconnected and only one other connection exists." - (when (database-disconnect database) - (setq *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setq *default-database* (car *connected-databases*))) - (change-class database 'closed-database) - t)) - - + (if pool + (release-to-pool database) + (when (database-disconnect database) + (setq *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setq *default-database* (car *connected-databases*))) + (change-class database 'closed-database) + t))) ;;; Basic operations on databases