view release on metacpan or  search on metacpan

lib/DBIx/Connector/Pool.pm  view on Meta::CPAN

our @ISA              = ('DBIx::Connector');
our $not_in_use_event = sub {
	$_[0]->used_now;
};

sub _rebase {
	my ($base) = @_;
	if ($base) {
		$ISA[0] = $base;
	}
}

sub import {
	my ($class, $base) = @_;
	_rebase $base;
}

sub used_now {
	$_[0]->{_item_last_use} = time;
}

sub txn {
	my $self = $_[0];
	my $use_guard
		= DBIx::Connector::Pool::Item::_on_destroy->new(\$_[0]->{_item_in_use}, $not_in_use_event, $_[0]);
	$_[0]->used_now;
	shift->SUPER::txn(@_);
}

sub run {
	my $use_guard
		= DBIx::Connector::Pool::Item::_on_destroy->new(\$_[0]->{_item_in_use}, $not_in_use_event, $_[0]);
	$_[0]->used_now;
	shift->SUPER::run(@_);
}

sub item_in_use {
	$_[0]->{_item_in_use};
}

sub item_last_use {
	$_[0]->{_item_last_use};
}

package DBIx::Connector::Pool;
use warnings;
use strict;
use Carp;
use Time::HiRes 'time';

our $VERSION = "0.02";

sub new {
	my ($class, %args) = @_;
	$args{initial}   //= 1;
	$args{tid_func}  //= sub {1};
	$args{wait_func} //= sub {croak "real waiting function must be supplied"};
	$args{max_size} ||= -1;
	$args{keep_alive}     //= -1;
	$args{user}           //= ((getpwuid $>)[0]);
	$args{password}       //= '';
	$args{attrs}          //= {};
	$args{dsn}            //= 'dbi:Pg:dbname=' . $args{user};
	$args{connector_mode} //= 'fixup';
	if ($args{max_size} > 0 && $args{initial} != 0 && $args{initial} > $args{max_size}) {
		$args{initial} = $args{max_size};
	}
	$args{pool} = [];
	my $self = bless \%args, $class;
	if ($args{connector_base}) {
		DBIx::Connector::Pool::Item::_rebase($args{connector_base});
	}
	$self->_make_initial;
	$self;
}

sub _make_initial {
	my $self = $_[0];
	for my $i (0 .. $self->{initial} - 1) {
		$self->{pool}[$i] = {
			tid       => undef,
			connector => (
				       DBIx::Connector::Pool::Item->new($self->{dsn}, $self->{user}, $self->{password}, $self->{attrs})
					or croak "Can't create initial connect: " . DBI::errstr
			)
		};
		$self->{pool}[$i]{connector}->mode($self->{connector_mode});
	}
}

sub connected_size {
	my $self           = $_[0];
	my $connected_size = 0;
	for my $i (0 .. @{$self->{pool}} - 1) {
		if (defined($self->{pool}[$i]{tid}) && $self->{pool}[$i]{connector}) {
			++$connected_size;
		}
	}
	$connected_size;
}

sub collect_unused {
	my $self           = $_[0];
	my $connected_size = $self->connected_size;
	return if $connected_size <= $self->{initial};
	my $i;
	my $remove_sub = sub {
		if ($i == @{$self->{pool}} - 1) {
			pop @{$self->{pool}};
		} else {
			$self->{pool}[$i] = {};
		}
		--$connected_size;
	};
	my $now = time;
	for ($i = @{$self->{pool}} - 1; $i >= 0 && $connected_size > $self->{initial}; --$i) {
		if ($self->{pool}[$i]{connector} && !$self->{pool}[$i]{connector}->item_in_use) {
			if ($now - $self->{pool}[$i]{connector}->item_last_use > $self->{keep_alive}) {
				$remove_sub->();
			} else {