view release on metacpan or  search on metacpan

lib/Kavorka.pm  view on Meta::CPAN

use PadWalker ();
use Parse::Keyword ();
use Module::Runtime ();
use Scalar::Util ();
use Sub::Util ();

package Kavorka;

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

our @ISA         = qw( Exporter::Tiny );
our @EXPORT      = qw( fun method );
our @EXPORT_OK   = qw( fun method after around before override augment classmethod objectmethod multi );
our %EXPORT_TAGS = (
	modifiers    => [qw( after around before )],
	allmodifiers => [qw( after around before override augment )],
);

our %IMPLEMENTATION = (
	after        => 'Kavorka::Sub::After',
	around       => 'Kavorka::Sub::Around',
	augment      => 'Kavorka::Sub::Augment',
	before       => 'Kavorka::Sub::Before',
	classmethod  => 'Kavorka::Sub::ClassMethod',
	f            => 'Kavorka::Sub::Fun',
	fun          => 'Kavorka::Sub::Fun',
	func         => 'Kavorka::Sub::Fun',
	function     => 'Kavorka::Sub::Fun',
	method       => 'Kavorka::Sub::Method',
	multi        => 'Kavorka::Multi',
	objectmethod => 'Kavorka::Sub::ObjectMethod',
	override     => 'Kavorka::Sub::Override',
);

our %INFO;

sub info
{
	my $me = shift;
	my $code = $_[0];
	$INFO{$code};
}

sub guess_implementation
{
	my $me = shift;
	$IMPLEMENTATION{$_[0]};
}

sub compose_implementation
{
	shift;
	require Moo::Role;
	Moo::Role->create_class_with_roles(@_);
}

sub _exporter_validate_opts
{
	my $class = shift;
	$^H{'Kavorka/package'} = $_[0]{into};
	$_[0]{replace} = 1 unless exists $_[0]{replace};
}

sub _fqname ($;$)
{
	my $name = shift;
	my ($package, $subname);
	
	$name =~ s{'}{::}g;
	
	if ($name =~ /::/)
	{
		($package, $subname) = $name =~ m{^(.+)::(\w+)$};
	}
	else
	{
		my $caller = @_ ? shift : $^H{'Kavorka/package'};
		($package, $subname) = ($caller, $name);
	}
	
	return wantarray ? ($package, $subname) : "$package\::$subname";
}


sub _exporter_fail
{
	my $me = shift;
	my ($name, $args, $globals) = @_;
	
	my $implementation =
		$args->{'implementation'}
		// $me->guess_implementation($name)
		// $me;
	
	my $into = $globals->{into};
	
	Module::Runtime::use_package_optimistically($implementation);
	
	{
		my $traits = $globals->{traits} // $args->{traits};
		$implementation = $me->compose_implementation($implementation, @$traits)
			if $traits;
	}
	
	$implementation->can('parse')
		or Carp::croak("No suitable implementation for keyword '$name'");
	
	# Workaround for RT#95786 which might be caused by a bug in the Perl
	# interpreter.
	# Also RT#98666 is why we can't just call undefer_all.
	require Sub::Defer;
	for (keys %Sub::Defer::DEFERRED) {
		no warnings;
		Sub::Defer::undefer_sub($_)
			if $Sub::Defer::DEFERRED{$_} && $Sub::Defer::DEFERRED{$_}[0] =~ /\AKavorkaX?\b/;
	}
	
	# Kavorka::Multi (for example) needs to know what Kavorka keywords are
	# currently in scope.
	$^H{'Kavorka'} .= "$name=$implementation ";