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