1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Support function for connection pool
7 ;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
8 ;;;; Date Started: Apr 2002
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
14 ;;;; CLSQL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
19 (in-package #:clsql-sys
)
21 (defvar *db-pool
* (make-hash-table :test
#'equal
))
22 (defvar *db-pool-lock
* (make-process-lock "DB Pool lock"))
24 (defclass conn-pool
()
25 ((connection-spec :accessor connection-spec
:initarg
:connection-spec
)
26 (database-type :accessor pool-database-type
:initarg
:pool-database-type
)
27 (free-connections :accessor free-connections
28 :initform
(make-array 5 :fill-pointer
0 :adjustable t
))
29 (all-connections :accessor all-connections
30 :initform
(make-array 5 :fill-pointer
0 :adjustable t
))
31 (lock :accessor conn-pool-lock
32 :initform
(make-process-lock "Connection pool"))))
34 (defun acquire-from-conn-pool (pool)
35 (or (with-process-lock ((conn-pool-lock pool
) "Acquire from pool")
36 (and (plusp (length (free-connections pool
)))
37 (vector-pop (free-connections pool
))))
38 (let ((conn (connect (connection-spec pool
)
39 :database-type
(pool-database-type pool
)
42 (with-process-lock ((conn-pool-lock pool
) "Acquire from pool")
43 (vector-push-extend conn
(all-connections pool
))
44 (setf (conn-pool conn
) pool
))
47 (defun release-to-conn-pool (conn)
48 (let ((pool (conn-pool conn
)))
49 (with-process-lock ((conn-pool-lock pool
) "Release to pool")
50 (vector-push-extend conn
(free-connections pool
)))))
52 (defun clear-conn-pool (pool)
53 (with-process-lock ((conn-pool-lock pool
) "Clear pool")
54 (loop for conn across
(all-connections pool
)
55 do
(setf (conn-pool conn
) nil
)
56 ;; disconnect may error if remote side closed connection
57 (ignore-errors (disconnect :database conn
)))
58 (setf (fill-pointer (free-connections pool
)) 0)
59 (setf (fill-pointer (all-connections pool
)) 0))
62 (defun find-or-create-connection-pool (connection-spec database-type
)
63 "Find connection pool in hash table, creates a new connection pool
65 (with-process-lock (*db-pool-lock
* "Find-or-create connection")
66 (let* ((key (list connection-spec database-type
))
67 (conn-pool (gethash key
*db-pool
*)))
69 (setq conn-pool
(make-instance 'conn-pool
70 :connection-spec connection-spec
71 :pool-database-type database-type
))
72 (setf (gethash key
*db-pool
*) conn-pool
))
75 (defun acquire-from-pool (connection-spec database-type
&optional pool
)
76 (unless (typep pool
'conn-pool
)
77 (setf pool
(find-or-create-connection-pool connection-spec database-type
)))
78 (acquire-from-conn-pool pool
))
80 (defun release-to-pool (database)
81 (release-to-conn-pool database
))
83 (defun disconnect-pooled (&optional clear
)
84 "Disconnects all connections in the pool."
85 (with-process-lock (*db-pool-lock
* "Disconnect pooled")
87 #'(lambda (key conn-pool
)
88 (declare (ignore key
))
89 (clear-conn-pool conn-pool
))
91 (when clear
(clrhash *db-pool
*)))
94 ;(defun pool-start-sql-recording (pool &key (types :command))
95 ; "Start all stream in the pool recording actions of TYPES"
96 ; (dolist (con (pool-connections pool))
97 ; (start-sql-recording :type types
98 ; :database (connection-database con))))
100 ;(defun pool-stop-sql-recording (pool &key (types :command))
101 ; "Start all stream in the pool recording actions of TYPES"
102 ; (dolist (con (pool-connections pool))
103 ; (stop-sql-recording :type types
104 ; :database (connection-database con))))
106 ;(defmacro with-database-connection (pool &body body)
107 ; `(let ((connection (obtain-connection ,pool))
110 ; (with-database ((connection-database connection))
111 ; (setq results (multiple-value-list (progn ,@body))))
112 ; (release-connection connection))
113 ; (values-list results)))