This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add test for previous fix
[perl5.git] / warning.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
3use strict ;
4
5sub DEFAULT_ON () { 1 }
6sub DEFAULT_OFF () { 2 }
7
8my $tree = {
9 'unsafe' => { 'untie' => DEFAULT_OFF,
10 'substr' => DEFAULT_OFF,
11 'taint' => DEFAULT_OFF,
12 'signal' => DEFAULT_OFF,
13 'closure' => DEFAULT_OFF,
14 'utf8' => DEFAULT_OFF,
15 } ,
16 'io' => { 'pipe' => DEFAULT_OFF,
17 'unopened' => DEFAULT_OFF,
18 'closed' => DEFAULT_OFF,
19 'newline' => DEFAULT_OFF,
20 'exec' => DEFAULT_OFF,
21 #'wr in in file'=> DEFAULT_OFF,
22 },
23 'syntax' => { 'ambiguous' => DEFAULT_OFF,
24 'semicolon' => DEFAULT_OFF,
25 'precedence' => DEFAULT_OFF,
26 'reserved' => DEFAULT_OFF,
27 'octal' => DEFAULT_OFF,
28 'parenthesis' => DEFAULT_OFF,
29 'deprecated' => DEFAULT_OFF,
30 'printf' => DEFAULT_OFF,
31 },
32 'void' => DEFAULT_OFF,
33 'recursion' => DEFAULT_OFF,
34 'redefine' => DEFAULT_OFF,
35 'numeric' => DEFAULT_OFF,
36 'uninitialized'=> DEFAULT_OFF,
37 'once' => DEFAULT_OFF,
38 'misc' => DEFAULT_OFF,
39 'default' => DEFAULT_ON,
40 } ;
41
42
43###########################################################################
44sub tab {
45 my($l, $t) = @_;
46 $t .= "\t" x ($l - (length($t) + 1) / 8);
47 $t;
48}
49
50###########################################################################
51
52my %list ;
53my %Value ;
54my $index = 0 ;
55
56sub walk
57{
58 my $tre = shift ;
59 my @list = () ;
60 my ($k, $v) ;
61
62 while (($k, $v) = each %$tre) {
63
64 die "duplicate key $k\n" if defined $list{$k} ;
65 $Value{$index} = uc $k ;
66 push @{ $list{$k} }, $index ++ ;
67 if (ref $v)
68 { push (@{ $list{$k} }, walk ($v)) }
69 push @list, @{ $list{$k} } ;
70 }
71
72 return @list ;
73
74}
75
76###########################################################################
77
78sub mkRange
79{
80 my @a = @_ ;
81 my @out = @a ;
82 my $i ;
83
84
85 for ($i = 1 ; $i < @a; ++ $i) {
86 $out[$i] = ".."
87 if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
88 }
89
90 my $out = join(",",@out);
91
92 $out =~ s/,(\.\.,)+/../g ;
93 return $out;
94}
95
96###########################################################################
97
98sub mkHex
99{
100 my ($max, @a) = @_ ;
101 my $mask = "\x00" x $max ;
102 my $string = "" ;
103
104 foreach (@a) {
105 vec($mask, $_, 1) = 1 ;
106 }
107
108 #$string = unpack("H$max", $mask) ;
109 #$string =~ s/(..)/\x$1/g;
110 foreach (unpack("C*", $mask)) {
111 $string .= '\x' . sprintf("%2.2x", $_) ;
112 }
113 return $string ;
114}
115
116###########################################################################
117
118
119#unlink "warning.h";
120#unlink "lib/warning.pm";
121open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
122open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
123
124print WARN <<'EOM' ;
125/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
126 This file is built by warning.pl
127 Any changes made here will be lost!
128*/
129
130
131#define Off(x) ((x) / 8)
132#define Bit(x) (1 << ((x) % 8))
133#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
134
135#define G_WARN_OFF 0 /* $^W == 0 */
136#define G_WARN_ON 1 /* $^W != 0 */
137#define G_WARN_ALL_ON 2 /* -W flag */
138#define G_WARN_ALL_OFF 4 /* -X flag */
139#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
140
141#if 1
142
143/* Part of the logic below assumes that WARN_NONE is NULL */
144
145#define ckDEAD(x) \
146 (curcop->cop_warnings != WARN_ALL && \
147 curcop->cop_warnings != WARN_NONE && \
148 IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
149
150#define ckWARN(x) \
151 ( (curcop->cop_warnings && \
152 (curcop->cop_warnings == WARN_ALL || \
153 IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
154 || (PL_dowarn & G_WARN_ON) )
155
156#define ckWARN2(x,y) \
157 ( (curcop->cop_warnings && \
158 (curcop->cop_warnings == WARN_ALL || \
159 IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
160 IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
161 || (PL_dowarn & G_WARN_ON) )
162
163#else
164
165#define ckDEAD(x) \
166 (curcop->cop_warnings != WARN_ALL && \
167 curcop->cop_warnings != WARN_NONE && \
168 SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
169
170#define ckWARN(x) \
171 ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
172 curcop->cop_warnings && \
173 ( curcop->cop_warnings == WARN_ALL || \
174 SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
175
176#define ckWARN2(x,y) \
177 ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
178 curcop->cop_warnings && \
179 ( curcop->cop_warnings == WARN_ALL || \
180 SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
181 SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
182
183#endif
184
185#define WARN_NONE NULL
186#define WARN_ALL (&sv_yes)
187
188EOM
189
190
191$index = 0 ;
192@{ $list{"all"} } = walk ($tree) ;
193
194$index *= 2 ;
195my $warn_size = int($index / 8) + ($index % 8 != 0) ;
196
197my $k ;
198foreach $k (sort { $a <=> $b } keys %Value) {
199 print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
200}
201print WARN "\n" ;
202
203print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
204#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
205print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
206print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
207
208print WARN <<'EOM';
209
210/* end of file warning.h */
211
212EOM
213
214close WARN ;
215
216while (<DATA>) {
217 last if /^KEYWORDS$/ ;
218 print PM $_ ;
219}
220
221$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
222print PM "%Bits = (\n" ;
223foreach $k (sort keys %list) {
224
225 my $v = $list{$k} ;
226 my @list = sort { $a <=> $b } @$v ;
227
228 print PM tab(4, " '$k'"), '=> "',
229 # mkHex($warn_size, @list),
230 mkHex($warn_size, map $_ * 2 , @list),
231 '", # [', mkRange(@list), "]\n" ;
232}
233
234print PM " );\n\n" ;
235
236print PM "%DeadBits = (\n" ;
237foreach $k (sort keys %list) {
238
239 my $v = $list{$k} ;
240 my @list = sort { $a <=> $b } @$v ;
241
242 print PM tab(4, " '$k'"), '=> "',
243 # mkHex($warn_size, @list),
244 mkHex($warn_size, map $_ * 2 + 1 , @list),
245 '", # [', mkRange(@list), "]\n" ;
246}
247
248print PM " );\n\n" ;
249while (<DATA>) {
250 print PM $_ ;
251}
252
253close PM ;
254
255__END__
256
257# This file was created by warning.pl
258# Any changes made here will be lost.
259#
260
261package warning;
262
263=head1 NAME
264
265warning - Perl pragma to control
266
267=head1 SYNOPSIS
268
269 use warning;
270
271 use warning "all";
272 use warning "deprecated";
273
274 use warning;
275 no warning "unsafe";
276
277=head1 DESCRIPTION
278
279If no import list is supplied, all possible restrictions are assumed.
280(This is the safest mode to operate in, but is sometimes too strict for
281casual programming.) Currently, there are three possible things to be
282strict about:
283
284=over 6
285
286=item C<warning deprecated>
287
288This generates a runtime error if you use deprecated
289
290 use warning 'deprecated';
291
292=back
293
294See L<perlmod/Pragmatic Modules>.
295
296
297=cut
298
299use Carp ;
300
301KEYWORDS
302
303sub bits {
304 my $mask ;
305 my $catmask ;
306 my $fatal = 0 ;
307 foreach my $word (@_) {
308 if ($word eq 'FATAL')
309 { $fatal = 1 }
310 elsif ($catmask = $Bits{$word}) {
311 $mask |= $catmask ;
312 $mask |= $DeadBits{$word} if $fatal ;
313 }
314 else
315 { croak "unknown warning category '$word'" }
316 }
317
318 return $mask ;
319}
320
321sub import {
322 shift;
323 $^B |= bits(@_ ? @_ : 'all') ;
324}
325
326sub unimport {
327 shift;
328 $^B &= ~ bits(@_ ? @_ : 'all') ;
329}
330
331
332sub make_fatal
333{
334 my $self = shift ;
335 my $bitmask = $self->bits(@_) ;
336 $SIG{__WARN__} =
337 sub
338 {
339 die @_ if $^B & $bitmask ;
340 warn @_
341 } ;
342}
343
344sub bitmask
345{
346 return $^B ;
347}
348
349sub enabled
350{
351 my $string = shift ;
352
353 return 1
354 if $bits{$string} && $^B & $bits{$string} ;
355
356 return 0 ;
357}
358
3591;