Commit | Line | Data |
599cee73 |
1 | #!/usr/bin/perl |
2 | |
73f0cc2d |
3 | BEGIN { |
4 | push @INC, './lib'; |
5 | } |
599cee73 |
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 |
35 | 'severe' => { 'inplace' => DEFAULT_ON, |
36 | 'internal' => DEFAULT_ON, |
37 | 'debugging' => DEFAULT_ON, |
38 | }, |
599cee73 |
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 |
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 |
69 | foreach $k (sort keys %$tre) { |
70 | $v = $tre->{$k}; |
599cee73 |
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 |
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 |
137 | #define Off(x) ((x) / 8) |
138 | #define Bit(x) (1 << ((x) % 8)) |
599cee73 |
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 |
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 |
147 | #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) |
148 | |
0453d815 |
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 |
153 | #define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ |
154 | (x) == WARN_NONE) |
599cee73 |
155 | |
156 | #define ckDEAD(x) \ |
0453d815 |
157 | ( ! specialWARN(PL_curcop->cop_warnings) && \ |
e24b16f9 |
158 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) |
599cee73 |
159 | |
160 | #define ckWARN(x) \ |
0453d815 |
161 | ( (PL_curcop->cop_warnings != WARN_STD && \ |
162 | PL_curcop->cop_warnings != WARN_NONE && \ |
e24b16f9 |
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 |
166 | |
167 | #define ckWARN2(x,y) \ |
0453d815 |
168 | ( (PL_curcop->cop_warnings != WARN_STD && \ |
169 | PL_curcop->cop_warnings != WARN_NONE && \ |
e24b16f9 |
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 |
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 |
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 |
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 |
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 |
272 | |
273 | =head1 SYNOPSIS |
274 | |
275 | use warning; |
0453d815 |
276 | no warning; |
599cee73 |
277 | |
278 | use warning "all"; |
0453d815 |
279 | no warning "all"; |
599cee73 |
280 | |
281 | =head1 DESCRIPTION |
282 | |
0453d815 |
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 |
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; |