File Coverage

blib/lib/Object/Stash.pm

Criterion	Covered	Total	%
statement	14	14	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	19	19	100.0

package Object::Stash;

use 5.010;
use strict;
use utf8;

BEGIN {
	$Object::Stash::AUTHORITY = 'cpan:TOBYINK';
	$Object::Stash::VERSION   = '0.006';
}

use base qw/Object::Role/;

use Carp qw/croak/;
use Hash::FieldHash qw/fieldhashes/;
use Scalar::Util qw/blessed/;
use Sub::Name qw/subname/;

my %known_stashes;
my %Stashes;
BEGIN {
	fieldhashes \%known_stashes, \%Stashes;
}

sub import
{
	my ($invocant, @args) = @_;

	my ($caller, %args) = __PACKAGE__->parse_arguments(-method => @args);
	$args{-method} //= ['stash'];
	$args{-type}   //= 'hashref';

	croak sprintf("Stash type '%s' is unknown.", $args{-type})
		unless $args{-type} =~ m{^ hashref | object $}ix;

	__PACKAGE__->register_consumer($caller);

	for my $method (@{$args{-method}})
	{
		no strict 'refs';
		my $name = "$caller\::$method";
		*$name = my $ref = subname($name, sub { unshift @_, $name, lc $args{-type}; goto &_internals; });
		$known_stashes{ $ref } = $name;

		if (lc $args{-type} eq 'object')
		{
			my $name_autoload = $name . '::AUTOLOAD';
			my $autoload = sub :lvalue
			{
				my ($func) = (${$name_autoload} =~ /::([^:]+)$/);
				my $self = shift;
				$self->{$func} = shift if @_;
				$self->{$func};
			};
			*$name_autoload = subname($name_autoload, $autoload);
		}
	}
}

sub is_stash
{
	shift if (!ref $_[0] and $_[0]->isa(__PACKAGE__));
	my ($name) = @_;

	return $known_stashes{ $name } if exists $known_stashes{ $name };
	return;
}

{
	sub _internals
	{
		my ($stashname, $type, $self, @args) = @_;

		my (%set, @retrieve);
		if (scalar @args == 1 and ref $args[0] eq 'HASH')
		{
			%set = %{ $args[0] };
		}
		elsif (scalar @args == 1 and ref $args[0] eq 'ARRAY')
		{
			@retrieve = @{ $args[0] };
		}
		elsif (scalar @args % 2 == 0)
		{
			%set = @args;
		}
		elsif (@args)
		{
			croak "$stashname expects to be passed a hash, hash reference, or nothing.";
		}

		return unless (defined wantarray or @args);

		my $stash = $Stashes{ $self }{ $stashname };
		unless (defined $stash)
		{
			$stash = $Stashes{ $self }{ $stashname }
			       = ($type eq 'object' ? (bless {}, $stashname) : {});
		}

		while (my ($k, $v) = each %set)
		{
			$stash->{$k} = $v;
		}

		if (@retrieve)
		{
			my @return = map { $stash->{$_} } @retrieve;
			return wantarray ? @return : \@return;
		}

		return $stash;
	}
}

'Secret stash';

__END__