File Coverage

blib/lib/MooX/LazierAttributes.pm

Criterion	Covered	Total	%
statement	118	118	100.0
branch	22	22	100.0
condition	15	15	100.0
subroutine	29	29	100.0
pod			n/a
total	184	184	100.0

package MooX::LazierAttributes;

use strict;
use warnings;
use Moo;
use Clone qw/clone/;
use MooX::ReturnModifiers qw/return_has return_sub/;
use namespace::clean ();

our $VERSION = '1.07010';

use constant ro => 'ro';
use constant is_ro => ( is => ro );
use constant rw => 'rw';
use constant is_rw => ( is => rw );
use constant nan => undef;
use constant lzy => ( lazy => 1 );
use constant bld => ( builder => 1 );
use constant lzy_bld => ( lazy_build => 1 );
use constant trg => ( trigger => 1 );
use constant clr => ( clearer => 1 );
use constant req => ( required => 1 );
use constant coe => ( coerce => 1 );
use constant lzy_hash => ( lazy => 1, default => sub { {} });
use constant lzy_array => ( lazy => 1, default => sub { [] });
use constant lzy_str => (lazy => 1, default => sub { "" });
use constant dhash => (default => sub { {} });
use constant darray => (default => sub { [] });
use constant dstr => (default => sub { "" });

sub import {
	my ($package, @export) = @_;
	my $target = caller;
	my $has = return_has($target);
	my $sub = return_sub($target);
	my $attributes = sub {
		my @attr = @_;
		while (@attr) {
			my @names = ref $attr[0] eq 'ARRAY' ? @{ shift @attr } : shift @attr;
			my @spec = @{ shift(@attr) };

			my $eye = 1;
			splice @spec, $#spec < 1 ? 0 : $eye, 0, delete $spec[-1]->{default}
				if (grep { ref $spec[$_] eq 'Type::Tiny' and $eye = $#spec } (0 .. $#spec) or ref $spec[-1] eq 'HASH' && exists $spec[-1]->{default} );

			for (@names) {
				unshift @spec, 'set' if $_ =~ m/^\+/ and ( !$spec[0] || $spec[0] ne 'set' );
				unshift @spec, ro unless ! ref $spec[0] and $spec[0] =~ m/^(ro|rw|set)$/;
				$has->( $_, _construct_attribute(@spec) );
			}
		}
	};

	my @ex = scalar @export
		? grep { !ref $_ } @export
		: qw/ro is_ro rw is_rw nan lzy bld lzy_bld trg clr req coe lzy_hash lzy_array/; # back compat as import used to accept a {}

	$sub->('attributes', $attributes);

	{
		no strict 'refs';
		${"${target}::"}{$_} = ${"${package}::"}{$_}
			foreach @ex;
		namespace::clean->import(
			-cleanee => $target,
			@ex, 'attributes'
		);
	}

	return 1;
}

sub _construct_attribute {
	my @spec = @_;
	my %attr = ();
	$attr{is} = $spec[0] unless $spec[0] eq 'set';
	do { $attr{isa} = splice @spec, 1, 1; } if ref $spec[1] eq 'Type::Tiny';
	$attr{default} = ref $spec[1] eq 'CODE' ? $spec[1] : sub { clone( $spec[1] ) }
		if defined $spec[1];
	$attr{$_} = $spec[2]->{$_} foreach keys %{ $spec[2] };
	return %attr;
}

1;

__END__