File Coverage

blib/lib/Class/Accessor/Array.pm

Criterion	Covered	Total	%
statement	71	73	97.2
branch	17	30	56.6
condition	2	2	100.0
subroutine	3	3	100.0
pod			n/a
total	93	108	86.1

package Class::Accessor::Array;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2021-08-03'; # DATE
our $DIST = 'Class-Accessor-Array'; # DIST
our $VERSION = '0.032'; # VERSION

#IFUNBUILT
# use strict 'subs', 'vars';
# use warnings;
#END IFUNBUILT

sub import {
    my ($class0, $spec) = @_;
    my $caller = caller();

    my $class = $caller;

#IFUNBUILT
#     no warnings 'redefine';
#END IFUNBUILT

    # user does not specify 'accessors', perhaps she just loads it. so we just
    # return.
    return unless exists $spec->{accessors};

    # generate accessors
    for my $meth (keys %{$spec->{accessors}}) {
        my $idx = $spec->{accessors}{$meth};
        my $code_str = 'sub (;$) { ';
        $code_str .= "\$_[0][$idx] = \$_[1] if \@_ > 1; ";
        $code_str .= "\$_[0][$idx]; ";
        $code_str .= "}";
        #say "D:accessor code for $meth: ", $code_str;
        *{"$class\::$meth"} = eval $code_str;
        die if $@;
    }

    # generate constructor
    {
        my $code_str;
        $code_str  = 'sub { my ($class, %args) = @_;';
        if (@{"$class\::ISA"}) {
            $code_str .= ' require '.${"$class\::ISA"}[0].';';
            $code_str .= ' my $self = '.${"$class\::ISA"}[0].'->new(map {($_=>delete $args{$_})}'.
                ' grep {'.(join " && ", map {'$_ ne \''.$_.'\''} keys %{$spec->{accessors}}).'} keys %args);';
            $code_str .= ' $self = bless $self, \''.$class.'\';';
        } else {
            $code_str .= ' my $self = bless [], $class;';
        }
        $code_str .= ' for my $key (grep {'.(join " || ", map {'$_ eq \''.$_.'\''} keys %{$spec->{accessors}}).'} keys %args) { $self->$key(delete $args{$key}) }';
        $code_str .= ' die "Unknown $class attributes in constructor: ".join(", ", sort keys %args) if keys %args;';
        $code_str .= ' $self }';

        #print "D:constructor code for class $class: ", $code_str, "\n";
        my $constructor = $spec->{constructor} || "new";
        unless (*{"$class\::$constructor"}{CODE}) {
            *{"$class\::$constructor"} = eval $code_str;
            die if $@;
        };
    }
}

1;
# ABSTRACT: Generate accessors/constructor for array-based object

__END__