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
CommitLineData
bd4dea8e
JH
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 $ENV{PERL5LIB} = '../lib';
7 require Config; import Config;
8}
9
10$| = 1;
11
12my $Is_VMS = $^O eq 'VMS';
13my $Is_MSWin32 = $^O eq 'MSWin32';
14my $Is_NetWare = $^O eq 'NetWare';
15my $tmpfile = "tmp0000";
16my $i = 0 ;
171 while -f ++$tmpfile;
18END { if ($tmpfile) { 1 while unlink $tmpfile} }
19
20my @prgs = () ;
21my @w_files = () ;
22
23if (@ARGV)
601f2d16 24 { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./lib/warnings/#; $_ } @ARGV }
bd4dea8e 25else
601f2d16 26 { @w_files = sort glob("lib/warnings/*") }
bd4dea8e
JH
27
28my $files = 0;
29foreach 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
48undef $/;
49
50print "1..", scalar(@prgs)-$files, "\n";
51
52
53for (@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";
d6920b13
MS
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.
bd4dea8e
JH
91 print TEST $prog,"\n";
92 close TEST;
93 my $results = $Is_VMS ?
d6920b13 94 `./perl "-I../lib" $switch $tmpfile` :
bd4dea8e 95 $Is_MSWin32 ?
d6920b13 96 `.\\perl -I../lib $switch $tmpfile` :
bd4dea8e 97 $Is_NetWare ?
d6920b13
MS
98 `perl -I../lib $switch $tmpfile` :
99 `./perl -I../lib $switch $tmpfile`;
bd4dea8e
JH
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;
765ebaf2
CB
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 }
bd4dea8e
JH
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}