File Coverage

blib/lib/MooX/late.pm

Criterion	Covered	Total	%
statement	118	129	91.4
branch	21	32	65.6
condition	5	19	26.3
subroutine	30	30	100.0
pod	0	3	0.0
total	174	213	81.6

use 5.008;
use strict;
use warnings;

package MooX::late;
our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.016';

use Moo              qw( );
use Carp             qw( carp croak );
use Scalar::Util     qw( blessed );
use Module::Runtime  qw( is_module_name );

BEGIN {
	package MooX::late::DefinitionContext;
	our $AUTHORITY = 'cpan:TOBYINK';
	our $VERSION   = '0.016';

	use Moo;
	use overload (
		q[""]    => 'to_string',
		q[bool]  => sub { 1 },
		fallback => 1,
	);

	has package  => (is => 'ro');
	has filename => (is => 'ro');
	has line     => (is => 'ro');

	sub to_string
	{
		my $self = shift;
		sprintf(
			'%s:%d, package %s',
			$self->filename,
			$self->line,
			$self->package,
		);
	}

	sub new_from_caller
	{
		my ($class, $level) = @_;
		$level = 0 unless defined $level;

		my ($p, $f, $c) = caller($level + 1);
		return $class->new(
			package  => $p,
			filename => $f,
			line     => $c,
		);
	}
};

# SUBCLASSING
# This is a hook for people subclassing MooX::late.
# It should be easy to tack on your own handlers
# to the end of the list. A handler is only called
# if exists($spec{$handler_name}) in the attribute
# spec.
#
sub _handlers
{
	qw( isa does lazy_build traits );
}

# SUBCLASSING
# Not really sure why you'd want to override
# this.
#
sub _definition_context_class
{
	"MooX::late::DefinitionContext";
}

sub import
{
	my $me = shift;
	my $caller = caller;

	my $install_tracked;
	{
		no warnings;
		if ($Moo::MAKERS{$caller})
		{
			$install_tracked = \&Moo::_install_tracked;
		}
		elsif ($Moo::Role::INFO{$caller})
		{
			$install_tracked = \&Moo::Role::_install_tracked;
		}
		else
		{
			croak "MooX::late applied to a non-Moo package"
				. "(need: use Moo or use Moo::Role)";
		}
	}

	my $orig = $caller->can('has')  # lolcat
		or croak "Could not locate 'has' function to alter";

	my @handlers = $me->_handlers;

	# SUBCLASSING
	# MooX::late itself does not provide a
	# `_finalize_attribute` method. Your subclass
	# can, in which case it will be called right
	# before setting up the attribute.
	#
	my $finalize = $me->can("_finalize_attribute");

	$install_tracked->(
		$caller, has => sub
		{
			my ($proto, %spec) = @_;
			my $context = $me->_definition_context_class->new_from_caller(0);

			for my $name (ref $proto ? @$proto : $proto)
			{
				my $spec = +{ %spec }; # shallow clone

				for my $option (@handlers)
				{
					next unless exists $spec->{$option};
					my $handler = $me->can("_handle_$option");

					# SUBCLASSING
					# Note that handlers are called as methods, and
					# get passed:
					# 1. the attribute name
					# 2. the attribute spec (hashref, modifiable)
					# 3. a context object
					# 4. the name of the caller class/role
					#
					$me->$handler($name, $spec, $context, $caller);
				}

				$me->$finalize($name, $spec, $context, $caller) if $finalize;
				$orig->($name, %$spec);
			}
			return;
		},
	);

	$me->_install_sugar($caller, $install_tracked);
}

# SUBCLASSING
# This can be used to install additional functions
# into the caller package.
#
sub _install_sugar
{
	my $me = shift;
	my ($caller, $installer) = @_;
	$installer->($caller, blessed => \&Scalar::Util::blessed);
	$installer->($caller, confess => \&Carp::confess);
}

sub _handle_isa
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;
	return if ref $spec->{isa};

	require Type::Utils;
	$spec->{isa} = Type::Utils::dwim_type($spec->{isa}, for => $class);

	return;
}

sub _handle_does
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;
	return unless defined $spec->{does};

	require Types::Standard;
	$spec->{isa} = Types::Standard::ConsumerOf()->of($spec->{does});

	return;
}

sub _handle_lazy_build
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;
	return unless delete $spec->{lazy_build};

	$spec->{is}      ||= "ro";
	$spec->{lazy}    ||= 1;
	$spec->{builder} ||= "_build_$name";

	if ($name =~ /^_/)
	{
		$spec->{clearer}   ||= "_clear$name";
		$spec->{predicate} ||= "_has$name";
	}
	else
	{
		$spec->{clearer}   ||= "clear_$name";
		$spec->{predicate} ||= "has_$name";
	}

	return;
}

sub _handle_traits
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;

	my @new;
	foreach my $trait (@{ $spec->{traits} || [] })
	{
		my $handler = $me->can("_handletrait_$trait");
		croak "$me cannot process trait $trait" unless $handler;

		# SUBCLASSING
		# There is a second level of handlers for traits.
		# Just add a method called "_handletrait_Foo"
		# and it will be called to handle the trait "Foo".
		# These handlers should normally return the empty
		# list, but may return a list of strings to add to
		# a *new* traits arrayref.
		#
		push @new, $me->$handler(@_);
	}

	$spec->{traits} = \@new;

	if ($spec->{handles_via})
	{
		eval "require MooX::HandlesVia"
			or croak("Requires MooX::HandlesVia for attribute trait defined at $context");

		my ($name, %spec) = MooX::HandlesVia::process_has($name, %$spec);
		%$spec = %spec;
	}

	return;
}

sub _handletrait_Array
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;

	$spec->{handles_via} = "Data::Perl::Collection::Array::MooseLike";

	return;
}

sub _handletrait_Hash
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;

	$spec->{handles_via} = "Data::Perl::Collection::Hash::MooseLike";

	return;
}

sub _handletrait_Code
{
	my $me = shift;
	my ($name, $spec, $context, $class) = @_;

	$spec->{handles_via} = "Data::Perl::Code";

	# Special handling for execute_method!
	while (my ($k, $v) = each %{ $spec->{handles} })
	{
		next unless $v eq q(execute_method);

		# MooX::HandlesVia can't handle this right yet.
		delete $spec->{handles}{$k};

		# ... so we handle it ourselves.
		eval qq{
			package ${class};
			sub ${k} {
				my \$self = shift;
				return \$self->${name}->(\$self, \@_);
			}
		};
	}

	return;
}

1;

__END__