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; |