File Coverage

blib/lib/Role/Inspector.pm

Criterion	Covered	Total	%
statement	74	111	66.6
branch	25	76	32.8
condition	20	55	36.3
subroutine	17	18	94.4
pod	3	3	100.0
total	139	263	52.8

use 5.006;
use strict;
use warnings;

package Role::Inspector;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.005';

use Exporter::Shiny qw( get_role_info learn does_role );
use Module::Runtime qw( use_package_optimistically );
use Scalar::Util qw( blessed );

BEGIN {
	*uniq = eval { require List::MoreUtils }
		? \&List::MoreUtils::uniq
		: sub { my %already; grep !$already{$_}++, @_ }
}

our @SCANNERS;

sub learn (&)
{
	push @SCANNERS, $_[0];
}

sub get_role_info
{
	my $me = shift;
	use_package_optimistically($_[0]);
	my ($info) = grep defined, map $_->(@_), @SCANNERS;
	$me->_canonicalize($info, @_);
	return $info;
}

sub _generate_get_role_info
{
	my $me = shift;
	my ($name, $args, $globals) = @_;
	return sub {
		my $info = $me->get_role_info(@_);
		delete($info->{meta}) if $args->{no_meta};
		return $info;
	};
}

sub _canonicalize
{
	my $me = shift;
	my ($info) = @_;

	if ( $info->{api} and not( $info->{provides} && $info->{requires} ) )
	{
		my @provides;
		my @requires;
		for my $method (@{ $info->{api} })
		{
			push @{
				$info->{name}->can($method) ? \@provides : \@requires
			}, $method;
		}
		$info->{provides} ||= \@provides;
		$info->{requires} ||= \@requires;
	}

	if ( not $info->{api} )
	{
		$info->{api} = [sort(
			@{ $info->{provides} ||= [] },
			@{ $info->{requires} ||= [] },
		)];
	}

	for my $k (qw/ api provides requires /) {
		@{ $info->{$k} } =
			map ref($_) ? $_->{name} : $_,
			uniq @{ $info->{$k} };
	}
}

sub _expand_attributes
{
	my $me = shift;
	my ($role, $meta) = @_;

	my @attrs = map {
		my $data = $meta->get_attribute($_);
		$data->{name} = $_ unless exists($data->{name});
		$data;
	} $meta->get_attribute_list;
	my %methods;

	for my $attr (@attrs)
	{
		my $is = blessed($attr) && $attr->can('is') ? $attr->is : $attr->{is};
		$methods{blessed($attr) && $attr->can('name') ? $attr->name : $attr->{name} }++
			if $is =~ /\A(ro|rw|lazy|rwp)\z/i;

		for my $method_type (qw(reader writer accessor clearer predicate))
		{
			my $method_name = blessed($attr) ? $attr->$method_type : $attr->{$method_type};
			($method_name) = %$method_name if ref($method_name); # HASH :-(
			$methods{$method_name}++ if defined $method_name;
		}

		my $handles;
		if (blessed($attr) and $attr->can('_canonicalize_handles'))
		{
			$handles =
				$attr->can('_canonicalize_handles') ? +{ $attr->_canonicalize_handles } :
				$attr->can('handles') ? $attr->handles :
				$attr->{handles};
		}
		else
		{
			$handles = $attr->{handles};
		}

		if (!defined $handles)
		{
			# no-op
		}
		elsif (not ref($handles))
		{
			$methods{$_}++ for @{ $me->get_info($handles)->{api} };
		}
		elsif (ref($handles) eq q(ARRAY))
		{
			$methods{$_}++ for @$handles;
		}
		elsif (ref($handles) eq q(HASH))
		{
			$methods{$_}++ for keys %$handles;
		}
		else
		{
			require Carp;
			Carp::carp(
				sprintf(
					"%s contains attribute with delegated methods, but %s cannot determine which methods are being delegated",
					$role,
					$me,
				)
			);
		}
	}

	return keys(%methods);
}

# Learn about mop
learn {
	my $role = shift;
	return unless $INC{'mop.pm'};

	my $meta = mop::meta($role);
	return unless $meta && $meta->isa('mop::role');

	return {
		name     => $role,
		type     => 'mop::role',
		provides => [ sort(map($_->name, $meta->methods)) ],
		requires => [ sort($meta->required_methods) ],
		meta     => $meta,
	};
};

# Learn about Role::Tiny and Moo::Role
learn {
	my $role = shift;
	return unless $INC{'Role/Tiny.pm'};

	# Moo 1.003000 added is_role, but that's too new to rely on.
	my @methods;
	return unless eval {
		@methods = 'Role::Tiny'->methods_provided_by($role);
		1;
	};

	no warnings qw(once);
	my $type =
		($INC{'Moo/Role.pm'} and $Moo::Role::INFO{$role}{accessor_maker})
		? 'Moo::Role'
		: 'Role::Tiny';

	@methods = $type->methods_provided_by($role)
		if $type ne 'Role::Tiny';

	return {
		name     => $role,
		type     => $type,
		api      => [ sort(@methods) ],  # keep: potentially more accurate
		provides => [ sort keys %{ $type->_concrete_methods_of($role) } ],
		requires => [ sort @{ $Role::Tiny::INFO{$role}{requires} or [] } ],
	};
};

# Learn about Moose
learn {
	my $role = shift;
	return unless $INC{'Moose.pm'};

	require Moose::Util;
	my $meta = Moose::Util::find_meta($role);
	return unless $meta && $meta->isa('Moose::Meta::Role');

	return {
		name     => $role,
		type     => 'Moose::Role',
		meta     => $meta,
		provides => [ sort($meta->get_method_list, __PACKAGE__->_expand_attributes($role, $meta)) ],
		requires => [ sort(map($_->name, $meta->get_required_method_list)) ],
	};
};

# Learn about Mouse
learn {
	my $role = shift;
	return unless $INC{'Mouse.pm'};

	require Mouse::Util;
	my $meta = Mouse::Util::find_meta($role);
	return unless $meta && $meta->isa('Mouse::Meta::Role');

	return {
		name     => $role,
		type     => 'Mouse::Role',
		meta     => $meta,
		provides => [ sort($meta->get_method_list, __PACKAGE__->_expand_attributes($role, $meta)) ],
		requires => [ sort($meta->get_required_method_list) ],
	};
};

# Learn about Role::Basic
learn {
	my $role = shift;
	return unless $INC{'Role/Basic.pm'};

	return unless eval { 'Role::Basic'->_load_role($role) };

	return {
		name     => $role,
		type     => 'Role::Basic',
		provides => [ sort(keys(%{ 'Role::Basic'->_get_methods($role) })) ],
		requires => [ sort('Role::Basic'->get_required_by($role)) ],
	};
};

sub does_role
{
	my $me = shift;
	my ($thing, $role) = @_;

	return !!0 if !defined($thing);
	return !!0 if ref($thing) && !blessed($thing);

	ref($_) or use_package_optimistically($_) for @_;

	return !!1 if $thing->can('does') && $thing->does($role);
	return !!1 if $thing->can('DOES') && $thing->DOES($role);

	my $info = $me->get_role_info($role)
		or return !!0;

	if ($info->{type} eq 'Role::Tiny' or $info->{type} eq 'Moo::Role')
	{
		return !!1 if Role::Tiny::does_role($thing, $role);
	}

	if ($info->{type} eq 'Moose::Role')
	{
		require Moose::Util;
		return !!1 if Moose::Util::does_role($thing, $role);
	}

	if ($info->{type} eq 'Mouse::Role')
	{
		require Mouse::Util;
		return !!1 if Mouse::Util::does_role($thing, $role);
	}

	if (not ref $thing)
	{
		my $info2 = $me->get_role_info($thing) || { type => '' };

		if ($info2->{type} eq 'Role::Tiny' or $info2->{type} eq 'Moo::Role')
		{
			return !!1 if Role::Tiny::does_role($thing, $role);
		}

		if ($info2->{type} eq 'Moose::Role'
		or $INC{'Moose.pm'} && Moose::Util::find_meta($thing))
		{
			require Moose::Util;
			return !!1 if Moose::Util::does_role($thing, $role);
		}

		if ($info2->{type} eq 'Mouse::Role'
		or $INC{'Mouse.pm'} && Mouse::Util::find_meta($thing))
		{
			require Mouse::Util;
			return !!1 if Mouse::Util::does_role($thing, $role);
		}
	}

	# No special handling for Role::Basic, but hopefully checking
	# `DOES` worked!

	!!0;
}

# very simple class method curry
sub _generate_does_role
{
	my $me = shift;
	sub { $me->does_role(@_) };
}


1;

__END__