Aggregator.pm

package App::Prove::Plugin::Aggregator;
use strict;
use warnings;

use File::Find;
use Path::Class;
use File::Temp qw/tempfile/;

# usage: prove -lr -PAggregator t

sub load {
    my ($class, $p) = @_;
    my @args = @{ $p->{args} };
    my $app  = $p->{app_prove};

    # replace $app->{ argv }

    my @files          = find_tests( @{ $app->{ argv } } );
    my $temp_test_file = create_temp_test_file( @files );

    $app->{ argv } = [ "$temp_test_file" ];

    return 1;
}

sub create_temp_test_file {
    my (@files) = @_;

    my $data;
    {
        local $/;
        $data = <DATA>;
    }

    $data =~ s!__FILES__!qw(@files)!;
    #warn $data;

    my ($fh, $filename) = tempfile( UNLINK => 0 );
    print $fh $data;

    return $filename;
}

sub find_tests {
    my @dirs = @_;
    my @files;
    find(
        {
            wanted   => sub {
                my $file = $File::Find::name;
                push( @files, $file ) if is_test( $file );
            },
            no_chdir => 1,
        },
        @dirs
    );
    return sort @files;
}

sub is_test {
    my ($file) = @_;
    return $file && (-e $file) && (-f $file) && ($file =~ m!\.t$!);
}

1;

__DATA__
use Test::More;
use Test::Base;
use Path::Class;

my @files = __FILES__;
plan tests => (scalar @files);

for my $file (@files) {
    subtest $file => sub {
        my $test = file( $file )->slurp;

        if ( should_skip($test) ) {
            plan skip_all => "skipped $file because having compile time tests";
            return;
        }

        pre_process( $test );

        my $ret = do $file;

        fail "$@" if $@;
        fail "$!" unless defined $ret;
    };
}

done_testing;

my %called;
sub pre_process {
    my ($test) = @_;

    if ( $test =~ m!use\s+Test::Base! ) {
        if ( $called{'Test::Base'}++ ) {
            # not called 1st time
            ### HACK! oh, somebody please..
            Test::Base::default_object->block_list(undef);
            Test::Base::default_object->spec(undef);
        }
    }
}

sub should_skip {
    my ($test) = @_;
    # ugly! oh, somebody please.. :-p
    return $test &&
        (
            ($test =~ m!use\s+FindBin!)
        );
}