File Coverage

blib/lib/Moops/Keyword/Role.pm

Criterion	Covered	Total	%
statement	38	39	97.4
branch	6	8	75.0
condition	2	3	66.6
subroutine	12	13	92.3
pod	0	5	0.0
total	58	68	85.2

use v5.14;
use strict;
use warnings FATAL => 'all';
no warnings qw(void once uninitialized numeric);

package Moops::Keyword::Role;

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

use Moo;
use B qw(perlstring);
extends qw( Moops::Keyword );

sub should_support_methods { 1 }

sub arguments_for_moosex_mungehas
{
	shift;
	return qw(eq_1);
}

my %using = (
	Moo   => 'use Moo::Role; use MooX::late;',
	Moose => 'use Moose::Role; use MooseX::KavorkaInfo;',
	Mouse => 'use Mouse::Role;',
	Tiny  => 'use Role::Tiny;',
	(
		map { $_ => "use $_;" }
		qw/ Role::Basic Role::Tiny Moo::Role Mouse::Role Moose::Role /
	),
);

sub default_oo_implementation
{
	'Moo';
}

sub generate_package_setup_oo
{
	my $self  = shift;
	my $using = $self->relations->{using}[0] // $self->default_oo_implementation;

	exists($using{$using})
		or Carp::croak("Cannot create a package using $using; stopped");

	my @lines = (
		'use namespace::autoclean -also => ["has", "lexical_has"];',
		'use Lexical::Accessor;',
	);
	push @lines, "use MooseX::MungeHas qw(@{[ $self->arguments_for_moosex_mungehas ]});"
		if $using =~ /^Mo/;

	return (
		$using{$using},
		$self->generate_package_setup_relationships,
		@lines,
	);
}

sub generate_package_setup_relationships
{
	my $self  = shift;
	my @roles = @{ $self->relations->{with} || [] };

	$self->_mk_guard(
		sprintf("with(%s);", join(",", map perlstring($_), @roles))
	) if @roles;
	return;
}

around known_relationships => sub
{
	my $next = shift;
	my $self = shift;
	return($self->$next(@_), qw/ with using /);
};

around qualify_relationship => sub
{
	my $next = shift;
	my $self = shift;
	$_[0] eq 'using' ? !!0 : $self->$next(@_);
};

around version_relationship => sub
{
	my $next = shift;
	my $self = shift;
	$_[0] eq 'using' ? !!0 : $self->$next(@_);
};

around arguments_for_kavorka => sub
{
	my $next = shift;
	my $self = shift;

	my @keywords = qw/ method before after around /;

	my $using = $self->relations->{using}[0] // $self->default_oo_implementation;
	push @keywords, qw/ override augment /
		if $using =~ /^Mo[ou]se\b/;

	return (
		$self->$next(@_),
		@keywords,
	);
};

1;