File Coverage

blib/lib/DBIx/Roles.pm

Criterion	Covered	Total	%
statement	226	257	87.9
branch	56	86	65.1
condition	6	8	75.0
subroutine	47	54	87.0
pod	2	4	50.0
total	337	409	82.4

# $Id: Roles.pm,v 1.18 2006/01/30 10:58:51 dk Exp $

package DBIx::Roles;

use DBI;
use Scalar::Util qw(weaken);
use strict;
use vars qw($VERSION %loaded_packages $DBI_connect %DBI_select_methods $debug $ExportDepth);

$VERSION = '1.04';
$ExportDepth = 0;
$DBI_connect = \&DBI::connect;
%DBI_select_methods = map { $_ => 1 } qw(
	selectrow_array
	selectrow_arrayref
	selectrow_hashref
	selectall_arrayref
	selectall_hashref
	selectcol_arrayref
);

sub import
{
	shift;
	return unless @_;

	# if given list of imports, override DBI->connect() with it
	my $callpkg = caller($ExportDepth);
	no strict;
	*{$callpkg."::DBIx_ROLES"}=[@_];
	use strict;
	local $SIG{__WARN__} = sub {};
	*DBI::connect = \&__DBI_import_connect;
}

# called instead of DBI-> connect
sub __DBI_import_connect
{
	shift;
	my $callpkg = caller(0);
	no strict;
	my @packages = @{$callpkg."::DBIx_ROLES"};
	use strict;
	if ( @packages) {
		return DBIx::Roles-> new( @packages)-> connect( @_);
	} else {
		return $DBI_connect->( 'DBI', @_);
	}
}

# prepare new instance, do not connect to DB
sub new
{
	my ( $class, @packages) = @_;

	# load the necessary packages
	for my $p ( @packages) {
		$p = "DBIx::Roles::$p" unless $p =~ /:/;
		next if exists $loaded_packages{$p};
		eval "use $p;";
		die $@ if $@;
		$loaded_packages{$p} = 1;
	}
	push @packages, 'DBIx::Roles::Default';

	##  create the object:
	# internal data instance
	my $instance	= {
		dbh	=> undef,     # DBI handle

		packages=> \@packages, # array of DBIx::Roles::* packages to use
		private	=> {          # packages' private data - all separated
			map { $_ => undef } @packages
		},
		defaults=> {},        # default values and source packages for attributes
		disabled=> {},        # dynamically disabled packages
		attr	=> {},        # packages' public data - all mixed, and
		vmt	=> {},        # packages' public methods - also all mixed
		                      # name clashes in public and vmt will be explicitly fatal

		loops   => [],
	};

	# populate package info
	for my $p ( @packages) {
		my $ref = $p->can('initialize');
		next unless $ref;
		my ( $storage, $data, @vmt) = $ref->( $instance);
		$instance-> {private}-> {$p} = $storage;

		# store default data
		if ( $data) {
			my $dst = $instance->{attr};
			my $def = $instance->{defaults};
			while ( my ( $key, $value) = each %$data) {
				die
					"Fatal: package '$p' defines attribute '$key' ".
					"that conflicts with package '$def->{$key}->[0]'"
						if exists $dst->{$key};
				$def->{$key} = [$p, $value];
				$dst->{$key} = $value;
			}
		}

		# store public methods
		my $dst = $instance->{vmt};
		for my $key ( @vmt) {
			die
				"Fatal: package '$p' defines method '$key' ".
				"that conflicts with package '$dst->{$key}'"
					if exists $dst->{$key};
			$dst->{$key} = $p;
		}
	}
	# DBIx::Roles::Instance provides API for the packages
	bless $instance, 'DBIx::Roles::Instance';

	# DBI attributes
	my $self 	= {};
	tie %{$self}, 'DBIx::Roles::Instance', $instance;
	bless $self, $class;

	# use this trick for cheap self-referencing ( otherwise the object is never destroyed )
	$instance->{self} = $self;
	weaken( $instance->{self});

	return $self;
}

# connect to DB
sub connect
{
	my $self = shift;

	unless ( ref($self)) {
		# called as DBIx::Roles-> connect(), packages provided
		$self = $self-> new( @{shift()});
	} # else the object is just being reconnected

	my $inst = $self-> instance;

	$self-> disconnect if $inst->{dbh};

	my @p = @_;

	# ask each package what do they think about params to connect
	$inst-> dispatch( 'rewrite', 'connect', \@p);

	# now, @p can be assumed to be in DBI-compatible format
	my ( $dsn, $user, $password, $attr) = @p;
	$attr ||= {};

	# validate each package's individual parameters
	for my $k ( keys %$attr) {
		next unless exists $inst->{defaults}->{$k};
		$inst-> dispatch( 'STORE', $k, $attr->{$k});
	}

	# apply eventual attributes passed from outside,
	# override with defaults those that have survived disconnect()
	for my $k ( keys %{$inst->{defaults}}) {
		if ( exists $attr-> {$k}) {
			$inst-> {attr}-> {$k} = $attr-> {$k};
			delete $attr-> {$k};
		} else {
			$inst-> {attr}-> {$k} = $inst->{defaults}->{$k}->[1];
		};
	}

	# try to connect
	return $self
		if $inst-> {dbh} = $inst-> connect( $dsn, $user, $password, $attr);
	die "Unable to connect: no suitable roles found\n"
		if $attr->{RaiseError};
	return undef;
}

# access object data instance
sub instance {  tied %{ $_[0] } }

# disconnect from DB, but retain the object
sub disconnect
{
	my $self = $_[0];
	my $inst = $self-> instance;

	$inst-> disconnect if $inst->{dbh};
}

sub AUTOLOAD
{
	my @p = @_;

	use vars qw($AUTOLOAD);
	my $method = $AUTOLOAD;
	$method =~ s/^.*:://;

	my $self = shift @p;
	my $inst = $self-> instance;

	my $package;

	if (
		exists( $DBI::DBI_methods{common}->{$method}) or
		exists( $DBI::DBI_methods{db}->{$method})
	) {
		# is it a DBI native method?
		# rewrite
		$inst-> dispatch( 'rewrite', $method, \@p);

		# dispatch
		@_ = ( $inst, $method, @p);
		goto $inst-> can('dispatch_dbi_method');
	} elsif ( exists $inst->{vmt}->{$method}) {
		# is it an exported method for outside usage?
		my $package = $inst->{vmt}->{$method};
		my $ref = $package-> can( $method);
		die "Package '$package' declared method '$method' as available, but it is not"
			unless $ref; # XXX AUTOLOAD cases are not handled
		@_ = ( $inst, $inst->{private}->{$package}, @p);
		goto $ref;
	} else {
		# none of the above, try wildcards
		@_ = ( $inst, 'any', $method, @p);
		goto $inst-> can('dispatch');
	}
}

sub DESTROY
{
	my $self = $_[0];
	my $inst = $self-> instance;
	$inst-> disconnect if $inst->{dbh};

	untie %$inst;
}

# internal API
package DBIx::Roles::Instance;

# since DBI::connect can be overloaded, call the connect method by reference
sub DBI_connect { shift; $DBIx::Roles::DBI_connect->('DBI', @_ ) }

# iterate through each package in the recursive way
sub get_super
{
	my ( $self) = @_;

	my $ref;
	my $ctx = $self->{loops}->[-1];
	while ( 1) {
		if ( $ctx->[0] < scalar @{$self-> {packages}}) {
			# next package
			my $package = $self-> {packages}->[ $ctx->[0]++];
			next if $self->{disabled}->{$package};
			next unless $ref = $package-> can( $ctx->[1]);
			print STDERR ('  'x @{$self->{loops}}), "-> $package\n" if $DBIx::Roles::debug;
			return ( $ref, $self-> {private}-> {$package});
		} elsif ( $ctx->[2]) {
			# signal end of list
			return $ctx->[2]->( $self, $ctx);
		} else {
			return;
		}
	}
}

# iterate through each package in the recursive way
sub super
{
	my $self = shift;
	my ( $ref, $private) = $self-> get_super;
	return unless $ref;
	unshift @_, $self, $private;
	goto $ref;
}

# saves and restores context of dispatch calls - needed if underlying roles
# are needed to be restarted
sub context
{
	if ( $#_) {
		@{$_[0]->{loops}->[-1]} = @{$_[1]};
	} else {
		return [ @{$_[0]->{loops}->[-1]} ];
	}
}

# call $method in all packages, where available, returns the result of the call
sub dispatch
{
	my $self = shift;
	my $eol_handler = shift if $_[0] and ref($_[0]);
	my $method = shift;

	my @ret;
	my $wa = wantarray;
	push @{$self->{loops}}, [ 0, $method, $eol_handler, 0];
	print STDERR ('  'x @{$self->{loops}}), "dispatch(",
		( join ',', map { defined($_) ? $_ : "undef"} $method,@_), ")\n"
			if $DBIx::Roles::debug;
	eval {
		if ( $wa) {
			@ret = $self-> super( @_);
		} else {
			$ret[0] = $self-> super( @_);
		}
	};
	print STDERR ('  'x @{$self->{loops}}), "done $method\n" if $DBIx::Roles::debug;
	pop @{$self->{loops}};
	die $@ if $@;
	return wantarray ? @ret : $ret[0];
}

# if called, then that means that all $method hooks were called,
# and now 'dbi_method' round must be run
sub _dispatch_dbi_eol
{
	my ( $self, $ctx, $params) = @_;

	$ctx->[0] = 0;               # reset the counter
	my $method = $ctx->[1];
	$ctx->[1] = 'dbi_method';    # call that hook instead
	$ctx->[2] = undef;           # clear the eol handler
	print STDERR ('  'x @{$self->{loops}}), "done($method),dispatch(dbi_method)\n" if $DBIx::Roles::debug;
	return sub { $_[0]-> super( $method, @_[2..$#_]) }
}

# dispatch a native DBI method - first $method, then dbi_method hooks
sub dispatch_dbi_method
{
	my ( $self, $method, @parameters) = @_;
	splice( @_, 1, 0, \&_dispatch_dbi_eol);
	goto &dispatch;
}

sub enable_roles
{
	my $hash = shift->{disabled};
	for my $p (@_) {
		my $g = ($p =~ /:/) ? $p : "DBIx::Roles::$p";
		$hash->{$g}-- if $hash->{$g} > 0;
	}
}

sub disable_roles
{
	my $hash = shift->{disabled};
	for my $p (@_) {
		my $g = ($p =~ /:/) ? $p : "DBIx::Roles::$p";
		$hash->{$g}++;
	}
}

# R/W access to the underlying DBI connection handle
sub dbh
{
	return $_[0]-> {dbh} unless $#_;
	$_[0]-> {dbh} = $_[1];
}

# access to the DBIx::Roles object
sub object { $_[0]-> {self} }

# all unknown functions, called by roles internally, are assumed to be DBI methods
sub AUTOLOAD
{
	use vars qw($AUTOLOAD);

	my $method = $AUTOLOAD;
	$method =~ s/^.*:://;

	splice( @_, 1, 0, $method);
	goto &dispatch_dbi_method;
}

sub TIEHASH { $_[1] }
sub EXISTS  { shift-> dispatch( 'EXISTS', @_) }
sub FETCH   { shift-> dispatch( 'FETCH',  @_) }
sub STORE   { shift-> dispatch( 'STORE',  @_) }
sub DELETE  { shift-> dispatch( 'DELETE', @_) }

sub DESTROY { shift-> dispatch( 'DESTROY') }

package DBIx::Roles::Default;

sub connect
{
	my ( $self, $storage, $dsn, $user, $password, $attr) = @_;
	return $DBIx::Roles::DBI_connect->( 'DBI', $dsn, $user, $password, $attr);
}

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

	$self-> {dbh}-> disconnect;
	$self-> {dbh} = undef;
}

sub dbi_method
{
	my ( $self, $storage, $method, @parameters) = @_;
	return $self-> {dbh}-> $method( @parameters);
}

sub any
{
	my ( $self, $storage, $method) = @_;
	my @c = caller( $self-> {loops}->[-1]->[3] * 2);
	die "Cannot locate method '$method' at $c[1] line $c[2]\n";
}

sub EXISTS
{
	my ( $self, $storage, $key) = @_;
	if ( exists $self-> {attr}-> {$key}) {
		return exists $self-> {attr}-> {$key};
	} else {
		return exists $self-> {dbh}-> {$key};
	}
}

sub FETCH
{
	my ( $self, $storage, $key) = @_;
	if ( exists $self-> {attr}-> {$key}) {
		return $self-> {attr}-> {$key};
	} else {
		return $self-> {dbh}-> {$key};
	}
}

sub STORE
{
	my ( $self, $storage, $key, $val) = @_;
	if ( exists $self-> {attr}-> {$key}) {
		$self-> {attr}-> {$key} = $val;
	} else {
		$self-> {dbh}-> {$key} = $val;
	}
}

sub DELETE
{
	my ( $self, $storage, $key) = @_;
	if ( exists $self-> {attr}-> {$key}) {
		delete $self-> {attr}-> {$key};
	} else {
		delete $self-> {dbh}-> {$key};
	}
}

1;

__DATA__