1#!./perl
2
3# This is written in a peculiar style, since we're trying to avoid
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.)
7
8$| = 1;
9
10# for testing TEST only
11#BEGIN { require '../lib/strict.pm'; strict->import() };
12#BEGIN { require '../lib/warnings.pm'; warnings->import() };
13
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;
17
18# remove empty elements due to insertion of empty symbols via "''p1'" syntax
19@ARGV = grep($_,@ARGV) if $^O eq 'VMS';
20our $show_elapsed_time = $ENV{HARNESS_TIMER} || 0;
21
22# Cheesy version of Getopt::Std.  Maybe we should replace it with that.
23{
24    my @argv = ();
25    foreach my $idx (0..$#ARGV) {
26	push( @argv, $ARGV[$idx] ), next unless $ARGV[$idx] =~ /^-(\S+)$/;
27	$::core    = 1 if $1 eq 'core';
28	$::verbose = 1 if $1 eq 'v';
29	$::torture = 1 if $1 eq 'torture';
30	$::with_utf8 = 1 if $1 eq 'utf8';
31	$::with_utf16 = 1 if $1 eq 'utf16';
32	$::bytecompile = 1 if $1 eq 'bytecompile';
33	$::compile = 1 if $1 eq 'compile';
34	$::taintwarn = 1 if $1 eq 'taintwarn';
35	$ENV{PERL_CORE_MINITEST} = 1 if $1 eq 'minitest';
36	if ($1 =~ /^deparse(,.+)?$/) {
37	    $::deparse = 1;
38	    $::deparse_opts = $1;
39	}
40    }
41    @ARGV = @argv;
42}
43
44chdir 't' if -f 't/TEST';
45
46die "You need to run \"make test\" first to set things up.\n"
47  unless -e 'perl' or -e 'perl.exe' or -e 'perl.pm';
48
49if ($ENV{PERL_3LOG}) { # Tru64 third(1) tool, see perlhack
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
64# check leakage for embedders
65$ENV{PERL_DESTRUCT_LEVEL} = 2 unless exists $ENV{PERL_DESTRUCT_LEVEL};
66
67$ENV{EMXSHELL} = 'sh';        # For OS/2
68
69# Roll your own File::Find!
70use TestInit;
71use File::Spec;
72if ($show_elapsed_time) { require Time::HiRes }
73my $curdir = File::Spec->curdir;
74my $updir  = File::Spec->updir;
75
76sub _find_tests {
77    my($dir) = @_;
78    opendir DIR, $dir or die "Trouble opening $dir: $!";
79    foreach my $f (sort { $a cmp $b } readdir DIR) {
80	next if $f eq $curdir or $f eq $updir or
81	    $f =~ /^(?:CVS|RCS|SCCS|\.svn)$/;
82
83	my $fullpath = File::Spec->catfile($dir, $f);
84
85	_find_tests($fullpath) if -d $fullpath;
86	$fullpath = VMS::Filespec::unixify($fullpath) if $^O eq 'VMS';
87	push @ARGV, $fullpath if $f =~ /\.t$/;
88    }
89}
90
91sub _quote_args {
92    my ($args) = @_;
93    my $argstring = '';
94
95    foreach (split(/\s+/,$args)) {
96       # In VMS protect with doublequotes because otherwise
97       # DCL will lowercase -- unless already doublequoted.
98       $_ = q(").$_.q(") if ($^O eq 'VMS') && !/^\"/ && length($_) > 0;
99       $argstring .= ' ' . $_;
100    }
101    return $argstring;
102}
103
104sub _populate_hash {
105    return map {$_, 1} split /\s+/, $_[0];
106}
107
108unless (@ARGV) {
109    foreach my $dir (qw(base comp cmd run io op uni)) {
110	_find_tests($dir);
111    }
112    _find_tests("lib") unless $::core;
113    # Config.pm may be broken for make minitest. And this is only a refinement
114    # for skipping tests on non-default builds, so it is allowed to fail.
115    # What we want to to is make a list of extensions which we did not build.
116    my $configsh = File::Spec->catfile($updir, "config.sh");
117    my %skip;
118    if (-f $configsh) {
119	my (%extensions, %known_extensions);
120	open FH, $configsh or die "Can't open $configsh: $!";
121	while (<FH>) {
122	    if (/^extensions=['"](.*)['"]$/) {
123		# Deliberate string interpolation to avoid triggering possible
124		# $1 resetting bugs.
125		%extensions = _populate_hash ("$1");
126	    }
127	    elsif (/^known_extensions=['"](.*)['"]$/) {
128		%known_extensions = _populate_hash ($1);
129	    }
130	}
131	if (%extensions) {
132	    if (%known_extensions) {
133		foreach (keys %known_extensions) {
134		    $skip{$_}++ unless $extensions{$_};
135		}
136	    } else {
137		warn "No known_extensions line found in $configsh";
138	    }
139	} else {
140	    warn "No extensions line found in $configsh";
141	}
142    }
143    my $mani = File::Spec->catfile($updir, "MANIFEST");
144    if (open(MANI, $mani)) {
145	while (<MANI>) { # similar code in t/harness
146	    if (m!^(ext/(\S+)/+(?:[^/\s]+\.t|test\.pl)|lib/\S+?(?:\.t|test\.pl))\s!) {
147		my $t = $1;
148		my $extension = $2;
149		if (!$::core || $t =~ m!^lib/[a-z]!)
150		{
151		    if (defined $extension) {
152			$extension =~ s!/t$!!;
153			# XXX Do I want to warn that I'm skipping these?
154			next if $skip{$extension};
155		    }
156		    my $path = File::Spec->catfile($updir, $t);
157		    push @ARGV, $path;
158		    $::path_to_name{$path} = $t;
159		}
160	    }
161	}
162	close MANI;
163    } else {
164	warn "$0: cannot open $mani: $!\n";
165    }
166    unless ($::core) {
167	_find_tests('pod');
168	_find_tests('x2p');
169	_find_tests('japh') if $::torture;
170    }
171}
172
173# Tests known to cause infinite loops for the perlcc tests.
174# %::infinite = ( 'comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
175%::infinite = ();
176
177if ($::deparse) {
178    _testprogs('deparse', '',   @ARGV);
179}
180elsif( $::compile ) {
181    _testprogs('compile', '',   @ARGV);
182}
183elsif( $::bytecompile ) {
184    _testprogs('bytecompile', '', @ARGV);
185}
186elsif ($::with_utf16) {
187    for my $e (0, 1) {
188	for my $b (0, 1) {
189	    print STDERR "# ENDIAN $e BOM $b\n";
190	    my @UARGV;
191	    for my $a (@ARGV) {
192		my $u = $a . "." . ($e ? "l" : "b") . "e" . ($b ? "b" : "");
193		my $f = $e ? "v" : "n";
194		push @UARGV, $u;
195		unlink($u);
196		if (open(A, $a)) {
197		    if (open(U, ">$u")) {
198			print U pack("$f", 0xFEFF) if $b;
199			while (<A>) {
200			    print U pack("$f*", unpack("C*", $_));
201			}
202			close(U);
203		    }
204		    close(A);
205		}
206	    }
207	    _testprogs('perl', '', @UARGV);
208	    unlink(@UARGV);
209	}
210    }
211}
212else {
213    _testprogs('compile', '',   @ARGV) if -e "../testcompile";
214    _testprogs('perl',    '',   @ARGV);
215}
216
217sub _testprogs {
218    my ($type, $args, @tests) = @_;
219
220    print <<'EOT' if ($type eq 'compile');
221------------------------------------------------------------------------------
222TESTING COMPILER
223------------------------------------------------------------------------------
224EOT
225
226    print <<'EOT' if ($type eq 'deparse');
227------------------------------------------------------------------------------
228TESTING DEPARSER
229------------------------------------------------------------------------------
230EOT
231
232    print <<EOT if ($type eq 'bytecompile');
233------------------------------------------------------------------------------
234TESTING BYTECODE COMPILER
235------------------------------------------------------------------------------
236EOT
237
238    $ENV{PERLCC_TIMEOUT} = 120
239	  if ($type eq 'compile' && !$ENV{PERLCC_TIMEOUT});
240
241    $::bad_files = 0;
242
243    foreach my $t (@tests) {
244      unless (exists $::path_to_name{$t}) {
245	my $tname = File::Spec->catfile('t',$t);
246	$tname = VMS::Filespec::unixify($tname) if $^O eq 'VMS';
247	$::path_to_name{$t} = $tname;
248      }
249    }
250    my $maxlen = 0;
251    foreach (@::path_to_name{@tests}) {
252	s/\.\w+\z/./;
253	my $len = length ;
254	$maxlen = $len if $len > $maxlen;
255    }
256    # + 3 : we want three dots between the test name and the "ok"
257    my $dotdotdot = $maxlen + 3 ;
258    my $valgrind = 0;
259    my $valgrind_log = 'current.valgrind';
260    my $total_files = @tests;
261    my $good_files = 0;
262    my $tested_files  = 0;
263    my $totmax = 0;
264
265    while (my $test = shift @tests) {
266        my $test_start_time = $show_elapsed_time ? Time::HiRes::time() : 0;
267
268	if ( $::infinite{$test} && $type eq 'compile' ) {
269	    print STDERR "$test creates infinite loop! Skipping.\n";
270	    next;
271	}
272	if ($test =~ /^$/) {
273	    next;
274	}
275	if ($type eq 'deparse') {
276	    if ($test eq "comp/redef.t") {
277		# Redefinition happens at compile time
278		next;
279	    }
280	    elsif ($test =~ m{lib/Switch/t/}) {
281		# B::Deparse doesn't support source filtering
282		next;
283	    }
284	}
285	my $te = $::path_to_name{$test} . '.'
286		    x ($dotdotdot - length($::path_to_name{$test}));
287
288	if ($^O ne 'VMS') {  # defer printing on VMS due to piping bug
289	    print $te;
290	    $te = '';
291	}
292
293	# XXX DAPM %OVER not defined anywhere
294	# $test = $OVER{$test} if exists $OVER{$test};
295
296	open(SCRIPT,"<",$test) or die "Can't run $test.\n";
297	$_ = <SCRIPT>;
298	close(SCRIPT) unless ($type eq 'deparse');
299	if ($::with_utf16) {
300	    $_ =~ tr/\0//d;
301	}
302	my $switch;
303	if (/#!.*\bperl.*\s-\w*([tT])/) {
304	    $switch = qq{"-$1"};
305	}
306	else {
307	    if ($::taintwarn) {
308		# not all tests are expected to pass with this option
309		$switch = '"-t"';
310	    }
311	    else {
312		$switch = '';
313	    }
314	}
315
316	my $test_executable; # for 'compile' tests
317	my $file_opts = "";
318	if ($type eq 'deparse') {
319	    # Look for #line directives which change the filename
320	    while (<SCRIPT>) {
321		$file_opts .= ",-f$3$4"
322			if /^#\s*line\s+(\d+)\s+((\w+)|"([^"]+)")/;
323	    }
324	    close(SCRIPT);
325	}
326
327	my $utf8 = $::with_utf8 ? '-I../lib -Mutf8' : '';
328	my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
329	if ($type eq 'deparse') {
330	    my $deparse_cmd =
331		"./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,".
332		"-l$::deparse_opts$file_opts ".
333		"$test > $test.dp ".
334		"&& ./perl $testswitch $switch -I../lib $test.dp |";
335	    open(RESULTS, $deparse_cmd)
336		or print "can't deparse '$deparse_cmd': $!.\n";
337	}
338	elsif ($type eq 'bytecompile') {
339	    my ($pwd, $null);
340	    if( $^O eq 'MSWin32') {
341		$pwd = `cd`;
342		$null = 'nul';
343	    } else {
344		$pwd = `pwd`;
345		$null = '/dev/null';
346	    }
347	    chomp $pwd;
348	    my $perl = $ENV{PERL} || "$pwd/perl";
349	    my $bswitch = "-MO=Bytecode,-H,-TI,-s$pwd/$test,";
350	    $bswitch .= "-TF$test.plc,"
351		if $test =~ m(chdir|pod/|CGI/t/carp|lib/DB);
352	    $bswitch .= "-k,"
353		if $test =~ m(deparse|terse|ext/Storable/t/code);
354	    $bswitch .= "-b,"
355		if $test =~ m(op/getpid);
356	    my $bytecompile_cmd =
357		"$perl $testswitch $switch -I../lib $bswitch".
358		"-o$test.plc $test 2>$null &&".
359		"$perl $testswitch $switch -I../lib $utf8 $test.plc |";
360	    open(RESULTS,$bytecompile_cmd)
361		or print "can't byte-compile '$bytecompile_cmd': $!.\n";
362	}
363	elsif ($type eq 'perl') {
364	    my $perl = $ENV{PERL} || './perl';
365	    my $redir = $^O eq 'VMS' ? '2>&1' : '';
366	    if ($ENV{PERL_VALGRIND}) {
367		$perl = "valgrind --suppressions=perl.supp --leak-check=yes "
368			       . "--leak-resolution=high --show-reachable=yes "
369			       . "--num-callers=50 --logfile-fd=3 $perl";
370		$redir = "3>$valgrind_log";
371	    }
372	    my $run = "$perl" . _quote_args("$testswitch $switch $utf8")
373			      . " $test $redir|";
374	    open(RESULTS,$run) or print "can't run '$run': $!.\n";
375	}
376	else {
377	    my $compile_cmd;
378	    my $pl2c = "$testswitch -I../lib ../utils/perlcc --testsuite " .
379	      # -O9 for good measure, -fcog is broken ATM
380		       "$switch -Wb=-O9,-fno-cog -L .. " .
381		       "-I \".. ../lib/CORE\" $args $utf8 $test -o ";
382
383	    if( $^O eq 'MSWin32' ) {
384		$test_executable = "$test.exe";
385		# hopefully unused name...
386		open HACK, "> xweghyz.pl";
387		print HACK <<EOT;
388#!./perl
389
390open HACK, '.\\perl $pl2c $test_executable |';
391# cl.exe prints the name of the .c file on stdout (\%^\$^#)
392while(<HACK>) {m/^\\w+\\.[cC]\$/ && next;print}
393open HACK, '$test_executable |';
394while(<HACK>) {print}
395EOT
396		close HACK;
397		$compile_cmd = 'xweghyz.pl |';
398	    }
399	    else {
400		$test_executable = "$test.plc";
401		$compile_cmd
402		    = "./perl $pl2c $test_executable && $test_executable |";
403	    }
404	    unlink $test_executable if -f $test_executable;
405	    open(RESULTS, $compile_cmd)
406		or print "can't compile '$compile_cmd': $!.\n";
407	}
408
409	my $failure;
410	my $next = 0;
411	my $seen_leader = 0;
412	my $seen_ok = 0;
413	my $trailing_leader = 0;
414	my $max;
415	my %todo;
416	while (<RESULTS>) {
417	    next if /^\s*$/; # skip blank lines
418	    if ($::verbose) {
419		print $_;
420	    }
421	    unless (/^\#/) {
422		if ($trailing_leader) {
423		    # shouldn't be anything following a postfix 1..n
424		    $failure = 'FAILED--extra output after trailing 1..n';
425		    last;
426		}
427		if (/^1\.\.([0-9]+)( todo ([\d ]+))?/) {
428		    if ($seen_leader) {
429			$failure = 'FAILED--seen duplicate leader';
430			last;
431		    }
432		    $max = $1;
433		    %todo = map { $_ => 1 } split / /, $3 if $3;
434		    $totmax += $max;
435		    $tested_files++;
436		    if ($seen_ok) {
437			# 1..n appears at end of file
438			$trailing_leader = 1;
439			if ($next != $max) {
440			    $failure = "FAILED--expected $max tests, saw $next";
441			    last;
442			}
443		    }
444		    else {
445			$next = 0;
446		    }
447		    $seen_leader = 1;
448		}
449		else {
450		    if (/^(not )?ok(?: (\d+))?[^\#]*(\s*\#.*)?/) {
451			unless ($seen_leader) {
452			    unless ($seen_ok) {
453				$next = 0;
454			    }
455			}
456			$seen_ok = 1;
457			$next++;
458			my($not, $num, $extra, $istodo) = ($1, $2, $3, 0);
459			$num = $next unless $num;
460
461			if ($num == $next) {
462
463			    # SKIP is essentially the same as TODO for t/TEST
464			    # this still conforms to TAP:
465			    # http://search.cpan.org/dist/Test-Harness/lib/Test/Harness/TAP.pod
466			    $extra and $istodo = $extra =~ /#\s*(?:TODO|SKIP)\b/;
467			    $istodo = 1 if $todo{$num};
468
469			    if( $not && !$istodo ) {
470				$failure = "FAILED at test $num";
471				last;
472			    }
473			}
474			else {
475			    $failure ="FAILED--expected test $next, saw test $num";
476			    last;
477			}
478		    }
479		    elsif (/^Bail out!\s*(.*)/i) { # magic words
480			die "FAILED--Further testing stopped" . ($1 ? ": $1\n" : ".\n");
481		    }
482		    else {
483			$failure = "FAILED--unexpected output at test $next";
484			last;
485		    }
486		}
487	    }
488	}
489	close RESULTS;
490
491	if (not defined $failure) {
492	    $failure = 'FAILED--no leader found' unless $seen_leader;
493	}
494
495	if ($ENV{PERL_VALGRIND}) {
496	    my @valgrind;
497	    if (-e $valgrind_log) {
498		if (open(V, $valgrind_log)) {
499		    @valgrind = <V>;
500		    close V;
501		} else {
502		    warn "$0: Failed to open '$valgrind_log': $!\n";
503		}
504	    }
505	    if (@valgrind) {
506		my $leaks = 0;
507		my $errors = 0;
508		for my $i (0..$#valgrind) {
509		    local $_ = $valgrind[$i];
510		    if (/^==\d+== ERROR SUMMARY: (\d+) errors? /) {
511			$errors += $1;   # there may be multiple error summaries
512		    } elsif (/^==\d+== LEAK SUMMARY:/) {
513			for my $off (1 .. 4) {
514			    if ($valgrind[$i+$off] =~
515				/(?:lost|reachable):\s+\d+ bytes in (\d+) blocks/) {
516				$leaks += $1;
517			    }
518			}
519		    }
520		}
521		if ($errors or $leaks) {
522		    if (rename $valgrind_log, "$test.valgrind") {
523			$valgrind++;
524		    } else {
525			warn "$0: Failed to create '$test.valgrind': $!\n";
526		    }
527		}
528	    } else {
529		warn "No valgrind output?\n";
530	    }
531	    if (-e $valgrind_log) {
532		unlink $valgrind_log
533		    or warn "$0: Failed to unlink '$valgrind_log': $!\n";
534	    }
535	}
536	if ($type eq 'deparse') {
537	    unlink "./$test.dp";
538	}
539	if ($ENV{PERL_3LOG}) {
540	    my $tpp = $test;
541	    $tpp =~ s:^\.\./::;
542	    $tpp =~ s:/:_:g;
543	    $tpp =~ s:\.t$:.3log:;
544	    rename("perl.3log", $tpp) ||
545		die "rename: perl3.log to $tpp: $!\n";
546	}
547	# test if the compiler compiled something
548	if( $type eq 'compile' && !-e "$test_executable" ) {
549	    $failure = "Test did not compile";
550	}
551	if (not defined $failure and $next != $max) {
552	    $failure="FAILED--expected $max tests, saw $next";
553	}
554
555	if (defined $failure) {
556	    print "${te}$failure\n";
557	    $::bad_files++;
558	    $_ = $test;
559	    if (/^base/) {
560		die "Failed a basic test--cannot continue.\n";
561	    }
562	}
563	else {
564	    if ($max) {
565		my $elapsed;
566		if ( $show_elapsed_time ) {
567		    $elapsed = sprintf( " %8.0f ms", (Time::HiRes::time() - $test_start_time) * 1000 );
568		}
569		else {
570		    $elapsed = "";
571		}
572		print "${te}ok$elapsed\n";
573		$good_files++;
574	    }
575	    else {
576		print "${te}skipping test on this platform\n";
577		$tested_files -= 1;
578	    }
579	}
580    } # while tests
581
582    if ($::bad_files == 0) {
583	if ($good_files) {
584	    print "All tests successful.\n";
585	    # XXX add mention of 'perlbug -ok' ?
586	}
587	else {
588	    die "FAILED--no tests were run for some reason.\n";
589	}
590    }
591    else {
592	my $pct = $tested_files ? sprintf("%.2f", ($tested_files - $::bad_files) / $tested_files * 100) : "0.00";
593	if ($::bad_files == 1) {
594	    warn "Failed 1 test script out of $tested_files, $pct% okay.\n";
595	}
596	else {
597	    warn "Failed $::bad_files test scripts out of $tested_files, $pct% okay.\n";
598	}
599	warn <<'SHRDLU_1';
600### Since not all tests were successful, you may want to run some of
601### them individually and examine any diagnostic messages they produce.
602### See the INSTALL document's section on "make test".
603SHRDLU_1
604	warn <<'SHRDLU_2' if $good_files / $total_files > 0.8;
605### You have a good chance to get more information by running
606###   ./perl harness
607### in the 't' directory since most (>=80%) of the tests succeeded.
608SHRDLU_2
609	if (eval {require Config; import Config; 1}) {
610	    if ($::Config{usedl} && (my $p = $::Config{ldlibpthname})) {
611		warn <<SHRDLU_3;
612### You may have to set your dynamic library search path,
613### $p, to point to the build directory:
614SHRDLU_3
615		if (exists $ENV{$p} && $ENV{$p} ne '') {
616		    warn <<SHRDLU_4a;
617###   setenv $p `pwd`:\$$p; cd t; ./perl harness
618###   $p=`pwd`:\$$p; export $p; cd t; ./perl harness
619###   export $p=`pwd`:\$$p; cd t; ./perl harness
620SHRDLU_4a
621		} else {
622		    warn <<SHRDLU_4b;
623###   setenv $p `pwd`; cd t; ./perl harness
624###   $p=`pwd`; export $p; cd t; ./perl harness
625###   export $p=`pwd`; cd t; ./perl harness
626SHRDLU_4b
627		}
628		warn <<SHRDLU_5;
629### for csh-style shells, like tcsh; or for traditional/modern
630### Bourne-style shells, like bash, ksh, and zsh, respectively.
631SHRDLU_5
632	    }
633	}
634    }
635    my ($user,$sys,$cuser,$csys) = times;
636    print sprintf("u=%.2f  s=%.2f  cu=%.2f  cs=%.2f  scripts=%d  tests=%d\n",
637	$user,$sys,$cuser,$csys,$tested_files,$totmax);
638    if ($ENV{PERL_VALGRIND}) {
639	my $s = $valgrind == 1 ? '' : 's';
640	print "$valgrind valgrind report$s created.\n", ;
641    }
642}
643exit ($::bad_files != 0);
644