t/lib/common.pl

   1 # This code is used by lib/charnames.t, lib/feature.t, lib/subs.t,
   2 # lib/strict.t and lib/warnings.t
   3 #
   4 # On input, $::local_tests is the number of tests in the caller; or
   5 # 'no_plan' if unknown, in which case it is the caller's responsibility
   6 # to call cur_test() to find out how many this executed
   7
   8 BEGIN {
   9     require './test.pl';
  10 }
  11
  12 use Config;
  13 use File::Path;
  14 use File::Spec::Functions qw(catfile curdir rel2abs);
  15
  16 use strict;
  17 use warnings;
  18 my (undef, $file) = caller;
  19 my ($pragma_name) = $file =~ /([A-Za-z_0-9]+)\.t$/
  20     or die "Can't identify pragama to test from file name '$file'";
  21
  22 $| = 1;
  23
  24 my $tmpfile = tempfile();
  25
  26 my @prgs = () ;
  27 my @w_files = () ;
  28
  29 if (@ARGV)
  30   { print "ARGV = [@ARGV]\n" ;
  31       @w_files = map { s#^#./lib/$pragma_name/#; $_ } @ARGV
  32   }
  33 else
  34   { @w_files = sort glob(catfile(curdir(), "lib", $pragma_name, "*")) }
  35
  36 my $files = 0;
  37 foreach my $file (@w_files) {
  38
  39     next if $file =~ /(~|\.orig|,v)$/;
  40     next if $file =~ /perlio$/ && !(find PerlIO::Layer 'perlio');
  41     next if -d $file;
  42
  43     open F, "<$file" or die "Cannot open $file: $!\n" ;
  44     my $line = 0;
  45     while (<F>) {
  46         $line++;
  47         last if /^__END__/ ;
  48     }
  49
  50     {
  51         local $/ = undef;
  52         $files++;
  53         @prgs = (@prgs, $file, split "\n########\n", <F>) ;
  54     }
  55     close F ;
  56 }
  57
  58 $^X = rel2abs($^X);
  59 my $tempdir = tempfile;
  60
  61 mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
  62 chdir $tempdir or die die "Can't chdir '$tempdir': $!";
  63 unshift @INC, '../../lib';
  64 my $cleanup = 1;
  65 my %tempfiles;
  66
  67 END {
  68     if ($cleanup) {
  69         chdir '..' or die "Couldn't chdir .. for cleanup: $!";
  70         rmtree($tempdir);
  71     }
  72 }
  73
  74 local $/ = undef;
  75
  76 my $tests = $::local_tests || 0;
  77 $tests = scalar(@prgs)-$files + $tests if $tests !~ /\D/;
  78 plan $tests;    # If input is 'no_plan', pass it on unchanged
  79
  80 for (@prgs){
  81     unless (/\n/)
  82      {
  83       print "# From $_\n";
  84       next;
  85      }
  86     my $switch = "";
  87     my @temps = () ;
  88     my @temp_path = () ;
  89     if (s/^\s*-\w+//){
  90         $switch = $&;
  91     }
  92     my($prog,$expected) = split(/\nEXPECT(?:\n|$)/, $_, 2);
  93
  94     my %reason;
  95     foreach my $what (qw(skip todo)) {
  96         $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
  97         # If the SKIP reason starts ? then it's taken as a code snippet to
  98         # evaluate. This provides the flexibility to have conditional SKIPs
  99         if ($reason{$what} && $reason{$what} =~ s/^\?//) {
 100             my $temp = eval $reason{$what};
 101             if ($@) {
 102                 die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
 103             }
 104             $reason{$what} = $temp;
 105         }
 106     }
 107
 108     if ( $prog =~ /--FILE--/) {
 109         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
 110         shift @files ;
 111         die "Internal error: test $_ didn't split into pairs, got " .
 112                 scalar(@files) . "[" . join("%%%%", @files) ."]\n"
 113             if @files % 2 ;
 114         while (@files > 2) {
 115             my $filename = shift @files ;
 116             my $code = shift @files ;
 117             push @temps, $filename ;
 118             if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) {
 119                 mkpath($1);
 120                 push(@temp_path, $1);
 121             }
 122             open F, ">$filename" or die "Cannot open $filename: $!\n" ;
 123             print F $code ;
 124             close F or die "Cannot close $filename: $!\n";
 125         }
 126         shift @files ;
 127         $prog = shift @files ;
 128     }
 129
 130     open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
 131     print TEST q{
 132         BEGIN {
 133             open(STDERR, ">&STDOUT")
 134               or die "Can't dup STDOUT->STDERR: $!;";
 135         }
 136     };
 137     print TEST "\n#line 1\n";  # So the line numbers don't get messed up.
 138     print TEST $prog,"\n";
 139     close TEST or die "Cannot close $tmpfile: $!";
 140     my $results = runperl( switches => ["-I../../lib", $switch], nolib => 1,
 141                            stderr => 1, progfile => $tmpfile );
 142     my $status = $?;
 143     $results =~ s/\n+$//;
 144     # allow expected output to be written as if $prog is on STDIN
 145     $results =~ s/$::tempfile_regexp/-/g;
 146     if ($^O eq 'VMS') {
 147         # some tests will trigger VMS messages that won't be expected
 148         $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
 149
 150         # pipes double these sometimes
 151         $results =~ s/\n\n/\n/g;
 152     }
 153 # bison says 'parse error' instead of 'syntax error',
 154 # various yaccs may or may not capitalize 'syntax'.
 155     $results =~ s/^(syntax|parse) error/syntax error/mig;
 156     # allow all tests to run when there are leaks
 157     $results =~ s/Scalars leaked: \d+\n//g;
 158
 159     $expected =~ s/\n+$//;
 160     my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
 161     # any special options? (OPTIONS foo bar zap)
 162     my $option_regex = 0;
 163     my $option_random = 0;
 164     if ($expected =~ s/^OPTIONS? (.+)\n//) {
 165         foreach my $option (split(' ', $1)) {
 166             if ($option eq 'regex') { # allow regular expressions
 167                 $option_regex = 1;
 168             }
 169             elsif ($option eq 'random') { # all lines match, but in any order
 170                 $option_random = 1;
 171             }
 172             else {
 173                 die "$0: Unknown OPTION '$option'\n";
 174             }
 175         }
 176     }
 177     die "$0: can't have OPTION regex and random\n"
 178         if $option_regex + $option_random > 1;
 179     my $ok = 0;
 180     if ($results =~ s/^SKIPPED\n//) {
 181         print "$results\n" ;
 182         $ok = 1;
 183     }
 184     elsif ($option_random) {
 185         $ok = randomMatch($results, $expected);
 186     }
 187     elsif ($option_regex) {
 188         $ok = $results =~ /^$expected/;
 189     }
 190     elsif ($prefix) {
 191         $ok = $results =~ /^\Q$expected/;
 192     }
 193     else {
 194         $ok = $results eq $expected;
 195     }
 196
 197     local $::TODO = $reason{todo};
 198     print_err_line( $switch, $prog, $expected, $results, $::TODO ) unless $ok;
 199
 200     ok($ok);
 201
 202     foreach (@temps)
 203         { unlink $_ if $_ }
 204     foreach (@temp_path)
 205         { rmtree $_ if -d $_ }
 206 }
 207
 208 sub randomMatch
 209 {
 210     my $got = shift ;
 211     my $expected = shift;
 212
 213     my @got = sort split "\n", $got ;
 214     my @expected = sort split "\n", $expected ;
 215
 216    return "@got" eq "@expected";
 217
 218 }
 219
 220 sub print_err_line {
 221     my($switch, $prog, $expected, $results, $todo) = @_;
 222     my $err_line = "PROG: $switch\n$prog\n" .
 223                    "EXPECTED:\n$expected\n" .
 224                    "GOT:\n$results\n";
 225     if ($todo) {
 226         $err_line =~ s/^/# /mg;
 227         print $err_line;  # Harness can't filter it out from STDERR.
 228     }
 229     else {
 230         print STDERR $err_line;
 231     }
 232
 233     return 1;
 234 }
 235
 236 1;