home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / warnings.t < prev   
Text File  |  2000-02-29  |  3KB  |  122 lines
  1. #!./perl 
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     $ENV{PERL5LIB} = '../lib';
  7.     require Config; import Config;
  8. }
  9.  
  10. $| = 1;
  11.  
  12. my $Is_VMS     = $^O eq 'VMS';
  13. my $Is_MSWin32 = $^O eq 'MSWin32';
  14. my $tmpfile = "tmp0000";
  15. my $i = 0 ;
  16. 1 while -f ++$tmpfile;
  17. END {  if ($tmpfile) { 1 while unlink $tmpfile} }
  18.  
  19. my @prgs = () ;
  20. my @w_files = () ;
  21.  
  22. if (@ARGV)
  23.   { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn/#; $_ } @ARGV }
  24. else
  25.   { @w_files = sort glob("pragma/warn/*") }
  26.  
  27. foreach (@w_files) {
  28.  
  29.     next if /\.orig$/ ;
  30.  
  31.     next if /(~|\.orig)$/;
  32.  
  33.     open F, "<$_" or die "Cannot open $_: $!\n" ;
  34.     while (<F>) {
  35.     last if /^__END__/ ;
  36.     }
  37.  
  38.     {
  39.         local $/ = undef;
  40.         @prgs = (@prgs, split "\n########\n", <F>) ;
  41.     }
  42.     close F ;
  43. }
  44.  
  45. undef $/;
  46.  
  47. print "1..", scalar @prgs, "\n";
  48.  
  49.  
  50. for (@prgs){
  51.     my $switch = "";
  52.     my @temps = () ;
  53.     if (s/^\s*-\w+//){
  54.         $switch = $&;
  55.         $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
  56.     }
  57.     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  58.     if ( $prog =~ /--FILE--/) {
  59.         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
  60.     shift @files ;
  61.     die "Internal error test $i didn't split into pairs, got " . 
  62.         scalar(@files) . "[" . join("%%%%", @files) ."]\n"
  63.         if @files % 2 ;
  64.     while (@files > 2) {
  65.         my $filename = shift @files ;
  66.         my $code = shift @files ;
  67.             push @temps, $filename ;
  68.         open F, ">$filename" or die "Cannot open $filename: $!\n" ;
  69.         print F $code ;
  70.         close F ;
  71.     }
  72.     shift @files ;
  73.     $prog = shift @files ;
  74.     }
  75.     open TEST, ">$tmpfile";
  76.     print TEST $prog,"\n";
  77.     close TEST;
  78.     my $results = $Is_VMS ?
  79.                   `./perl "-I../lib" $switch $tmpfile 2>&1` :
  80.           $Is_MSWin32 ?
  81.                   `.\\perl -I../lib $switch $tmpfile 2>&1` :
  82.                   `./perl -I../lib $switch $tmpfile 2>&1`;
  83.     my $status = $?;
  84.     $results =~ s/\n+$//;
  85.     # allow expected output to be written as if $prog is on STDIN
  86.     $results =~ s/tmp\d+/-/g;
  87.     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  88. # bison says 'parse error' instead of 'syntax error',
  89. # various yaccs may or may not capitalize 'syntax'.
  90.     $results =~ s/^(syntax|parse) error/syntax error/mig;
  91.     # allow all tests to run when there are leaks
  92.     $results =~ s/Scalars leaked: \d+\n//g;
  93.     $expected =~ s/\n+$//;
  94.     my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
  95.     # any special options? (OPTIONS foo bar zap)
  96.     my $option_regex = 0;
  97.     if ($expected =~ s/^OPTIONS? (.+)\n//) {
  98.     foreach my $option (split(' ', $1)) {
  99.         if ($option eq 'regex') { # allow regular expressions
  100.         $option_regex = 1;
  101.         } else {
  102.         die "$0: Unknown OPTION '$option'\n";
  103.         }
  104.     }
  105.     }
  106.     if ( $results =~ s/^SKIPPED\n//) {
  107.     print "$results\n" ;
  108.     }
  109.     elsif (($prefix  && (( $option_regex && $results !~ /^$expected/) ||
  110.              (!$option_regex && $results !~ /^\Q$expected/))) or
  111.        (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
  112.              (!$option_regex && $results ne $expected)))) {
  113.         print STDERR "PROG: $switch\n$prog\n";
  114.         print STDERR "EXPECTED:\n$expected\n";
  115.         print STDERR "GOT:\n$results\n";
  116.         print "not ";
  117.     }
  118.     print "ok ", ++$i, "\n";
  119.     foreach (@temps) 
  120.     { unlink $_ if $_ } 
  121. }
  122.