[p5sagit/p5-mst-13.2.git] / t / TEST

#!./perl

# This is written in a peculiar style, since we're trying to avoid
# most of the constructs we'll be testing for.  (This comment is
# probably obsolete on the avoidance side, though still currrent
# on the peculiarity side.)

# Location to put the Valgrind log.
my $Valgrind_Log = 'current.valgrind';

$| = 1;

# for testing TEST only
#BEGIN { require '../lib/strict.pm'; "strict"->import() };
#BEGIN { require '../lib/warnings.pm'; "warnings"->import() };

delete $ENV{PERL5LIB};

# remove empty elements due to insertion of empty symbols via "''p1'" syntax
@ARGV = grep($_,@ARGV) if $^O eq 'VMS';
our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;

# Cheesy version of Getopt::Std.  Maybe we should replace it with that.
{
    my @argv = ();
    foreach my $idx (0..$#ARGV) {
	push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
	$::benchmark = 1 if $1 eq 'benchmark';
	$::core    = 1 if $1 eq 'core';
	$::verbose = 1 if $1 eq 'v';
	$::torture = 1 if $1 eq 'torture';
	$::with_utf8 = 1 if $1 eq 'utf8';
	$::with_utf16 = 1 if $1 eq 'utf16';
	$::taintwarn = 1 if $1 eq 'taintwarn';
	$ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest';
	if ($1 =~ /^deparse(,.+)?$/) {
	    $::deparse = 1;
	    $::deparse_opts = $1;
	}
    }
    @ARGV = @argv;
}

chdir 't' if -f 't/TEST';

die "You need to run \"make test\" first to set things up.\n"
  unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';

if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
    unless (-x 'perl.third') {
	unless (-x '../perl.third') {
	    die "You need to run \"make perl.third first.\n";
	}
	else {
	    print "Symlinking ../perl.third as perl.third...\n";
	    die "Failed to symlink: $!\n"
		unless symlink("../perl.third", "perl.third");
	    die "Symlinked but no executable perl.third: $!\n"
		unless -x 'perl.third';
	}
    }
}

# check leakage for embedders
$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};

$ENV{EMXSHELL} = 'sh';        # For OS/2

# Roll your own File::Find!
if ($show_elapsed_time) { require Time::HiRes }

my %skip = (
	    '.' => 1,
	    '..' => 1,
	    'CVS' => 1,
	    'RCS' => 1,
	    'SCCS' => 1,
	    '.svn' => 1,
	   );

sub _find_tests {
    my($dir) = @_;
    opendir DIR, $dir or die "Trouble opening $dir: $!";
    foreach my $f (sort { $a cmp $b } readdir DIR) {
	next if $skip{$f};

	my $fullpath = "$dir/$f";

	if (-d $fullpath) {
	    _find_tests($fullpath);
	} elsif ($f =~ /\.t$/) {
	    push @ARGV, $fullpath;
	}
    }
}


# Scan the text of the test program to find switches and special options
# we might need to apply.
sub _scan_test {
    my($test, $type) = @_;

    open(my $script, "<", $test) or die "Can't read $test.\n";
    my $first_line = <$script>;

    $first_line =~ tr/\0//d if $::with_utf16;

    my $switch = "";
    if ($first_line =~ /#!.*\bperl.*\s-\w*([tT])/) {
        $switch = qq{"-$1"};
    } else {
        if ($::taintwarn) {
            # not all tests are expected to pass with this option
            $switch = '"-t"';
        } else {
            $switch = '';
        }
    }

    my $file_opts = "";
    if ($type eq 'deparse') {
        # Look for #line directives which change the filename
        while (<$script>) {
            $file_opts .= ",-f$3$4"
              if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
        }
    }

    return { file => $file_opts, switch => $switch };
}

# directories with special sets of test switches
my %dir_to_switch =
    (base => '',
     comp => '',
     run => '',
     );

sub _run_test {
    my($test, $type) = @_;

    my $options = _scan_test($test, $type);

    my $perl = './perl';
    my $lib  = '../lib';
    $test =~ /^([^\/]+)/;

    my $testswitch = $dir_to_switch{$1};
    if (!defined $testswitch) {
	$testswitch = '-I. -MTestInit';  # -T will remove . from @INC
    }

    my $utf8 = $::with_utf8 ? '-I$lib -Mutf8' : '';

    my $results;
    if ($type eq 'deparse') {
        my $deparse_cmd =
          "$perl $testswitch $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
          "-l$::deparse_opts$options->{file} ".
          "$test > $test.dp ".
          "&& $perl $testswitch $options->{switch} -I$lib $test.dp |";
        open($results, $deparse_cmd)
          or print "can't deparse '$deparse_cmd': $!.\n";
    }
    elsif ($type eq 'perl') {
        my $perl = $ENV{PERL} || $perl;
        my $redir = $^O eq 'VMS' ? '2>&1' : '';

        if ($ENV{PERL_VALGRIND}) {
            my $valgrind = $ENV{VALGRIND} // 'valgrind';
            my $vg_opts = $ENV{VG_OPTS}
              //  "--suppressions=perl.supp --leak-check=yes "
                . "--leak-resolution=high --show-reachable=yes "
                  . "--num-callers=50"; 
            $perl = "$valgrind --log-fd=3 $vg_opts $perl";
            $redir = "3>$Valgrind_Log";
        }

        my $run = $perl . _quote_args("$testswitch $options->{switch} $utf8")
          . " $test $redir|";
        open($results, $run) or print "can't run '$run': $!.\n";
    }

    # Our environment may force us to use UTF-8, but we can't be sure that
    # anything we're reading from will be generating (well formed) UTF-8
    # This may not be the best way - possibly we should unset ${^OPEN} up
    # top?
    binmode $results;

    return $results;
}

sub _quote_args {
    my ($args) = @_;
    my $argstring = '';

    foreach (split(/\s+/,$args)) {
       # In VMS protect with doublequotes because otherwise
       # DCL will lowercase -- unless already doublequoted.
       $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
       $argstring .= ' ' . $_;
    }
    return $argstring;
}

sub _populate_hash {
    return map {$_, 1} split /\s+/, $_[0];
}

unless (@ARGV) {
    # base first, as TEST bails out if that can't run
    # then comp, to validate that require works
    # then run, to validate that -M works
    # then we know we can -MTestInit for everything else, making life simpler
    foreach my $dir (qw(base comp run cmd io op uni mro)) {
	_find_tests($dir);
    }
    _find_tests("lib") unless $::core;
    # Config.pm may be broken for make minitest. And this is only a refinement
    # for skipping tests on non-default builds, so it is allowed to fail.
    # What we want to to is make a list of extensions which we did not build.
    my $configsh = '../config.sh';
    my %skip;
    if (-f $configsh) {
	my (%extensions, %known_extensions);
	open FH, $configsh or die "Can't open $configsh: $!";
	while (<FH>) {
	    if (/^extensions=['"](.*)['"]$/) {
		# Deliberate string interpolation to avoid triggering possible
		# $1 resetting bugs.
		%extensions = _populate_hash ("$1");
	    }
	    elsif (/^known_extensions=['"](.*)['"]$/) {
		%known_extensions = _populate_hash ($1);
	    }
	}
	if (%extensions) {
	    if (%known_extensions) {
		foreach (keys %known_extensions) {
		    $skip{$_}++ unless $extensions{$_};
		}
	    } else {
		warn "No known_extensions line found in $configsh";
	    }
	} else {
	    warn "No extensions line found in $configsh";
	}
    }
    my $mani = '../MANIFEST';
    if (open(MANI, $mani)) {
	while (<MANI>) { # similar code in t/harness
	    if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
		my $t = $1;
		my $extension = $2;
		if (!$::core || $t =~ m!^lib/[a-z]!)
		{
		    if (defined $extension) {
			$extension =~ s!/t$!!;
			# XXX Do I want to warn that I'm skipping these?
			next if $skip{$extension};
			my $flat_extension = $extension;
			$flat_extension =~ s!-!/!g;
			next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
		    }
		    my $path = "../$t";
		    push @ARGV, $path;
		    $::path_to_name{$path} = $t;
		}
	    }
	}
	close MANI;
    } else {
	warn "$0: cannot open $mani: $!\n";
    }
    unless ($::core) {
	_find_tests('pod');
	_find_tests('x2p');
	_find_tests('porting');
	_find_tests('japh') if $::torture;
	_find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
    }
}

if ($::deparse) {
    _testprogs('deparse', '',   @ARGV);
}
elsif ($::with_utf16) {
    for my $e (0, 1) {
	for my $b (0, 1) {
	    print STDERR "# ENDIAN $e BOM $b\n";
	    my @UARGV;
	    for my $a (@ARGV) {
		my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
		my $f = $e ? "v" : "n";
		push @UARGV, $u;
		unlink($u);
		if (open(A, $a)) {
		    if (open(U, ">$u")) {
			print U pack("$f", 0xFEFF) if $b;
			while (<A>) {
			    print U pack("$f*", unpack("C*", $_));
			}
			close(U);
		    }
		    close(A);
		}
	    }
	    _testprogs('perl', '', @UARGV);
	    unlink(@UARGV);
	}
    }
}
else {
    _testprogs('perl',    '',   @ARGV);
}

sub _testprogs {
    my ($type, $args, @tests) = @_;

    print <<'EOT' if ($type eq 'deparse');
------------------------------------------------------------------------------
TESTING DEPARSER
------------------------------------------------------------------------------
EOT

    $::bad_files = 0;

    foreach my $t (@tests) {
      unless (exists $::path_to_name{$t}) {
	my $tname = "t/$t";
	$::path_to_name{$t} = $tname;
      }
    }
    my $maxlen = 0;
    foreach (@::path_to_name{@tests}) {
	s/\.\w+\z/./;
	my $len = length ;
	$maxlen = $len if $len > $maxlen;
    }
    # + 3 : we want three dots between the test name and the "ok"
    my $dotdotdot = $maxlen + 3 ;
    my $valgrind = 0;
    my $total_files = @tests;
    my $good_files = 0;
    my $tested_files  = 0;
    my $totmax = 0;
    my %failed_tests;

    while (my $test = shift @tests) {
        my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0;

	if ($test =~ /^$/) {
	    next;
	}
	if ($type eq 'deparse') {
	    if ($test eq "comp/redef.t") {
		# Redefinition happens at compile time
		next;
	    }
	    elsif ($test =~ m{lib/Switch/t/}) {
		# B::Deparse doesn't support source filtering
		next;
	    }
	}
	my $te = $::path_to_name{$test} . '.'
		    x ($dotdotdot - length($::path_to_name{$test}));

	if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
	    print $te;
	    $te = '';
	}

	# XXX DAPM %OVER not defined anywhere
	# $test = $OVER{$test} if exists $OVER{$test};

        my $results = _run_test($test, $type);

	my $failure;
	my $next = 0;
	my $seen_leader = 0;
	my $seen_ok = 0;
	my $trailing_leader = 0;
	my $max;
	my %todo;
	while (<$results>) {
	    next if /^\s*$/; # skip blank lines
	    if (/^1..$/ && ($^O eq 'VMS')) {
		# VMS pipe bug inserts blank lines.
		my $l2 = <RESULTS>;
		if ($l2 =~ /^\s*$/) {
		    $l2 = <RESULTS>;
		}
		$_ = '1..' . $l2;
	    }
	    if ($::verbose) {
		print $_;
	    }
	    unless (/^\#/) {
		if ($trailing_leader) {
		    # shouldn't be anything following a postfix 1..n
		    $failure = 'FAILED--extra output after trailing 1..n';
		    last;
		}
		if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
		    if ($seen_leader) {
			$failure = 'FAILED--seen duplicate leader';
			last;
		    }
		    $max = $1;
		    %todo = map { $_ => 1 } split / /, $3 if $3;
		    $totmax += $max;
		    $tested_files++;
		    if ($seen_ok) {
			# 1..n appears at end of file
			$trailing_leader = 1;
			if ($next != $max) {
			    $failure = "FAILED--expected $max tests, saw $next";
			    last;
			}
		    }
		    else {
			$next = 0;
		    }
		    $seen_leader = 1;
		}
		else {
		    if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
			unless ($seen_leader) {
			    unless ($seen_ok) {
				$next = 0;
			    }
			}
			$seen_ok = 1;
			$next++;
			my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
			$num = $next unless $num;

			if ($num == $next) {

			    # SKIP is essentially the same as TODO for t/TEST
			    # this still conforms to TAP:
			    # http://search.cpan.org/dist/TAP/TAP.pod
			    $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
			    $istodo = 1 if $todo{$num};

			    if( $not && !$istodo ) {
				$failure = "FAILED at test $num";
				last;
			    }
			}
			else {
			    $failure ="FAILED--expected test $next, saw test $num";
			    last;
			}
		    }
		    elsif (/^Bail out!\s*(.*)/i) { # magic words
			die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
		    }
		    else {
			# module tests are allowed extra output,
			# because Test::Harness allows it
			next if $test =~ /^\W*(ext|lib)\b/;
			$failure = "FAILED--unexpected output at test $next";
			last;
		    }
		}
	    }
	}
	close $results;

	if (not defined $failure) {
	    $failure = 'FAILED--no leader found' unless $seen_leader;
	}

	if ($ENV{PERL_VALGRIND}) {
	    my @valgrind;
	    if (-e $Valgrind_Log) {
		if (open(V, $Valgrind_Log)) {
		    @valgrind = <V>;
		    close V;
		} else {
		    warn "$0: Failed to open '$Valgrind_Log': $!\n";
		}
	    }
	    if ($ENV{VG_OPTS} =~ /cachegrind/) {
		if (rename $Valgrind_Log, "$test.valgrind") {
		    $valgrind++;
		} else {
		    warn "$0: Failed to create '$test.valgrind': $!\n";
		}
	    }
	    elsif (@valgrind) {
		my $leaks = 0;
		my $errors = 0;
		for my $i (0..$#valgrind) {
		    local $_ = $valgrind[$i];
		    if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
			$errors += $1;   # there may be multiple error summaries
		    } elsif (/^==\d+== LEAK SUMMARY:/) {
			for my $off (1 .. 4) {
			    if ($valgrind[$i+$off] =~
				/(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
				$leaks += $1;
			    }
			}
		    }
		}
		if ($errors or $leaks) {
		    if (rename $Valgrind_Log, "$test.valgrind") {
			$valgrind++;
		    } else {
			warn "$0: Failed to create '$test.valgrind': $!\n";
		    }
		}
	    } else {
		warn "No valgrind output?\n";
	    }
	    if (-e $Valgrind_Log) {
		unlink $Valgrind_Log
		    or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
	    }
	}
	if ($type eq 'deparse') {
	    unlink "./$test.dp";
	}
	if ($ENV{PERL_3LOG}) {
	    my $tpp = $test;
	    $tpp =~ s:^\.\./::;
	    $tpp =~ s:/:_:g;
	    $tpp =~ s:\.t$:.3log:;
	    rename("perl.3log", $tpp) ||
		die "rename: perl3.log to $tpp: $!\n";
	}
	if (not defined $failure and $next != $max) {
	    $failure="FAILED--expected $max tests, saw $next";
	}

	if( !defined $failure  # don't mask a test failure
	    and $? )
	{
	    $failure = "FAILED--non-zero wait status: $?";
	}

	if (defined $failure) {
	    print "${te}$failure\n";
	    $::bad_files++;
	    if ($test =~ /^base/) {
		die "Failed a basic test ($test) -- cannot continue.\n";
	    }
	    ++$failed_tests{$test};
	}
	else {
	    if ($max) {
		my $elapsed;
		if ( $show_elapsed_time ) {
		    $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 );
		}
		else {
		    $elapsed = "";
		}
		print "${te}ok$elapsed\n";
		$good_files++;
	    }
	    else {
		print "${te}skipped\n";
		$tested_files -= 1;
	    }
	}
    } # while tests

    if ($::bad_files == 0) {
	if ($good_files) {
	    print "All tests successful.\n";
	    # XXX add mention of 'perlbug -ok' ?
	}
	else {
	    die "FAILED--no tests were run for some reason.\n";
	}
    }
    else {
	my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
	my $s = $::bad_files == 1 ? "" : "s";
	warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
	for my $test ( sort keys %failed_tests ) {
	    print "\t$test\n";
	}
	warn <<'SHRDLU_1';
### Since not all tests were successful, you may want to run some of
### them individually and examine any diagnostic messages they produce.
### See the INSTALL document's section on "make test".
SHRDLU_1
	warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
### You have a good chance to get more information by running
###   ./perl harness
### in the 't' directory since most (>=80%) of the tests succeeded.
SHRDLU_2
	if (eval {require Config; import Config; 1}) {
	    if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
		warn <<SHRDLU_3;
### You may have to set your dynamic library search path,
### $p, to point to the build directory:
SHRDLU_3
		if (exists $ENV{$p} && $ENV{$p} ne '') {
		    warn <<SHRDLU_4a;
###   setenv $p `pwd`:\$$p; cd t; ./perl harness
###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
###   export $p=`pwd`:\$$p; cd t; ./perl harness
SHRDLU_4a
		} else {
		    warn <<SHRDLU_4b;
###   setenv $p `pwd`; cd t; ./perl harness
###   $p=`pwd`; export $p; cd t; ./perl harness
###   export $p=`pwd`; cd t; ./perl harness
SHRDLU_4b
		}
		warn <<SHRDLU_5;
### for csh-style shells, like tcsh; or for traditional/modern
### Bourne-style shells, like bash, ksh, and zsh, respectively.
SHRDLU_5
	    }
	}
    }
    my ($user,$sys,$cuser,$csys) = times;
    print sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d\n",
	$user,$sys,$cuser,$csys,$tested_files,$totmax);
    if ($ENV{PERL_VALGRIND}) {
	my $s = $valgrind == 1 ? '' : 's';
	print "$valgrind valgrind report$s created.\n", ;
    }
}
exit ($::bad_files != 0);

# ex: set ts=8 sts=4 sw=4 noet:
Commit	Line	Data
8d063cd8	1	#!./perl
8d063cd8	2
8d063cd8	3	# This is written in a peculiar style, since we're trying to avoid
1de9afcd	4	# most of the constructs we'll be testing for. (This comment is
	5	# probably obsolete on the avoidance side, though still currrent
	6	# on the peculiarity side.)
8d063cd8	7
84650816	8	# Location to put the Valgrind log.
	9	my $Valgrind_Log = 'current.valgrind';
	10
a687059c	11	$\| = 1;
a687059c	12
80ed0dea	13	# for testing TEST only
0c3906b8	14	#BEGIN { require '../lib/strict.pm'; "strict"->import() };
0c3906b8	15	#BEGIN { require '../lib/warnings.pm'; "warnings"->import() };
80ed0dea	16
104393a7	17	delete $ENV{PERL5LIB};
60e23f2f	18
cc6ae9e5	19	# remove empty elements due to insertion of empty symbols via "''p1'" syntax
cc6ae9e5	20	@ARGV = grep($_,@ARGV) if $^O eq 'VMS';
551405c4	21	our $show_elapsed_time = $ENV{HARNESS_TIMER} \|\| 0;
cc6ae9e5	22
5d9a6404	23	# Cheesy version of Getopt::Std. Maybe we should replace it with that.
80ed0dea	24	{
80ed0dea	25	my @argv = ();
5d9a6404	26	foreach my $idx (0..$#ARGV) {
b326da91	27	push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
7019aa11	28	$::benchmark = 1 if $1 eq 'benchmark';
80ed0dea	29	$::core = 1 if $1 eq 'core';
	30	$::verbose = 1 if $1 eq 'v';
	31	$::torture = 1 if $1 eq 'torture';
	32	$::with_utf8 = 1 if $1 eq 'utf8';
	33	$::with_utf16 = 1 if $1 eq 'utf16';
80ed0dea	34	$::taintwarn = 1 if $1 eq 'taintwarn';
43651d81	35	$ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest';
485988ae	36	if ($1 =~ /^deparse(,.+)?$/) {
80ed0dea	37	$::deparse = 1;
80ed0dea	38	$::deparse_opts = $1;
485988ae	39	}
5d9a6404	40	}
80ed0dea	41	@ARGV = @argv;
8d063cd8	42	}
8d063cd8	43
378cc40b	44	chdir 't' if -f 't/TEST';
378cc40b	45
3e6e8be7	46	die "You need to run \"make test\" first to set things up.\n"
196918b0	47	unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
4633a7c4	48
7a315204	49	if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
09187cb1	50	unless (-x 'perl.third') {
	51	unless (-x '../perl.third') {
	52	die "You need to run \"make perl.third first.\n";
	53	}
	54	else {
	55	print "Symlinking ../perl.third as perl.third...\n";
	56	die "Failed to symlink: $!\n"
	57	unless symlink("../perl.third", "perl.third");
	58	die "Symlinked but no executable perl.third: $!\n"
	59	unless -x 'perl.third';
	60	}
	61	}
	62	}
	63
3fb91a5e	64	# check leakage for embedders
	65	$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
	66
4633a7c4	67	$ENV{EMXSHELL} = 'sh'; # For OS/2
748a9306	68
24c841ba	69	# Roll your own File::Find!
28ffa55a	70	if ($show_elapsed_time) { require Time::HiRes }
7ebf5c89	71
	72	my %skip = (
	73	'.' => 1,
	74	'..' => 1,
	75	'CVS' => 1,
	76	'RCS' => 1,
	77	'SCCS' => 1,
	78	'.svn' => 1,
	79	);
24c841ba	80
	81	sub _find_tests {
	82	my($dir) = @_;
93e325a7	83	opendir DIR, $dir or die "Trouble opening $dir: $!";
a1886d87	84	foreach my $f (sort { $a cmp $b } readdir DIR) {
7ebf5c89	85	next if $skip{$f};
24c841ba	86
7ebf5c89	87	my $fullpath = "$dir/$f";
24c841ba	88
7ebf5c89	89	if (-d $fullpath) {
	90	_find_tests($fullpath);
	91	} elsif ($f =~ /\.t$/) {
	92	push @ARGV, $fullpath;
	93	}
24c841ba	94	}
	95	}
	96
3fd4b359	97
	98	# Scan the text of the test program to find switches and special options
	99	# we might need to apply.
	100	sub _scan_test {
	101	my($test, $type) = @_;
	102
	103	open(my $script, "<", $test) or die "Can't read $test.\n";
	104	my $first_line = <$script>;
	105
	106	$first_line =~ tr/\0//d if $::with_utf16;
	107
	108	my $switch = "";
	109	if ($first_line =~ /#!.\bperl.\s-\w*([tT])/) {
	110	$switch = qq{"-$1"};
	111	} else {
	112	if ($::taintwarn) {
	113	# not all tests are expected to pass with this option
	114	$switch = '"-t"';
	115	} else {
	116	$switch = '';
	117	}
	118	}
	119
	120	my $file_opts = "";
	121	if ($type eq 'deparse') {
	122	# Look for #line directives which change the filename
	123	while (<$script>) {
	124	$file_opts .= ",-f$3$4"
	125	if /^#\s*line\s+(\d+)\s+((\w+)\|"([^"]+)")/;
	126	}
	127	}
	128
	129	return { file => $file_opts, switch => $switch };
	130	}
	131
5ed59b83	132	# directories with special sets of test switches
	133	my %dir_to_switch =
	134	(base => '',
	135	comp => '',
	136	run => '',
	137	);
84650816	138
	139	sub _run_test {
	140	my($test, $type) = @_;
	141
	142	my $options = _scan_test($test, $type);
	143
923e061d	144	my $perl = './perl';
923e061d	145	my $lib = '../lib';
5ed59b83	146	$test =~ /^([^\/]+)/;
	147
	148	my $testswitch = $dir_to_switch{$1};
	149	if (!defined $testswitch) {
	150	$testswitch = '-I. -MTestInit'; # -T will remove . from @INC
	151	}
923e061d	152
923e061d	153	my $utf8 = $::with_utf8 ? '-I$lib -Mutf8' : '';
84650816	154
	155	my $results;
	156	if ($type eq 'deparse') {
	157	my $deparse_cmd =
923e061d	158	"$perl $testswitch $options->{switch} -I$lib -MO=-qq,Deparse,-sv1.,".
84650816	159	"-l$::deparse_opts$options->{file} ".
84650816	160	"$test > $test.dp ".
923e061d	161	"&& $perl $testswitch $options->{switch} -I$lib $test.dp \|";
84650816	162	open($results, $deparse_cmd)
	163	or print "can't deparse '$deparse_cmd': $!.\n";
	164	}
	165	elsif ($type eq 'perl') {
923e061d	166	my $perl = $ENV{PERL} \|\| $perl;
84650816	167	my $redir = $^O eq 'VMS' ? '2>&1' : '';
	168
	169	if ($ENV{PERL_VALGRIND}) {
	170	my $valgrind = $ENV{VALGRIND} // 'valgrind';
	171	my $vg_opts = $ENV{VG_OPTS}
	172	// "--suppressions=perl.supp --leak-check=yes "
	173	. "--leak-resolution=high --show-reachable=yes "
	174	. "--num-callers=50";
	175	$perl = "$valgrind --log-fd=3 $vg_opts $perl";
	176	$redir = "3>$Valgrind_Log";
	177	}
	178
923e061d	179	my $run = $perl . _quote_args("$testswitch $options->{switch} $utf8")
84650816	180	. " $test $redir\|";
	181	open($results, $run) or print "can't run '$run': $!.\n";
	182	}
	183
	184	# Our environment may force us to use UTF-8, but we can't be sure that
	185	# anything we're reading from will be generating (well formed) UTF-8
	186	# This may not be the best way - possibly we should unset ${^OPEN} up
	187	# top?
	188	binmode $results;
	189
	190	return $results;
	191	}
	192
cc6ae9e5	193	sub _quote_args {
	194	my ($args) = @_;
	195	my $argstring = '';
	196
	197	foreach (split(/\s+/,$args)) {
	198	# In VMS protect with doublequotes because otherwise
	199	# DCL will lowercase -- unless already doublequoted.
	200	$_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
	201	$argstring .= ' ' . $_;
	202	}
	203	return $argstring;
	204	}
	205
6234cb77	206	sub _populate_hash {
	207	return map {$_, 1} split /\s+/, $_[0];
	208	}
	209
24c841ba	210	unless (@ARGV) {
03d95bfa	211	# base first, as TEST bails out if that can't run
	212	# then comp, to validate that require works
	213	# then run, to validate that -M works
	214	# then we know we can -MTestInit for everything else, making life simpler
	215	foreach my $dir (qw(base comp run cmd io op uni mro)) {
f458b6e8	216	_find_tests($dir);
24c841ba	217	}
80ed0dea	218	_find_tests("lib") unless $::core;
6234cb77	219	# Config.pm may be broken for make minitest. And this is only a refinement
	220	# for skipping tests on non-default builds, so it is allowed to fail.
	221	# What we want to to is make a list of extensions which we did not build.
7ebf5c89	222	my $configsh = '../config.sh';
6234cb77	223	my %skip;
	224	if (-f $configsh) {
	225	my (%extensions, %known_extensions);
	226	open FH, $configsh or die "Can't open $configsh: $!";
	227	while (<FH>) {
	228	if (/^extensions=['"](.*)['"]$/) {
	229	# Deliberate string interpolation to avoid triggering possible
	230	# $1 resetting bugs.
	231	%extensions = _populate_hash ("$1");
	232	}
	233	elsif (/^known_extensions=['"](.*)['"]$/) {
	234	%known_extensions = _populate_hash ($1);
	235	}
	236	}
	237	if (%extensions) {
	238	if (%known_extensions) {
	239	foreach (keys %known_extensions) {
	240	$skip{$_}++ unless $extensions{$_};
	241	}
	242	} else {
	243	warn "No known_extensions line found in $configsh";
	244	}
	245	} else {
	246	warn "No extensions line found in $configsh";
	247	}
	248	}
7ebf5c89	249	my $mani = '../MANIFEST';
7a315204	250	if (open(MANI, $mani)) {
f458b6e8	251	while (<MANI>) { # similar code in t/harness
e469beda	252	if (m!^(ext/(\S+)/+(?:[^/\s]+\.t\|test\.pl)\|lib/\S+?(?:\.t\|test\.pl))\s!) {
80ed0dea	253	my $t = $1;
	254	my $extension = $2;
	255	if (!$::core \|\| $t =~ m!^lib/[a-z]!)
5a6e071d	256	{
6234cb77	257	if (defined $extension) {
	258	$extension =~ s!/t$!!;
	259	# XXX Do I want to warn that I'm skipping these?
	260	next if $skip{$extension};
142f6a0d	261	my $flat_extension = $extension;
6ebb0601	262	$flat_extension =~ s!-!/!g;
6ebb0601	263	next if $skip{$flat_extension}; # Foo/Bar may live in Foo-Bar
6234cb77	264	}
7ebf5c89	265	my $path = "../$t";
73ddec28	266	push @ARGV, $path;
80ed0dea	267	$::path_to_name{$path} = $t;
5a6e071d	268	}
7a315204	269	}
7a315204	270	}
35d88760	271	close MANI;
7a315204	272	} else {
f458b6e8	273	warn "$0: cannot open $mani: $!\n";
7a315204	274	}
80ed0dea	275	unless ($::core) {
d44161bf	276	_find_tests('pod');
e018f8be	277	_find_tests('x2p');
6b77813c	278	_find_tests('porting');
80ed0dea	279	_find_tests('japh') if $::torture;
7019aa11	280	_find_tests('t/benchmark') if $::benchmark or $ENV{PERL_BENCHMARK};
e018f8be	281	}
8d063cd8	282	}
8d063cd8	283
80ed0dea	284	if ($::deparse) {
f193aa2f	285	_testprogs('deparse', '', @ARGV);
f193aa2f	286	}
80ed0dea	287	elsif ($::with_utf16) {
1de9afcd	288	for my $e (0, 1) {
	289	for my $b (0, 1) {
	290	print STDERR "# ENDIAN $e BOM $b\n";
	291	my @UARGV;
	292	for my $a (@ARGV) {
	293	my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
	294	my $f = $e ? "v" : "n";
	295	push @UARGV, $u;
	296	unlink($u);
	297	if (open(A, $a)) {
	298	if (open(U, ">$u")) {
90f6ca78	299	print U pack("$f", 0xFEFF) if $b;
1de9afcd	300	while (<A>) {
	301	print U pack("$f", unpack("C", $_));
	302	}
80ed0dea	303	close(U);
1de9afcd	304	}
80ed0dea	305	close(A);
1de9afcd	306	}
	307	}
	308	_testprogs('perl', '', @UARGV);
	309	unlink(@UARGV);
	310	}
	311	}
	312	}
f193aa2f	313	else {
f193aa2f	314	_testprogs('perl', '', @ARGV);
485988ae	315	}
6ee623d5	316
bb365837	317	sub _testprogs {
80ed0dea	318	my ($type, $args, @tests) = @_;
6ee623d5	319
485988ae	320	print <<'EOT' if ($type eq 'deparse');
7a315204	321	------------------------------------------------------------------------------
485988ae	322	TESTING DEPARSER
7a315204	323	------------------------------------------------------------------------------
485988ae	324	EOT
485988ae	325
80ed0dea	326	$::bad_files = 0;
73ddec28	327
cc6ae9e5	328	foreach my $t (@tests) {
80ed0dea	329	unless (exists $::path_to_name{$t}) {
7ebf5c89	330	my $tname = "t/$t";
f458b6e8	331	$::path_to_name{$t} = $tname;
cc6ae9e5	332	}
73ddec28	333	}
908801fe	334	my $maxlen = 0;
80ed0dea	335	foreach (@::path_to_name{@tests}) {
73ddec28	336	s/\.\w+\z/./;
	337	my $len = length ;
	338	$maxlen = $len if $len > $maxlen;
088b5126	339	}
908801fe	340	# + 3 : we want three dots between the test name and the "ok"
80ed0dea	341	my $dotdotdot = $maxlen + 3 ;
7a834142	342	my $valgrind = 0;
80ed0dea	343	my $total_files = @tests;
	344	my $good_files = 0;
	345	my $tested_files = 0;
	346	my $totmax = 0;
ade55ef4	347	my %failed_tests;
80ed0dea	348
551405c4	349	while (my $test = shift @tests) {
28ffa55a	350	my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0;
bb365837	351
bb365837	352	if ($test =~ /^$/) {
bb365837	353	next;
6ee623d5	354	}
485988ae	355	if ($type eq 'deparse') {
	356	if ($test eq "comp/redef.t") {
	357	# Redefinition happens at compile time
	358	next;
	359	}
7a834142	360	elsif ($test =~ m{lib/Switch/t/}) {
485988ae	361	# B::Deparse doesn't support source filtering
	362	next;
	363	}
	364	}
80ed0dea	365	my $te = $::path_to_name{$test} . '.'
80ed0dea	366	x ($dotdotdot - length($::path_to_name{$test}));
cc6ae9e5	367
	368	if ($^O ne 'VMS') { # defer printing on VMS due to piping bug
	369	print $te;
	370	$te = '';
	371	}
bb365837	372
80ed0dea	373	# XXX DAPM %OVER not defined anywhere
80ed0dea	374	# $test = $OVER{$test} if exists $OVER{$test};
7a315204	375
84650816	376	my $results = _run_test($test, $type);
d638aca2	377
f458b6e8	378	my $failure;
	379	my $next = 0;
	380	my $seen_leader = 0;
	381	my $seen_ok = 0;
20f82676	382	my $trailing_leader = 0;
80ed0dea	383	my $max;
43fe0836	384	my %todo;
84650816	385	while (<$results>) {
cc6ae9e5	386	next if /^\s*$/; # skip blank lines
615b7a35	387	if (/^1..$/ && ($^O eq 'VMS')) {
	388	# VMS pipe bug inserts blank lines.
	389	my $l2 = <RESULTS>;
	390	if ($l2 =~ /^\s*$/) {
	391	$l2 = <RESULTS>;
	392	}
	393	$_ = '1..' . $l2;
	394	}
80ed0dea	395	if ($::verbose) {
bb365837	396	print $_;
bb365837	397	}
21c74f43	398	unless (/^\#/) {
20f82676	399	if ($trailing_leader) {
20f82676	400	# shouldn't be anything following a postfix 1..n
a5890677	401	$failure = 'FAILED--extra output after trailing 1..n';
20f82676	402	last;
20f82676	403	}
809908f7	404	if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
20f82676	405	if ($seen_leader) {
a5890677	406	$failure = 'FAILED--seen duplicate leader';
20f82676	407	last;
20f82676	408	}
bb365837	409	$max = $1;
f458b6e8	410	%todo = map { $_ => 1 } split / /, $3 if $3;
bb365837	411	$totmax += $max;
80ed0dea	412	$tested_files++;
f458b6e8	413	if ($seen_ok) {
20f82676	414	# 1..n appears at end of file
	415	$trailing_leader = 1;
	416	if ($next != $max) {
a5890677	417	$failure = "FAILED--expected $max tests, saw $next";
20f82676	418	last;
	419	}
	420	}
	421	else {
	422	$next = 0;
	423	}
f458b6e8	424	$seen_leader = 1;
bb365837	425	}
bb365837	426	else {
f458b6e8	427	if (/^(not )?ok(?: (\d+))?[^\#](\s\#.*)?/) {
21c74f43	428	unless ($seen_leader) {
21c74f43	429	unless ($seen_ok) {
20f82676	430	$next = 0;
21c74f43	431	}
37ce32a7	432	}
21c74f43	433	$seen_ok = 1;
20f82676	434	$next++;
f458b6e8	435	my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
	436	$num = $next unless $num;
	437
	438	if ($num == $next) {
	439
eac7c728	440	# SKIP is essentially the same as TODO for t/TEST
eac7c728	441	# this still conforms to TAP:
3722f0dc	442	# http://search.cpan.org/dist/TAP/TAP.pod
eac7c728	443	$extra and $istodo = $extra =~ /#\s*(?:TODO\|SKIP)\b/;
21c74f43	444	$istodo = 1 if $todo{$num};
	445
	446	if( $not && !$istodo ) {
20f82676	447	$failure = "FAILED at test $num";
21c74f43	448	last;
21c74f43	449	}
20f82676	450	}
20f82676	451	else {
f458b6e8	452	$failure ="FAILED--expected test $next, saw test $num";
20f82676	453	last;
37ce32a7	454	}
f458b6e8	455	}
	456	elsif (/^Bail out!\s(.)/i) { # magic words
	457	die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
bb365837	458	}
bb365837	459	else {
dbf51d07	460	# module tests are allowed extra output,
	461	# because Test::Harness allows it
	462	next if $test =~ /^\W*(ext\|lib)\b/;
a5890677	463	$failure = "FAILED--unexpected output at test $next";
20f82676	464	last;
bb365837	465	}
8d063cd8	466	}
	467	}
	468	}
84650816	469	close $results;
20f82676	470
20f82676	471	if (not defined $failure) {
a5890677	472	$failure = 'FAILED--no leader found' unless $seen_leader;
20f82676	473	}
20f82676	474
7a834142	475	if ($ENV{PERL_VALGRIND}) {
da51b73c	476	my @valgrind;
84650816	477	if (-e $Valgrind_Log) {
84650816	478	if (open(V, $Valgrind_Log)) {
da51b73c	479	@valgrind = <V>;
	480	close V;
	481	} else {
84650816	482	warn "$0: Failed to open '$Valgrind_Log': $!\n";
da51b73c	483	}
da51b73c	484	}
3068023c	485	if ($ENV{VG_OPTS} =~ /cachegrind/) {
84650816	486	if (rename $Valgrind_Log, "$test.valgrind") {
3068023c	487	$valgrind++;
	488	} else {
	489	warn "$0: Failed to create '$test.valgrind': $!\n";
	490	}
	491	}
	492	elsif (@valgrind) {
d44161bf	493	my $leaks = 0;
d44161bf	494	my $errors = 0;
7a834142	495	for my $i (0..$#valgrind) {
7a834142	496	local $_ = $valgrind[$i];
d44161bf	497	if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
	498	$errors += $1; # there may be multiple error summaries
	499	} elsif (/^==\d+== LEAK SUMMARY:/) {
	500	for my $off (1 .. 4) {
	501	if ($valgrind[$i+$off] =~
	502	/(?:lost\|reachable):\s+\d+ bytes in (\d+) blocks/) {
	503	$leaks += $1;
	504	}
	505	}
7a834142	506	}
7a834142	507	}
d44161bf	508	if ($errors or $leaks) {
84650816	509	if (rename $Valgrind_Log, "$test.valgrind") {
d44161bf	510	$valgrind++;
	511	} else {
	512	warn "$0: Failed to create '$test.valgrind': $!\n";
7a834142	513	}
	514	}
	515	} else {
	516	warn "No valgrind output?\n";
	517	}
84650816	518	if (-e $Valgrind_Log) {
	519	unlink $Valgrind_Log
	520	or warn "$0: Failed to unlink '$Valgrind_Log': $!\n";
da51b73c	521	}
7a834142	522	}
485988ae	523	if ($type eq 'deparse') {
	524	unlink "./$test.dp";
	525	}
211f317f	526	if ($ENV{PERL_3LOG}) {
211f317f	527	my $tpp = $test;
3716a21d	528	$tpp =~ s:^\.\./::;
9c54ecba	529	$tpp =~ s:/:_:g;
3716a21d	530	$tpp =~ s:\.t$:.3log:;
	531	rename("perl.3log", $tpp) \|\|
	532	die "rename: perl3.log to $tpp: $!\n";
211f317f	533	}
20f82676	534	if (not defined $failure and $next != $max) {
a5890677	535	$failure="FAILED--expected $max tests, saw $next";
20f82676	536	}
20f82676	537
343bc60d	538	if( !defined $failure # don't mask a test failure
	539	and $? )
	540	{
	541	$failure = "FAILED--non-zero wait status: $?";
	542	}
	543
20f82676	544	if (defined $failure) {
	545	print "${te}$failure\n";
	546	$::bad_files++;
ade55ef4	547	if ($test =~ /^base/) {
ade55ef4	548	die "Failed a basic test ($test) -- cannot continue.\n";
20f82676	549	}
ade55ef4	550	++$failed_tests{$test};
20f82676	551	}
20f82676	552	else {
bb365837	553	if ($max) {
551405c4	554	my $elapsed;
	555	if ( $show_elapsed_time ) {
	556	$elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 );
	557	}
	558	else {
	559	$elapsed = "";
	560	}
	561	print "${te}ok$elapsed\n";
80ed0dea	562	$good_files++;
bb365837	563	}
bb365837	564	else {
6b202754	565	print "${te}skipped\n";
80ed0dea	566	$tested_files -= 1;
bb365837	567	}
bcce72a7	568	}
551405c4	569	} # while tests
8d063cd8	570
80ed0dea	571	if ($::bad_files == 0) {
20f82676	572	if ($good_files) {
bb365837	573	print "All tests successful.\n";
	574	# XXX add mention of 'perlbug -ok' ?
	575	}
	576	else {
	577	die "FAILED--no tests were run for some reason.\n";
	578	}
8d063cd8	579	}
bb365837	580	else {
80ed0dea	581	my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
ade55ef4	582	my $s = $::bad_files == 1 ? "" : "s";
	583	warn "Failed $::bad_files test$s out of $tested_files, $pct% okay.\n";
	584	for my $test ( sort keys %failed_tests ) {
	585	print "\t$test\n";
bb365837	586	}
4e4732c1	587	warn <<'SHRDLU_1';
f7d228c6	588	### Since not all tests were successful, you may want to run some of
	589	### them individually and examine any diagnostic messages they produce.
	590	### See the INSTALL document's section on "make test".
4e4732c1	591	SHRDLU_1
80ed0dea	592	warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
f7d228c6	593	### You have a good chance to get more information by running
	594	### ./perl harness
	595	### in the 't' directory since most (>=80%) of the tests succeeded.
4e4732c1	596	SHRDLU_2
f458b6e8	597	if (eval {require Config; import Config; 1}) {
80ed0dea	598	if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
4e4732c1	599	warn <<SHRDLU_3;
f7d228c6	600	### You may have to set your dynamic library search path,
f7d228c6	601	### $p, to point to the build directory:
4e4732c1	602	SHRDLU_3
f458b6e8	603	if (exists $ENV{$p} && $ENV{$p} ne '') {
4e4732c1	604	warn <<SHRDLU_4a;
f7d228c6	605	### setenv $p `pwd`:\$$p; cd t; ./perl harness
	606	### $p=`pwd`:\$$p; export $p; cd t; ./perl harness
	607	### export $p=`pwd`:\$$p; cd t; ./perl harness
4e4732c1	608	SHRDLU_4a
f458b6e8	609	} else {
4e4732c1	610	warn <<SHRDLU_4b;
f7d228c6	611	### setenv $p `pwd`; cd t; ./perl harness
	612	### $p=`pwd`; export $p; cd t; ./perl harness
	613	### export $p=`pwd`; cd t; ./perl harness
4e4732c1	614	SHRDLU_4b
f458b6e8	615	}
4e4732c1	616	warn <<SHRDLU_5;
f7d228c6	617	### for csh-style shells, like tcsh; or for traditional/modern
f7d228c6	618	### Bourne-style shells, like bash, ksh, and zsh, respectively.
4e4732c1	619	SHRDLU_5
f458b6e8	620	}
afd33fa9	621	}
bb365837	622	}
80ed0dea	623	my ($user,$sys,$cuser,$csys) = times;
f47304e9	624	print sprintf("u=%.2f s=%.2f cu=%.2f cs=%.2f scripts=%d tests=%d\n",
80ed0dea	625	$user,$sys,$cuser,$csys,$tested_files,$totmax);
7a834142	626	if ($ENV{PERL_VALGRIND}) {
	627	my $s = $valgrind == 1 ? '' : 's';
	628	print "$valgrind valgrind report$s created.\n", ;
	629	}
6ee623d5	630	}
80ed0dea	631	exit ($::bad_files != 0);
ade55ef4	632
ade55ef4	633	# ex: set ts=8 sts=4 sw=4 noet: