File Coverage

blib/lib/MooX/ClassStash.pm

Criterion	Covered	Total	%
statement	76	113	67.2
branch	16	32	50.0
condition	2	6	33.3
subroutine	21	35	60.0
pod	24	26	92.3
total	139	212	65.5

package MooX::ClassStash;
BEGIN {
  $MooX::ClassStash::AUTHORITY = 'cpan:GETTY';
}
{
  $MooX::ClassStash::VERSION = '0.005';
}
# ABSTRACT: Extra class information for Moo


use Moo;
use Package::Stash;
use Class::Method::Modifiers qw( install_modifier );

my %stash_cache;

sub import {
	my ( $class, @args ) = @_;
	my $target = caller;
	unless ($target->can('has')) {
		warn "Not using ".$class." on a class which is not Moo, doing nothing";
		return;
	}
	return if defined $stash_cache{$target};
	$stash_cache{$target} = $class->new($target);
}


has class => (
	is => 'ro',
	required => 1,
);


has package_stash => (
	is => 'ro',
	lazy => 1,
	builder => 1,
	handles => [qw(
		name
		namespace
		add_symbol
		remove_glob
		has_symbol
		get_symbol
		get_or_add_symbol
		remove_symbol
		list_all_symbols
		get_all_symbols
	)],
);

sub _build_package_stash { Package::Stash->new(shift->class) }


has attributes => (
	is => 'ro',
	default => sub {{}},
);


has data => (
	is => 'ro',
	default => sub {{}},
);


has keyword_functions => (
	is => 'ro',
	default => sub {[qw(
		after
		around
		before
		extends
		has
		with
	)]},
);


sub add_keyword_functions { push @{shift->keyword_functions}, @_ }

sub BUILDARGS {
	my ( $class, @args ) = @_;
	return $_[0] if (scalar @args == 1 and ref $_[0] eq 'HASH');
	unshift @args, "class" if @args % 2 == 1;
	return { @args };
}

sub BUILD {
	my ( $self ) = @_;
	$self->add_method('class_stash', sub { return $self });
	$self->add_method('package_stash', sub { return $self->package_stash });
	$self->around_method('has',sub {
		my $orig = shift;
		my $method = shift;
		my $data = { @_ };
		for (ref $method eq 'ARRAY' ? @{$method} : ($method)) {
			$self->attributes->{$_} = $data;
		}
		$orig->($method, @_);
	})
}


sub add_data {
	my $self = shift;
	my $target = caller;
	$self->data->{$target} = {} unless defined $self->data->{$target};
	my $key = shift;
	$self->data->{$target}->{$key} = shift;
}


sub get_data {
	my $self = shift;
	my $target = caller;
	return unless defined $self->data->{$target};
	my $key = shift;
	if (defined $key) {
		return $self->data->{$target}->{$key} if defined $self->data->{$target}->{$key};
	} else {
		return $self->data->{$target};
	}
}


sub remove_data {
	my $self = shift;
	my $target = caller;
	return unless defined $self->data->{$target};
	my $key = shift;
	delete $self->data->{$target}->{$key} if defined $self->data->{$target}->{$key};
}


sub add_keyword {
	my $self = shift;
	my $keyword = shift;
	push @{$self->keyword_functions}, $keyword;
	$self->add_symbol('&'.$keyword,@_);
}

# so far no check if its not a keyword


sub get_keyword { shift->get_method(@_) }


sub has_keyword { shift->has_method(@_) }


sub remove_keyword {
	my $self = shift;
	my $keyword = shift;
	$self->keyword_functions([
		grep { $_ ne $keyword }
		@{$self->keyword_functions}
	]);
	$self->remove_method($keyword, @_);
}


sub get_or_add_keyword {
	my $self = shift;
	my $keyword = shift;
	push @{$self->keyword_functions}, $keyword;
	$self->get_or_add_method($keyword, @_)
}


sub add_attribute {
	my $self = shift;
	my $has = $self->class->can('has');
	$has->(@_);
}


sub get_attribute {
	my $self = shift;
	my $attribute = shift;
	my $key = shift;
	return unless defined $self->attributes->{$attribute};
	if ($key) {
		return $self->attributes->{$attribute}->{$key};
	} else {
		return $self->attributes->{$attribute};
	}
}


sub has_attribute {
	my $self = shift;
	my $attribute = shift;
	defined $self->attributes->{$attribute} ? 1 : 0;
}


sub remove_attribute { die "If you need MooX::ClassStash->remove_attribute, patches welcome" }


sub get_or_add_attribute {
	my $self = shift;
	my $attribute = shift;
	die __PACKAGE__."->get_or_add_attribute requires complete attribute definition" if @_ % 2 or @_ == 0;
	$self->add_attribute($attribute => @_) unless defined $self->attributes->{$attribute};
	return $self->attributes->{$attribute};
}


sub list_all_keywords {
	my $self = shift;
	my %keywords = map { $_ => 1 } @{$self->keyword_functions};
	return
		sort { $a cmp $b }
		grep { $keywords{$_} }
		$self->list_all_symbols('CODE');
}


sub add_method { shift->add_symbol('&'.(shift),@_) }


sub get_method { shift->get_symbol('&'.(shift),@_) }


sub has_method { shift->has_symbol('&'.(shift),@_) }


sub remove_method { shift->remove_symbol('&'.(shift),@_) }


sub get_or_add_method { shift->get_or_add_symbol('&'.(shift),@_) }


sub list_all_methods {
	my $self = shift;
	my %keywords = map { $_ => 1 } @{$self->keyword_functions};
	return
		sort { $a cmp $b }
		grep { !$keywords{$_} }
		$self->list_all_symbols('CODE');
}


sub after_method { install_modifier(shift->class,'after',@_) }


sub before_method { install_modifier(shift->class,'before',@_) }


sub around_method { install_modifier(shift->class,'around',@_) }

1;

__END__