File Coverage

blib/lib/Class/Build/Array/Glob.pm

Criterion	Covered	Total	%
statement	102	118	86.4
branch	29	58	50.0
condition	6	9	66.6
subroutine	10	11	90.9
pod			n/a
total	147	196	75.0

package Class::Build::Array::Glob;

our $DATE = '2016-03-27'; # DATE
our $VERSION = '0.01'; # VERSION

use 5.010001;
use strict 'subs', 'vars';
use warnings;

use Hook::AfterRuntime;

our %all_attribute_specs; # key=class, value=[$attr, \%predicates, ...]

sub _collect_attributes {
    my ($target_class, $package, $attrs) = @_;

    for my $parent (@{"$package\::ISA"}) {
        _collect_attributes($target_class, $parent, $attrs);
    }
    push @$attrs, @{ $all_attribute_specs{$package} // [] };
}

sub import {
    my $class0 = shift;

    my $caller = caller();
    *{"$caller\::has"} = sub {
        my ($attr_name, %predicates) = @_;
        push @{ $all_attribute_specs{$caller} }, [$attr_name, \%predicates];

        # define the sub first, to allow things like Role::Tiny::With to check
        # the existence of required methods
        my $is = $predicates{is} // 'ro';
        *{"$caller\::$attr_name"} = $is eq 'rw' ? sub(;$) {} : sub() {};
    };
    after_runtime {
        my @attr_specs;

        # prepend the parent classes' attributes
        _collect_attributes($caller, $caller, \@attr_specs);

        my $glob_attr;
        my %attr_indexes;
        # generate the accessor methods
        {
            no warnings 'redefine';
            my $idx = 0;
            for my $attr_spec (@attr_specs) {
                my ($attr_name, $predicates) = @$attr_spec;
                next if defined $attr_indexes{$attr_name};
                $attr_indexes{$attr_name} = $idx;
                die "Class $caller attribute $attr_name: can't declare ".
                    "another attribute after globbing attribute ($glob_attr)"
                    if defined $glob_attr;
                if ($predicates->{glob}) {
                    $glob_attr = $attr_name;
                }
                my $is = $predicates->{is} // 'ro';
                my $code_str = $is eq 'rw' ? 'sub (;$) { ' : 'sub () { ';
                if (defined $glob_attr) {
                    $code_str .= "splice(\@{\$_[0]}, $idx, scalar(\@{\$_[0]}), \@{\$_[1]}) if \@_ > 1; "
                        if $is eq 'rw';
                    $code_str .= "[ \@{\$_[0]}[$idx .. \$#{\$_[0]}] ]; ";
                } else {
                    $code_str .= "\$_[0][$idx] = \$_[1] if \@_ > 1; "
                        if $is eq 'rw';
                    $code_str .= "\$_[0][$idx]; ";
                }
                $code_str .= "}";
                #say "D:accessor code for attr $attr_name: ", $code_str;
                *{"$caller\::$attr_name"} = eval $code_str;
                die if $@;
                $idx++;
            }
        }

        # generate constructor
        {
            my $code_str = 'sub { ';
            $code_str .= 'my ($class, %args) = @_; ';
            if (defined $glob_attr) {
                $code_str .= 'my $obj = bless [(undef) x '.(scalar(keys %attr_indexes)-1).'], $class; ';
            } else {
                $code_str .= 'my $obj = bless [], $class; ';
            }
            for my $attr_name (sort keys %attr_indexes) {
                my $idx = $attr_indexes{$attr_name};
                if (defined($glob_attr) && $attr_name eq $glob_attr) {
                    $code_str .= "if (exists \$args{'$attr_name'}) { splice(\@\$obj, $idx, scalar(\@\$obj), \@{ \$args{'$attr_name'} }) } ";
                } else {
                    $code_str .= "if (exists \$args{'$attr_name'}) { \$obj->[$idx] = \$args{'$attr_name'} } ";
                }
            }
            $code_str .= '$obj; }';
            #say "D:constructor code for class $caller: ", $code_str;
            unless (*{"$caller\::new"}{CODE}) {
                *{"$caller\::new"} = eval $code_str;
                die if $@;
            };
        }

        # cleanup, so user can't do $obj->has(...) etc later
        undef *{"$caller\::has"};
    };
}

1;
# ABSTRACT: Generate Class accessors/constructor (array-based object, supports globbing attribute)

__END__