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