File Coverage

blib/lib/Test/Subtest/Attribute.pm

Criterion	Covered	Total	%
statement	43	79	54.4
branch	7	24	29.1
condition	2	31	6.4
subroutine	13	16	81.2
pod	7	8	87.5
total	72	158	45.5

package Test::Subtest::Attribute;

# ABSTRACT: Declare subtests using subroutine attributes

use 5.006;
use strict;
use warnings;


use Attribute::Handlers;
use Test::Builder qw();

use base qw( Exporter );

our @EXPORT_OK = qw(
    subtests
);
our $VERSION = '0.03';

my @subtests;
my $builder;
my $unknown_sub_count = 0;

sub UNIVERSAL::Subtest : ATTR(CODE) {       ## no critic (Capitalization)
    my ( $package, $symbol, $referent, $attr, $data ) = @_;

    my $sub_name;
    if ( ref $symbol ) {
        $sub_name = *{ $symbol }{NAME};
    }

    my @args = ref $data ? @{ $data } : ();
    my ( $name, $append_prepend ) = @args;
    $append_prepend ||= 'append';
    if ( $sub_name && ! $name ) {
        $name = $sub_name;
        $name =~ s/ ^ subtest_ //msx;
    }

    my %args = (
        coderef   => $referent,
        data      => $data,
        name      => $name,
        'package' => $package,
        sub_name  => $sub_name,
        symbol    => $symbol,
        where     => $append_prepend,
    );

    subtests()->add( %args );

    return 1;
}


sub subtests {
    return __PACKAGE__;
}



sub add {
    my ( $self, %args ) = @_;

    $args{name} ||= $args{sub_name};
    if ( ! $args{name} ) {
        $unknown_sub_count++;
        $args{name} = '__unknown_subtest' . $unknown_sub_count;
    }

    # If we have a subtest with the same name as one that's already in our list,
    # replace it.  This allows derived classes to override the subtests in
    # parent classes.
    foreach my $subtest ( @subtests ) {
        if ( $subtest->{name} eq $args{name} ) {
            $subtest = \%args;
            return 1;
        }
    }

    $args{where} ||= 'append';
    if ( $args{where} eq 'prepend' ) {
        unshift @subtests, { %args };
    }
    else {
        push @subtests, { %args };
    }

    return 1;
}


sub prepend {
    my ( $self, %args ) = @_;

    return subtests()->add( %args, where => 'prepend' );
}


sub append {
    my ( $self, %args ) = @_;

    return subtests()->add( %args, where => 'append' );
}


sub remove {
    my ( $self, $which ) = @_;

    return if ! $which;

    my $field = ref $which ? 'coderef' : 'name';
    my @clean = grep { $_->{ $field } ne $which } @subtests;
    @subtests = @clean;

    return 1;
}


sub get_all {
    return @subtests;
}


sub run {
    my ( $self, %args ) = @_;

    $builder ||= $args{builder} || Test::Builder->new();

    foreach my $subtest ( @subtests ) {
        my $invocant = $args{invocant} || $subtest->{package} || 'main';
        my $name     = $subtest->{name} || '(unknown)';
        if ( $args{verbose_names} ) {
            my $sub_name     = $subtest->{sub_name} || '(unknown sub)';
            my $package_name = $subtest->{package};
            my $verbose_name = ( $package_name && $package_name ne 'main' )
                ? "${package_name}::${sub_name}"
                : $sub_name;
            $name .= " [$verbose_name]";
        }

        my $subref = $subtest->{coderef};
        if ( $subtest->{sub_name} && ! $subref ) {
            $subref = $invocant->can( $subtest->{sub_name} );
        }
        if ( $subref && ref $subref eq 'CODE' ) {
            $builder->subtest( $name, sub { return $invocant->$subref(); } );
        }
    }

    return 1;
}

1;

__END__