File Coverage

lib/Class/Roles.pm

Criterion	Covered	Total	%
statement	64	64	100.0
branch	14	16	87.5
condition	3	8	37.5
subroutine	14	14	100.0
pod	0	7	0.0
total	95	109	87.1

package Class::Roles;

use strict;
use Scalar::Util 'blessed';

use vars '$VERSION';
$VERSION = '0.30';

my %actions =
(
	role  => \&role,
	does  => \&does,
	multi => \&multi,
	apply => \&apply,
);

my (%roles, %does);

sub import
{
	my $caller          = caller();
	my $self            = shift;

	if ( @_ % 2 != 0 )
	{
		require Carp;
		Carp::croak( 'Improper argument list' );
	}

	while (my ($name, $value) = splice( @_, 0, 2 ))
	{
		unless (exists $actions{ $name })
		{
			require Carp;
			Carp::croak( "Unknown action '$name'" );
		}
		$actions{ $name }->( $caller, $value );
	}
}

sub role
{
	my ($caller, $role)   = @_;
	$role                 = [ $role ] unless ref $role eq 'ARRAY';
	$roles{ $caller }   ||= [];

	install_methods( $caller, $caller, @$role );
}

sub multi
{
	my ($caller, $multi) = @_;

	while (my ($role, $methods) = each %$multi)
	{
		$methods = [ $methods ] unless ref $methods eq 'ARRAY';
		install_methods( $caller, $role, @$methods );
	}
}

sub apply
{
	my ($caller, $args) = @_;
	my ($role, $to)     = @$args{ qw( role to ) };
	does( $to, $role );
}

sub does
{
	my ($caller, $role) = @_;

	no strict 'refs';
	for my $method (@{ $roles{ $role } })
	{
		my ($name, $code)           = @$method;
		my $export_name             = $caller . '::' . $name;
		*{ $export_name }           = $code unless defined &{ $export_name };
	}

	$does{ $caller }{ $role } = 1;
}

sub install_methods
{
	my ($source, $role, @methods) = @_;

	no strict 'refs';

	for my $method (@methods)
	{
		push @{ $roles{ $role } },
			[ $method, \&{ $source . '::' . $method } ];
	}
}

sub universal_does
{
	my ($invocant, $role) = @_;
	my $class               = blessed $invocant || $invocant;

	return 1 if $class eq $role;
	return 1 if exists $does{ $class }{ $role };

	return check_isa( $class, $role );
}

sub check_isa
{
	my ($class, $role) = @_;

	no strict 'refs';

	my @isa = @{ $class . '::ISA' };
	for my $parent (@isa)
	{
		return 1 if $parent->does( $role ) or check_isa( $parent, $role );
	}

	return;
}

*UNIVERSAL::does = \&universal_does;

1;
__END__