File Coverage

blib/lib/DBIx/Roles/Shared.pm

Criterion	Covered	Total	%
statement	47	51	92.1
branch	12	18	66.6
condition			n/a
subroutine	4	4	100.0
pod	0	2	0.0
total	63	75	84.0

# $Id: Shared.pm,v 1.4 2005/12/19 15:02:00 dk Exp $

package DBIx::Roles::Shared;

use strict;
use vars qw(%instances %dsns $VERSION);

$VERSION = '1.00';

sub connect
{
	my ( $self, undef, $dsn, $user, $pass, $attr) = @_;

	my $inst_key = "$self";
	my $dsn_key = join( ' | ', $dsn, $user, $pass);
	my $dbh;

	if ( exists $instances{$inst_key}) {
		# apparently, connect() without disconnect --
		# 1. find if the object was connected to another handle, and clean it up
		keys %dsns; # reset each()
		while ( my ( $k, $v) = each %dsns) {
			my @d = grep { $_ != $self } @$v;
			next if @d == @$v;
			# found a connection
			last if $k eq $dsn_key; # yes, it is trying to reconnect
			# cleanup
			@d ? ( @$v = @d ) : delete $dsns{$k};
			delete $instances{"$self"};
			goto DEFAULT_CONNECT;
		}
		# 2. reconnect and apply the new handle to all the shared objects
		eval { $dbh = $self-> super( $dsn, $user, $pass, $attr); };
		my $exception = $@;

		for my $obj (@{$dsns{$dsn_key}}) {
			$obj-> dbh( $dbh);
		}
		$instances{$inst_key} = $dbh;

		die $exception if $exception;
	} else {
	DEFAULT_CONNECT:
		if ( exists $dsns{$dsn_key}) {
			# reuse an existing connection
			$dbh = $dsns{$dsn_key}-> [0]-> dbh;
		} else {
			# new connection
			$dbh = $self-> super( $dsn, $user, $pass, $attr);
			return undef unless $dbh;
			$instances{$inst_key} = $dbh;
		}
		push @{$dsns{$dsn_key}}, $self;
	}

	return $dbh;
}

sub disconnect
{
	my $self = $_[0];

	keys %dsns; # reset each()
	while ( my ( $k, $v) = each %dsns) {
		my @d = grep { $_ != $self } @$v;
		if ( @d == @$v) {
			# not found
			next;
		} elsif ( @d) {
			# remove the shared connection from the list but do not disconnect
			@$v = @d;
			delete $instances{"$self"};
			$self-> dbh( undef); # disconnect can be called twice
			return;
		} else {
			# that was the last reference, disconnect
			delete $dsns{$k};
			last;
		}
	}

	# also disconnect if wasn't found somehow
	delete $instances{"$self"};
	$self-> super();
}

1;

__DATA__