[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.)

$| = 1;

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

# Let tests know they're running in the perl core.  Useful for modules
# which live dual lives on CPAN.
$ENV{PERL_CORE} = 1;
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!
use TestInit;
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 };
}

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 $valgrind_log = 'current.valgrind';
    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 $options = _scan_test($test, $type);

	my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : '';
	my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
	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;

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