view release on metacpan or  search on metacpan

Roles.pm  view on Meta::CPAN

# $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;