File Coverage

blib/lib/OOP/Perlish/Class/AutoTest.pm

Criterion	Covered	Total	%
statement	92	97	94.8
branch	16	30	53.3
condition	4	18	22.2
subroutine	18	18	100.0
pod	1	1	100.0
total	131	164	79.8

#!/usr/bin/perl
use warnings;
use strict;
{

    package OOP::Perlish::Class::AutoTest;
    use warnings;
    use strict;
    ############################################################################################
    ## Simple, somewhat hacky way of running unit-tests in batch to make testing framework
    ## easier to manage.
    ############################################################################################

    use Data::Dumper;
    use B;
    use File::Basename qw(dirname fileparse basename);
    use File::Find;
    use Test::Class;

    ############################################################################################
    ## Provide an import method to handle testing parameters.
    ############################################################################################
    sub import
    {
        my ( $self, @tags ) = @_;
        my %test_opts = @tags if( scalar @tags % 2 == 0 );
        my @packages;
        my @test_directories;
        my @exclude;

        return unless( scalar keys %test_opts );

        if( exists $test_opts{package} ) {
            if( $test_opts{package} && ref( $test_opts{package} ) eq 'ARRAY' ) {
                @packages = @{ $test_opts{package} };
            }
            elsif( $test_opts{package} && !ref( $test_opts{package} ) ) {
                @packages = ( $test_opts{package} );
            }
        }
        if( exists $test_opts{tests} ) {
            if( $test_opts{tests} && ref( $test_opts{tests} ) eq 'ARRAY' ) {
                @test_directories = @{ $test_opts{tests} };
            }
            elsif( $test_opts{tests} && !ref( $test_opts{tests} ) ) {
                @test_directories = ( $test_opts{tests} );
            }
        }
        if( exists $test_opts{exclude} ) {
            if( $test_opts{exclude} && ref( $test_opts{exclude} ) eq 'ARRAY' ) {
                @exclude = @{ $test_opts{exclude} };
            }
            elsif( $test_opts{exclude} && !ref( $test_opts{exclude} ) ) {
                @exclude = ( $test_opts{exclude} );
            }
        }

        for my $package ( $self->_find_test_modules( \@packages, \@test_directories, \@exclude ) ) {
            eval "require $package" || die "$@";
        }
    }

    ############################################################################################
    ## Divine information from whence a subroutine is loaded
    ############################################################################################
    sub _introspect_sub
    {
        my ( $self, $sub ) = @_;
        my $cv = B::svref_2object($sub);

        return ( ( $cv->STASH()->NAME(), $cv->FILE() ) );
    }

    ############################################################################################
    ## using introspect_sub, find any subroutine, introspect it to learn which package_name and
    ## file_name it comes from.
    ############################################################################################
    sub _find_package_filename
    {
        my ( $self, $package ) = @_;

        my ( $package_name, $file_name );

        eval "require $package";

        no strict 'refs';
        my %sym = %{ *{ '::' . $package . '::' } };
        use strict;

        while( my ( $k, $v ) = each %sym ) {
            if( defined *{$v}{CODE} ) {
                ( $package_name, $file_name ) = $self->_introspect_sub( *{$v}{CODE} );
                last if( $package_name eq $package );
            }
        }
        return $file_name;
    }

    ############################################################################################
    ## Search the path of a module for subdirectories matching paths in 'tests => []', yet not
    ## matching $exclude_re
    ############################################################################################
    sub _find_test_modules
    {
        my ( $self, $packages, $test_directories, $exclude ) = @_;
        my @packages         = @{$packages};
        my @test_directories = @{$test_directories};
        my @exclude          = @{$exclude};

        my @test_packages;

        for my $package (@packages) {
            my $package_path = $self->_find_package_filename($package);
            my $search_path = join( '/', ( fileparse( $package_path, qr/\.pm/ ) )[ 1, 0 ] );

            File::Find::find(
                {
                   follow            => 0,
                   no_chdir          => 1,
                   bydepth           => 1,
                   untaint           => 1,
                   untaint_exclude   => 1,
                   dangling_symlinks => undef,
                   preprocess        => sub {
                       my $exclude_re = '(?:' . join( '|', @exclude ) . ')';
                       return grep { !/$exclude_re/ } @_;
                   },
                   wanted => sub {
                       m/\.pm$/ && do {
                           ( my $module = $_ ) =~ s/^\Q$search_path\E//;
                           $module =~ s,/+,/,g;
                           $module =~ s,/,::,g;
                           $module =~ s/\.pm$//;
                           $module = $package . $module;
                           push @test_packages, $module;
                       };
                   },
                },
                map { $search_path . '/' . $_ } @test_directories,
                            );
        }
        return @test_packages;
    } ## end sub _find_test_modules

    ############################################################################################
    ## convenience function to invoke Test::Class->runtests() indirectly
    ############################################################################################
    sub runtests
    {
        my ($self) = @_;
        Test::Class->runtests();
    }
}
1;
__END__