File Coverage

blib/lib/Test2/Harness/Util/HashBase.pm

Criterion	Covered	Total	%
statement	71	79	89.8
branch	24	30	80.0
condition	5	12	41.6
subroutine	14	15	93.3
pod	1	1	100.0
total	115	137	83.9

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

#################################################################
#                                                               #
#  This is a generated file! Do not modify this file directly!  #
#  Use hashbase_inc.pl script to regenerate this file.          #
#  The script is part of the Object::HashBase distribution.     #
#                                                               #
#################################################################

{
    no warnings 'once';
    $Test2::Harness::Util::HashBase::VERSION = '0.005';
    *Test2::Harness::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
    *Test2::Harness::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
    *Test2::Harness::Util::HashBase::VERSION   = \%Object::HashBase::VERSION;
    *Test2::Harness::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
}


require Carp;
{
    no warnings 'once';
    $Carp::Internal{+__PACKAGE__} = 1;
}

BEGIN {
    # these are not strictly equivalent, but for out use we don't care
    # about order
    *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
        no strict 'refs';
        my @packages = ($_[0]);
        my %seen;
        for my $package (@packages) {
            push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
        }
        return \@packages;
    }
}

my %STRIP = (
    '^' => 1,
    '-' => 1,
);

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

    # Make sure we list the OLDEST version used to create this class.
    $Test2::Harness::Util::HashBase::VERSION{$into} = $Test2::Harness::Util::HashBase::VERSION
        if !$Test2::Harness::Util::HashBase::VERSION{$into}
        || $Test2::Harness::Util::HashBase::VERSION{$into} > $Test2::Harness::Util::HashBase::VERSION;

    my $isa = _isa($into);
    my $attr_list = $Test2::Harness::Util::HashBase::ATTR_LIST{$into} ||= [];
    my $attr_subs = $Test2::Harness::Util::HashBase::ATTR_SUBS{$into} ||= {};

    my %subs = (
        ($into->can('new') ? () : (new => \&_new)),
        (map %{$Test2::Harness::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
        (
            map {
                my $p = substr($_, 0, 1);
                my $x = $_;
                substr($x, 0, 1) = '' if $STRIP{$p};
                push @$attr_list => $x;
                my ($sub, $attr) = (uc $x, $x);
                $sub => ($attr_subs->{$sub} = sub() { $attr }),
                    $attr => sub { $_[0]->{$attr} },
                      $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
                    : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
                    : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
            } @_
        ),
    );

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

sub attr_list {
    my $class = shift;

    my $isa = _isa($class);

    my %seen;
    my @list = grep { !$seen{$_}++ } map {
        my @out;

        if (0.004 > ($Test2::Harness::Util::HashBase::VERSION{$_} || 0)) {
            Carp::carp("$_ uses an inlined version of Test2::Harness::Util::HashBase too old to support attr_list()");
        }
        else {
            my $list = $Test2::Harness::Util::HashBase::ATTR_LIST{$_};
            @out = $list ? @$list : ()
        }

        @out;
    } reverse @$isa;

    return @list;
}

sub _new {
    my $class = shift;

    my $self;

    if (@_ == 1) {
        my $arg = shift;
        my $type = ref($arg);

        if ($type eq 'HASH') {
            $self = bless({%$arg}, $class)
        }
        else {
            Carp::croak("Not sure what to do with '$type' in $class constructor")
                unless $type eq 'ARRAY';

            my %proto;
            my @attributes = attr_list($class);
            while (@$arg) {
                my $val = shift @$arg;
                my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
                $proto{$key} = $val;
            }

            $self = bless(\%proto, $class);
        }
    }
    else {
        $self = bless({@_}, $class);
    }

    $Test2::Harness::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
        unless exists $Test2::Harness::Util::HashBase::CAN_CACHE{$class};

    $self->init if $Test2::Harness::Util::HashBase::CAN_CACHE{$class};

    $self;
}

1;

__END__