File Coverage

blib/lib/Class/Tiny/Antlers.pm

Criterion	Covered	Total	%
statement	144	163	88.3
branch	77	96	80.2
condition	31	42	73.8
subroutine	29	30	96.6
pod	5	6	83.3
total	286	337	84.8

package Class::Tiny::Antlers;

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

use strict;
use warnings;

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

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 $class = 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;
	_install_tracked($caller, has     => sub { unshift @_, $caller; goto \&has })     if delete $want{has};
	_install_tracked($caller, extends => sub { unshift @_, $caller; goto \&extends }) if delete $want{extends};
	_install_tracked($caller, with    => sub { unshift @_, $caller; goto \&with })    if delete $want{with};
	_install_tracked($caller, confess => \&confess)                                   if delete $want{confess};

	for my $modifier (qw/ before after around /)
	{
		next unless delete $want{$modifier};
		_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;

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

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

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

sub _clean
{
	my ($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));
}

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

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

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

	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});

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

	if (defined $lazy and not $lazy)
	{
		croak("Class::Tiny does not support eager defaults");
	}
	elsif ($spec{isa} or $spec{coerce})
	{
		croak("Class::Tiny does not support type constraints");
	}
	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 @methods;
	my $needs_clean = 0;
	if ($is eq 'rw')
	{
		push @methods, "sub $attr :method { \$_[0]{'$attr'} = \$_[1] if \@_ > 1; $getter };";
	}
	elsif ($is eq 'ro' or $is eq 'rwp')
	{
		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";
	__PACKAGE__->create_attributes($caller, $attr);

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

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

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

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

sub with
{
	my $caller = 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__