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