From: Kevin Rosenberg Date: Wed, 3 Jun 2009 00:28:48 +0000 (-0600) Subject: Version 4.0.5 X-Git-Tag: v4.0.5~4 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=b0aeb15f9ab4059792ffef6b819bf795755ff8b4 Version 4.0.5 02 Jun 2009 Kevin Rosenberg * Version 4.0.5 * sql/database.lisp: Add process-lock for deleting database from a pool (thanks to Ralf Mattes). --- diff --git a/ChangeLog b/ChangeLog index 92444cc..0e1c1d6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +02 Jun 2009 Kevin Rosenberg + * Version 4.0.5 + * sql/database.lisp: Add process-lock for deleting database from + a pool (thanks to Ralf Mattes). + 25 Feb 2008 Kevin Rosenberg * Version 4.0.4 * sql/expressions.lisp: Remove stray form (thanks to Samuel Ward) diff --git a/db-mysql/Makefile b/db-mysql/Makefile index 63004c7..bffec74 100644 --- a/db-mysql/Makefile +++ b/db-mysql/Makefile @@ -28,7 +28,7 @@ shared_lib=$(base).so all: $(shared_lib) CFLAGS=-I /usr/local/include/mysql -I /usr/include/mysql -I /sw/include/mysql -I /opt/local/include/mysql -I /usr/local/mysql/include -LDFLAGS=-L/usr/local/lib64/mysql -L/usr/local/lib/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/usr/local/mysql/lib -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lz -lc +LDFLAGS=-L/usr/local/lib64/mysql -L/usr/local/mysql/lib32 -L/usr/local/lib/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/usr/local/mysql/lib -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lz -lc ifneq ($(OS_CYGWIN),0) CFLAGS=-I /cygdrive/c/Program\ Files/MySQL/MySQL\ Server\ 5.0/include diff --git a/db-mysql/clsql_mysql.dylib b/db-mysql/clsql_mysql.dylib new file mode 100644 index 0000000..e637f21 Binary files /dev/null and b/db-mysql/clsql_mysql.dylib differ diff --git a/db-mysql/z.dylib b/db-mysql/z.dylib new file mode 100644 index 0000000..8821d09 Binary files /dev/null and b/db-mysql/z.dylib differ diff --git a/sql/#pool.lisp# b/sql/#pool.lisp# new file mode 100644 index 0000000..4573155 --- /dev/null +++ b/sql/#pool.lisp# @@ -0,0 +1,133 @@ +;;;; -*- 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 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 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) + +(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 (make-array 5 :fill-pointer 0 :adjustable t)) + (all-connections :accessor all-connections + :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (lock :accessor conn-pool-lock + :initform (make-process-lock "Connection pool")))) + +(defun acquire-from-conn-pool (pool) + (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (when (plusp (length (free-connections pool))) + (let ((pconn (vector-pop (free-connections pool)))) + ;; test if connection still valid. + ;; Currently, on supported on MySQL + (cond + ((eq :mysql (database-type pconn)) + (handler-case + (database-query "SHOW ERRORS LIMIT 1" pconn nil nil) + (error (e) + ;; we could check for error type 2006 for "SERVER GONE AWAY", + ;; but, it's safer just to disconnect the pooled conn for any error + (warn "Database connection ~S had an error when attempted to be acquired from the pool: + ~S +Disconnecting.~%" + pconn e) + (ignore-errors (database-disconnect pconn)) + nil) + (:no-error (res fields) + (declare (ignore res fields)) + pconn))) + (t + pconn))))) + (let ((conn (connect (connection-spec pool) + :database-type (pool-database-type pool) + :if-exists :new + :make-default nil))) + (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (vector-push-extend conn (all-connections pool)) + (setf (conn-pool conn) pool)) + conn))) + +(defun release-to-conn-pool (conn) + (let ((pool (conn-pool conn))) + (with-process-lock ((conn-pool-lock pool) "Release to pool") + (vector-push-extend conn (free-connections pool))))) + +(defun clear-conn-pool (pool) + (with-process-lock ((conn-pool-lock pool) "Clear pool") + (loop for conn across (all-connections pool) + do (setf (conn-pool conn) nil) + ;; disconnect may error if remote side closed connection + (ignore-errors (disconnect :database conn))) + (setf (fill-pointer (free-connections pool)) 0) + (setf (fill-pointer (all-connections pool)) 0)) + 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" + (with-process-lock (*db-pool-lock* "Find-or-create connection") + (let* ((key (list connection-spec database-type)) + (conn-pool (gethash key *db-pool*))) + (unless conn-pool + (setq conn-pool (make-instance 'conn-pool + :connection-spec connection-spec + :pool-database-type database-type)) + (setf (gethash key *db-pool*) conn-pool)) + conn-pool))) + +(defun acquire-from-pool (connection-spec database-type &optional pool) + (unless (typep pool 'conn-pool) + (setf pool (find-or-create-connection-pool connection-spec database-type))) + (acquire-from-conn-pool pool)) + +(defun release-to-pool (database) + (release-to-conn-pool database)) + +(defun disconnect-pooled (&optional clear) + "Disconnects all connections in the pool." + (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-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))) diff --git a/sql/database.lisp b/sql/database.lisp index 9b71644..14bcdc8 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -166,11 +166,12 @@ from a pool it will be released to this pool." (let ((database (find-database database :errorp (and database error)))) (when database (if (conn-pool database) - (when (release-to-pool database) - (setf *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setf *default-database* (car *connected-databases*))) - t) + (with-process-lock ((conn-pool-lock pool) "Delete from pool") + (when (release-to-pool database) + (setf *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setf *default-database* (car *connected-databases*))) + t)) (when (database-disconnect database) (setf *connected-databases* (delete database *connected-databases*)) (when (eq database *default-database*) diff --git a/uffi/clsql_uffi.dylib b/uffi/clsql_uffi.dylib new file mode 100644 index 0000000..3741fc2 Binary files /dev/null and b/uffi/clsql_uffi.dylib differ diff --git a/uffi/z.dylib b/uffi/z.dylib new file mode 100644 index 0000000..39d4200 Binary files /dev/null and b/uffi/z.dylib differ