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
8 ;;;; Date Started: Apr 2002
10 ;;;; $Id: pool.cl,v 1.1 2002/04/27 20:58:11 kevin Exp $
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
20 (in-package :clsql-sys)
22 (defvar *db-pool* (make-hash-table :test #'equal))
24 (defun make-conn-vector ()
25 "Creates an empty connection vector"
26 (make-array 5 :fill-pointer 0 :adjustable t))
28 (defun find-or-create-conn-vector (connection-spec database-type)
29 "Find connection vector in hash table, creates a new conn-vector if not found"
30 (let* ((key (list connection-spec database-type))
31 (conn-vector (gethash *db-pool* key)))
33 (setq conn-vector (make-conn-vector))
34 (setf (gethash *db-pool* key) conn-vector))
37 (defun acquire-from-pool (connection-spec database-type)
38 (let ((conn-vector (find-or-create-conn-vector connection-spec database-type)))
39 (when (zerop (length conn-vector))
41 (connect connection-spec :database-type database-type :if-exists :new)
43 (vector-pop conn-vector)))
45 (defun release-to-pool (database)
46 (let ((conn-vector (find-or-create-conn-vector (connection-spec database)
47 (database-type database))))
48 (vector-push-extend database conn-vector)))
50 (defun disconnect-pooled ()
51 "Disconnects all connections in the pool"
53 #'(lambda (key conn-vector)
54 (declare (ignore key))
55 (dotimes (i (length conn-vector))
56 (disconnect (aref conn-vector i)))
57 (setf (fill-pointer conn-vector) 0))