This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove the final recursion path from S_regmatch: (??{...})
[perl5.git] / warnings.pl
CommitLineData
599cee73
PM
1#!/usr/bin/perl
2
98225a64 3$VERSION = '1.02_02';
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
a0714e2c 279#define pWARN_STD NULL
78db725d
NC
280#define pWARN_ALL (((SV*)0)+1) /* use warnings 'all' */
281#define pWARN_NONE (((SV*)0)+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
98225a64 435our $VERSION = '1.05';
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
dbab294c 567 local $Carp::CarpInternal{'warnings'};
c3186b65 568 delete $Carp::CarpInternal{'warnings'};
8becbb3b 569 Carp::croak(@_);
c3186b65
PM
570}
571
6e9af7e4
PM
572sub bits
573{
574 # called from B::Deparse.pm
575
576 push @_, 'all' unless @_;
577
578 my $mask;
599cee73
PM
579 my $catmask ;
580 my $fatal = 0 ;
6e9af7e4
PM
581 my $no_fatal = 0 ;
582
583 foreach my $word ( @_ ) {
584 if ($word eq 'FATAL') {
327afb7f 585 $fatal = 1;
6e9af7e4
PM
586 $no_fatal = 0;
587 }
588 elsif ($word eq 'NONFATAL') {
589 $fatal = 0;
590 $no_fatal = 1;
327afb7f 591 }
d3a7d8c7
GS
592 elsif ($catmask = $Bits{$word}) {
593 $mask |= $catmask ;
594 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 595 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 596 }
d3a7d8c7 597 else
c3186b65 598 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
599 }
600
601 return $mask ;
602}
603
6e9af7e4
PM
604sub import
605{
599cee73 606 shift;
6e9af7e4
PM
607
608 my $catmask ;
609 my $fatal = 0 ;
610 my $no_fatal = 0 ;
611
f1f33818 612 my $mask = ${^WARNING_BITS} ;
6e9af7e4 613
f1f33818
PM
614 if (vec($mask, $Offsets{'all'}, 1)) {
615 $mask |= $Bits{'all'} ;
616 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
617 }
6e9af7e4
PM
618
619 push @_, 'all' unless @_;
620
621 foreach my $word ( @_ ) {
622 if ($word eq 'FATAL') {
623 $fatal = 1;
624 $no_fatal = 0;
625 }
626 elsif ($word eq 'NONFATAL') {
627 $fatal = 0;
628 $no_fatal = 1;
629 }
630 elsif ($catmask = $Bits{$word}) {
631 $mask |= $catmask ;
632 $mask |= $DeadBits{$word} if $fatal ;
633 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
634 }
635 else
636 { Croaker("Unknown warnings category '$word'")}
637 }
638
639 ${^WARNING_BITS} = $mask ;
599cee73
PM
640}
641
6e9af7e4
PM
642sub unimport
643{
599cee73 644 shift;
6e9af7e4
PM
645
646 my $catmask ;
d3a7d8c7 647 my $mask = ${^WARNING_BITS} ;
6e9af7e4 648
d3a7d8c7 649 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 650 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
651 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
652 }
6e9af7e4
PM
653
654 push @_, 'all' unless @_;
655
656 foreach my $word ( @_ ) {
657 if ($word eq 'FATAL') {
658 next;
659 }
660 elsif ($catmask = $Bits{$word}) {
661 $mask &= ~($catmask | $DeadBits{$word} | $All);
662 }
663 else
664 { Croaker("Unknown warnings category '$word'")}
665 }
666
667 ${^WARNING_BITS} = $mask ;
599cee73
PM
668}
669
9df0f64f 670my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
671
7e6d00f8 672sub __chk
599cee73 673{
d3a7d8c7
GS
674 my $category ;
675 my $offset ;
7e6d00f8 676 my $isobj = 0 ;
d3a7d8c7
GS
677
678 if (@_) {
679 # check the category supplied.
680 $category = shift ;
9df0f64f 681 if (my $type = ref $category) {
682 Croaker("not an object")
683 if exists $builtin_type{$type};
684 $category = $type;
7e6d00f8
PM
685 $isobj = 1 ;
686 }
d3a7d8c7 687 $offset = $Offsets{$category};
c3186b65 688 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
689 unless defined $offset;
690 }
691 else {
0ca4541c 692 $category = (caller(1))[0] ;
d3a7d8c7 693 $offset = $Offsets{$category};
c3186b65 694 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
695 unless defined $offset ;
696 }
697
0ca4541c 698 my $this_pkg = (caller(1))[0] ;
7e6d00f8
PM
699 my $i = 2 ;
700 my $pkg ;
701
702 if ($isobj) {
703 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
704 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
705 }
706 $i -= 2 ;
707 }
708 else {
4f527b71 709 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
710 }
711
0ca4541c 712 my $callers_bitmask = (caller($i))[9] ;
7e6d00f8
PM
713 return ($callers_bitmask, $offset, $i) ;
714}
715
4f527b71
AS
716sub _error_loc {
717 require Carp::Heavy;
718 goto &Carp::short_error_loc; # don't introduce another stack frame
719}
720
7e6d00f8
PM
721sub enabled
722{
c3186b65 723 Croaker("Usage: warnings::enabled([category])")
7e6d00f8
PM
724 unless @_ == 1 || @_ == 0 ;
725
726 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
727
728 return 0 unless defined $callers_bitmask ;
d3a7d8c7
GS
729 return vec($callers_bitmask, $offset, 1) ||
730 vec($callers_bitmask, $Offsets{'all'}, 1) ;
599cee73
PM
731}
732
d3a7d8c7 733
e476b1b5
GS
734sub warn
735{
c3186b65 736 Croaker("Usage: warnings::warn([category,] 'message')")
d3a7d8c7 737 unless @_ == 2 || @_ == 1 ;
d3a7d8c7 738
7e6d00f8
PM
739 my $message = pop ;
740 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
09e96b99 741 require Carp;
8becbb3b 742 Carp::croak($message)
d3a7d8c7
GS
743 if vec($callers_bitmask, $offset+1, 1) ||
744 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
8becbb3b 745 Carp::carp($message) ;
e476b1b5
GS
746}
747
7e6d00f8
PM
748sub warnif
749{
c3186b65 750 Croaker("Usage: warnings::warnif([category,] 'message')")
7e6d00f8
PM
751 unless @_ == 2 || @_ == 1 ;
752
753 my $message = pop ;
754 my ($callers_bitmask, $offset, $i) = __chk(@_) ;
7e6d00f8 755
0ca4541c 756 return
7e6d00f8
PM
757 unless defined $callers_bitmask &&
758 (vec($callers_bitmask, $offset, 1) ||
759 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
760
09e96b99 761 require Carp;
8becbb3b 762 Carp::croak($message)
7e6d00f8
PM
763 if vec($callers_bitmask, $offset+1, 1) ||
764 vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
765
8becbb3b 766 Carp::carp($message) ;
7e6d00f8 767}
0d658bf5 768
599cee73 7691;