/usr/share/common-lisp/source/clsql/sql/pool.lisp is in cl-sql 6.7.0-1.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: pool.lisp
;;;; Purpose: Support function for connection pool
;;;; Programmers: Kevin M. Rosenberg, Marc Battyani
;;;; Date Started: Apr 2002
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002-2010 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.
;;;; *************************************************************************
(in-package #:clsql-sys)
(defparameter *db-pool-max-free-connections* 4
"Threshold of free-connections in the pool before we disconnect a database
rather than returning it to the pool. NIL for no limit. This is really a
heuristic that should, on avg keep the free connections about this size.")
(defvar *db-pool* (make-hash-table :test #'equal))
(defvar *db-pool-lock* (make-process-lock "DB Pool lock"))
(defclass conn-pool ()
((connection-spec :accessor connection-spec :initarg :connection-spec)
(database-type :accessor pool-database-type :initarg :pool-database-type)
(free-connections :accessor free-connections :initform nil)
(all-connections :accessor all-connections :initform nil)
(lock :accessor conn-pool-lock
:initform (make-process-lock "Connection pool"))))
(defun acquire-from-pool (connection-spec database-type &optional pool (encoding *default-encoding*))
"Try to find a working database connection in the pool or create a new
one if needed. This performs 1 query against the DB to ensure it's still
valid. When possible (postgres, mssql) that query will be a reset
command to put the connection back into its default state."
(unless (typep pool 'conn-pool)
(setf pool (find-or-create-connection-pool connection-spec database-type)))
(or
(loop for pconn = (with-process-lock ((conn-pool-lock pool) "Acquire")
(pop (free-connections pool)))
always pconn
thereis
;; test if connection still valid.
;; (e.g. db reboot -> invalid connection )
(handler-case
(progn (database-acquire-from-conn-pool pconn)
pconn)
(sql-database-error (e)
;; we could check for a specific error,
;; but, it's safer just to disconnect the pooled conn for any error ?
(warn "Database connection ~S had an error while acquiring from the pool:
~S
Disconnecting.~%"
pconn e)
;;run database disconnect to give chance for cleanup
;;there, then remove it from the lists of connected
;;databases.
(%pool-force-disconnect pconn)
(with-process-lock ((conn-pool-lock pool) "remove dead conn")
(setf (all-connections pool)
(delete pconn (all-connections pool))))
nil)))
(let ((conn (connect (connection-spec pool)
:database-type (pool-database-type pool)
:if-exists :new
:make-default nil
:encoding encoding)))
(setf (conn-pool conn) pool)
(with-process-lock ((conn-pool-lock pool) "new conection")
(push conn (all-connections pool)))
conn)))
(defun release-to-pool (database &optional (pool (conn-pool database)))
"Release a database connection to the pool. The backend will have a
chance to do cleanup."
(unless (conn-pool database) (setf (conn-pool database) pool))
(cond
;;We read the list of free-connections outside the lock. This
;;should be fine as long as that list is never dealt with
;;destructively (push and pop destructively modify the place,
;;not the list). Multiple threads getting to this test at the
;;same time might result in the free-connections getting
;;longer... meh.
((or (and *db-pool-max-free-connections*
(>= (length (free-connections pool))
*db-pool-max-free-connections*)))
(%pool-force-disconnect database)
(with-process-lock ((conn-pool-lock pool) "Remove extra Conn")
(setf (all-connections pool)
(delete database (all-connections pool)))))
(t
;;let it do cleanup
(database-release-to-conn-pool database)
(with-process-lock ((conn-pool-lock pool) "Release to pool")
(push database (free-connections pool))))))
(defmethod database-acquire-from-conn-pool (database)
(case (database-underlying-type database)
(:postgresql
(database-execute-command "RESET ALL" database))
(:mysql
(database-query "SHOW ERRORS LIMIT 1" database nil nil))
(:mssql
;; rpc escape sequence since this can't be called as a normal sp.
;;http://msdn.microsoft.com/en-us/library/aa198358%28SQL.80%29.aspx
(database-execute-command "{rpc sp_reset_connection}" database))
(T
(database-query "SELECT 1;" database '(integer) nil))))
(defmethod database-release-to-conn-pool (database)
(case (database-underlying-type database)
(:postgresql
(ignore-errors
;;http://www.postgresql.org/docs/current/static/sql-discard.html
;;this was introduced relatively recently, wrap in ignore-errors
;;so that it doesn't choke older versions.
(database-execute-command "DISCARD ALL" database)))))
(defun clear-conn-pool (pool)
"Be careful this function will disconnect connections without regard
to whether another thread is actively using them."
(with-process-lock ((conn-pool-lock pool) "Clear pool")
(mapc #'%pool-force-disconnect (all-connections pool))
(setf (all-connections pool) nil
(free-connections pool) nil))
nil)
(defun find-or-create-connection-pool (connection-spec database-type)
"Find connection pool in hash table, creates a new connection pool
if not found"
(let ((key (list connection-spec database-type)))
(with-process-lock (*db-pool-lock* "Find-or-create connection")
(or (gethash key *db-pool*)
(setf (gethash key *db-pool*)
(make-instance 'conn-pool
:connection-spec connection-spec
:pool-database-type database-type))))))
(defun disconnect-pooled (&optional clear)
"Disconnects all connections in the pool. When clear, also deletes
the pool objects."
(with-process-lock (*db-pool-lock* "Disconnect pooled")
(maphash
#'(lambda (key conn-pool)
(declare (ignore key))
(clear-conn-pool conn-pool))
*db-pool*)
(when clear (clrhash *db-pool*)))
t)
(defun %pool-force-disconnect (database)
"Force disconnection of a connection from the pool."
;;so it isn't just returned to pool
(setf (conn-pool database) nil)
;; disconnect may error if remote side closed connection
(ignore-errors (disconnect :database database)))
;(defun pool-start-sql-recording (pool &key (types :command))
; "Start all stream in the pool recording actions of TYPES"
; (dolist (con (pool-connections pool))
; (start-sql-recording :type types
; :database (connection-database con))))
;(defun pool-stop-sql-recording (pool &key (types :command))
; "Start all stream in the pool recording actions of TYPES"
; (dolist (con (pool-connections pool))
; (stop-sql-recording :type types
; :database (connection-database con))))
;(defmacro with-database-connection (pool &body body)
; `(let ((connection (obtain-connection ,pool))
; (results nil))
; (unwind-protect
; (with-database ((connection-database connection))
; (setq results (multiple-value-list (progn ,@body))))
; (release-connection connection))
; (values-list results)))
|