File Coverage

blib/lib/MooX/LazierAttributes.pm

Criterion	Covered	Total	%
statement	121	127	95.2
branch	29	32	90.6
condition	16	23	69.5
subroutine	30	30	100.0
pod	0	1	0.0
total	196	213	92.0

package MooX::LazierAttributes;

use strict;
use warnings;
use Scalar::Util qw/reftype refaddr blessed/;
use MooX::ReturnModifiers qw/return_has/;

our $VERSION = '1.07';

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 { "" });

our %opts;
BEGIN {
    %opts => (limit => 5, skip => '');
}

sub import {
    my ($package, @export) = @_;
    my $target    = caller;
    my $has = return_has($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 = scalar @spec - 1;
            (grep { ref $spec[$_] eq 'Type::Tiny'} (0 .. $eye))
                ? push @spec, delete $spec[$eye]->{default}
                : ( ref $spec[$eye] eq 'HASH' && exists $spec[$eye]->{default} ) && splice @spec, ($eye == 0 ? 0 : 1), 0, delete $spec[$eye]->{default};

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

    if (ref $export[0]) {
        my $o = shift @export;
        exists $o->{$_} and $opts{$_} = $o->{$_} for (qw/limit skip/);
    }

    {
        no strict 'refs';
        ${"${target}::"}{$_} = ${"${package}::"}{$_}
          foreach (scalar @export ? @export : qw/ro is_ro rw is_rw nan lzy bld lzy_bld trg clr req coe lzy_hash lzy_array/);
        *{"${target}::attributes"} = $attributes;
    }

    return 1;
}

sub construct_attribute {
    my @spec = @_;
    my %attr = ();
    $attr{is} = $spec[0] unless $spec[0] eq 'set';

    if ( ref $spec[1] eq 'Type::Tiny' ) {
        $attr{isa} = $spec[1];
        $spec[1] = pop @spec;
    }

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

sub _clone {
    my ($to_clone, $recur) = @_;
    my $blessed = blessed $to_clone;
    $blessed =~ m/^$opts{skip}$/ and return $to_clone if $opts{skip};
    my $clone   = _deep_clone($to_clone, $recur);
    return $blessed ? bless $clone, $blessed : $clone;
}

sub _deep_clone {
    my ($to_clone, $recur) = @_;
    my $rt = reftype($to_clone) || reftype(\$to_clone);
    $rt eq 'SCALAR' and return $to_clone;
    my $addr = refaddr $to_clone;
    $recur->{$addr}++ && $recur->{$addr} > $opts{limit} and return $to_clone;
    $rt eq 'HASH'   and return { map +( $_ => _clone( $to_clone->{$_}, $recur ) ), keys %$to_clone };
    $rt eq 'ARRAY'  and return [ map _clone($_, $recur), @$to_clone ];
    return $to_clone;
}

1;

__END__