lib/warnings.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     $ENV{PERL5LIB} = '../lib';
   7     require Config; import Config;
   8 }
   9
  10 use File::Path;
  11
  12 $| = 1;
  13
  14 my $Is_VMS     = $^O eq 'VMS';
  15 my $Is_MSWin32 = $^O eq 'MSWin32';
  16 my $Is_NetWare = $^O eq 'NetWare';
  17 my $tmpfile = "tmp0000";
  18 my $i = 0 ;
  19 1 while -f ++$tmpfile;
  20 END {  if ($tmpfile) { 1 while unlink $tmpfile} }
  21
  22 my @prgs = () ;
  23 my @w_files = () ;
  24
  25 if (@ARGV)
  26   { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV }
  27 else
  28   { @w_files = sort glob("lib/warnings/*") }
  29
  30 my $files = 0;
  31 foreach my $file (@w_files) {
  32
  33     next if $file =~ /(~|\.orig|,v)$/;
  34     next if $file =~ /perlio$/ && !$Config{useperlio};
  35
  36     open F, "<$file" or die "Cannot open $file: $!\n" ;
  37     my $line = 0;
  38     while (<F>) {
  39         $line++;
  40         last if /^__END__/ ;
  41     }
  42
  43     {
  44         local $/ = undef;
  45         $files++;
  46         @prgs = (@prgs, $file, split "\n########\n", <F>) ;
  47     }
  48     close F ;
  49 }
  50
  51 undef $/;
  52
  53 print "1..", scalar(@prgs)-$files, "\n";
  54
  55
  56 for (@prgs){
  57     unless (/\n/)
  58      {
  59       print "# From $_\n";
  60       next;
  61      }
  62     my $switch = "";
  63     my @temps = () ;
  64     my @temp_path = () ;
  65     if (s/^\s*-\w+//){
  66         $switch = $&;
  67         $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
  68     }
  69     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  70     if ( $prog =~ /--FILE--/) {
  71         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
  72         shift @files ;
  73         die "Internal error test $i didn't split into pairs, got " .
  74                 scalar(@files) . "[" . join("%%%%", @files) ."]\n"
  75             if @files % 2 ;
  76         while (@files > 2) {
  77             my $filename = shift @files ;
  78             my $code = shift @files ;
  79             push @temps, $filename ;
  80             if ($filename =~ m#(.*)/#) {
  81                 mkpath($1);
  82                 push(@temp_path, $1);
  83             }
  84             open F, ">$filename" or die "Cannot open $filename: $!\n" ;
  85             print F $code ;
  86             close F or die "Cannot close $filename: $!\n";
  87         }
  88         shift @files ;
  89         $prog = shift @files ;
  90     }
  91     open TEST, ">$tmpfile" or die "Cannot open >$tmpfile: $!";
  92     print TEST q{
  93         BEGIN {
  94             open(STDERR, ">&STDOUT")
  95               or die "Can't dup STDOUT->STDERR: $!;";
  96         }
  97     };
  98     print TEST "\n#line 1\n";  # So the line numbers don't get messed up.
  99     print TEST $prog,"\n";
 100     close TEST or die "Cannot close $tmpfile: $!";
 101     my $results = $Is_VMS ?
 102                       `./perl "-I../lib" $switch $tmpfile` :
 103                   $Is_MSWin32 ?
 104                       `.\\perl -I../lib $switch $tmpfile` :
 105                   $Is_NetWare ?
 106                       `perl -I../lib $switch $tmpfile` :
 107                   $Is_MacOS ?
 108                       `$^X -I::lib $switch -MMac::err=unix $tmpfile` :
 109                   `./perl -I../lib $switch $tmpfile`;
 110     my $status = $?;
 111     $results =~ s/\n+$//;
 112     # allow expected output to be written as if $prog is on STDIN
 113     $results =~ s/tmp\d+/-/g;
 114     if ($^O eq 'VMS') {
 115         # some tests will trigger VMS messages that won't be expected
 116         $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
 117
 118         # pipes double these sometimes
 119         $results =~ s/\n\n/\n/g;
 120     }
 121 # bison says 'parse error' instead of 'syntax error',
 122 # various yaccs may or may not capitalize 'syntax'.
 123     $results =~ s/^(syntax|parse) error/syntax error/mig;
 124     # allow all tests to run when there are leaks
 125     $results =~ s/Scalars leaked: \d+\n//g;
 126     $expected =~ s/\n+$//;
 127     my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
 128     # any special options? (OPTIONS foo bar zap)
 129     my $option_regex = 0;
 130     my $option_random = 0;
 131     if ($expected =~ s/^OPTIONS? (.+)\n//) {
 132         foreach my $option (split(' ', $1)) {
 133             if ($option eq 'regex') { # allow regular expressions
 134                 $option_regex = 1;
 135             }
 136             elsif ($option eq 'random') { # all lines match, but in any order
 137                 $option_random = 1;
 138             }
 139             else {
 140                 die "$0: Unknown OPTION '$option'\n";
 141             }
 142         }
 143     }
 144     die "$0: can't have OPTION regex and random\n"
 145         if $option_regex + option_random > 1;
 146     if ( $results =~ s/^SKIPPED\n//) {
 147         print "$results\n" ;
 148     }
 149     elsif ($option_random)
 150     {
 151         print "not " if !randomMatch($results, $expected);
 152     }
 153     elsif (($prefix  && (( $option_regex && $results !~ /^$expected/) ||
 154                          (!$option_regex && $results !~ /^\Q$expected/))) or
 155            (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
 156                          (!$option_regex && $results ne $expected)))) {
 157         print STDERR "PROG: $switch\n$prog\n";
 158         print STDERR "EXPECTED:\n$expected\n";
 159         print STDERR "GOT:\n$results\n";
 160         print "not ";
 161     }
 162     print "ok ", ++$i, "\n";
 163     foreach (@temps)
 164         { unlink $_ if $_ }
 165     foreach (@temp_path)
 166         { rmtree $_ if -d $_ }
 167 }
 168
 169 sub randomMatch
 170 {
 171     my $got = shift ;
 172     my $expected = shift;
 173
 174     my @got = sort split "\n", $got ;
 175     my @expected = sort split "\n", $expected ;
 176
 177    return "@got" eq "@expected";
 178
 179 }