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 | |
95dfd3ab |
62 | foreach $k (sort keys %$tre) { |
63 | $v = $tre->{$k}; |
599cee73 |
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 ; |
599cee73 |
73 | } |
74 | |
75 | ########################################################################### |
76 | |
77 | sub mkRange |
78 | { |
79 | my @a = @_ ; |
80 | my @out = @a ; |
81 | my $i ; |
82 | |
83 | |
84 | for ($i = 1 ; $i < @a; ++ $i) { |
85 | $out[$i] = ".." |
86 | if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ; |
87 | } |
88 | |
89 | my $out = join(",",@out); |
90 | |
91 | $out =~ s/,(\.\.,)+/../g ; |
92 | return $out; |
93 | } |
94 | |
95 | ########################################################################### |
96 | |
97 | sub mkHex |
98 | { |
99 | my ($max, @a) = @_ ; |
100 | my $mask = "\x00" x $max ; |
101 | my $string = "" ; |
102 | |
103 | foreach (@a) { |
104 | vec($mask, $_, 1) = 1 ; |
105 | } |
106 | |
107 | #$string = unpack("H$max", $mask) ; |
108 | #$string =~ s/(..)/\x$1/g; |
109 | foreach (unpack("C*", $mask)) { |
110 | $string .= '\x' . sprintf("%2.2x", $_) ; |
111 | } |
112 | return $string ; |
113 | } |
114 | |
115 | ########################################################################### |
116 | |
117 | |
118 | #unlink "warning.h"; |
119 | #unlink "lib/warning.pm"; |
120 | open(WARN, ">warning.h") || die "Can't create warning.h: $!\n"; |
121 | open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n"; |
122 | |
123 | print WARN <<'EOM' ; |
124 | /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! |
125 | This file is built by warning.pl |
126 | Any changes made here will be lost! |
127 | */ |
128 | |
129 | |
130 | #define Off(x) ((x) / 8) |
131 | #define Bit(x) (1 << ((x) % 8)) |
132 | #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) |
133 | |
134 | #define G_WARN_OFF 0 /* $^W == 0 */ |
135 | #define G_WARN_ON 1 /* $^W != 0 */ |
136 | #define G_WARN_ALL_ON 2 /* -W flag */ |
137 | #define G_WARN_ALL_OFF 4 /* -X flag */ |
138 | #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) |
139 | |
140 | #if 1 |
141 | |
142 | /* Part of the logic below assumes that WARN_NONE is NULL */ |
143 | |
144 | #define ckDEAD(x) \ |
e24b16f9 |
145 | (PL_curcop->cop_warnings != WARN_ALL && \ |
146 | PL_curcop->cop_warnings != WARN_NONE && \ |
147 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) |
599cee73 |
148 | |
149 | #define ckWARN(x) \ |
e24b16f9 |
150 | ( (PL_curcop->cop_warnings && \ |
151 | (PL_curcop->cop_warnings == WARN_ALL || \ |
152 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ |
599cee73 |
153 | || (PL_dowarn & G_WARN_ON) ) |
154 | |
155 | #define ckWARN2(x,y) \ |
e24b16f9 |
156 | ( (PL_curcop->cop_warnings && \ |
157 | (PL_curcop->cop_warnings == WARN_ALL || \ |
158 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ |
159 | IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ |
599cee73 |
160 | || (PL_dowarn & G_WARN_ON) ) |
161 | |
162 | #else |
163 | |
e24b16f9 |
164 | #define ckDEAD(x) \ |
165 | (PL_curcop->cop_warnings != WARN_ALL && \ |
166 | PL_curcop->cop_warnings != WARN_NONE && \ |
167 | SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) |
599cee73 |
168 | |
e24b16f9 |
169 | #define ckWARN(x) \ |
599cee73 |
170 | ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ |
e24b16f9 |
171 | PL_curcop->cop_warnings && \ |
172 | ( PL_curcop->cop_warnings == WARN_ALL || \ |
173 | SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) |
599cee73 |
174 | |
e24b16f9 |
175 | #define ckWARN2(x,y) \ |
599cee73 |
176 | ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ |
e24b16f9 |
177 | PL_curcop->cop_warnings && \ |
178 | ( PL_curcop->cop_warnings == WARN_ALL || \ |
179 | SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ |
180 | SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) |
599cee73 |
181 | |
182 | #endif |
183 | |
184 | #define WARN_NONE NULL |
e24b16f9 |
185 | #define WARN_ALL (&PL_sv_yes) |
599cee73 |
186 | |
187 | EOM |
188 | |
189 | |
190 | $index = 0 ; |
191 | @{ $list{"all"} } = walk ($tree) ; |
192 | |
193 | $index *= 2 ; |
194 | my $warn_size = int($index / 8) + ($index % 8 != 0) ; |
195 | |
196 | my $k ; |
197 | foreach $k (sort { $a <=> $b } keys %Value) { |
198 | print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ; |
199 | } |
200 | print WARN "\n" ; |
201 | |
202 | print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; |
203 | #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; |
204 | print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; |
205 | print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; |
206 | |
207 | print WARN <<'EOM'; |
208 | |
209 | /* end of file warning.h */ |
210 | |
211 | EOM |
212 | |
213 | close WARN ; |
214 | |
215 | while (<DATA>) { |
216 | last if /^KEYWORDS$/ ; |
217 | print PM $_ ; |
218 | } |
219 | |
220 | $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; |
221 | print PM "%Bits = (\n" ; |
222 | foreach $k (sort keys %list) { |
223 | |
224 | my $v = $list{$k} ; |
225 | my @list = sort { $a <=> $b } @$v ; |
226 | |
227 | print PM tab(4, " '$k'"), '=> "', |
228 | # mkHex($warn_size, @list), |
229 | mkHex($warn_size, map $_ * 2 , @list), |
230 | '", # [', mkRange(@list), "]\n" ; |
231 | } |
232 | |
233 | print PM " );\n\n" ; |
234 | |
235 | print PM "%DeadBits = (\n" ; |
236 | foreach $k (sort keys %list) { |
237 | |
238 | my $v = $list{$k} ; |
239 | my @list = sort { $a <=> $b } @$v ; |
240 | |
241 | print PM tab(4, " '$k'"), '=> "', |
242 | # mkHex($warn_size, @list), |
243 | mkHex($warn_size, map $_ * 2 + 1 , @list), |
244 | '", # [', mkRange(@list), "]\n" ; |
245 | } |
246 | |
247 | print PM " );\n\n" ; |
248 | while (<DATA>) { |
249 | print PM $_ ; |
250 | } |
251 | |
252 | close PM ; |
253 | |
254 | __END__ |
255 | |
256 | # This file was created by warning.pl |
257 | # Any changes made here will be lost. |
258 | # |
259 | |
260 | package warning; |
261 | |
262 | =head1 NAME |
263 | |
264 | warning - Perl pragma to control |
265 | |
266 | =head1 SYNOPSIS |
267 | |
268 | use warning; |
269 | |
270 | use warning "all"; |
271 | use warning "deprecated"; |
272 | |
273 | use warning; |
274 | no warning "unsafe"; |
275 | |
276 | =head1 DESCRIPTION |
277 | |
278 | If no import list is supplied, all possible restrictions are assumed. |
279 | (This is the safest mode to operate in, but is sometimes too strict for |
280 | casual programming.) Currently, there are three possible things to be |
281 | strict about: |
282 | |
283 | =over 6 |
284 | |
285 | =item C<warning deprecated> |
286 | |
287 | This generates a runtime error if you use deprecated |
288 | |
289 | use warning 'deprecated'; |
290 | |
291 | =back |
292 | |
293 | See L<perlmod/Pragmatic Modules>. |
294 | |
295 | |
296 | =cut |
297 | |
298 | use Carp ; |
299 | |
300 | KEYWORDS |
301 | |
302 | sub bits { |
303 | my $mask ; |
304 | my $catmask ; |
305 | my $fatal = 0 ; |
306 | foreach my $word (@_) { |
307 | if ($word eq 'FATAL') |
308 | { $fatal = 1 } |
309 | elsif ($catmask = $Bits{$word}) { |
310 | $mask |= $catmask ; |
311 | $mask |= $DeadBits{$word} if $fatal ; |
312 | } |
313 | else |
314 | { croak "unknown warning category '$word'" } |
315 | } |
316 | |
317 | return $mask ; |
318 | } |
319 | |
320 | sub import { |
321 | shift; |
322 | $^B |= bits(@_ ? @_ : 'all') ; |
323 | } |
324 | |
325 | sub unimport { |
326 | shift; |
327 | $^B &= ~ bits(@_ ? @_ : 'all') ; |
328 | } |
329 | |
330 | |
331 | sub make_fatal |
332 | { |
333 | my $self = shift ; |
334 | my $bitmask = $self->bits(@_) ; |
335 | $SIG{__WARN__} = |
336 | sub |
337 | { |
338 | die @_ if $^B & $bitmask ; |
339 | warn @_ |
340 | } ; |
341 | } |
342 | |
343 | sub bitmask |
344 | { |
345 | return $^B ; |
346 | } |
347 | |
348 | sub enabled |
349 | { |
350 | my $string = shift ; |
351 | |
352 | return 1 |
353 | if $bits{$string} && $^B & $bits{$string} ; |
354 | |
355 | return 0 ; |
356 | } |
357 | |
358 | 1; |