harness.pm

UNIX下perl实现代码

package Test::Harness;

use 5.005_64;
use Exporter;
use Benchmark;
use Config;
use FileHandle;
use strict;

our($VERSION, $verbose, $switches, $have_devel_corestack, $curtest,
    $columns, @ISA, @EXPORT, @EXPORT_OK);
$have_devel_corestack = 0;

$VERSION = "1.1604";

$ENV{HARNESS_ACTIVE} = 1;

# Some experimental versions of OS/2 build have broken $?
my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};

my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};

my $tests_skipped = 0;
my $subtests_skipped = 0;

@ISA=('Exporter');
@EXPORT= qw(&runtests);
@EXPORT_OK= qw($verbose $switches);

$verbose = 0;
$switches = "-w";
$columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;

sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }

sub runtests {
    my(@tests) = @_;
    local($|) = 1;
    my($test,$te,$ok,$next,$max,$pct,$totbonus,@failed,%failedtests);
    my $totmax = 0;
    my $totok = 0;
    my $files = 0;
    my $bad = 0;
    my $good = 0;
    my $total = @tests;

    # pass -I flags to children
    my $old5lib = $ENV{PERL5LIB};

    # VMS has a 255-byte limit on the length of %ENV entries, so
    # toss the ones that involve perl_root, the install location
    # for VMS
    my $new5lib;
    if ($^O eq 'VMS') {
	$new5lib = join($Config{path_sep}, grep {!/perl_root/i;} @INC);
	$switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
    }
    else {
        $new5lib = join($Config{path_sep}, @INC);
    }

    local($ENV{'PERL5LIB'}) = $new5lib;

    my @dir_files = globdir $files_in_dir if defined $files_in_dir;
    my $t_start = new Benchmark;
    while ($test = shift(@tests)) {
	$te = $test;
	chop($te);
	if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./s; }
	my $blank = (' ' x 77);
	my $leader = "$te" . '.' x (20 - length($te));
	my $ml = "";
	$ml = "\r$blank\r$leader"
	    if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $verbose;
	print $leader;
	my $fh = new FileHandle;
	$fh->open($test) or print "can't open $test. $!\n";
	my $first = <$fh>;
	my $s = $switches;
	$s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
	    if exists $ENV{'HARNESS_PERL_SWITCHES'};
	$s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
	    if $first =~ /^#!.*\bperl.*-\w*T/;
	$fh->close or print "can't close $test. $!\n";
	my $cmd = ($ENV{'HARNESS_COMPILE_TEST'})
		? "./perl -I../lib ../utils/perlcc $test "
		  . "-r 2>> ./compilelog |" 
		: "$^X $s $test|";
	$cmd = "MCR $cmd" if $^O eq 'VMS';
	$fh->open($cmd) or print "can't run $test. $!\n";
	$ok = $next = $max = 0;
	@failed = ();
	my %todo = ();
        my $bonus = 0;
	my $skipped = 0;
	my $skip_reason;
	while (<$fh>) {
	    if( $verbose ){
		print $_;
	    }
	    if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
		$max = $1;
		for (split(/\s+/, $2)) { $todo{$_} = 1; }
		$totmax += $max;
		$files++;
		$next = 1;
	    } elsif (/^1\.\.([0-9]+)(\s*\#\s*[Ss]kip\S*(?>\s+)(.+))?/) {
		$max = $1;
		$totmax += $max;
		$files++;
		$next = 1;
		$skip_reason = $3 if not $max and defined $3;
	    } elsif ($max && /^(not\s+)?ok\b/) {
		my $this = $next;
		if (/^not ok\s*(\d*)/){
		    $this = $1 if $1 > 0;
		    print "${ml}NOK $this" if $ml;
		    if (!$todo{$this}) {
			push @failed, $this;
		    } else {
			$ok++;
			$totok++;
		    }
		} elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip\S*(?:(?>\s+)(.+))?)?/) {
		    $this = $1 if $1 > 0;
		    print "${ml}ok $this/$max" if $ml;
		    $ok++;
		    $totok++;
		    $skipped++ if defined $2;
		    my $reason;
		    $reason = 'unknown reason' if defined $2;
		    $reason = $3 if defined $3;
		    if (defined $reason and defined $skip_reason) {
		      # print "was: '$skip_reason' new '$reason'\n";
		      $skip_reason = 'various reasons'
			if $skip_reason ne $reason;
		    } elsif (defined $reason) {
		      $skip_reason = $reason;
		    }
		    $bonus++, $totbonus++ if $todo{$this};
		}
		if ($this > $next) {
		    # print "Test output counter mismatch [test $this]\n";
		    # no need to warn probably
		    push @failed, $next..$this-1;
		} elsif ($this < $next) {
		    #we have seen more "ok" lines than the number suggests
		    print "Confused test output: test $this answered after test ", $next-1, "\n";
		    $next = $this;
		}
		$next = $this + 1;
	    }
	}
	$fh->close; # must close to reap child resource values
	my $wstatus = $ignore_exitcode ? 0 : $?;	# Can trust $? ?
	my $estatus;
	$estatus = ($^O eq 'VMS'
		       ? eval 'use vmsish "status"; $estatus = $?'
		       : $wstatus >> 8);
	if ($wstatus) {
	    my ($failed, $canon, $percent) = ('??', '??');
	    printf "${ml}dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
		    $wstatus,$wstatus;
	    print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
	    if (corestatus($wstatus)) { # until we have a wait module
		if ($have_devel_corestack) {
		    Devel::CoreStack::stack($^X);
		} else {
		    print "\ttest program seems to have generated a core\n";
		}
	    }
	    $bad++;
	    if ($max) {
	      if ($next == $max + 1 and not @failed) {
		print "\tafter all the subtests completed successfully\n";
		$percent = 0;
		$failed = 0;	# But we do not set $canon!
	      } else {
		push @failed, $next..$max;
		$failed = @failed;
		(my $txt, $canon) = canonfailed($max,$skipped,@failed);
		$percent = 100*(scalar @failed)/$max;
		print "DIED. ",$txt;
	      }
	    }
	    $failedtests{$test} = { canon => $canon,  max => $max || '??',
				    failed => $failed, 
				    name => $test, percent => $percent,
				    estat => $estatus, wstat => $wstatus,
				  };
	} elsif ($ok == $max && $next == $max+1) {
	    if ($max and $skipped + $bonus) {
		my @msg;
		push(@msg, "$skipped/$max skipped: $skip_reason")
		    if $skipped;
		push(@msg, "$bonus/$max unexpectedly succeeded")
		    if $bonus;
		print "${ml}ok, ".join(', ', @msg)."\n";
	    } elsif ($max) {
		print "${ml}ok\n";
	    } elsif (defined $skip_reason) {
		print "skipped: $skip_reason\n";
		$tests_skipped++;
	    } else {
		print "skipped test on this platform\n";
		$tests_skipped++;
	    }
	    $good++;
	} elsif ($max) {
	    if ($next <= $max) {
		push @failed, $next..$max;
	    }
	    if (@failed) {
		my ($txt, $canon) = canonfailed($max,$skipped,@failed);
		print "${ml}$txt";
		$failedtests{$test} = { canon => $canon,  max => $max,
					failed => scalar @failed,
					name => $test, percent => 100*(scalar @failed)/$max,
					estat => '', wstat => '',
				      };
	    } else {
		print "Don't know which tests failed: got $ok ok, expected $max\n";
		$failedtests{$test} = { canon => '??',  max => $max,
					failed => '??', 
					name => $test, percent => undef,
					estat => '', wstat => '',
				      };
	    }
	    $bad++;
	} elsif ($next == 0) {
	    print "FAILED before any test output arrived\n";
	    $bad++;
	    $failedtests{$test} = { canon => '??',  max => '??',
				    failed => '??',
				    name => $test, percent => undef,
				    estat => '', wstat => '',
				  };
	}
	$subtests_skipped += $skipped;
	if (defined $files_in_dir) {
	    my @new_dir_files = globdir $files_in_dir;
	    if (@new_dir_files != @dir_files) {
		my %f;
		@f{@new_dir_files} = (1) x @new_dir_files;
		delete @f{@dir_files};
		my @f = sort keys %f;
		print "LEAKED FILES: @f\n";
		@dir_files = @new_dir_files;
	    }
	}
    }
    my $t_total = timediff(new Benchmark, $t_start);
    
    if ($^O eq 'VMS') {
	if (defined $old5lib) {
	    $ENV{PERL5LIB} = $old5lib;
	} else {
	    delete $ENV{PERL5LIB};
	}
    }
    my $bonusmsg = '';
    $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
	       " UNEXPECTEDLY SUCCEEDED)")
	if $totbonus;
    if ($tests_skipped) {
	$bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
	if ($subtests_skipped) {
	    $bonusmsg .= " and $subtests_skipped subtest"
			 . ($subtests_skipped != 1 ? 's' : '');
	}
	$bonusmsg .= ' skipped';
    }
    elsif ($subtests_skipped) {
	$bonusmsg .= ", $subtests_skipped subtest"
	             . ($subtests_skipped != 1 ? 's' : '')
		     . " skipped";
    }
    if ($bad == 0 && $totmax) {
	print "All tests successful$bonusmsg.\n";
    } elsif ($total==0){
	die "FAILED--no tests were run for some reason.\n";
    } elsif ($totmax==0) {
	my $blurb = $total==1 ? "script" : "scripts";
	die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
    } else {
	$pct = sprintf("%.2f", $good / $total * 100);