File Coverage

blib/lib/Class/Tiny/Antlers.pm

Criterion	Covered	Total	%
statement	157	214	73.3
branch	78	124	62.9
condition	31	51	60.7
subroutine	32	36	88.8
pod	5	6	83.3
total	303	431	70.3

package Class::Tiny::Antlers;

sub _getstash { \%{"$_[0]::"} }

use 5.006;
use strict;
use warnings;

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

use Class::Tiny 0.006 ();
our @ISA = 'Class::Tiny';

my %EXPORT_TAGS = (
	default => [qw/ has extends with strict /],
	all     => [qw/ has extends with before after around strict warnings confess /],
	cmm     => [qw/ before after around /],
);

my %CLASS_ATTRIBUTES;

sub import
{
	my $me = shift;
	my %want =
		map +($_ => 1),
		map +(@{ $EXPORT_TAGS{substr($_, 1)} or [$_] }),
		(@_ ? @_ : '-default');

	strict->import   if delete $want{strict};
	warnings->import if delete $want{warnings};

	my $caller = caller;
	$me->_install_tracked($caller, has     => sub { unshift @_, $me, $caller; goto \&has })     if delete $want{has};
	$me->_install_tracked($caller, extends => sub { unshift @_, $me, $caller; goto \&extends }) if delete $want{extends};
	$me->_install_tracked($caller, with    => sub { unshift @_, $me, $caller; goto \&with })    if delete $want{with};
	$me->_install_tracked($caller, confess => \&confess)                                        if delete $want{confess};

	for my $modifier (qw/ before after around /)
	{
		next unless delete $want{$modifier};
		$me->_install_tracked($caller, $modifier, sub
		{
			require Class::Method::Modifiers;
			Class::Method::Modifiers::install_modifier($caller, $modifier, @_);
		});
	}

	croak("Unknown import symbols (%s)", join ", ", sort keys %want) if keys %want;

	@_ = ($me);
	goto \&Class::Tiny::import;
}

my %INSTALLED;
sub _install_tracked
{
	no strict 'refs';
	my ($me, $pkg, $name, $code) = @_;
	*{"$pkg\::$name"} = $code;
	$INSTALLED{$pkg}{$name} = "$code";
}

sub unimport
{
	my $me = shift;
	my $caller = caller;
	$me->_clean($caller, $INSTALLED{$caller});
}

sub _clean
{
	my ($me, $target, $exports) = @_;
	my %rev = reverse %$exports or return;
	my $stash = _getstash($target);

	for my $name (keys %$exports)
	{
		if ($stash->{$name} and defined(&{$stash->{$name}}))
		{
			if ($rev{$target->can($name)})
			{
				my $old = delete $stash->{$name};
				my $full_name = join('::',$target,$name);
				# Copy everything except the code slot back into place (e.g. $has)
				foreach my $type (qw(SCALAR HASH ARRAY IO))
				{
					next unless defined(*{$old}{$type});
					no strict 'refs';
					*$full_name = *{$old}{$type};
				}
			}
		}
	}
}

sub croak
{
	require Carp;
	my ($fmt, @values) = @_;
	Carp::croak(sprintf($fmt, @values));
}

sub confess
{
	require Carp;
	my ($fmt, @values) = @_;
	Carp::confess(sprintf($fmt, @values));
}

my %BUILD_WRAPPED;

sub has
{
	my ($me, $caller) = (shift, shift);
	my ($attr, %spec) = @_;

	if (defined($attr) and ref($attr) eq q(ARRAY))
	{
		has($caller, $_, %spec) for @$attr;
		return;
	}

	$CLASS_ATTRIBUTES{$caller}{$attr} = +{ %spec };
	$CLASS_ATTRIBUTES{$caller}{$attr}{is}   ||= 'ro';
	$CLASS_ATTRIBUTES{$caller}{$attr}{lazy} ||= 1 if exists($spec{default});

	if (!defined($attr) or ref($attr) or $attr !~ /^[^\W\d]\w*$/s)
	{
		croak("Invalid accessor name '%s'", $attr);
	}

	my $init_arg  = exists($spec{init_arg}) ? delete($spec{init_arg}) : \undef;
	my $is        = delete($spec{is}) || 'rw';
	my $required  = delete($spec{required});
	my $default   = delete($spec{default});
	my $lazy      = delete($spec{lazy});
	my $clearer   = delete($spec{clearer});
	my $predicate = delete($spec{predicate});
	my $setter_wrap;

	if ($spec{isa} or $spec{coerce})
	{
		ref($spec{isa}) or croak("Type names are strings are not supported");
		$spec{isa}->can('check')       or croak("Type doesn't have a `check` method");
		$spec{isa}->can('get_message') or croak("Type doesn't have a `get_message` method");
		$spec{isa}->can('coerce')      or !$spec{coerce} or croak("Type doesn't have a `coerce` method");
		$setter_wrap = 1;
		delete $spec{$_} for qw/ isa coerce /;
		__PACKAGE__->_wrap_build($caller) unless $BUILD_WRAPPED{$caller}++;
	}

	if ($is eq 'lazy')
	{
		$lazy = 1;
		$is   = 'ro';
	}

	if (defined $lazy and not $lazy)
	{
		croak("Class::Tiny does not support eager defaults");
	}
	elsif (keys %spec)
	{
		croak("Unknown options in attribute specification (%s)", join ", ", sort keys %spec);
	}

	if ($required and 'Class::Tiny::Object'->can('new') == $caller->can('new'))
	{
		croak("Class::Tiny::Object::new does not support required attributes; please manually override the constructor to enforce required attributes");
	}

	if ($init_arg and ref($init_arg) eq 'SCALAR' and not defined $$init_arg)
	{
		# ok
	}
	elsif (!$init_arg or $init_arg ne $attr)
	{
		croak("Class::Tiny does not support init_arg");
	}

	my $getter = "\$_[0]{'$attr'}";
	if (defined $default and ref($default) eq 'CODE')
	{
		$getter = "\$_[0]{'$attr'} = \$default->(\$_[0]) unless exists \$_[0]{'$attr'}; $getter";
	}
	elsif (defined $default)
	{
		$getter = "\$_[0]{'$attr'} = \$default unless exists \$_[0]{'$attr'}; $getter";
	}

	my $setter_name;
	my @methods;
	my $needs_clean = 0;
	if ($is eq 'rw')
	{
		$setter_name = $attr;
		push @methods, "sub $attr :method { \$_[0]{'$attr'} = \$_[1] if \@_ > 1; $getter };";
	}
	elsif ($is eq 'ro' or $is eq 'rwp')
	{
		$setter_name = "_set_$attr";
		push @methods, "sub $attr :method { $getter };";
		push @methods, "sub _set_$attr :method { \$_[0]{'$attr'} = \$_[1] };"
			if $is eq 'rwp';
	}
	elsif ($is eq 'bare')
	{
		no strict 'refs';
		$needs_clean = not exists &{"$caller\::$attr"};
	}
	else
	{
		croak("Class::Tiny::Antlers does not support '$is' accessors");
	}

	if ($clearer)
	{
		$clearer = ($attr =~ /^_/) ? "_clear$attr" : "clear_$attr" if $clearer eq '1';
		push @methods, "sub $clearer :method { delete(\$_[0]{'$attr'}) }";
	}

	if ($predicate)
	{
		$predicate = ($attr =~ /^_/) ? "_has$attr" : "has_$attr" if $predicate eq '1';
		push @methods, "sub $predicate :method { exists(\$_[0]{'$attr'}) }";
	}

	eval "package $caller; @methods";
	$me->create_attributes($caller, $attr);

	$me->_wrap_setter($caller, $attr, $setter_name) if $setter_wrap;

	$me->_clean($caller, { $attr => do { no strict 'refs'; ''.\&{"$caller\::$attr"} } })
		if $needs_clean;
}

sub _wrap_build {
	my ($me, $caller) = @_;
	no strict 'refs';
	if (exists &{"$caller\::BUILD"}) {
		my $next = \&{"$caller\::BUILD"};
		$me->_clean($caller, { BUILD => $next });
		eval sprintf(q{
			package %s;
			sub BUILD {
				my $self = shift;
				%s->_check_args('%s', @_);
				$self->$next(@_);
			}
		}, $caller, $me, $caller);
	}
	else {
		eval sprintf(q{
			package %s;
			sub BUILD {
				my $self = shift;
				%s->_check_args('%s', $self, @_);
			}
		}, $caller, $me, $caller);
	}
}

sub _check_args {
	my ($me, $caller, $object, $args) = @_;
	my $spec = $CLASS_ATTRIBUTES{$caller};
	for my $attr (sort keys %$spec) {
		my $type = $spec->{$attr}{isa} or next;
		exists $args->{$attr} or next;
		$type->check($args->{$attr}) and next;
		if ($spec->{$attr}{coerce}) {
			my $coerced = $type->coerce($args->{$attr});
			if ($type->check($coerced)) {
				$object->{$attr} = $args->{$attr} = $coerced;
				next;
			}
		}
		croak('Type constraint check failed for attribute "%s": %s', $attr, $type->get_message($args->{$attr}));
	}
}

sub _wrap_setter {
	my ($me, $caller, $attr, $setter_name) = @_;
	no strict 'refs';
	my $next = \&{"$caller\::$setter_name"};
	my $spec = $CLASS_ATTRIBUTES{$caller};
	my $type = $spec->{$attr}{isa};
	my $coerce = $spec->{$attr}{coerce};
	$me->_clean($caller, { $setter_name => $next });
	if ($coerce) {
		eval sprintf(q{
			package %s;
			sub %s {
				my $self = shift;
				if (@_) {
					$type->check(@_)
					or do {
						my $coerced = $type->coerce(@_);
						$type->check($coerced) and do { @_ = ($coerced); 1 };
					}
					or %s::croak('Type constraint check failed for attribute "%s": %%s', $type->get_message(@_));
				}
				$self->$next(@_);
			}
		}, $caller, $setter_name, $me, $attr);
	}
	elsif ($type->can('can_be_inlined') && $type->can_be_inlined) {
		my $ic = $type->can('inline_check') || $type->can('_inline_check');
		eval sprintf(q{
			package %s;
			sub %s {
				my $self = shift;
				if (@_) {
					my $val = $_[0];
					%s or %s::croak('Type constraint check failed for attribute "%s": %%s', $type->get_message(@_));
				}
				$self->$next(@_);
			}
		}, $caller, $setter_name, $type->$ic('$val'), $me, $attr);
	}
	else {
		eval sprintf(q{
			package %s;
			sub %s {
				my $self = shift;
				if (@_) {
					$type->check(@_) or %s::croak('Type constraint check failed for attribute "%s": %%s', $type->get_message(@_));
				}
				$self->$next(@_);
			}
		}, $caller, $setter_name, $me, $attr);
	}
}

sub extends
{
	my ($me, $caller) = (shift, shift);
	my (@parents) = @_;

	for my $parent (@parents)
	{
		eval "require $parent";
	}

	no strict 'refs';
	@{"$caller\::ISA"} = @parents;
}

sub with
{
	my ($me, $caller) = (shift, shift);
	require Role::Tiny::With;
	goto \&Role::Tiny::With::with;
}

sub get_all_attribute_specs_for
{
	my $me = shift;
	my $class = $_[0];

	my %specs = %{ $me->get_all_attribute_defaults_for };
	$specs{$_} =
		defined($specs{$_})
			? +{ is => 'rw', lazy => 1, default => $specs{$_} }
			: +{ is => 'rw' }
		for keys %specs;

	for my $p ( reverse @{ $class->mro::get_linear_isa } )
	{
		while ( my ($k, $v) = each %{$CLASS_ATTRIBUTES{$p}||{}} )
		{
			$specs{$k} = $v;
		}
	}

	\%specs;
}

1;


__END__