File Coverage

blib/lib/Test/Stream/HashBase.pm

Criterion	Covered	Total	%
statement	64	64	100.0
branch	13	16	81.2
condition	6	8	75.0
subroutine	14	14	100.0
pod	2	3	66.6
total	99	105	94.2

package Test::Stream::HashBase;
use strict;
use warnings;

use Carp qw/confess croak carp/;
use Scalar::Util qw/blessed reftype/;

$Carp::Internal{(__PACKAGE__)}++;

my (%META);

sub import {
    my ($class, %args) = @_;

    my $into = $args{into} || caller;
    my $meta = $META{$into} = $args{accessors} || [];

    # Use the comment to change the filename slightly so that Devel::Cover does
    # not try to cover the contents of the string eval.
    my $file = __FILE__;
    $file =~ s/(\.*)$/.eval$1/;
    my $eval = "# line 1 \"$file\"\npackage $into;\n";

    my $isa = do { no strict 'refs'; \@{"$into\::ISA"} };

    if(my @bmetas = map { $META{$_} or () } @$isa) {
        $eval .= "sub " . uc($_) . "() { '$_' };\n" for map { @{$_} } @bmetas;
    }

    if(my $base = $args{base}) {
        carp "'base' argument to HashBase is deprecated.";
        my $bmeta = $META{$base} || croak "Base class '$base' is not a HashBase class";

        unless ($into->isa($base)) {
            $eval .= "sub " . uc($_) . "() { '$_' };\n" for @$bmeta;
            push @$isa => $base;
        }
    }

    {
        $eval .= join '' => map {
            my $const = uc($_);
            <<"            EOT"
sub $const() { '$_' }
sub $_       { \$_[0]->{'$_'} }
sub set_$_   { \$_[0]->{'$_'} = \$_[1] }
sub clear_$_ { delete \$_[0]->{'$_'} }
            EOT
        } @$meta;
    }

    eval "${eval}1;" || die $@;

    return if $args{no_new};

    no strict 'refs';
    *{"$into\::new"} = \&_new;
}

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

sub gen_accessor {
    my $class = shift;
    my ($field) = @_;
    sub {
        my $self = shift;
        ($self->{$field}) = @_ if @_;
        $self->{$field};
    };
}

sub gen_getter {
    my $class = shift;
    my ($field) = @_;
    sub { $_[0]->{$field} };
}

sub gen_setter {
    my $class = shift;
    my ($field) = @_;
    sub { $_[0]->{$field} = $_[1] };
}

1;

__END__