File Coverage

blib/lib/Role/Inspector.pm

Criterion	Covered	Total	%
statement	110	116	94.8
branch	57	76	75.0
condition	36	55	65.4
subroutine	18	18	100.0
pod	3	3	100.0
total	224	268	83.5

use 5.006;
use strict;
use warnings;

package Role::Inspector;

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

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} = [
			@{ $info->{provides} ||= [] },
			@{ $info->{requires} ||= [] },
		];
	}

	# if a method is in both `provides` and `requires`, remove from `requires`
	my %lookup;
	undef $lookup{$_} for @{$info->{provides}};
	@{$info->{requires}} = grep !exists($lookup{$_}), @{$info->{requires}};

	for my $k (qw/ api provides requires /) {
		@{ $info->{$k} } = sort(
			uniq(
				map ref($_) ? $_->{name} : $_,
				@{ $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';

	my @requires = @{ $Role::Tiny::INFO{$role}{requires} or [] };

	my $modifiers = $Role::Tiny::INFO{$role}{modifiers} || [];
	foreach my $modifier (@$modifiers) {
		my @modified = @$modifier[ 1 .. $#$modifier - 1 ];
		# handle: before ['foo', 'bar'] => sub { ... }
		@modified = @{ $modified[0] } if ref $modified[0] eq 'ARRAY';
		push @requires, @modified;
	}

	return {
		name     => $role,
		type     => $type,
		api      => [ @methods, @requires ],
		provides => [ keys %{ $type->_concrete_methods_of($role) } ],
		requires => \@requires,
	};
};

# 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');

	my (@provides, @requires);
	push @provides, $meta->get_method_list;
	push @provides, __PACKAGE__->_expand_attributes($role, $meta);
	push @requires, map($_->name, $meta->get_required_method_list);
	for my $kind (qw/before after around/) {
		my $accessor = "get_${kind}_method_modifiers_map";
		push @requires, keys %{ $meta->$accessor };
	}

	return {
		name     => $role,
		type     => 'Moose::Role',
		meta     => $meta,
		provides => \@provides,
		requires => \@requires,
	};
};

# 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');

	my (@provides, @requires);
	push @provides, $meta->get_method_list;
	push @provides, __PACKAGE__->_expand_attributes($role, $meta);
	push @requires, $meta->get_required_method_list;
	for my $kind (qw/before after around/) {
		push @requires, keys %{ $meta->{"${kind}_method_modifiers"} };
	}

	return {
		name     => $role,
		type     => 'Mouse::Role',
		meta     => $meta,
		provides => \@provides,
		requires => \@requires,
	};
};

# 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 => [ keys %{ 'Role::Basic'->_get_methods($role) } ],
		requires => [ '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__

=pod

=encoding utf-8

=for stopwords metaobject

=head1 NAME

Role::Inspector - introspection for roles

=head1 SYNOPSIS

   use strict;
   use warnings;
   use feature qw(say);

   {
      package Local::Role;
      use Role::Tiny;   # or Moose::Role, Mouse::Role, etc...

      requires qw( foo );

      sub bar { ... }
   }

   use Role::Inspector qw( get_role_info );

   my $info = get_role_info('Local::Role');

   say $info->{name};          # Local::Role
   say $info->{type};          # Role::Tiny
   say for @{$info->{api}};    # bar
                               # foo

=head1 DESCRIPTION

This module allows you to retrieve a hashref of information about a
given role. The following role implementations are supported:

=over

=item *

L<Moose::Role>

=item *

L<Mouse::Role>

=item *

L<Moo::Role>

=item *

L<Role::Tiny>

=item *

L<Role::Basic>

=item *

L<p5-mop-redux|https://github.com/stevan/p5-mop-redux>

=back

=head2 Functions

=over

=item C<< get_role_info($package_name) >>

Returns a hashref of information about a role; returns C<undef> if the
package does not appear to be a role. Attempts to load the package
using L<Module::Runtime> if it's not already loaded.

The hashref may contain the following keys:

=over

=item *

C<name> - the package name of the role

=item *

C<type> - the role implementation used by the role

=item *

C<api> - an arrayref of method names required/provided by the role

=item *

C<provides> and C<requires> - the same as C<api>, but split into lists
of methods provided and required by the role

=item *

C<meta> - a metaobject for the role (e.g. a L<Moose::Meta::Role> object).
This key may be absent if the role implementation does not provide a
metaobject

=back

This function may be exported, but is not exported by default.

=item C<< does_role($thing, $role) >>

Returns a boolean indicating if C<< $thing >> does role C<< $role >>.
C<< $thing >> can be an object, a class name, or a role name.

This should mostly give the same answers as C<< $thing->DOES($role) >>,
but may be slightly more reliable in some cross-implementation (i.e.
Moose roles consuming Moo roles) cases.

This function may be exported, but is not exported by default.

=back

=head2 Methods

If you do not wish to export the functions provided by Role::Inspector,
you may call them as a class methods:

   my $info = Role::Inspector->get_role_info($package_name);

   $thing->blah() if Role::Inspector->does_role($thing, $role);

=head2 Extending Role::Inspector

=over

=item C<< Role::Inspector::learn { BLOCK } >>

In the unlikely situation that you have to deal with some other role
implementation that Role::Inspector doesn't know about, you can teach
it:

   use Role::Inspector qw( learn );

   learn {
      my $r = shift;
      return unless My::Implementation::is_role($r);
      return {
         name     => $r,
         type     => 'My::Implementation',
         provides => [ sort(@{My::Implementation::provides($r)}) ],
         requires => [ sort(@{My::Implementation::requires($r)}) ],
      };
   };

An alternative way to do this is:

   push @Role::Inspector::SCANNERS, sub {
      my $r = shift;
      ...;
   };

You can do the C<push> thing without having loaded Role::Inspector.
This makes it suitable for doing inside My::Implementation itself,
without introducing an additional dependency on Role::Inspector.

Note that if you don't provide all of C<provides>, C<requires>, and
C<api>, Role::Inspector will attempt to guess the missing parts.

=back

=head1 CAVEATS

=over

=item *

It is difficult to distinguish between L<Moo::Role> and L<Role::Tiny>
roles. (The distinction is not often important anyway.) Thus sometimes
the C<type> for a Moo::Role may say C<< "Role::Tiny" >>.

=item *

The way that Role::Basic roles are detected and introspected is a bit
dodgy, relying on undocumented methods.

=item *

Where Moose or Mouse roles define attributes, those attributes tend to
result in accessor methods being generated. However neither of these
frameworks provides a decent way of figuring out which accessor methods
will result from composing the role with the class.

Role::Inspector does its damnedest to figure out the list of likely
methods, but (especially in the case of unusual attribute traits) may
get things wrong from time to time.

=back

=head1 BUGS

Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Role-Inspector>.

=head1 SEE ALSO

L<Class::Inspector>.

=head1 AUTHOR

Toby Inkster E<lt>[e-mail]<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2014 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.