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