The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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.034';

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;