sql/pool.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          pool.cl
   6 ;;;; Purpose:       Support function for connection pool
   7 ;;;; Programmers:   Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2002
   9 ;;;;
  10 ;;;; $Id: pool.cl,v 1.2 2002/04/28 00:50:17 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :clsql-sys)
  21
  22 (defvar *db-pool* (make-hash-table :test #'equal))
  23
  24 (defun make-conn-vector ()
  25   "Creates an empty connection vector"
  26   (make-array 5 :fill-pointer 0 :adjustable t))
  27
  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 key *db-pool*)))
  32     (unless conn-vector
  33       (setq conn-vector (make-conn-vector))
  34       (setf (gethash key *db-pool*) conn-vector))
  35     conn-vector))
  36
  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))
  40       (vector-push-extend
  41        (connect connection-spec :database-type database-type :if-exists :new)
  42        conn-vector))
  43     (vector-pop conn-vector)))
  44
  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)))
  49
  50 (defun disconnect-pooled ()
  51   "Disconnects all connections in the pool"
  52   (maphash
  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))
  58    *db-pool*)
  59   t)