File Coverage

blib/lib/Object/Stash/Util.pm

Criterion	Covered	Total	%
statement	13	14	92.8
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	17	18	94.4

package Object::Stash::Util;

use 5.010;
use strict;
use utf8;

our @EXPORT_OK;
BEGIN {
	$Object::Stash::AUTHORITY = 'cpan:TOBYINK';
	$Object::Stash::VERSION   = '0.006';

	@EXPORT_OK = qw/
		has_stash make_method make_stash
		/;

	require Object::Role;
	require Object::Stash;
}

use Carp qw/croak/;

use base qw/Exporter Object::Role/;

our $caller_level = 0;

sub make_method
{
	my $stash   = shift;
	my $method  = shift;
	my $options = { @_ };
	my $package;

	if ($stash =~ m{^(.+)::([^:]+)$})
	{
		$package = $1;
		$stash   = $2;
	}
	else
	{
		$package = caller($caller_level);
	}

	my $stash_coderef = do {
		no strict 'refs';
		\&{ "$package\::$stash" };
		};

	my $slot    = $options->{'slot'} // $method;
	my $default = sub { undef };
	if (exists $options->{'default'})
	{
		$default = (ref $options->{'default'} eq 'CODE') ?
			$options->{'default'} :
			sub { $options->{'default'} } ;
	}

	my $coderef =
		($options->{'is'} eq 'ro') ?
		sub
		{
			my $self = shift;
			my $hash = $self->$stash_coderef;
			$hash->{$slot} = $default->($self) unless exists $hash->{$slot};
			$hash->{$slot};
		} :
		sub :lvalue
		{
			my $self = shift;
			my $hash = $self->$stash_coderef;
			$hash->{$slot} = shift if @_;
			$hash->{$slot} = $default->($self) unless exists $hash->{$slot};
			$hash->{$slot};
		} ;

	__PACKAGE__ -> install_method(
		$method => $coderef,
		do { my $caller = caller($caller_level) },
		);
}

sub make_stash
{
	my ($stash, @args) = @_;
	my $package;

	if ($stash =~ m{^(.+)::([^:]+)$})
	{
		$package = $1;
		$stash   = $2;
	}
	else
	{
		$package = caller($caller_level);
	}

	no strict 'refs';
	Object::Stash->import(-method => [$stash], -package => $package, @args)
		unless Object::Stash::is_stash(\&{"$package\::$stash"});
}

sub has_stash
{
	my ($stash_name, %args) = @_;
	my $old_caller_level;
	local $caller_level = $old_caller_level + 1;

	make_stash($stash_name, -type => ($args{isa} // 'object'));

	if (ref $args{handles} eq 'ARRAY')
	{
		my @handles = @{ $args{handles} };
		while (@handles)
		{
			my $method = shift @handles;
			my $opts   = (ref $handles[0] eq 'HASH') ?  shift(@handles) : {};
			make_method($stash_name, $method, %$opts);
		}
	}
	elsif (ref $args{handles} eq 'HASH')
	{
		my %handles = %{ $args{handles} };
		while (my ($method, $opts) = each %handles)
		{
			make_method($stash_name, $method, %$opts);
		}
	}
	elsif (!ref $args{handles})
	{
		make_method($stash_name, $args{handles});
	}

	return;
}

__PACKAGE__
__END__