File Coverage

blib/lib/Class/Accessor/Lite/Lazy.pm

Criterion	Covered	Total	%
statement	58	64	90.6
branch	21	24	87.5
condition			n/a
subroutine	15	16	93.7
pod	2	2	100.0
total	96	106	90.5

package Class::Accessor::Lite::Lazy;
use strict;
use warnings;
use 5.008_001;
use parent 'Class::Accessor::Lite';
use Carp ();

our $VERSION = '0.03';

my %key_ctor = (
    ro_lazy => \&_mk_ro_lazy_accessors,
    rw_lazy => \&_mk_lazy_accessors,
);

sub import {
    my ($class, %args) = @_;
    my $pkg = caller;
    foreach my $key (sort keys %key_ctor) {
        if (defined (my $value = delete $args{$key})) {
            Carp::croak "value of the '$key' parameter should be an arrayref or hashref"
                unless ref($value) =~ /^(ARRAY|HASH)$/;
            $value = [ $value ] if ref $value eq 'HASH';
            $key_ctor{$key}->($pkg, @$value);
        }
    }
    @_ = ($class, %args);
    goto \&Class::Accessor::Lite::import;
}

sub mk_lazy_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller;
    _mk_lazy_accessors($pkg, @properties);
}

sub mk_ro_lazy_accessors {
    (undef, my @properties) = @_;
    my $pkg = caller;
    _mk_ro_lazy_accessors($pkg, @properties);
}

sub _mk_ro_lazy_accessors {
    my $pkg = shift;
    my %decls = map { ref $_ eq 'HASH' ? ( %$_ ) : ( $_ => undef ) } @_;
    no strict 'refs';
    while (my ($name, $builder) = each %decls) {
        *{"$pkg\::$name"} = __m_ro_lazy($pkg, $name, $builder);
    }
}

sub _mk_lazy_accessors {
    my $pkg = shift;
    my %decls = map { ref $_ eq 'HASH' ? ( %$_ ) : ( $_ => undef ) } @_;
    no strict 'refs';
    while (my ($name, $builder) = each %decls) {
        *{"$pkg\::$name"} = __m_lazy($name, $builder);
    }
}

sub __m_ro_lazy {
    my ($pkg, $name, $builder) = @_;
    $builder = "_build_$name" unless defined $builder;
    return sub {
        if (@_ == 1) {
            return $_[0]->{$name} if exists $_[0]->{$name};
            return $_[0]->{$name} = $_[0]->$builder;
        } else {
            my $caller = caller(0);
            Carp::croak("'$caller' cannot access the value of '$name' on objects of class '$pkg'");
        }
    };
}

sub __m_lazy {
    my ($name, $builder) = @_;
    $builder = "_build_$name" unless defined $builder;
    return sub {
        if (@_ == 1) {
            return $_[0]->{$name} if exists $_[0]->{$name};
            return $_[0]->{$name} = $_[0]->$builder;
        } elsif (@_ == 2) {
            return $_[0]->{$name} = $_[1];
        } else {
            return shift->{$name} = \@_;
        }
    };
}

1;

__END__