Commit | Line | Data |
599cee73 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict ; |
4 | |
5 | sub DEFAULT_ON () { 1 } |
6 | sub DEFAULT_OFF () { 2 } |
7 | |
8 | my $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 | ########################################################################### |
44 | sub tab { |
45 | my($l, $t) = @_; |
46 | $t .= "\t" x ($l - (length($t) + 1) / 8); |
47 | $t; |
48 | } |
49 | |
50 | ########################################################################### |
51 | |
52 | my %list ; |
53 | my %Value ; |
54 | my $index = 0 ; |
55 | |
56 | sub 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 | |
78 | sub 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 | |
98 | sub 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"; |
121 | open(WARN, ">warning.h") || die "Can't create warning.h: $!\n"; |
122 | open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n"; |
123 | |
124 | print 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) \ |
e24b16f9 |
146 | (PL_curcop->cop_warnings != WARN_ALL && \ |
147 | PL_curcop->cop_warnings != WARN_NONE && \ |
148 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) |
599cee73 |
149 | |
150 | #define ckWARN(x) \ |
e24b16f9 |
151 | ( (PL_curcop->cop_warnings && \ |
152 | (PL_curcop->cop_warnings == WARN_ALL || \ |
153 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ |
599cee73 |
154 | || (PL_dowarn & G_WARN_ON) ) |
155 | |
156 | #define ckWARN2(x,y) \ |
e24b16f9 |
157 | ( (PL_curcop->cop_warnings && \ |
158 | (PL_curcop->cop_warnings == WARN_ALL || \ |
159 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ |
160 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ |
599cee73 |
161 | || (PL_dowarn & G_WARN_ON) ) |
162 | |
163 | #else |
164 | |
e24b16f9 |
165 | #define ckDEAD(x) \ |
166 | (PL_curcop->cop_warnings != WARN_ALL && \ |
167 | PL_curcop->cop_warnings != WARN_NONE && \ |
168 | SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) |
599cee73 |
169 | |
e24b16f9 |
170 | #define ckWARN(x) \ |
599cee73 |
171 | ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ |
e24b16f9 |
172 | PL_curcop->cop_warnings && \ |
173 | ( PL_curcop->cop_warnings == WARN_ALL || \ |
174 | SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) |
599cee73 |
175 | |
e24b16f9 |
176 | #define ckWARN2(x,y) \ |
599cee73 |
177 | ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ |
e24b16f9 |
178 | PL_curcop->cop_warnings && \ |
179 | ( PL_curcop->cop_warnings == WARN_ALL || \ |
180 | SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ |
181 | SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) |
599cee73 |
182 | |
183 | #endif |
184 | |
185 | #define WARN_NONE NULL |
e24b16f9 |
186 | #define WARN_ALL (&PL_sv_yes) |
599cee73 |
187 | |
188 | EOM |
189 | |
190 | |
191 | $index = 0 ; |
192 | @{ $list{"all"} } = walk ($tree) ; |
193 | |
194 | $index *= 2 ; |
195 | my $warn_size = int($index / 8) + ($index % 8 != 0) ; |
196 | |
197 | my $k ; |
198 | foreach $k (sort { $a <=> $b } keys %Value) { |
199 | print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ; |
200 | } |
201 | print WARN "\n" ; |
202 | |
203 | print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; |
204 | #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; |
205 | print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; |
206 | print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; |
207 | |
208 | print WARN <<'EOM'; |
209 | |
210 | /* end of file warning.h */ |
211 | |
212 | EOM |
213 | |
214 | close WARN ; |
215 | |
216 | while (<DATA>) { |
217 | last if /^KEYWORDS$/ ; |
218 | print PM $_ ; |
219 | } |
220 | |
221 | $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; |
222 | print PM "%Bits = (\n" ; |
223 | foreach $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 | |
234 | print PM " );\n\n" ; |
235 | |
236 | print PM "%DeadBits = (\n" ; |
237 | foreach $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 | |
248 | print PM " );\n\n" ; |
249 | while (<DATA>) { |
250 | print PM $_ ; |
251 | } |
252 | |
253 | close PM ; |
254 | |
255 | __END__ |
256 | |
257 | # This file was created by warning.pl |
258 | # Any changes made here will be lost. |
259 | # |
260 | |
261 | package warning; |
262 | |
263 | =head1 NAME |
264 | |
265 | warning - 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 | |
279 | If 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 |
281 | casual programming.) Currently, there are three possible things to be |
282 | strict about: |
283 | |
284 | =over 6 |
285 | |
286 | =item C<warning deprecated> |
287 | |
288 | This generates a runtime error if you use deprecated |
289 | |
290 | use warning 'deprecated'; |
291 | |
292 | =back |
293 | |
294 | See L<perlmod/Pragmatic Modules>. |
295 | |
296 | |
297 | =cut |
298 | |
299 | use Carp ; |
300 | |
301 | KEYWORDS |
302 | |
303 | sub 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 | |
321 | sub import { |
322 | shift; |
323 | $^B |= bits(@_ ? @_ : 'all') ; |
324 | } |
325 | |
326 | sub unimport { |
327 | shift; |
328 | $^B &= ~ bits(@_ ? @_ : 'all') ; |
329 | } |
330 | |
331 | |
332 | sub 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 | |
344 | sub bitmask |
345 | { |
346 | return $^B ; |
347 | } |
348 | |
349 | sub enabled |
350 | { |
351 | my $string = shift ; |
352 | |
353 | return 1 |
354 | if $bits{$string} && $^B & $bits{$string} ; |
355 | |
356 | return 0 ; |
357 | } |
358 | |
359 | 1; |