Commit | Line | Data |
---|---|---|
599cee73 PM |
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) \ | |
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 | ||
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; |