view release on metacpan or  search on metacpan

lib/Class/Tiny/Antlers.pm  view on Meta::CPAN

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