File Coverage

blib/lib/Test2/Util/HashBase.pm

Criterion	Covered	Total	%
statement	42	43	97.6
branch	8	10	80.0
condition	2	2	100.0
subroutine	10	11	90.9
pod			n/a
total	62	66	93.9

package Test2::Util::HashBase;
use strict;
use warnings;

our $VERSION = '0.000042';

my %ATTRS;
my %META;

sub _get_inherited_attrs {
    no strict 'refs';
    my @todo = map @{"$_\::ISA"}, @_;
    my %seen;
    my @all;
    while (my $pkg = shift @todo) {
        next if $seen{$pkg}++;
        my $found = $META{$pkg};
        push @all => %$found if $found;

        my $isa = \@{"$pkg\::ISA"};
        push @todo => @$isa if @$isa;
    }

    return \@all;
}

sub _make_subs {
    my ($str) = @_;
    return $ATTRS{$str} ||= {
        uc($str) => sub() { $str },
        $str => sub { $_[0]->{$str} },
        "set_$str" => sub { $_[0]->{$str} = $_[1] },
    };
}

sub import {
    my $class = shift;
    my $into = caller;

    my %attrs = map %{_make_subs($_)}, @_;

    my @meta = map uc, @_;
    @{$META{$into}}{@meta} = map $attrs{$_}, @meta;

    my %subs = (
        %attrs,
        @{_get_inherited_attrs($into)},
        $into->can('new') ? () : (new => \&_new)
    );

    no strict 'refs';
    *{"$into\::$_"} = $subs{$_} for keys %subs;
}

sub _new {
    my ($class, %params) = @_;
    my $self = bless \%params, $class;
    $self->init if $self->can('init');
    $self;
}

1;

__END__