File Coverage

blib/lib/Fennec/Runner.pm

Criterion	Covered	Total	%
statement	133	155	85.8
branch	32	60	53.3
condition	8	19	42.1
subroutine	29	31	93.5
pod	0	11	0.0
total	202	276	73.1

package Fennec::Runner;
use strict;
use warnings;

use Fennec::Util qw/verbose_message/;

BEGIN {
    my @ltime = localtime;
    $ltime[5] += 1900;
    $ltime[4] += 1;      # months start at 0?
    for ( 3, 4 ) {
        $ltime[4] = "0$ltime[$_]" unless $ltime[$_] > 9;
    }
    my $seed = $ENV{FENNEC_SEED} || join( '', @ltime[5, 4, 3] );
    verbose_message("\n*** Seeding random with date ($seed) ***\n");
    srand($seed);
}

use Cwd qw/abs_path/;
use Carp qw/carp croak confess/;
use List::Util qw/shuffle/;
use Scalar::Util qw/blessed/;
use Fennec::Util qw/accessors require_module/;
use Fennec::Collector::TB::TempFiles;
use Parallel::Runner;

accessors qw/pid test_classes collector _ran _skip_all/;

my $SINGLETON;
sub is_initialized { $SINGLETON ? 1 : 0 }

sub init { }

sub import {
    my $self = shift->new();
    return unless @_;
    $self->_load_guess($_) for @_;
    $self->inject_run( scalar caller );
}

sub inject_run {
    my $self = shift;
    my ( $caller, $sub ) = @_;

    $sub ||= sub { $self->run(@_) };

    require Fennec::Util;
    Fennec::Util::inject_sub( $caller, 'run', $sub );
}

sub new {
    my $class  = shift;
    my @caller = caller;

    croak "listener_class is deprecated, it was thought nobody used it... sorry. See Fennec::Collector now"
        if $class->can('listener_class');

    croak "Runner was already initialized!"
        if $SINGLETON && @_;

    return $SINGLETON if $SINGLETON;

    my %params = @_;

    my $collector_class = $params{collector_class} || 'Fennec::Collector::TB::TempFiles';
    my $collector = $collector_class->new();

    $SINGLETON = bless(
        {
            test_classes => [],
            pid          => $$,
            collector    => $collector,
        },
        $class
    );

    $SINGLETON->init(%params);

    return $SINGLETON;
}

sub _load_guess {
    my $self = shift;
    my ($item) = @_;

    if ( ref $item && ref $item eq 'CODE' ) {
        $self->_load_guess($_) for ( $self->$item );
        return;
    }

    return $self->load_file($item)
        if $item =~ m/\.(pm|t|pl|ft)$/i
        || $item =~ m{/};

    return $self->load_module($item)
        if $item =~ m/::/
        || $item =~ m/^\w[\w\d_]+$/;

    die "Not sure how to load '$item'\n";
}

sub load_file {
    my $self = shift;
    my ($file) = @_;
    print "Loading: $file\n";
    eval { require $file; 1 } || $self->exception( $file, $@ );
}

sub load_module {
    my $self   = shift;
    my $module = shift;
    print "Loading: $module\n";
    eval { require_module $module } || $self->exception( $module, $@ );
}

sub check_pid {
    my $self = shift;
    return unless $self->pid != $$;
    die "PID has changed! Did you forget to exit a child process?\n";
}

sub exception {
    my $self = shift;
    my ( $name, $exception ) = @_;

    if ( $exception =~ m/^FENNEC_SKIP: (.*)\n/ ) {
        $self->collector->ok( 1, "SKIPPING $name: $1" );
        $self->_skip_all(1);
    }
    else {
        $self->collector->ok( 0, $name );
        $self->collector->diag($exception);
    }
}

sub prunner {
    my $self = shift;
    my ($max) = @_;

    my $runner = Parallel::Runner->new($max);

    $runner->reap_callback(
        sub {
            my ( $status, $pid, $pid_again, $proc ) = @_;

            # Status as returned from system, so 0 is good, 1+ is bad.
            $self->exception( "Child process did not exit cleanly", "Status: $status" )
                if $status;
        }
    );

    $runner->iteration_callback( sub { $self->collector->collect } );

    return $runner;
}

sub run {
    my $self = shift;
    my ($follow) = @_;

    $self->_ran(1);

    for my $class ( shuffle @{$self->test_classes} ) {
        next unless $class;
        $self->run_test_class($class);
        $self->check_pid;
    }

    if ($follow) {
        $self->collector->collect;
        verbose_message("Entering final follow-up stage\n");
        $follow->();
    }

    $self->collector->collect;
    $self->collector->finish();
}

sub run_test_class {
    my $self = shift;
    my ($class) = @_;

    return unless $class;

    verbose_message("Entering workflow stage: $class\n");
    return unless $class->can('TEST_WORKFLOW');

    my $instance = $class->can('new') ? $class->new : bless( {}, $class );
    my $ptests   = $self->prunner( $class->FENNEC->parallel );
    my $pforce   = $class->FENNEC->parallel ? 1 : 0;
    my $meta     = $instance->TEST_WORKFLOW;
    my $orig_cwd = abs_path;

    $meta->test_wait( sub { $ptests->finish } );
    $meta->test_run(
        sub {
            my ($run) = @_;
            $ptests->run(
                sub {
                    chdir $orig_cwd;
                    local %ENV = %ENV;
                    $run->();
                    $self->collector->end_pid();
                },
                $pforce
            );
        }
    );

    Test::Workflow::run_tests($instance);
    $ptests->finish;

    if ( my $post = $class->FENNEC->post ) {
        $self->collector->collect;
        verbose_message("Entering follow-up stage: $class\n");
        eval { $post->(); 1 } || $self->exception( 'done_testing', $@ );
    }
}

sub DESTROY {
    my $self = shift;
    return unless $self->pid == $$;
    return if $self->_ran;
    return if $self->_skip_all;
    return if $^C; # No warning in syntax check

    my $tests = join "\n" => map { "#   * $_" } @{$self->test_classes};

    print STDERR <<"    EOT";

# *****************************************************************************
# ERROR: done_testing() was never called!
#
# This usually means you ran a Fennec test file directly with prove or perl,
# but the file does not call done_testing at the end.
#
# Fennec Tests loaded, but not run:
$tests
#
# *****************************************************************************

    EOT
    exit(1);
}

# Set exit code to failed tests
my $PID = $$;

END {
    return if $?;
    return unless $SINGLETON;
    return unless $PID == $$;
    my $failed = $SINGLETON->collector->test_failed;
    return unless $failed;
    $? = $failed;
}

1;

__END__