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