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