home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / strict.t < prev    next >
Text File  |  2000-02-29  |  2KB  |  92 lines
  1. #!./perl 
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib';
  6.     $ENV{PERL5LIB} = '../lib';
  7. }
  8.  
  9. $| = 1;
  10.  
  11. my $Is_VMS = $^O eq 'VMS';
  12. my $Is_MSWin32 = $^O eq 'MSWin32';
  13. my $tmpfile = "tmp0000";
  14. my $i = 0 ;
  15. 1 while -f ++$tmpfile;
  16. END { if ($tmpfile) { 1 while unlink $tmpfile; } }
  17.  
  18. my @prgs = () ;
  19.  
  20. foreach (sort glob("pragma/strict-*")) {
  21.  
  22.     next if /(~|\.orig)$/;
  23.  
  24.     open F, "<$_" or die "Cannot open $_: $!\n" ;
  25.     while (<F>) {
  26.     last if /^__END__/ ;
  27.     }
  28.  
  29.     {
  30.         local $/ = undef;
  31.         @prgs = (@prgs, split "\n########\n", <F>) ;
  32.     }
  33.     close F ;
  34. }
  35.  
  36. undef $/;
  37.  
  38. print "1..", scalar @prgs, "\n";
  39.  
  40.  
  41. for (@prgs){
  42.     my $switch = "";
  43.     my @temps = () ;
  44.     if (s/^\s*-\w+//){
  45.         $switch = $&;
  46.     }
  47.     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  48.     if ( $prog =~ /--FILE--/) {
  49.         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
  50.     shift @files ;
  51.     die "Internal error test $i didn't split into pairs, got " . 
  52.         scalar(@files) . "[" . join("%%%%", @files) ."]\n"
  53.         if @files % 2 ;
  54.     while (@files > 2) {
  55.         my $filename = shift @files ;
  56.         my $code = shift @files ;
  57.             push @temps, $filename ;
  58.         open F, ">$filename" or die "Cannot open $filename: $!\n" ;
  59.         print F $code ;
  60.         close F ;
  61.     }
  62.     shift @files ;
  63.     $prog = shift @files ;
  64.     }
  65.     open TEST, ">$tmpfile";
  66.     print TEST $prog,"\n";
  67.     close TEST;
  68.     my $results = $Is_MSWin32 ?
  69.                   `.\\perl -I../lib $switch $tmpfile 2>&1` :
  70.                   `./perl $switch $tmpfile 2>&1`;
  71.     my $status = $?;
  72.     $results =~ s/\n+$//;
  73.     # allow expected output to be written as if $prog is on STDIN
  74.     $results =~ s/tmp\d+/-/g;
  75.     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  76.     $expected =~ s/\n+$//;
  77.     my $prefix = ($results =~ s/^PREFIX\n//) ;
  78.     if ( $results =~ s/^SKIPPED\n//) {
  79.     print "$results\n" ;
  80.     }
  81.     elsif (($prefix and $results !~ /^\Q$expected/) or
  82.        (!$prefix and $results ne $expected)){
  83.         print STDERR "PROG: $switch\n$prog\n";
  84.         print STDERR "EXPECTED:\n$expected\n";
  85.         print STDERR "GOT:\n$results\n";
  86.         print "not ";
  87.     }
  88.     print "ok ", ++$i, "\n";
  89.     foreach (@temps) 
  90.     { unlink $_ if $_ } 
  91. }
  92.