This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tweak warnings.t and kill_perl.t for VMS
[perl5.git] / 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 $| = 1;
11
12 my $Is_VMS     = $^O eq 'VMS';
13 my $Is_MSWin32 = $^O eq 'MSWin32';
14 my $Is_NetWare = $^O eq 'NetWare';
15 my $tmpfile = "tmp0000";
16 my $i = 0 ;
17 1 while -f ++$tmpfile;
18 END {  if ($tmpfile) { 1 while unlink $tmpfile} }
19
20 my @prgs = () ;
21 my @w_files = () ;
22
23 if (@ARGV)
24   { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV }
25 else
26   { @w_files = sort glob("lib/warnings/*") }
27
28 my $files = 0;
29 foreach my $file (@w_files) {
30
31     next if $file =~ /(~|\.orig|,v)$/;
32
33     open F, "<$file" or die "Cannot open $file: $!\n" ;
34     my $line = 0;
35     while (<F>) {
36         $line++; 
37         last if /^__END__/ ;
38     }
39
40     {
41         local $/ = undef;
42         $files++; 
43         @prgs = (@prgs, $file, split "\n########\n", <F>) ;
44     }
45     close F ;
46 }
47
48 undef $/;
49
50 print "1..", scalar(@prgs)-$files, "\n";
51  
52  
53 for (@prgs){
54     unless (/\n/)
55      {
56       print "# From $_\n"; 
57       next; 
58      }
59     my $switch = "";
60     my @temps = () ;
61     if (s/^\s*-\w+//){
62         $switch = $&;
63         $switch =~ s/(-\S*[A-Z]\S*)/"$1"/ if $Is_VMS; # protect uc switches
64     }
65     my($prog,$expected) = split(/\nEXPECT\n/, $_);
66     if ( $prog =~ /--FILE--/) {
67         my(@files) = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ;
68         shift @files ;
69         die "Internal error test $i didn't split into pairs, got " . 
70                 scalar(@files) . "[" . join("%%%%", @files) ."]\n"
71             if @files % 2 ;
72         while (@files > 2) {
73             my $filename = shift @files ;
74             my $code = shift @files ;
75             push @temps, $filename ;
76             open F, ">$filename" or die "Cannot open $filename: $!\n" ;
77             print F $code ;
78             close F ;
79         }
80         shift @files ;
81         $prog = shift @files ;
82     }
83     open TEST, ">$tmpfile";
84     print TEST q{
85         BEGIN { 
86             open(STDERR, ">&STDOUT") 
87               or die "Can't dup STDOUT->STDERR: $!;";
88         }
89     };
90     print TEST "\n#line 1\n";  # So the line numbers don't get messed up.
91     print TEST $prog,"\n";
92     close TEST;
93     my $results = $Is_VMS ?
94                   `./perl "-I../lib" $switch $tmpfile` :
95                   $Is_MSWin32 ?
96                   `.\\perl -I../lib $switch $tmpfile` :
97                   $Is_NetWare ?
98                   `perl -I../lib $switch $tmpfile` :
99                   `./perl -I../lib $switch $tmpfile`;
100     my $status = $?;
101     $results =~ s/\n+$//;
102     # allow expected output to be written as if $prog is on STDIN
103     $results =~ s/tmp\d+/-/g;
104     if ($^O eq 'VMS') {
105         # some tests will trigger VMS messages that won't be expected
106         $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
107
108         # pipes double these sometimes
109         $results =~ s/\n\n/\n/g;
110     }
111 # bison says 'parse error' instead of 'syntax error',
112 # various yaccs may or may not capitalize 'syntax'.
113     $results =~ s/^(syntax|parse) error/syntax error/mig;
114     # allow all tests to run when there are leaks
115     $results =~ s/Scalars leaked: \d+\n//g;
116     $expected =~ s/\n+$//;
117     my $prefix = ($results =~ s#^PREFIX(\n|$)##) ;
118     # any special options? (OPTIONS foo bar zap)
119     my $option_regex = 0;
120     if ($expected =~ s/^OPTIONS? (.+)\n//) {
121         foreach my $option (split(' ', $1)) {
122             if ($option eq 'regex') { # allow regular expressions
123                 $option_regex = 1;
124             } else {
125                 die "$0: Unknown OPTION '$option'\n";
126             }
127         }
128     }
129     if ( $results =~ s/^SKIPPED\n//) {
130         print "$results\n" ;
131     }
132     elsif (($prefix  && (( $option_regex && $results !~ /^$expected/) ||
133                          (!$option_regex && $results !~ /^\Q$expected/))) or
134            (!$prefix && (( $option_regex && $results !~ /^$expected/) ||
135                          (!$option_regex && $results ne $expected)))) {
136         print STDERR "PROG: $switch\n$prog\n";
137         print STDERR "EXPECTED:\n$expected\n";
138         print STDERR "GOT:\n$results\n";
139         print "not ";
140     }
141     print "ok ", ++$i, "\n";
142     foreach (@temps) 
143         { unlink $_ if $_ } 
144 }