This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
replace ckWARN macros with functions
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
3b9e3074 3$VERSION = '1.02_01';
b75c8c73 4
73f0cc2d
GS
5BEGIN {
6 push @INC, './lib';
7}
599cee73
PM
8use strict ;
9
10sub DEFAULT_ON () { 1 }
11sub DEFAULT_OFF () { 2 }
12
13my $tree = {
d3a7d8c7 14
0d658bf5
PM
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
PM
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
SF
64 'assertions' => [ 5.009, DEFAULT_OFF],
65
0d658bf5
PM
66 #'default' => [ 5.008, DEFAULT_ON ],
67 }],
d3a7d8c7 68} ;
599cee73 69
599cee73
PM
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
PM
81my %ValueToName ;
82my %NameToValue ;
d3a7d8c7 83my $index ;
599cee73 84
0d658bf5
PM
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
PM
124sub walk
125{
126 my $tre = shift ;
127 my @list = () ;
128 my ($k, $v) ;
129
95dfd3ab
GS
130 foreach $k (sort keys %$tre) {
131 $v = $tre->{$k};
599cee73 132 die "duplicate key $k\n" if defined $list{$k} ;
0d658bf5
PM
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
PM
144 push @list, @{ $list{$k} } ;
145 }
146
147 return @list ;
599cee73
PM
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
PM
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
GS
171sub printTree
172{
173 my $tre = shift ;
174 my $prefix = shift ;
e476b1b5
GS
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
PM
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
PM
199 my $bar = @keys ? "|" : " ";
200 print " -" . "-" x ($max - length $k ) . "+\n" ;
201 printTree ($rest, $prefix . $bar . $offset )
e476b1b5
GS
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
PM
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
MS
222 if ($f eq 'x') {
223 $string .= '\x' . sprintf("%2.2x", $_)
224 }
225 else {
226 $string .= '\\' . sprintf("%o", $_)
227 }
599cee73
PM
228 }
229 return $string ;
230}
231
317ea90d
MS
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
PM
244###########################################################################
245
e476b1b5
GS
246if (@ARGV && $ARGV[0] eq "tree")
247{
0d658bf5 248 printTree($tree, " ") ;
e476b1b5
GS
249 exit ;
250}
599cee73 251
918426be
NC
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
PM
258
259print WARN <<'EOM' ;
37442d52
RGS
260/* -*- buffer-read-only: t -*-
261 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 262 This file is built by warnings.pl
599cee73
PM
263 Any changes made here will be lost!
264*/
265
266
0453d815
PM
267#define Off(x) ((x) / 8)
268#define Bit(x) (1 << ((x) % 8))
599cee73
PM
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
PM
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
PM
277#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
278
d3a7d8c7
GS
279#define pWARN_STD Nullsv
280#define pWARN_ALL (Nullsv+1) /* use warnings 'all' */
281#define pWARN_NONE (Nullsv+2) /* no warnings 'all' */
599cee73 282
d3a7d8c7
GS
283#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
284 (x) == pWARN_NONE)
599cee73
PM
285EOM
286
d3a7d8c7
GS
287my $offset = 0 ;
288
289$index = $offset ;
290#@{ $list{"all"} } = walk ($tree) ;
0d658bf5
PM
291valueWalk ($tree) ;
292my $index = orderValues();
599cee73 293
12bcd1a6
PM
294die <<EOM if $index > 255 ;
295Too many warnings categories -- max is 255
296 rewrite packWARN* & unpackWARN* macros
297EOM
599cee73 298
0d658bf5
PM
299walk ($tree) ;
300
599cee73
PM
301$index *= 2 ;
302my $warn_size = int($index / 8) + ($index % 8 != 0) ;
303
304my $k ;
0d658bf5
PM
305my $last_ver = 0;
306foreach $k (sort { $a <=> $b } keys %ValueToName) {
307 my ($name, $version) = @{ $ValueToName{$k} };
308 print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
309 if $last_ver != $version ;
310 print WARN tab(5, "#define WARN_$name"), "$k\n" ;
311 $last_ver = $version ;
599cee73
PM
312}
313print WARN "\n" ;
314
315print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
316#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
317print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
318print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
317ea90d
MS
319my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
320
321print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
599cee73
PM
322
323print WARN <<'EOM';
324
d5a71f30
GS
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))
95a20fc0
SP
328#define isWARN_on(c,x) (IsSet(SvPVX_const(c), 2*(x)))
329#define isWARNf_on(c,x) (IsSet(SvPVX_const(c), 2*(x)+1))
d5a71f30 330
f54ba1c2
DM
331#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
332#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
333#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
334#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
335
336#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
337#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
338#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
339#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 340
3b9e3074
SH
341#define packWARN(a) (a )
342#define packWARN2(a,b) ((a) | ((b)<<8) )
343#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
344#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
345
346#define unpackWARN1(x) ((x) & 0xFF)
347#define unpackWARN2(x) (((x) >>8) & 0xFF)
348#define unpackWARN3(x) (((x) >>16) & 0xFF)
349#define unpackWARN4(x) (((x) >>24) & 0xFF)
350
351#define ckDEAD(x) \
352 ( ! specialWARN(PL_curcop->cop_warnings) && \
353 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
354 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
355 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
356 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
357 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
358
4438c4b7 359/* end of file warnings.h */
37442d52 360/* ex: set ro: */
599cee73
PM
361EOM
362
363close WARN ;
364
365while (<DATA>) {
366 last if /^KEYWORDS$/ ;
367 print PM $_ ;
368}
369
d3a7d8c7
GS
370#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
371
0d658bf5 372$last_ver = 0;
53c33732 373print PM "our %Offsets = (\n" ;
0d658bf5
PM
374foreach my $k (sort { $a <=> $b } keys %ValueToName) {
375 my ($name, $version) = @{ $ValueToName{$k} };
376 $name = lc $name;
d3a7d8c7 377 $k *= 2 ;
0d658bf5
PM
378 if ( $last_ver != $version ) {
379 print PM "\n";
380 print PM tab(4, " # Warnings Categories added in Perl $version");
381 print PM "\n\n";
382 }
383 print PM tab(4, " '$name'"), "=> $k,\n" ;
384 $last_ver = $version;
d3a7d8c7
GS
385}
386
387print PM " );\n\n" ;
388
53c33732 389print PM "our %Bits = (\n" ;
599cee73
PM
390foreach $k (sort keys %list) {
391
392 my $v = $list{$k} ;
393 my @list = sort { $a <=> $b } @$v ;
394
0ca4541c
NIS
395 print PM tab(4, " '$k'"), '=> "',
396 # mkHex($warn_size, @list),
397 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
398 '", # [', mkRange(@list), "]\n" ;
399}
400
401print PM " );\n\n" ;
402
53c33732 403print PM "our %DeadBits = (\n" ;
599cee73
PM
404foreach $k (sort keys %list) {
405
406 my $v = $list{$k} ;
407 my @list = sort { $a <=> $b } @$v ;
408
0ca4541c
NIS
409 print PM tab(4, " '$k'"), '=> "',
410 # mkHex($warn_size, @list),
411 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
412 '", # [', mkRange(@list), "]\n" ;
413}
414
415print PM " );\n\n" ;
d3a7d8c7
GS
416print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
417print PM '$LAST_BIT = ' . "$index ;\n" ;
418print PM '$BYTES = ' . "$warn_size ;\n" ;
599cee73
PM
419while (<DATA>) {
420 print PM $_ ;
421}
422
37442d52 423print PM "# ex: set ro:\n";
599cee73
PM
424close PM ;
425
426__END__
37442d52 427# -*- buffer-read-only: t -*-
38875929 428# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
4438c4b7 429# This file was created by warnings.pl
599cee73
PM
430# Any changes made here will be lost.
431#
432
4438c4b7 433package warnings;
599cee73 434
09e96b99 435our $VERSION = '1.04';
b75c8c73 436
599cee73
PM
437=head1 NAME
438
4438c4b7 439warnings - Perl pragma to control optional warnings
599cee73
PM
440
441=head1 SYNOPSIS
442
4438c4b7
JH
443 use warnings;
444 no warnings;
599cee73 445
4438c4b7
JH
446 use warnings "all";
447 no warnings "all";
599cee73 448
d3a7d8c7
GS
449 use warnings::register;
450 if (warnings::enabled()) {
451 warnings::warn("some warning");
452 }
453
454 if (warnings::enabled("void")) {
e476b1b5
GS
455 warnings::warn("void", "some warning");
456 }
457
7e6d00f8
PM
458 if (warnings::enabled($object)) {
459 warnings::warn($object, "some warning");
460 }
461
721f911b
PM
462 warnings::warnif("some warning");
463 warnings::warnif("void", "some warning");
464 warnings::warnif($object, "some warning");
7e6d00f8 465
599cee73
PM
466=head1 DESCRIPTION
467
fe2e802c
EM
468The C<warnings> pragma is a replacement for the command line flag C<-w>,
469but the pragma is limited to the enclosing block, while the flag is global.
470See L<perllexwarn> for more information.
471
0453d815
PM
472If no import list is supplied, all possible warnings are either enabled
473or disabled.
599cee73 474
0ca4541c 475A number of functions are provided to assist module authors.
e476b1b5
GS
476
477=over 4
478
d3a7d8c7
GS
479=item use warnings::register
480
7e6d00f8
PM
481Creates a new warnings category with the same name as the package where
482the call to the pragma is used.
483
484=item warnings::enabled()
485
486Use the warnings category with the same name as the current package.
487
488Return TRUE if that warnings category is enabled in the calling module.
489Otherwise returns FALSE.
490
491=item warnings::enabled($category)
492
493Return TRUE if the warnings category, C<$category>, is enabled in the
494calling module.
495Otherwise returns FALSE.
496
497=item warnings::enabled($object)
498
499Use the name of the class for the object reference, C<$object>, as the
500warnings category.
501
502Return TRUE if that warnings category is enabled in the first scope
503where the object is used.
504Otherwise returns FALSE.
505
506=item warnings::warn($message)
507
508Print C<$message> to STDERR.
509
510Use the warnings category with the same name as the current package.
511
512If that warnings category has been set to "FATAL" in the calling module
513then die. Otherwise return.
514
515=item warnings::warn($category, $message)
516
517Print C<$message> to STDERR.
518
519If the warnings category, C<$category>, has been set to "FATAL" in the
520calling module then die. Otherwise return.
d3a7d8c7 521
7e6d00f8 522=item warnings::warn($object, $message)
e476b1b5 523
7e6d00f8 524Print C<$message> to STDERR.
e476b1b5 525
7e6d00f8
PM
526Use the name of the class for the object reference, C<$object>, as the
527warnings category.
e476b1b5 528
7e6d00f8
PM
529If that warnings category has been set to "FATAL" in the scope where C<$object>
530is first used then die. Otherwise return.
599cee73 531
e476b1b5 532
7e6d00f8
PM
533=item warnings::warnif($message)
534
535Equivalent to:
536
537 if (warnings::enabled())
538 { warnings::warn($message) }
539
540=item warnings::warnif($category, $message)
541
542Equivalent to:
543
544 if (warnings::enabled($category))
545 { warnings::warn($category, $message) }
546
547=item warnings::warnif($object, $message)
548
549Equivalent to:
550
551 if (warnings::enabled($object))
552 { warnings::warn($object, $message) }
d3a7d8c7 553
e476b1b5
GS
554=back
555
749f83fa 556See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
599cee73
PM
557
558=cut
559
599cee73
PM
560KEYWORDS
561
d3a7d8c7
GS
562$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
563
c3186b65
PM
564sub Croaker
565{
29ddba3b 566 require Carp::Heavy; # this initializes %CarpInternal
c3186b65 567 delete $Carp::CarpInternal{'warnings'};
8becbb3b 568 Carp::croak(@_);
c3186b65
PM
569}
570
6e9af7e4
PM
571sub bits
572{
573 # called from B::Deparse.pm
574
575 push @_, 'all' unless @_;
576
577 my $mask;
599cee73
PM
578 my $catmask ;
579 my $fatal = 0 ;
6e9af7e4
PM
580 my $no_fatal = 0 ;
581
582 foreach my $word ( @_ ) {
583 if ($word eq 'FATAL') {
327afb7f 584 $fatal = 1;
6e9af7e4
PM
585 $no_fatal = 0;
586 }
587 elsif ($word eq 'NONFATAL') {
588 $fatal = 0;
589 $no_fatal = 1;
327afb7f 590 }
d3a7d8c7
GS
591 elsif ($catmask = $Bits{$word}) {
592 $mask |= $catmask ;
593 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 594 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 595 }
d3a7d8c7 596 else
c3186b65 597 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
598 }
599
600 return $mask ;
601}
602
6e9af7e4
PM
603sub import
604{
599cee73 605 shift;
6e9af7e4
PM
606
607 my $catmask ;
608 my $fatal = 0 ;
609 my $no_fatal = 0 ;
610
f1f33818 611 my $mask = ${^WARNING_BITS} ;
6e9af7e4 612
f1f33818
PM
613 if (vec($mask, $Offsets{'all'}, 1)) {
614 $mask |= $Bits{'all'} ;
615 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
616 }
6e9af7e4
PM
617
618 push @_, 'all' unless @_;
619
620 foreach my $word ( @_ ) {
621 if ($word eq 'FATAL') {
622 $fatal = 1;
623 $no_fatal = 0;
624 }
625 elsif ($word eq 'NONFATAL') {
626 $fatal = 0;
627 $no_fatal = 1;
628 }
629 elsif ($catmask = $Bits{$word}) {
630 $mask |= $catmask ;
631 $mask |= $DeadBits{$word} if $fatal ;
632 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
633 }
634 else
635 { Croaker("Unknown warnings category '$word'")}
636 }
637
638 ${^WARNING_BITS} = $mask ;
599cee73
PM
639}
640
6e9af7e4
PM
641sub unimport
642{
599cee73 643 shift;
6e9af7e4
PM
644
645 my $catmask ;
d3a7d8c7 646 my $mask = ${^WARNING_BITS} ;
6e9af7e4 647
d3a7d8c7 648 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 649 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
650 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
651 }
6e9af7e4
PM
652
653 push @_, 'all' unless @_;
654
655 foreach my $word ( @_ ) {
656 if ($word eq 'FATAL') {
657 next;
658 }
659 elsif ($catmask = $Bits{$word}) {
660 $mask &= ~($catmask | $DeadBits{$word} | $All);
661 }
662 else
663 { Croaker("Unknown warnings category '$word'")}
664 }
665
666 ${^WARNING_BITS} = $mask ;
599cee73
PM
667}
668
9df0f64f 669my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
670
7e6d00f8 671sub __chk
599cee73 672{
d3a7d8c7
GS
673 my $category ;
674 my $offset ;
7e6d00f8 675 my $isobj = 0 ;
d3a7d8c7
GS
676
677 if (@_) {
678 # check the category supplied.
679 $category = shift ;
9df0f64f 680 if (my $type = ref $category) {
681 Croaker("not an object")
682 if exists $builtin_type{$type};
683 $category = $type;
7e6d00f8
PM
684 $isobj = 1 ;
685 }
d3a7d8c7 686 $offset = $Offsets{$category};
c3186b65 687 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
688 unless defined $offset;
689 }
690 else {
0ca4541c 691 $category = (caller(1))[0] ;
d3a7d8c7 692 $offset = $Offsets{$category};
c3186b65 693 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
694 unless defined $offset ;
695 }
696
0ca4541c 697 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
698 my $i = 2 ;
699 my $pkg ;
700
701 if ($isobj) {
702 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
703 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
704 }
705 $i -= 2 ;
706 }
707 else {
4f527b71 708 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
709 }
710
0ca4541c 711 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
712 return ($callers_bitmask, $offset, $i) ;
713}
714
4f527b71
AS
715sub _error_loc {
716 require Carp::Heavy;
717 goto &Carp::short_error_loc; # don't introduce another stack frame
718}
719
7e6d00f8
PM
720sub enabled
721{
c3186b65 722 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
723 unless @_ == 1 || @_ == 0 ;
724
725 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
726
727 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
728 return vec($callers_bitmask, $offset, 1) ||
729 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
730}
731
d3a7d8c7 732
e476b1b5
GS
733sub warn
734{
c3186b65 735 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 736 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 737
7e6d00f8
PM
738 my $message = pop ;
739 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
09e96b99 740 require Carp;
8becbb3b 741 Carp::croak($message)
d3a7d8c7
GS
742 if vec($callers_bitmask, $offset+1, 1) ||
743 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
8becbb3b 744 Carp::carp($message) ;
e476b1b5
GS
745}
746
7e6d00f8
PM
747sub warnif
748{
c3186b65 749 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
750 unless @_ == 2 || @_ == 1 ;
751
752 my $message = pop ;
753 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 754
0ca4541c 755 return
7e6d00f8
PM
756 unless defined $callers_bitmask &&
757 (vec($callers_bitmask, $offset, 1) ||
758 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
759
09e96b99 760 require Carp;
8becbb3b 761 Carp::croak($message)
7e6d00f8
PM
762 if vec($callers_bitmask, $offset+1, 1) ||
763 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
764
8becbb3b 765 Carp::carp($message) ;
7e6d00f8 766}
0d658bf5 767
599cee73 7681;