1 |
root |
1.1 |
#!/usr/bin/perl |
2 |
|
|
|
3 |
|
|
$VERSION = '1.02'; |
4 |
|
|
|
5 |
|
|
BEGIN { |
6 |
|
|
push @INC, './lib'; |
7 |
|
|
} |
8 |
|
|
use strict ; |
9 |
|
|
|
10 |
|
|
sub DEFAULT_ON () { 1 } |
11 |
|
|
sub DEFAULT_OFF () { 2 } |
12 |
|
|
|
13 |
|
|
my $tree = { |
14 |
|
|
|
15 |
|
|
'all' => [ 5.008, { |
16 |
|
|
'io' => [ 5.008, { |
17 |
|
|
'pipe' => [ 5.008, DEFAULT_OFF], |
18 |
|
|
'unopened' => [ 5.008, DEFAULT_OFF], |
19 |
|
|
'closed' => [ 5.008, DEFAULT_OFF], |
20 |
|
|
'newline' => [ 5.008, DEFAULT_OFF], |
21 |
|
|
'exec' => [ 5.008, DEFAULT_OFF], |
22 |
|
|
'layer' => [ 5.008, DEFAULT_OFF], |
23 |
|
|
}], |
24 |
|
|
'syntax' => [ 5.008, { |
25 |
|
|
'ambiguous' => [ 5.008, DEFAULT_OFF], |
26 |
|
|
'semicolon' => [ 5.008, DEFAULT_OFF], |
27 |
|
|
'precedence' => [ 5.008, DEFAULT_OFF], |
28 |
|
|
'bareword' => [ 5.008, DEFAULT_OFF], |
29 |
|
|
'reserved' => [ 5.008, DEFAULT_OFF], |
30 |
|
|
'digit' => [ 5.008, DEFAULT_OFF], |
31 |
|
|
'parenthesis' => [ 5.008, DEFAULT_OFF], |
32 |
|
|
'printf' => [ 5.008, DEFAULT_OFF], |
33 |
|
|
'prototype' => [ 5.008, DEFAULT_OFF], |
34 |
|
|
'qw' => [ 5.008, DEFAULT_OFF], |
35 |
|
|
}], |
36 |
|
|
'severe' => [ 5.008, { |
37 |
|
|
'inplace' => [ 5.008, DEFAULT_ON], |
38 |
|
|
'internal' => [ 5.008, DEFAULT_ON], |
39 |
|
|
'debugging' => [ 5.008, DEFAULT_ON], |
40 |
|
|
'malloc' => [ 5.008, DEFAULT_ON], |
41 |
|
|
}], |
42 |
|
|
'deprecated' => [ 5.008, DEFAULT_OFF], |
43 |
|
|
'void' => [ 5.008, DEFAULT_OFF], |
44 |
|
|
'recursion' => [ 5.008, DEFAULT_OFF], |
45 |
|
|
'redefine' => [ 5.008, DEFAULT_OFF], |
46 |
|
|
'numeric' => [ 5.008, DEFAULT_OFF], |
47 |
|
|
'uninitialized' => [ 5.008, DEFAULT_OFF], |
48 |
|
|
'once' => [ 5.008, DEFAULT_OFF], |
49 |
|
|
'misc' => [ 5.008, DEFAULT_OFF], |
50 |
|
|
'regexp' => [ 5.008, DEFAULT_OFF], |
51 |
|
|
'glob' => [ 5.008, DEFAULT_OFF], |
52 |
|
|
'y2k' => [ 5.008, DEFAULT_OFF], |
53 |
|
|
'untie' => [ 5.008, DEFAULT_OFF], |
54 |
|
|
'substr' => [ 5.008, DEFAULT_OFF], |
55 |
|
|
'taint' => [ 5.008, DEFAULT_OFF], |
56 |
|
|
'signal' => [ 5.008, DEFAULT_OFF], |
57 |
|
|
'closure' => [ 5.008, DEFAULT_OFF], |
58 |
|
|
'overflow' => [ 5.008, DEFAULT_OFF], |
59 |
|
|
'portable' => [ 5.008, DEFAULT_OFF], |
60 |
|
|
'utf8' => [ 5.008, DEFAULT_OFF], |
61 |
|
|
'exiting' => [ 5.008, DEFAULT_OFF], |
62 |
|
|
'pack' => [ 5.008, DEFAULT_OFF], |
63 |
|
|
'unpack' => [ 5.008, DEFAULT_OFF], |
64 |
|
|
'threads' => [ 5.008, DEFAULT_OFF], |
65 |
|
|
#'default' => [ 5.008, DEFAULT_ON ], |
66 |
|
|
}], |
67 |
|
|
} ; |
68 |
|
|
|
69 |
|
|
########################################################################### |
70 |
|
|
sub tab { |
71 |
|
|
my($l, $t) = @_; |
72 |
|
|
$t .= "\t" x ($l - (length($t) + 1) / 8); |
73 |
|
|
$t; |
74 |
|
|
} |
75 |
|
|
|
76 |
|
|
########################################################################### |
77 |
|
|
|
78 |
|
|
my %list ; |
79 |
|
|
my %Value ; |
80 |
|
|
my %ValueToName ; |
81 |
|
|
my %NameToValue ; |
82 |
|
|
my $index ; |
83 |
|
|
|
84 |
|
|
my %v_list = () ; |
85 |
|
|
|
86 |
|
|
sub valueWalk |
87 |
|
|
{ |
88 |
|
|
my $tre = shift ; |
89 |
|
|
my @list = () ; |
90 |
|
|
my ($k, $v) ; |
91 |
|
|
|
92 |
|
|
foreach $k (sort keys %$tre) { |
93 |
|
|
$v = $tre->{$k}; |
94 |
|
|
die "duplicate key $k\n" if defined $list{$k} ; |
95 |
|
|
die "Value associated with key '$k' is not an ARRAY reference" |
96 |
|
|
if !ref $v || ref $v ne 'ARRAY' ; |
97 |
|
|
|
98 |
|
|
my ($ver, $rest) = @{ $v } ; |
99 |
|
|
push @{ $v_list{$ver} }, $k; |
100 |
|
|
|
101 |
|
|
if (ref $rest) |
102 |
|
|
{ valueWalk ($rest) } |
103 |
|
|
|
104 |
|
|
} |
105 |
|
|
|
106 |
|
|
} |
107 |
|
|
|
108 |
|
|
sub orderValues |
109 |
|
|
{ |
110 |
|
|
my $index = 0; |
111 |
|
|
foreach my $ver ( sort { $a <=> $b } keys %v_list ) { |
112 |
|
|
foreach my $name (@{ $v_list{$ver} } ) { |
113 |
|
|
$ValueToName{ $index } = [ uc $name, $ver ] ; |
114 |
|
|
$NameToValue{ uc $name } = $index ++ ; |
115 |
|
|
} |
116 |
|
|
} |
117 |
|
|
|
118 |
|
|
return $index ; |
119 |
|
|
} |
120 |
|
|
|
121 |
|
|
########################################################################### |
122 |
|
|
|
123 |
|
|
sub walk |
124 |
|
|
{ |
125 |
|
|
my $tre = shift ; |
126 |
|
|
my @list = () ; |
127 |
|
|
my ($k, $v) ; |
128 |
|
|
|
129 |
|
|
foreach $k (sort keys %$tre) { |
130 |
|
|
$v = $tre->{$k}; |
131 |
|
|
die "duplicate key $k\n" if defined $list{$k} ; |
132 |
|
|
#$Value{$index} = uc $k ; |
133 |
|
|
die "Can't find key '$k'" |
134 |
|
|
if ! defined $NameToValue{uc $k} ; |
135 |
|
|
push @{ $list{$k} }, $NameToValue{uc $k} ; |
136 |
|
|
die "Value associated with key '$k' is not an ARRAY reference" |
137 |
|
|
if !ref $v || ref $v ne 'ARRAY' ; |
138 |
|
|
|
139 |
|
|
my ($ver, $rest) = @{ $v } ; |
140 |
|
|
if (ref $rest) |
141 |
|
|
{ push (@{ $list{$k} }, walk ($rest)) } |
142 |
|
|
|
143 |
|
|
push @list, @{ $list{$k} } ; |
144 |
|
|
} |
145 |
|
|
|
146 |
|
|
return @list ; |
147 |
|
|
} |
148 |
|
|
|
149 |
|
|
########################################################################### |
150 |
|
|
|
151 |
|
|
sub mkRange |
152 |
|
|
{ |
153 |
|
|
my @a = @_ ; |
154 |
|
|
my @out = @a ; |
155 |
|
|
my $i ; |
156 |
|
|
|
157 |
|
|
|
158 |
|
|
for ($i = 1 ; $i < @a; ++ $i) { |
159 |
|
|
$out[$i] = ".." |
160 |
|
|
if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ; |
161 |
|
|
} |
162 |
|
|
|
163 |
|
|
my $out = join(",",@out); |
164 |
|
|
|
165 |
|
|
$out =~ s/,(\.\.,)+/../g ; |
166 |
|
|
return $out; |
167 |
|
|
} |
168 |
|
|
|
169 |
|
|
########################################################################### |
170 |
|
|
sub printTree |
171 |
|
|
{ |
172 |
|
|
my $tre = shift ; |
173 |
|
|
my $prefix = shift ; |
174 |
|
|
my ($k, $v) ; |
175 |
|
|
|
176 |
|
|
my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ; |
177 |
|
|
my @keys = sort keys %$tre ; |
178 |
|
|
|
179 |
|
|
while ($k = shift @keys) { |
180 |
|
|
$v = $tre->{$k}; |
181 |
|
|
die "Value associated with key '$k' is not an ARRAY reference" |
182 |
|
|
if !ref $v || ref $v ne 'ARRAY' ; |
183 |
|
|
|
184 |
|
|
my $offset ; |
185 |
|
|
if ($tre ne $tree) { |
186 |
|
|
print $prefix . "|\n" ; |
187 |
|
|
print $prefix . "+- $k" ; |
188 |
|
|
$offset = ' ' x ($max + 4) ; |
189 |
|
|
} |
190 |
|
|
else { |
191 |
|
|
print $prefix . "$k" ; |
192 |
|
|
$offset = ' ' x ($max + 1) ; |
193 |
|
|
} |
194 |
|
|
|
195 |
|
|
my ($ver, $rest) = @{ $v } ; |
196 |
|
|
if (ref $rest) |
197 |
|
|
{ |
198 |
|
|
my $bar = @keys ? "|" : " "; |
199 |
|
|
print " -" . "-" x ($max - length $k ) . "+\n" ; |
200 |
|
|
printTree ($rest, $prefix . $bar . $offset ) |
201 |
|
|
} |
202 |
|
|
else |
203 |
|
|
{ print "\n" } |
204 |
|
|
} |
205 |
|
|
|
206 |
|
|
} |
207 |
|
|
|
208 |
|
|
########################################################################### |
209 |
|
|
|
210 |
|
|
sub mkHexOct |
211 |
|
|
{ |
212 |
|
|
my ($f, $max, @a) = @_ ; |
213 |
|
|
my $mask = "\x00" x $max ; |
214 |
|
|
my $string = "" ; |
215 |
|
|
|
216 |
|
|
foreach (@a) { |
217 |
|
|
vec($mask, $_, 1) = 1 ; |
218 |
|
|
} |
219 |
|
|
|
220 |
|
|
foreach (unpack("C*", $mask)) { |
221 |
|
|
if ($f eq 'x') { |
222 |
|
|
$string .= '\x' . sprintf("%2.2x", $_) |
223 |
|
|
} |
224 |
|
|
else { |
225 |
|
|
$string .= '\\' . sprintf("%o", $_) |
226 |
|
|
} |
227 |
|
|
} |
228 |
|
|
return $string ; |
229 |
|
|
} |
230 |
|
|
|
231 |
|
|
sub mkHex |
232 |
|
|
{ |
233 |
|
|
my($max, @a) = @_; |
234 |
|
|
return mkHexOct("x", $max, @a); |
235 |
|
|
} |
236 |
|
|
|
237 |
|
|
sub mkOct |
238 |
|
|
{ |
239 |
|
|
my($max, @a) = @_; |
240 |
|
|
return mkHexOct("o", $max, @a); |
241 |
|
|
} |
242 |
|
|
|
243 |
|
|
########################################################################### |
244 |
|
|
|
245 |
|
|
if (@ARGV && $ARGV[0] eq "tree") |
246 |
|
|
{ |
247 |
|
|
printTree($tree, " ") ; |
248 |
|
|
exit ; |
249 |
|
|
} |
250 |
|
|
|
251 |
|
|
unlink "warnings.h"; |
252 |
|
|
unlink "lib/warnings.pm"; |
253 |
|
|
open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n"; |
254 |
|
|
binmode WARN; |
255 |
|
|
open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n"; |
256 |
|
|
binmode PM; |
257 |
|
|
|
258 |
|
|
print WARN <<'EOM' ; |
259 |
|
|
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! |
260 |
|
|
This file is built by warnings.pl |
261 |
|
|
Any changes made here will be lost! |
262 |
|
|
*/ |
263 |
|
|
|
264 |
|
|
|
265 |
|
|
#define Off(x) ((x) / 8) |
266 |
|
|
#define Bit(x) (1 << ((x) % 8)) |
267 |
|
|
#define IsSet(a, x) ((a)[Off(x)] & Bit(x)) |
268 |
|
|
|
269 |
|
|
|
270 |
|
|
#define G_WARN_OFF 0 /* $^W == 0 */ |
271 |
|
|
#define G_WARN_ON 1 /* -w flag and $^W != 0 */ |
272 |
|
|
#define G_WARN_ALL_ON 2 /* -W flag */ |
273 |
|
|
#define G_WARN_ALL_OFF 4 /* -X flag */ |
274 |
|
|
#define G_WARN_ONCE 8 /* set if 'once' ever enabled */ |
275 |
|
|
#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) |
276 |
|
|
|
277 |
|
|
#define pWARN_STD Nullsv |
278 |
|
|
#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */ |
279 |
|
|
#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */ |
280 |
|
|
|
281 |
|
|
#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \ |
282 |
|
|
(x) == pWARN_NONE) |
283 |
|
|
EOM |
284 |
|
|
|
285 |
|
|
my $offset = 0 ; |
286 |
|
|
|
287 |
|
|
$index = $offset ; |
288 |
|
|
#@{ $list{"all"} } = walk ($tree) ; |
289 |
|
|
valueWalk ($tree) ; |
290 |
|
|
my $index = orderValues(); |
291 |
|
|
|
292 |
|
|
die <<EOM if $index > 255 ; |
293 |
|
|
Too many warnings categories -- max is 255 |
294 |
|
|
rewrite packWARN* & unpackWARN* macros |
295 |
|
|
EOM |
296 |
|
|
|
297 |
|
|
walk ($tree) ; |
298 |
|
|
|
299 |
|
|
$index *= 2 ; |
300 |
|
|
my $warn_size = int($index / 8) + ($index % 8 != 0) ; |
301 |
|
|
|
302 |
|
|
my $k ; |
303 |
|
|
my $last_ver = 0; |
304 |
|
|
foreach $k (sort { $a <=> $b } keys %ValueToName) { |
305 |
|
|
my ($name, $version) = @{ $ValueToName{$k} }; |
306 |
|
|
print WARN "\n/* Warnings Categories added in Perl $version */\n\n" |
307 |
|
|
if $last_ver != $version ; |
308 |
|
|
print WARN tab(5, "#define WARN_$name"), "$k\n" ; |
309 |
|
|
$last_ver = $version ; |
310 |
|
|
} |
311 |
|
|
print WARN "\n" ; |
312 |
|
|
|
313 |
|
|
print WARN tab(5, '#define WARNsize'), "$warn_size\n" ; |
314 |
|
|
#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ; |
315 |
|
|
print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ; |
316 |
|
|
print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ; |
317 |
|
|
my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} }); |
318 |
|
|
|
319 |
|
|
print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ; |
320 |
|
|
|
321 |
|
|
print WARN <<'EOM'; |
322 |
|
|
|
323 |
|
|
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD) |
324 |
|
|
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD) |
325 |
|
|
#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) |
326 |
|
|
#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) |
327 |
|
|
#define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1)) |
328 |
|
|
|
329 |
|
|
#define ckWARN(x) \ |
330 |
|
|
( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ |
331 |
|
|
(PL_curcop->cop_warnings == pWARN_ALL || \ |
332 |
|
|
isWARN_on(PL_curcop->cop_warnings, x) ) ) \ |
333 |
|
|
|| (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) |
334 |
|
|
|
335 |
|
|
#define ckWARN2(x,y) \ |
336 |
|
|
( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ |
337 |
|
|
(PL_curcop->cop_warnings == pWARN_ALL || \ |
338 |
|
|
isWARN_on(PL_curcop->cop_warnings, x) || \ |
339 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) ) ) \ |
340 |
|
|
|| (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) |
341 |
|
|
|
342 |
|
|
#define ckWARN3(x,y,z) \ |
343 |
|
|
( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ |
344 |
|
|
(PL_curcop->cop_warnings == pWARN_ALL || \ |
345 |
|
|
isWARN_on(PL_curcop->cop_warnings, x) || \ |
346 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) || \ |
347 |
|
|
isWARN_on(PL_curcop->cop_warnings, z) ) ) \ |
348 |
|
|
|| (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) |
349 |
|
|
|
350 |
|
|
#define ckWARN4(x,y,z,t) \ |
351 |
|
|
( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE && \ |
352 |
|
|
(PL_curcop->cop_warnings == pWARN_ALL || \ |
353 |
|
|
isWARN_on(PL_curcop->cop_warnings, x) || \ |
354 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) || \ |
355 |
|
|
isWARN_on(PL_curcop->cop_warnings, z) || \ |
356 |
|
|
isWARN_on(PL_curcop->cop_warnings, t) ) ) \ |
357 |
|
|
|| (isLEXWARN_off && PL_dowarn & G_WARN_ON) ) |
358 |
|
|
|
359 |
|
|
#define ckWARN_d(x) \ |
360 |
|
|
(isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ |
361 |
|
|
(PL_curcop->cop_warnings != pWARN_NONE && \ |
362 |
|
|
isWARN_on(PL_curcop->cop_warnings, x) ) ) |
363 |
|
|
|
364 |
|
|
#define ckWARN2_d(x,y) \ |
365 |
|
|
(isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ |
366 |
|
|
(PL_curcop->cop_warnings != pWARN_NONE && \ |
367 |
|
|
(isWARN_on(PL_curcop->cop_warnings, x) || \ |
368 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) ) ) ) |
369 |
|
|
|
370 |
|
|
#define ckWARN3_d(x,y,z) \ |
371 |
|
|
(isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ |
372 |
|
|
(PL_curcop->cop_warnings != pWARN_NONE && \ |
373 |
|
|
(isWARN_on(PL_curcop->cop_warnings, x) || \ |
374 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) || \ |
375 |
|
|
isWARN_on(PL_curcop->cop_warnings, z) ) ) ) |
376 |
|
|
|
377 |
|
|
#define ckWARN4_d(x,y,z,t) \ |
378 |
|
|
(isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL || \ |
379 |
|
|
(PL_curcop->cop_warnings != pWARN_NONE && \ |
380 |
|
|
(isWARN_on(PL_curcop->cop_warnings, x) || \ |
381 |
|
|
isWARN_on(PL_curcop->cop_warnings, y) || \ |
382 |
|
|
isWARN_on(PL_curcop->cop_warnings, z) || \ |
383 |
|
|
isWARN_on(PL_curcop->cop_warnings, t) ) ) ) |
384 |
|
|
|
385 |
|
|
#define packWARN(a) (a ) |
386 |
|
|
#define packWARN2(a,b) ((a) | (b)<<8 ) |
387 |
|
|
#define packWARN3(a,b,c) ((a) | (b)<<8 | (c) <<16 ) |
388 |
|
|
#define packWARN4(a,b,c,d) ((a) | (b)<<8 | (c) <<16 | (d) <<24) |
389 |
|
|
|
390 |
|
|
#define unpackWARN1(x) ((x) & 0xFF) |
391 |
|
|
#define unpackWARN2(x) (((x) >>8) & 0xFF) |
392 |
|
|
#define unpackWARN3(x) (((x) >>16) & 0xFF) |
393 |
|
|
#define unpackWARN4(x) (((x) >>24) & 0xFF) |
394 |
|
|
|
395 |
|
|
#define ckDEAD(x) \ |
396 |
|
|
( ! specialWARN(PL_curcop->cop_warnings) && \ |
397 |
|
|
( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \ |
398 |
|
|
isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \ |
399 |
|
|
isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \ |
400 |
|
|
isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \ |
401 |
|
|
isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))) |
402 |
|
|
|
403 |
|
|
/* end of file warnings.h */ |
404 |
|
|
|
405 |
|
|
EOM |
406 |
|
|
|
407 |
|
|
close WARN ; |
408 |
|
|
|
409 |
|
|
while (<DATA>) { |
410 |
|
|
last if /^KEYWORDS$/ ; |
411 |
|
|
print PM $_ ; |
412 |
|
|
} |
413 |
|
|
|
414 |
|
|
#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ; |
415 |
|
|
|
416 |
|
|
$last_ver = 0; |
417 |
|
|
print PM "our %Offsets = (\n" ; |
418 |
|
|
foreach my $k (sort { $a <=> $b } keys %ValueToName) { |
419 |
|
|
my ($name, $version) = @{ $ValueToName{$k} }; |
420 |
|
|
$name = lc $name; |
421 |
|
|
$k *= 2 ; |
422 |
|
|
if ( $last_ver != $version ) { |
423 |
|
|
print PM "\n"; |
424 |
|
|
print PM tab(4, " # Warnings Categories added in Perl $version"); |
425 |
|
|
print PM "\n\n"; |
426 |
|
|
} |
427 |
|
|
print PM tab(4, " '$name'"), "=> $k,\n" ; |
428 |
|
|
$last_ver = $version; |
429 |
|
|
} |
430 |
|
|
|
431 |
|
|
print PM " );\n\n" ; |
432 |
|
|
|
433 |
|
|
print PM "our %Bits = (\n" ; |
434 |
|
|
foreach $k (sort keys %list) { |
435 |
|
|
|
436 |
|
|
my $v = $list{$k} ; |
437 |
|
|
my @list = sort { $a <=> $b } @$v ; |
438 |
|
|
|
439 |
|
|
print PM tab(4, " '$k'"), '=> "', |
440 |
|
|
# mkHex($warn_size, @list), |
441 |
|
|
mkHex($warn_size, map $_ * 2 , @list), |
442 |
|
|
'", # [', mkRange(@list), "]\n" ; |
443 |
|
|
} |
444 |
|
|
|
445 |
|
|
print PM " );\n\n" ; |
446 |
|
|
|
447 |
|
|
print PM "our %DeadBits = (\n" ; |
448 |
|
|
foreach $k (sort keys %list) { |
449 |
|
|
|
450 |
|
|
my $v = $list{$k} ; |
451 |
|
|
my @list = sort { $a <=> $b } @$v ; |
452 |
|
|
|
453 |
|
|
print PM tab(4, " '$k'"), '=> "', |
454 |
|
|
# mkHex($warn_size, @list), |
455 |
|
|
mkHex($warn_size, map $_ * 2 + 1 , @list), |
456 |
|
|
'", # [', mkRange(@list), "]\n" ; |
457 |
|
|
} |
458 |
|
|
|
459 |
|
|
print PM " );\n\n" ; |
460 |
|
|
print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ; |
461 |
|
|
print PM '$LAST_BIT = ' . "$index ;\n" ; |
462 |
|
|
print PM '$BYTES = ' . "$warn_size ;\n" ; |
463 |
|
|
while (<DATA>) { |
464 |
|
|
print PM $_ ; |
465 |
|
|
} |
466 |
|
|
|
467 |
|
|
close PM ; |
468 |
|
|
|
469 |
|
|
__END__ |
470 |
|
|
|
471 |
|
|
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! |
472 |
|
|
# This file was created by warnings.pl |
473 |
|
|
# Any changes made here will be lost. |
474 |
|
|
# |
475 |
|
|
|
476 |
|
|
package warnings; |
477 |
|
|
|
478 |
|
|
our $VERSION = '1.03'; |
479 |
|
|
|
480 |
|
|
=head1 NAME |
481 |
|
|
|
482 |
|
|
warnings - Perl pragma to control optional warnings |
483 |
|
|
|
484 |
|
|
=head1 SYNOPSIS |
485 |
|
|
|
486 |
|
|
use warnings; |
487 |
|
|
no warnings; |
488 |
|
|
|
489 |
|
|
use warnings "all"; |
490 |
|
|
no warnings "all"; |
491 |
|
|
|
492 |
|
|
use warnings::register; |
493 |
|
|
if (warnings::enabled()) { |
494 |
|
|
warnings::warn("some warning"); |
495 |
|
|
} |
496 |
|
|
|
497 |
|
|
if (warnings::enabled("void")) { |
498 |
|
|
warnings::warn("void", "some warning"); |
499 |
|
|
} |
500 |
|
|
|
501 |
|
|
if (warnings::enabled($object)) { |
502 |
|
|
warnings::warn($object, "some warning"); |
503 |
|
|
} |
504 |
|
|
|
505 |
|
|
warnings::warnif("some warning"); |
506 |
|
|
warnings::warnif("void", "some warning"); |
507 |
|
|
warnings::warnif($object, "some warning"); |
508 |
|
|
|
509 |
|
|
=head1 DESCRIPTION |
510 |
|
|
|
511 |
|
|
The C<warnings> pragma is a replacement for the command line flag C<-w>, |
512 |
|
|
but the pragma is limited to the enclosing block, while the flag is global. |
513 |
|
|
See L<perllexwarn> for more information. |
514 |
|
|
|
515 |
|
|
If no import list is supplied, all possible warnings are either enabled |
516 |
|
|
or disabled. |
517 |
|
|
|
518 |
|
|
A number of functions are provided to assist module authors. |
519 |
|
|
|
520 |
|
|
=over 4 |
521 |
|
|
|
522 |
|
|
=item use warnings::register |
523 |
|
|
|
524 |
|
|
Creates a new warnings category with the same name as the package where |
525 |
|
|
the call to the pragma is used. |
526 |
|
|
|
527 |
|
|
=item warnings::enabled() |
528 |
|
|
|
529 |
|
|
Use the warnings category with the same name as the current package. |
530 |
|
|
|
531 |
|
|
Return TRUE if that warnings category is enabled in the calling module. |
532 |
|
|
Otherwise returns FALSE. |
533 |
|
|
|
534 |
|
|
=item warnings::enabled($category) |
535 |
|
|
|
536 |
|
|
Return TRUE if the warnings category, C<$category>, is enabled in the |
537 |
|
|
calling module. |
538 |
|
|
Otherwise returns FALSE. |
539 |
|
|
|
540 |
|
|
=item warnings::enabled($object) |
541 |
|
|
|
542 |
|
|
Use the name of the class for the object reference, C<$object>, as the |
543 |
|
|
warnings category. |
544 |
|
|
|
545 |
|
|
Return TRUE if that warnings category is enabled in the first scope |
546 |
|
|
where the object is used. |
547 |
|
|
Otherwise returns FALSE. |
548 |
|
|
|
549 |
|
|
=item warnings::warn($message) |
550 |
|
|
|
551 |
|
|
Print C<$message> to STDERR. |
552 |
|
|
|
553 |
|
|
Use the warnings category with the same name as the current package. |
554 |
|
|
|
555 |
|
|
If that warnings category has been set to "FATAL" in the calling module |
556 |
|
|
then die. Otherwise return. |
557 |
|
|
|
558 |
|
|
=item warnings::warn($category, $message) |
559 |
|
|
|
560 |
|
|
Print C<$message> to STDERR. |
561 |
|
|
|
562 |
|
|
If the warnings category, C<$category>, has been set to "FATAL" in the |
563 |
|
|
calling module then die. Otherwise return. |
564 |
|
|
|
565 |
|
|
=item warnings::warn($object, $message) |
566 |
|
|
|
567 |
|
|
Print C<$message> to STDERR. |
568 |
|
|
|
569 |
|
|
Use the name of the class for the object reference, C<$object>, as the |
570 |
|
|
warnings category. |
571 |
|
|
|
572 |
|
|
If that warnings category has been set to "FATAL" in the scope where C<$object> |
573 |
|
|
is first used then die. Otherwise return. |
574 |
|
|
|
575 |
|
|
|
576 |
|
|
=item warnings::warnif($message) |
577 |
|
|
|
578 |
|
|
Equivalent to: |
579 |
|
|
|
580 |
|
|
if (warnings::enabled()) |
581 |
|
|
{ warnings::warn($message) } |
582 |
|
|
|
583 |
|
|
=item warnings::warnif($category, $message) |
584 |
|
|
|
585 |
|
|
Equivalent to: |
586 |
|
|
|
587 |
|
|
if (warnings::enabled($category)) |
588 |
|
|
{ warnings::warn($category, $message) } |
589 |
|
|
|
590 |
|
|
=item warnings::warnif($object, $message) |
591 |
|
|
|
592 |
|
|
Equivalent to: |
593 |
|
|
|
594 |
|
|
if (warnings::enabled($object)) |
595 |
|
|
{ warnings::warn($object, $message) } |
596 |
|
|
|
597 |
|
|
=back |
598 |
|
|
|
599 |
|
|
See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>. |
600 |
|
|
|
601 |
|
|
=cut |
602 |
|
|
|
603 |
|
|
use Carp (); |
604 |
|
|
|
605 |
|
|
KEYWORDS |
606 |
|
|
|
607 |
|
|
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ; |
608 |
|
|
|
609 |
|
|
sub Croaker |
610 |
|
|
{ |
611 |
|
|
delete $Carp::CarpInternal{'warnings'}; |
612 |
|
|
Carp::croak(@_); |
613 |
|
|
} |
614 |
|
|
|
615 |
|
|
sub bits |
616 |
|
|
{ |
617 |
|
|
# called from B::Deparse.pm |
618 |
|
|
|
619 |
|
|
push @_, 'all' unless @_; |
620 |
|
|
|
621 |
|
|
my $mask; |
622 |
|
|
my $catmask ; |
623 |
|
|
my $fatal = 0 ; |
624 |
|
|
my $no_fatal = 0 ; |
625 |
|
|
|
626 |
|
|
foreach my $word ( @_ ) { |
627 |
|
|
if ($word eq 'FATAL') { |
628 |
|
|
$fatal = 1; |
629 |
|
|
$no_fatal = 0; |
630 |
|
|
} |
631 |
|
|
elsif ($word eq 'NONFATAL') { |
632 |
|
|
$fatal = 0; |
633 |
|
|
$no_fatal = 1; |
634 |
|
|
} |
635 |
|
|
elsif ($catmask = $Bits{$word}) { |
636 |
|
|
$mask |= $catmask ; |
637 |
|
|
$mask |= $DeadBits{$word} if $fatal ; |
638 |
|
|
$mask &= ~($DeadBits{$word}|$All) if $no_fatal ; |
639 |
|
|
} |
640 |
|
|
else |
641 |
|
|
{ Croaker("Unknown warnings category '$word'")} |
642 |
|
|
} |
643 |
|
|
|
644 |
|
|
return $mask ; |
645 |
|
|
} |
646 |
|
|
|
647 |
|
|
sub import |
648 |
|
|
{ |
649 |
|
|
shift; |
650 |
|
|
|
651 |
|
|
my $catmask ; |
652 |
|
|
my $fatal = 0 ; |
653 |
|
|
my $no_fatal = 0 ; |
654 |
|
|
|
655 |
|
|
my $mask = ${^WARNING_BITS} ; |
656 |
|
|
|
657 |
|
|
if (vec($mask, $Offsets{'all'}, 1)) { |
658 |
|
|
$mask |= $Bits{'all'} ; |
659 |
|
|
$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); |
660 |
|
|
} |
661 |
|
|
|
662 |
|
|
push @_, 'all' unless @_; |
663 |
|
|
|
664 |
|
|
foreach my $word ( @_ ) { |
665 |
|
|
if ($word eq 'FATAL') { |
666 |
|
|
$fatal = 1; |
667 |
|
|
$no_fatal = 0; |
668 |
|
|
} |
669 |
|
|
elsif ($word eq 'NONFATAL') { |
670 |
|
|
$fatal = 0; |
671 |
|
|
$no_fatal = 1; |
672 |
|
|
} |
673 |
|
|
elsif ($catmask = $Bits{$word}) { |
674 |
|
|
$mask |= $catmask ; |
675 |
|
|
$mask |= $DeadBits{$word} if $fatal ; |
676 |
|
|
$mask &= ~($DeadBits{$word}|$All) if $no_fatal ; |
677 |
|
|
} |
678 |
|
|
else |
679 |
|
|
{ Croaker("Unknown warnings category '$word'")} |
680 |
|
|
} |
681 |
|
|
|
682 |
|
|
${^WARNING_BITS} = $mask ; |
683 |
|
|
} |
684 |
|
|
|
685 |
|
|
sub unimport |
686 |
|
|
{ |
687 |
|
|
shift; |
688 |
|
|
|
689 |
|
|
my $catmask ; |
690 |
|
|
my $mask = ${^WARNING_BITS} ; |
691 |
|
|
|
692 |
|
|
if (vec($mask, $Offsets{'all'}, 1)) { |
693 |
|
|
$mask |= $Bits{'all'} ; |
694 |
|
|
$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1); |
695 |
|
|
} |
696 |
|
|
|
697 |
|
|
push @_, 'all' unless @_; |
698 |
|
|
|
699 |
|
|
foreach my $word ( @_ ) { |
700 |
|
|
if ($word eq 'FATAL') { |
701 |
|
|
next; |
702 |
|
|
} |
703 |
|
|
elsif ($catmask = $Bits{$word}) { |
704 |
|
|
$mask &= ~($catmask | $DeadBits{$word} | $All); |
705 |
|
|
} |
706 |
|
|
else |
707 |
|
|
{ Croaker("Unknown warnings category '$word'")} |
708 |
|
|
} |
709 |
|
|
|
710 |
|
|
${^WARNING_BITS} = $mask ; |
711 |
|
|
} |
712 |
|
|
|
713 |
|
|
my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); |
714 |
|
|
|
715 |
|
|
sub __chk |
716 |
|
|
{ |
717 |
|
|
my $category ; |
718 |
|
|
my $offset ; |
719 |
|
|
my $isobj = 0 ; |
720 |
|
|
|
721 |
|
|
if (@_) { |
722 |
|
|
# check the category supplied. |
723 |
|
|
$category = shift ; |
724 |
|
|
if (my $type = ref $category) { |
725 |
|
|
Croaker("not an object") |
726 |
|
|
if exists $builtin_type{$type}; |
727 |
|
|
$category = $type; |
728 |
|
|
$isobj = 1 ; |
729 |
|
|
} |
730 |
|
|
$offset = $Offsets{$category}; |
731 |
|
|
Croaker("Unknown warnings category '$category'") |
732 |
|
|
unless defined $offset; |
733 |
|
|
} |
734 |
|
|
else { |
735 |
|
|
$category = (caller(1))[0] ; |
736 |
|
|
$offset = $Offsets{$category}; |
737 |
|
|
Croaker("package '$category' not registered for warnings") |
738 |
|
|
unless defined $offset ; |
739 |
|
|
} |
740 |
|
|
|
741 |
|
|
my $this_pkg = (caller(1))[0] ; |
742 |
|
|
my $i = 2 ; |
743 |
|
|
my $pkg ; |
744 |
|
|
|
745 |
|
|
if ($isobj) { |
746 |
|
|
while (do { { package DB; $pkg = (caller($i++))[0] } } ) { |
747 |
|
|
last unless @DB::args && $DB::args[0] =~ /^$category=/ ; |
748 |
|
|
} |
749 |
|
|
$i -= 2 ; |
750 |
|
|
} |
751 |
|
|
else { |
752 |
|
|
for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) { |
753 |
|
|
last if $pkg ne $this_pkg ; |
754 |
|
|
} |
755 |
|
|
$i = 2 |
756 |
|
|
if !$pkg || $pkg eq $this_pkg ; |
757 |
|
|
} |
758 |
|
|
|
759 |
|
|
my $callers_bitmask = (caller($i))[9] ; |
760 |
|
|
return ($callers_bitmask, $offset, $i) ; |
761 |
|
|
} |
762 |
|
|
|
763 |
|
|
sub enabled |
764 |
|
|
{ |
765 |
|
|
Croaker("Usage: warnings::enabled([category])") |
766 |
|
|
unless @_ == 1 || @_ == 0 ; |
767 |
|
|
|
768 |
|
|
my ($callers_bitmask, $offset, $i) = __chk(@_) ; |
769 |
|
|
|
770 |
|
|
return 0 unless defined $callers_bitmask ; |
771 |
|
|
return vec($callers_bitmask, $offset, 1) || |
772 |
|
|
vec($callers_bitmask, $Offsets{'all'}, 1) ; |
773 |
|
|
} |
774 |
|
|
|
775 |
|
|
|
776 |
|
|
sub warn |
777 |
|
|
{ |
778 |
|
|
Croaker("Usage: warnings::warn([category,] 'message')") |
779 |
|
|
unless @_ == 2 || @_ == 1 ; |
780 |
|
|
|
781 |
|
|
my $message = pop ; |
782 |
|
|
my ($callers_bitmask, $offset, $i) = __chk(@_) ; |
783 |
|
|
Carp::croak($message) |
784 |
|
|
if vec($callers_bitmask, $offset+1, 1) || |
785 |
|
|
vec($callers_bitmask, $Offsets{'all'}+1, 1) ; |
786 |
|
|
Carp::carp($message) ; |
787 |
|
|
} |
788 |
|
|
|
789 |
|
|
sub warnif |
790 |
|
|
{ |
791 |
|
|
Croaker("Usage: warnings::warnif([category,] 'message')") |
792 |
|
|
unless @_ == 2 || @_ == 1 ; |
793 |
|
|
|
794 |
|
|
my $message = pop ; |
795 |
|
|
my ($callers_bitmask, $offset, $i) = __chk(@_) ; |
796 |
|
|
|
797 |
|
|
return |
798 |
|
|
unless defined $callers_bitmask && |
799 |
|
|
(vec($callers_bitmask, $offset, 1) || |
800 |
|
|
vec($callers_bitmask, $Offsets{'all'}, 1)) ; |
801 |
|
|
|
802 |
|
|
Carp::croak($message) |
803 |
|
|
if vec($callers_bitmask, $offset+1, 1) || |
804 |
|
|
vec($callers_bitmask, $Offsets{'all'}+1, 1) ; |
805 |
|
|
|
806 |
|
|
Carp::carp($message) ; |
807 |
|
|
} |
808 |
|
|
|
809 |
|
|
1; |