Added with-db-from-pool macro.
+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
;;;; 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
((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."))
-;;;; -*- 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
;;;;
;;;; 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
;;;;
(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))))
;;;; 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
(defvar *default-database* nil
"Specifies the default database to be used.")
-
-
(defun find-database (database &optional (errorp t))
(etypecase database
(database
"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))
projects / clsql.git / commitdiff