view release on metacpan or  search on metacpan

examples/forked_harness.pl  view on Meta::CPAN

    $glob_required = 1;
}

if ($^O eq 'MSWin32' || $glob_required) {
    # might need to glob the command line arg ourselves ...
    my @to_glob = grep { /[*?]/ } @ARGV;
    if (@to_glob > 0) {
	@ARGV = grep { !/[*?]/ } @ARGV;
	push @ARGV, glob($_) foreach @to_glob;
    }
}

my @test_files = (@ARGV) x $xrepeat;
my @result = ();
my $total_status = 0;
my $total_fail = 0;
my $iteration;
my $ntests = scalar @test_files;
if ($debug) {
    # running too many tests simultaneously will use up all your filehandles ...
    color_print(DEBUG => "There are $ntests tests to run (",
		scalar @ARGV, " x $xrepeat)\n");
}
my (%j,$jcount,@j);

&main;
&summarize;
&check_endgame if $check_endgame;
exit ($total_fail > 254 ? 254 : $total_fail);

# exit ($total_status > 254 << 8 ? 254 : $total_status >> 8);

##################################################################
#
# iterate over list of test files and run tests in background processes.
# when child processes are reaped, dispatch &process_test_output
# to analyze the output
#
sub main {
    if ($debug) {
	color_print(DEBUG => "Test files: @test_files\n");
    }
    if (@test_files == 0) {
	die "No tests specified.\n";
    }

    my $sshd;

    if ($ssh_test) {
        print STDERR "Trying to identify or create test ssh server ...\n";
        Forks::Super::POSTFORK_CHILD {
            *Test::SSH::Backend::OpenSSH::_run_dir = sub { };
        };

        # first, try public key authentication for the current user and host
        my $userathost = $ENV{USER} . '@' . $ENV{HOSTNAME};
        my $ssh = Forks::Super::Config::CONFIG_external_program("ssh");
        if ($ssh && $userathost =~ /.@./) {
            my @cmds = ("true", "echo", "dir");
            foreach my $cmd (@cmds) {
                local $SIG{ALRM} = sub { die "ssh timeout $$ $0 @ARGV\n"; };
                alarm 15;
                if (eval {my $c1=system($ssh, $userathost, $cmd);$c1==0}) {
                    $ENV{TEST_SSH_TARGET} = "ssh://$userathost";
                    print STDERR
                        "... publickey on current user,host works!\n";
                    alarm 0;
                    last;
                }
                alarm 0;
            }
        }

        # second, let Test::SSH try to find a server or set one up
        if (!$ENV{TEST_SSH_TARGET}) {
            my $main_pid = $$;
            if (eval "use Test::SSH;1") {
                my %opts = (logger => sub {}, timeout => 600);
                $sshd = eval { Test::SSH->new(%opts) };
                if ($sshd) {
                    $ENV{TEST_SSH_TARGET} = $sshd->uri;
                    print STDERR "... Test::SSH uri: $ENV{TEST_SSH_TARGET}\n";
                }
            }
        }
    }

    for ($iteration = 1; $iteration <= $repeat; $iteration++) {
	color_print ITERATION => "Iteration #$iteration/$repeat\n" if $repeat>1;
	if ($iteration > 1) {
	    sleep 1;
	}

	if ($shuffle) {
	    for (my $j = $#test_files; $j >= 1; $j--) {
		my $k = int($j * rand());
		($test_files[$j],$test_files[$k]) =
		    ($test_files[$k],$test_files[$j]);
	    }
	}

	%j = ();
	$jcount = 0;

	foreach my $test_file (@test_files) {

	    $test_file =~ /(.*)/;
	    $test_file = $1;

	    launch_test_file($test_file);
	    Forks::Super::pause($pause) if $pause;

	    if ($debug) {
		color_print(DEBUG => 'Queue size: ',
			    scalar @Forks::Super::Deferred::QUEUE, "\n");
	    }

	    # see if any tests have finished lately
	    my $waitproc = $inorder ? $j[0] : -1;
	    my $reap = waitpid $waitproc, WNOHANG;
	    while (Forks::Super::Util::isValidPid($reap)) {