t/lib/common.pl

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