This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
silence warning after "Fold join to const or stringify where possible"
[perl5.git] / regen / warnings.pl
CommitLineData
599cee73 1#!/usr/bin/perl
c4a853d1 2#
6294c161
DM
3# Regenerate (overwriting only if changed):
4#
5# lib/warnings.pm
6# warnings.h
7#
8# from information hardcoded into this script (the $tree hash), plus the
d2ec25a5 9# template for warnings.pm in the DATA section.
6294c161 10#
91efc02c
KW
11# When changing the number of warnings, t/op/caller.t should change to
12# correspond with the value of $BYTES in lib/warnings.pm
8457b38f 13#
6294c161
DM
14# With an argument of 'tree', just dump the contents of $tree and exits.
15# Also accepts the standard regen_lib -q and -v args.
16#
17# This script is normally invoked from regen.pl.
599cee73 18
0febf6c1 19$VERSION = '1.03';
b75c8c73 20
73f0cc2d 21BEGIN {
af001346 22 require 'regen/regen_lib.pl';
b6b9a099 23 push @INC, './lib';
73f0cc2d 24}
599cee73
PM
25use strict ;
26
27sub DEFAULT_ON () { 1 }
28sub DEFAULT_OFF () { 2 }
29
30my $tree = {
d3a7d8c7 31
0d658bf5 32'all' => [ 5.008, {
c4a853d1 33 'io' => [ 5.008, {
0d658bf5
PM
34 'pipe' => [ 5.008, DEFAULT_OFF],
35 'unopened' => [ 5.008, DEFAULT_OFF],
36 'closed' => [ 5.008, DEFAULT_OFF],
37 'newline' => [ 5.008, DEFAULT_OFF],
38 'exec' => [ 5.008, DEFAULT_OFF],
39 'layer' => [ 5.008, DEFAULT_OFF],
c8028aa6 40 'syscalls' => [ 5.019, DEFAULT_OFF],
0d658bf5 41 }],
c4a853d1 42 'syntax' => [ 5.008, {
0d658bf5
PM
43 'ambiguous' => [ 5.008, DEFAULT_OFF],
44 'semicolon' => [ 5.008, DEFAULT_OFF],
45 'precedence' => [ 5.008, DEFAULT_OFF],
46 'bareword' => [ 5.008, DEFAULT_OFF],
47 'reserved' => [ 5.008, DEFAULT_OFF],
48 'digit' => [ 5.008, DEFAULT_OFF],
49 'parenthesis' => [ 5.008, DEFAULT_OFF],
50 'printf' => [ 5.008, DEFAULT_OFF],
51 'prototype' => [ 5.008, DEFAULT_OFF],
52 'qw' => [ 5.008, DEFAULT_OFF],
197afce1 53 'illegalproto' => [ 5.011, DEFAULT_OFF],
0d658bf5 54 }],
c4a853d1 55 'severe' => [ 5.008, {
0d658bf5 56 'inplace' => [ 5.008, DEFAULT_ON],
7fc874e8 57 'internal' => [ 5.008, DEFAULT_OFF],
0d658bf5
PM
58 'debugging' => [ 5.008, DEFAULT_ON],
59 'malloc' => [ 5.008, DEFAULT_ON],
c8028aa6 60 }],
7fc874e8 61 'deprecated' => [ 5.008, DEFAULT_ON],
0d658bf5
PM
62 'void' => [ 5.008, DEFAULT_OFF],
63 'recursion' => [ 5.008, DEFAULT_OFF],
64 'redefine' => [ 5.008, DEFAULT_OFF],
65 'numeric' => [ 5.008, DEFAULT_OFF],
66 'uninitialized' => [ 5.008, DEFAULT_OFF],
67 'once' => [ 5.008, DEFAULT_OFF],
68 'misc' => [ 5.008, DEFAULT_OFF],
69 'regexp' => [ 5.008, DEFAULT_OFF],
7fc874e8 70 'glob' => [ 5.008, DEFAULT_ON],
0d658bf5
PM
71 'untie' => [ 5.008, DEFAULT_OFF],
72 'substr' => [ 5.008, DEFAULT_OFF],
73 'taint' => [ 5.008, DEFAULT_OFF],
74 'signal' => [ 5.008, DEFAULT_OFF],
75 'closure' => [ 5.008, DEFAULT_OFF],
76 'overflow' => [ 5.008, DEFAULT_OFF],
77 'portable' => [ 5.008, DEFAULT_OFF],
8457b38f
KW
78 'utf8' => [ 5.008, {
79 'surrogate' => [ 5.013, DEFAULT_OFF],
80 'nonchar' => [ 5.013, DEFAULT_OFF],
81 'non_unicode' => [ 5.013, DEFAULT_OFF],
82 }],
0d658bf5
PM
83 'exiting' => [ 5.008, DEFAULT_OFF],
84 'pack' => [ 5.008, DEFAULT_OFF],
85 'unpack' => [ 5.008, DEFAULT_OFF],
38875929 86 'threads' => [ 5.008, DEFAULT_OFF],
b88df990 87 'imprecision' => [ 5.011, DEFAULT_OFF],
6f87cb12 88 'experimental' => [ 5.017, {
f1d34ca8 89 'experimental::lexical_subs' =>
6f87cb12 90 [ 5.017, DEFAULT_ON ],
db620012
KW
91 'experimental::regex_sets' =>
92 [ 5.017, DEFAULT_ON ],
4055dbce
RS
93 'experimental::lexical_topic' =>
94 [ 5.017, DEFAULT_ON ],
0f539b13
BF
95 'experimental::smartmatch' =>
96 [ 5.017, DEFAULT_ON ],
1f25714a
FC
97 'experimental::postderef' =>
98 [ 5.019, DEFAULT_ON ],
d401967c 99 'experimental::autoderef' =>
0953b66b 100 [ 5.019, DEFAULT_ON ],
30d9c59b
Z
101 'experimental::signatures' =>
102 [ 5.019, DEFAULT_ON ],
7ac92924
TC
103 'experimental::win32_perlio' =>
104 [ 5.021, DEFAULT_ON ],
f438dbf0
FC
105 'experimental::lvalue_refs' =>
106 [ 5.021, DEFAULT_ON ],
6f87cb12 107 }],
8fa7688f 108
3664866e 109 'missing' => [ 5.021, DEFAULT_OFF],
4077a6bc 110 'redundant' => [ 5.021, DEFAULT_OFF],
3664866e 111
0d658bf5
PM
112 #'default' => [ 5.008, DEFAULT_ON ],
113 }],
d3a7d8c7 114} ;
599cee73 115
7fc874e8 116my @def ;
599cee73
PM
117my %list ;
118my %Value ;
0d658bf5
PM
119my %ValueToName ;
120my %NameToValue ;
599cee73 121
0d658bf5
PM
122my %v_list = () ;
123
124sub valueWalk
125{
126 my $tre = shift ;
127 my @list = () ;
128 my ($k, $v) ;
129
130 foreach $k (sort keys %$tre) {
131 $v = $tre->{$k};
132 die "duplicate key $k\n" if defined $list{$k} ;
133 die "Value associated with key '$k' is not an ARRAY reference"
134 if !ref $v || ref $v ne 'ARRAY' ;
135
136 my ($ver, $rest) = @{ $v } ;
137 push @{ $v_list{$ver} }, $k;
c4a853d1 138
0d658bf5
PM
139 if (ref $rest)
140 { valueWalk ($rest) }
141
142 }
143
144}
145
146sub orderValues
147{
148 my $index = 0;
149 foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
150 foreach my $name (@{ $v_list{$ver} } ) {
151 $ValueToName{ $index } = [ uc $name, $ver ] ;
152 $NameToValue{ uc $name } = $index ++ ;
153 }
154 }
155
156 return $index ;
157}
158
159###########################################################################
160
599cee73
PM
161sub walk
162{
163 my $tre = shift ;
164 my @list = () ;
165 my ($k, $v) ;
166
95dfd3ab
GS
167 foreach $k (sort keys %$tre) {
168 $v = $tre->{$k};
599cee73 169 die "duplicate key $k\n" if defined $list{$k} ;
0d658bf5
PM
170 die "Can't find key '$k'"
171 if ! defined $NameToValue{uc $k} ;
172 push @{ $list{$k} }, $NameToValue{uc $k} ;
173 die "Value associated with key '$k' is not an ARRAY reference"
174 if !ref $v || ref $v ne 'ARRAY' ;
c4a853d1 175
0d658bf5
PM
176 my ($ver, $rest) = @{ $v } ;
177 if (ref $rest)
178 { push (@{ $list{$k} }, walk ($rest)) }
7fc874e8
FC
179 elsif ($rest == DEFAULT_ON)
180 { push @def, $NameToValue{uc $k} }
0d658bf5 181
599cee73
PM
182 push @list, @{ $list{$k} } ;
183 }
184
185 return @list ;
599cee73
PM
186}
187
188###########################################################################
189
190sub mkRange
191{
192 my @a = @_ ;
193 my @out = @a ;
599cee73 194
e95a9fc2 195 for my $i (1 .. @a - 1) {
0ca4541c 196 $out[$i] = ".."
e95a9fc2
KW
197 if $a[$i] == $a[$i - 1] + 1
198 && ($i >= @a - 1 || $a[$i] + 1 == $a[$i + 1] );
599cee73 199 }
e95a9fc2 200 $out[-1] = $a[-1] if $out[-1] eq "..";
599cee73
PM
201
202 my $out = join(",",@out);
203
204 $out =~ s/,(\.\.,)+/../g ;
205 return $out;
206}
207
208###########################################################################
e15f14b8 209sub warningsTree
e476b1b5
GS
210{
211 my $tre = shift ;
212 my $prefix = shift ;
e476b1b5
GS
213 my ($k, $v) ;
214
215 my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
0d658bf5 216 my @keys = sort keys %$tre ;
e476b1b5 217
e15f14b8
RS
218 my $rv = '';
219
0d658bf5 220 while ($k = shift @keys) {
e476b1b5 221 $v = $tre->{$k};
0d658bf5
PM
222 die "Value associated with key '$k' is not an ARRAY reference"
223 if !ref $v || ref $v ne 'ARRAY' ;
c4a853d1 224
0d658bf5
PM
225 my $offset ;
226 if ($tre ne $tree) {
e15f14b8
RS
227 $rv .= $prefix . "|\n" ;
228 $rv .= $prefix . "+- $k" ;
0d658bf5
PM
229 $offset = ' ' x ($max + 4) ;
230 }
231 else {
e15f14b8 232 $rv .= $prefix . "$k" ;
0d658bf5
PM
233 $offset = ' ' x ($max + 1) ;
234 }
235
236 my ($ver, $rest) = @{ $v } ;
f1d34ca8 237 if (ref $rest)
0ca4541c 238 {
0d658bf5 239 my $bar = @keys ? "|" : " ";
e15f14b8
RS
240 $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
241 $rv .= warningsTree ($rest, $prefix . $bar . $offset )
e476b1b5
GS
242 }
243 else
e15f14b8 244 { $rv .= "\n" }
e476b1b5
GS
245 }
246
e15f14b8 247 return $rv;
e476b1b5
GS
248}
249
250###########################################################################
599cee73 251
317ea90d 252sub mkHexOct
599cee73 253{
317ea90d 254 my ($f, $max, @a) = @_ ;
599cee73
PM
255 my $mask = "\x00" x $max ;
256 my $string = "" ;
257
258 foreach (@a) {
259 vec($mask, $_, 1) = 1 ;
260 }
261
599cee73 262 foreach (unpack("C*", $mask)) {
317ea90d
MS
263 if ($f eq 'x') {
264 $string .= '\x' . sprintf("%2.2x", $_)
265 }
266 else {
267 $string .= '\\' . sprintf("%o", $_)
268 }
599cee73
PM
269 }
270 return $string ;
271}
272
317ea90d
MS
273sub mkHex
274{
275 my($max, @a) = @_;
276 return mkHexOct("x", $max, @a);
277}
278
279sub mkOct
280{
281 my($max, @a) = @_;
282 return mkHexOct("o", $max, @a);
283}
284
599cee73
PM
285###########################################################################
286
e476b1b5
GS
287if (@ARGV && $ARGV[0] eq "tree")
288{
e15f14b8 289 print warningsTree($tree, " ") ;
e476b1b5
GS
290 exit ;
291}
599cee73 292
cc49830d
NC
293my ($warn, $pm) = map {
294 open_new($_, '>', { by => 'regen/warnings.pl' });
295} 'warnings.h', 'lib/warnings.pm';
599cee73 296
c4a853d1
RS
297my ($index, $warn_size);
298
299{
300 # generate warnings.h
301
302 print $warn <<'EOM';
599cee73 303
0453d815
PM
304#define Off(x) ((x) / 8)
305#define Bit(x) (1 << ((x) % 8))
599cee73
PM
306#define IsSet(a, x) ((a)[Off(x)] & Bit(x))
307
0453d815 308
599cee73 309#define G_WARN_OFF 0 /* $^W == 0 */
0453d815 310#define G_WARN_ON 1 /* -w flag and $^W != 0 */
599cee73
PM
311#define G_WARN_ALL_ON 2 /* -W flag */
312#define G_WARN_ALL_OFF 4 /* -X flag */
0453d815 313#define G_WARN_ONCE 8 /* set if 'once' ever enabled */
599cee73
PM
314#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
315
a0714e2c 316#define pWARN_STD NULL
72dc9ed5
NC
317#define pWARN_ALL (((STRLEN*)0)+1) /* use warnings 'all' */
318#define pWARN_NONE (((STRLEN*)0)+2) /* no warnings 'all' */
599cee73 319
d3a7d8c7
GS
320#define specialWARN(x) ((x) == pWARN_STD || (x) == pWARN_ALL || \
321 (x) == pWARN_NONE)
5f2d9966
DM
322
323/* if PL_warnhook is set to this value, then warnings die */
06dcd5bf 324#define PERL_WARNHOOK_FATAL (&PL_sv_placeholder)
599cee73
PM
325EOM
326
c4a853d1 327 my $offset = 0 ;
d3a7d8c7 328
c4a853d1
RS
329 valueWalk ($tree) ;
330 $index = orderValues();
599cee73 331
c4a853d1 332 die <<EOM if $index > 255 ;
12bcd1a6 333Too many warnings categories -- max is 255
c4a853d1 334 rewrite packWARN* & unpackWARN* macros
12bcd1a6 335EOM
599cee73 336
c4a853d1 337 walk ($tree) ;
0d658bf5 338
c4a853d1
RS
339 $index *= 2 ;
340 $warn_size = int($index / 8) + ($index % 8 != 0) ;
599cee73 341
c4a853d1
RS
342 my $k ;
343 my $last_ver = 0;
344 foreach $k (sort { $a <=> $b } keys %ValueToName) {
345 my ($name, $version) = @{ $ValueToName{$k} };
346 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
347 if $last_ver != $version ;
348 $name =~ y/:/_/;
349 print $warn tab(5, "#define WARN_$name"), " $k\n" ;
350 $last_ver = $version ;
351 }
352 print $warn "\n" ;
599cee73 353
c4a853d1
RS
354 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
355 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
356 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
599cee73 357
c4a853d1 358 print $warn <<'EOM';
599cee73 359
d5a71f30
GS
360#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
361#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
362#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
72dc9ed5
NC
363#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
364#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
365
366#define DUP_WARNINGS(p) \
594cd643
NC
367 (specialWARN(p) ? (STRLEN*)(p) \
368 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
369 char))
d5a71f30 370
f54ba1c2 371#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
7c08c4c5
KW
372
373/* The w1, w2 ... should be independent warnings categories; one shouldn't be
374 * a subcategory of any other */
375
f54ba1c2
DM
376#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
377#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
378#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
379
380#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
381#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
382#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
383#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 384
98fe6610
NC
385#define WARNshift 8
386
3b9e3074 387#define packWARN(a) (a )
7c08c4c5
KW
388
389/* The a, b, ... should be independent warnings categories; one shouldn't be
390 * a subcategory of any other */
391
3b9e3074
SH
392#define packWARN2(a,b) ((a) | ((b)<<8) )
393#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
394#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
395
396#define unpackWARN1(x) ((x) & 0xFF)
397#define unpackWARN2(x) (((x) >>8) & 0xFF)
398#define unpackWARN3(x) (((x) >>16) & 0xFF)
399#define unpackWARN4(x) (((x) >>24) & 0xFF)
400
401#define ckDEAD(x) \
402 ( ! specialWARN(PL_curcop->cop_warnings) && \
403 ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) || \
404 isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
405 isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
406 isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
407 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
408
4438c4b7 409/* end of file warnings.h */
599cee73
PM
410EOM
411
c4a853d1
RS
412 read_only_bottom_close_and_rename($warn);
413}
599cee73
PM
414
415while (<DATA>) {
416 last if /^KEYWORDS$/ ;
33edcb80
RS
417 if ($_ eq "=for warnings.pl tree-goes-here\n") {
418 print $pm warningsTree($tree, " ");
419 next;
420 }
424a4936 421 print $pm $_ ;
599cee73
PM
422}
423
c4a853d1 424my $last_ver = 0;
424a4936 425print $pm "our %Offsets = (\n" ;
0d658bf5
PM
426foreach my $k (sort { $a <=> $b } keys %ValueToName) {
427 my ($name, $version) = @{ $ValueToName{$k} };
428 $name = lc $name;
d3a7d8c7 429 $k *= 2 ;
0d658bf5 430 if ( $last_ver != $version ) {
424a4936
NC
431 print $pm "\n";
432 print $pm tab(4, " # Warnings Categories added in Perl $version");
433 print $pm "\n\n";
0d658bf5 434 }
424a4936 435 print $pm tab(4, " '$name'"), "=> $k,\n" ;
0d658bf5 436 $last_ver = $version;
d3a7d8c7
GS
437}
438
424a4936 439print $pm " );\n\n" ;
d3a7d8c7 440
424a4936 441print $pm "our %Bits = (\n" ;
c4a853d1 442foreach my $k (sort keys %list) {
599cee73
PM
443
444 my $v = $list{$k} ;
445 my @list = sort { $a <=> $b } @$v ;
446
424a4936 447 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 448 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
449 '", # [', mkRange(@list), "]\n" ;
450}
451
424a4936 452print $pm " );\n\n" ;
599cee73 453
424a4936 454print $pm "our %DeadBits = (\n" ;
c4a853d1 455foreach my $k (sort keys %list) {
599cee73
PM
456
457 my $v = $list{$k} ;
458 my @list = sort { $a <=> $b } @$v ;
459
424a4936 460 print $pm tab(4, " '$k'"), '=> "',
0ca4541c 461 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
462 '", # [', mkRange(@list), "]\n" ;
463}
464
424a4936
NC
465print $pm " );\n\n" ;
466print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
7fc874e8
FC
467print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def),
468 '", # [', mkRange(@def), "]\n" ;
424a4936
NC
469print $pm '$LAST_BIT = ' . "$index ;\n" ;
470print $pm '$BYTES = ' . "$warn_size ;\n" ;
599cee73 471while (<DATA>) {
424a4936 472 print $pm $_ ;
599cee73
PM
473}
474
ce716c52 475read_only_bottom_close_and_rename($pm);
599cee73
PM
476
477__END__
4438c4b7 478package warnings;
599cee73 479
be16e595 480our $VERSION = '1.27';
f2c3e829
RGS
481
482# Verify that we're called correctly so that warnings will work.
483# see also strict.pm.
5108dc18 484unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
f2c3e829 485 my (undef, $f, $l) = caller;
5108dc18 486 die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
f2c3e829 487}
b75c8c73 488
599cee73
PM
489=head1 NAME
490
4438c4b7 491warnings - Perl pragma to control optional warnings
599cee73
PM
492
493=head1 SYNOPSIS
494
4438c4b7
JH
495 use warnings;
496 no warnings;
599cee73 497
4438c4b7
JH
498 use warnings "all";
499 no warnings "all";
599cee73 500
d3a7d8c7
GS
501 use warnings::register;
502 if (warnings::enabled()) {
503 warnings::warn("some warning");
504 }
505
506 if (warnings::enabled("void")) {
e476b1b5
GS
507 warnings::warn("void", "some warning");
508 }
509
7e6d00f8
PM
510 if (warnings::enabled($object)) {
511 warnings::warn($object, "some warning");
512 }
513
721f911b
PM
514 warnings::warnif("some warning");
515 warnings::warnif("void", "some warning");
516 warnings::warnif($object, "some warning");
7e6d00f8 517
599cee73
PM
518=head1 DESCRIPTION
519
188c4f6f
RS
520The C<warnings> pragma gives control over which warnings are enabled in
521which parts of a Perl program. It's a more flexible alternative for
522both the command line flag B<-w> and the equivalent Perl variable,
523C<$^W>.
33edcb80
RS
524
525This pragma works just like the C<strict> pragma.
526This means that the scope of the warning pragma is limited to the
527enclosing block. It also means that the pragma setting will not
528leak across files (via C<use>, C<require> or C<do>). This allows
529authors to independently define the degree of warning checks that will
530be applied to their module.
531
532By default, optional warnings are disabled, so any legacy code that
533doesn't attempt to control the warnings will work unchanged.
534
535All warnings are enabled in a block by either of these:
536
537 use warnings;
538 use warnings 'all';
539
540Similarly all warnings are disabled in a block by either of these:
541
542 no warnings;
543 no warnings 'all';
544
545For example, consider the code below:
546
547 use warnings;
548 my @a;
549 {
550 no warnings;
551 my $b = @a[0];
552 }
553 my $c = @a[0];
554
555The code in the enclosing block has warnings enabled, but the inner
556block has them disabled. In this case that means the assignment to the
557scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
558warning, but the assignment to the scalar C<$b> will not.
559
560=head2 Default Warnings and Optional Warnings
561
562Before the introduction of lexical warnings, Perl had two classes of
563warnings: mandatory and optional.
564
565As its name suggests, if your code tripped a mandatory warning, you
566would get a warning whether you wanted it or not.
567For example, the code below would always produce an C<"isn't numeric">
568warning about the "2:".
569
570 my $a = "2:" + 3;
571
572With the introduction of lexical warnings, mandatory warnings now become
573I<default> warnings. The difference is that although the previously
574mandatory warnings are still enabled by default, they can then be
575subsequently enabled or disabled with the lexical warning pragma. For
576example, in the code below, an C<"isn't numeric"> warning will only
577be reported for the C<$a> variable.
578
579 my $a = "2:" + 3;
580 no warnings;
581 my $b = "2:" + 3;
582
583Note that neither the B<-w> flag or the C<$^W> can be used to
584disable/enable default warnings. They are still mandatory in this case.
585
586=head2 What's wrong with B<-w> and C<$^W>
587
588Although very useful, the big problem with using B<-w> on the command
589line to enable warnings is that it is all or nothing. Take the typical
590scenario when you are writing a Perl program. Parts of the code you
591will write yourself, but it's very likely that you will make use of
592pre-written Perl modules. If you use the B<-w> flag in this case, you
593end up enabling warnings in pieces of code that you haven't written.
594
595Similarly, using C<$^W> to either disable or enable blocks of code is
596fundamentally flawed. For a start, say you want to disable warnings in
597a block of code. You might expect this to be enough to do the trick:
598
599 {
600 local ($^W) = 0;
601 my $a =+ 2;
602 my $b; chop $b;
603 }
604
605When this code is run with the B<-w> flag, a warning will be produced
606for the C<$a> line: C<"Reversed += operator">.
607
608The problem is that Perl has both compile-time and run-time warnings. To
609disable compile-time warnings you need to rewrite the code like this:
610
611 {
612 BEGIN { $^W = 0 }
613 my $a =+ 2;
614 my $b; chop $b;
615 }
616
617The other big problem with C<$^W> is the way you can inadvertently
618change the warning setting in unexpected places in your code. For example,
619when the code below is run (without the B<-w> flag), the second call
620to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
621the first will not.
622
623 sub doit
624 {
625 my $b; chop $b;
626 }
627
628 doit();
629
630 {
631 local ($^W) = 1;
632 doit()
633 }
634
635This is a side-effect of C<$^W> being dynamically scoped.
636
637Lexical warnings get around these limitations by allowing finer control
638over where warnings can or can't be tripped.
639
640=head2 Controlling Warnings from the Command Line
641
642There are three Command Line flags that can be used to control when
643warnings are (or aren't) produced:
644
645=over 5
646
647=item B<-w>
648X<-w>
649
650This is the existing flag. If the lexical warnings pragma is B<not>
651used in any of you code, or any of the modules that you use, this flag
652will enable warnings everywhere. See L<Backward Compatibility> for
653details of how this flag interacts with lexical warnings.
654
655=item B<-W>
656X<-W>
657
658If the B<-W> flag is used on the command line, it will enable all warnings
659throughout the program regardless of whether warnings were disabled
660locally using C<no warnings> or C<$^W =0>.
661This includes all files that get
662included via C<use>, C<require> or C<do>.
663Think of it as the Perl equivalent of the "lint" command.
664
665=item B<-X>
666X<-X>
667
668Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
669
670=back
671
672=head2 Backward Compatibility
673
674If you are used to working with a version of Perl prior to the
675introduction of lexically scoped warnings, or have code that uses both
676lexical warnings and C<$^W>, this section will describe how they interact.
677
678How Lexical Warnings interact with B<-w>/C<$^W>:
679
680=over 5
681
682=item 1.
683
684If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
685control warnings is used and neither C<$^W> nor the C<warnings> pragma
686are used, then default warnings will be enabled and optional warnings
687disabled.
688This means that legacy code that doesn't attempt to control the warnings
689will work unchanged.
690
691=item 2.
692
693The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
694means that any legacy code that currently relies on manipulating C<$^W>
695to control warning behavior will still work as is.
696
697=item 3.
698
699Apart from now being a boolean, the C<$^W> variable operates in exactly
700the same horrible uncontrolled global way, except that it cannot
701disable/enable default warnings.
702
703=item 4.
704
705If a piece of code is under the control of the C<warnings> pragma,
706both the C<$^W> variable and the B<-w> flag will be ignored for the
707scope of the lexical warning.
708
709=item 5.
710
711The only way to override a lexical warnings setting is with the B<-W>
712or B<-X> command line flags.
713
714=back
715
716The combined effect of 3 & 4 is that it will allow code which uses
717the C<warnings> pragma to control the warning behavior of $^W-type
718code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
719
720=head2 Category Hierarchy
721X<warning, categories>
722
723A hierarchy of "categories" have been defined to allow groups of warnings
724to be enabled/disabled in isolation.
725
726The current hierarchy is:
727
728=for warnings.pl tree-goes-here
729
730Just like the "strict" pragma any of these categories can be combined
731
732 use warnings qw(void redefine);
733 no warnings qw(io syntax untie);
734
735Also like the "strict" pragma, if there is more than one instance of the
736C<warnings> pragma in a given scope the cumulative effect is additive.
737
738 use warnings qw(void); # only "void" warnings enabled
739 ...
740 use warnings qw(io); # only "void" & "io" warnings enabled
741 ...
742 no warnings qw(void); # only "io" warnings enabled
743
744To determine which category a specific warning has been assigned to see
745L<perldiag>.
746
747Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
748sub-category of the "syntax" category. It is now a top-level category
749in its own right.
750
3664866e
AB
751Note: Before 5.21.0, the "missing" lexical warnings category was
752internally defined to be the same as the "uninitialized" category. It
753is now a top-level category in its own right.
754
33edcb80
RS
755=head2 Fatal Warnings
756X<warning, fatal>
757
758The presence of the word "FATAL" in the category list will escalate any
759warnings detected from the categories specified in the lexical scope
760into fatal errors. In the code below, the use of C<time>, C<length>
761and C<join> can all produce a C<"Useless use of xxx in void context">
762warning.
763
764 use warnings;
765
766 time;
767
768 {
769 use warnings FATAL => qw(void);
770 length "abc";
771 }
772
773 join "", 1,2,3;
774
775 print "done\n";
776
777When run it produces this output
778
779 Useless use of time in void context at fatal line 3.
780 Useless use of length in void context at fatal line 7.
781
782The scope where C<length> is used has escalated the C<void> warnings
783category into a fatal error, so the program terminates immediately when it
784encounters the warning.
785
786To explicitly turn off a "FATAL" warning you just disable the warning
787it is associated with. So, for example, to disable the "void" warning
788in the example above, either of these will do the trick:
789
790 no warnings qw(void);
791 no warnings FATAL => qw(void);
792
793If you want to downgrade a warning that has been escalated into a fatal
794error back to a normal warning, you can use the "NONFATAL" keyword. For
795example, the code below will promote all warnings into fatal errors,
796except for those in the "syntax" category.
797
798 use warnings FATAL => 'all', NONFATAL => 'syntax';
799
800As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
801use:
802
803 use v5.20; # Perl 5.20 or greater is required for the following
804 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
805
806If you want your program to be compatible with versions of Perl before
8075.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
808previous versions of Perl, the behavior of the statements
809C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
810C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
811they included the C<< => 'all' >> portion. As of 5.20, they do.)
812
813B<NOTE:> Users of FATAL warnings, especially
814those using C<< FATAL => 'all' >>
815should be fully aware that they are risking future portability of their
816programs by doing so. Perl makes absolutely no commitments to not
817introduce new warnings, or warnings categories in the future, and indeed
818we explicitly reserve the right to do so. Code that may not warn now may
819warn in a future release of Perl if the Perl5 development team deems it
820in the best interests of the community to do so. Should code using FATAL
821warnings break due to the introduction of a new warning we will NOT
822consider it an incompatible change. Users of FATAL warnings should take
823special caution during upgrades to check to see if their code triggers
824any new warnings and should pay particular attention to the fine print of
825the documentation of the features they use to ensure they do not exploit
826features that are documented as risky, deprecated, or unspecified, or where
827the documentation says "so don't do that", or anything with the same sense
828and spirit. Use of such features in combination with FATAL warnings is
829ENTIRELY AT THE USER'S RISK.
830
831=head2 Reporting Warnings from a Module
832X<warning, reporting> X<warning, registering>
833
834The C<warnings> pragma provides a number of functions that are useful for
835module authors. These are used when you want to report a module-specific
836warning to a calling module has enabled warnings via the C<warnings>
837pragma.
838
839Consider the module C<MyMod::Abc> below.
840
841 package MyMod::Abc;
842
843 use warnings::register;
844
845 sub open {
846 my $path = shift;
847 if ($path !~ m#^/#) {
848 warnings::warn("changing relative path to /var/abc")
849 if warnings::enabled();
850 $path = "/var/abc/$path";
851 }
852 }
853
854 1;
855
856The call to C<warnings::register> will create a new warnings category
857called "MyMod::Abc", i.e. the new category name matches the current
858package name. The C<open> function in the module will display a warning
859message if it gets given a relative path as a parameter. This warnings
860will only be displayed if the code that uses C<MyMod::Abc> has actually
861enabled them with the C<warnings> pragma like below.
862
863 use MyMod::Abc;
864 use warnings 'MyMod::Abc';
865 ...
866 abc::open("../fred.txt");
867
868It is also possible to test whether the pre-defined warnings categories are
869set in the calling module with the C<warnings::enabled> function. Consider
870this snippet of code:
871
872 package MyMod::Abc;
873
874 sub open {
875 warnings::warnif("deprecated",
876 "open is deprecated, use new instead");
877 new(@_);
878 }
879
880 sub new
881 ...
882 1;
883
884The function C<open> has been deprecated, so code has been included to
885display a warning message whenever the calling module has (at least) the
886"deprecated" warnings category enabled. Something like this, say.
887
888 use warnings 'deprecated';
889 use MyMod::Abc;
890 ...
891 MyMod::Abc::open($filename);
892
893Either the C<warnings::warn> or C<warnings::warnif> function should be
894used to actually display the warnings message. This is because they can
895make use of the feature that allows warnings to be escalated into fatal
896errors. So in this case
897
898 use MyMod::Abc;
899 use warnings FATAL => 'MyMod::Abc';
900 ...
901 MyMod::Abc::open('../fred.txt');
902
903the C<warnings::warnif> function will detect this and die after
904displaying the warning message.
905
906The three warnings functions, C<warnings::warn>, C<warnings::warnif>
907and C<warnings::enabled> can optionally take an object reference in place
908of a category name. In this case the functions will use the class name
909of the object as the warnings category.
910
911Consider this example:
912
913 package Original;
914
915 no warnings;
916 use warnings::register;
917
918 sub new
919 {
920 my $class = shift;
921 bless [], $class;
922 }
923
924 sub check
925 {
926 my $self = shift;
927 my $value = shift;
928
929 if ($value % 2 && warnings::enabled($self))
930 { warnings::warn($self, "Odd numbers are unsafe") }
931 }
932
933 sub doit
934 {
935 my $self = shift;
936 my $value = shift;
937 $self->check($value);
938 # ...
939 }
940
941 1;
942
943 package Derived;
944
945 use warnings::register;
946 use Original;
947 our @ISA = qw( Original );
948 sub new
949 {
950 my $class = shift;
951 bless [], $class;
952 }
953
954
955 1;
956
957The code below makes use of both modules, but it only enables warnings from
958C<Derived>.
959
960 use Original;
961 use Derived;
962 use warnings 'Derived';
963 my $a = Original->new();
964 $a->doit(1);
965 my $b = Derived->new();
966 $a->doit(1);
967
968When this code is run only the C<Derived> object, C<$b>, will generate
969a warning.
970
971 Odd numbers are unsafe at main.pl line 7
972
973Notice also that the warning is reported at the line where the object is first
974used.
975
976When registering new categories of warning, you can supply more names to
977warnings::register like this:
978
979 package MyModule;
980 use warnings::register qw(format precision);
981
982 ...
fe2e802c 983
33edcb80 984 warnings::warnif('MyModule::format', '...');
599cee73 985
33edcb80 986=head1 FUNCTIONS
e476b1b5
GS
987
988=over 4
989
d3a7d8c7
GS
990=item use warnings::register
991
7e6d00f8
PM
992Creates a new warnings category with the same name as the package where
993the call to the pragma is used.
994
995=item warnings::enabled()
996
997Use the warnings category with the same name as the current package.
998
999Return TRUE if that warnings category is enabled in the calling module.
1000Otherwise returns FALSE.
1001
1002=item warnings::enabled($category)
1003
1004Return TRUE if the warnings category, C<$category>, is enabled in the
1005calling module.
1006Otherwise returns FALSE.
1007
1008=item warnings::enabled($object)
1009
1010Use the name of the class for the object reference, C<$object>, as the
1011warnings category.
1012
1013Return TRUE if that warnings category is enabled in the first scope
1014where the object is used.
1015Otherwise returns FALSE.
1016
ec983580
AR
1017=item warnings::fatal_enabled()
1018
1019Return TRUE if the warnings category with the same name as the current
1020package has been set to FATAL in the calling module.
1021Otherwise returns FALSE.
1022
1023=item warnings::fatal_enabled($category)
1024
1025Return TRUE if the warnings category C<$category> has been set to FATAL in
1026the calling module.
1027Otherwise returns FALSE.
1028
1029=item warnings::fatal_enabled($object)
1030
1031Use the name of the class for the object reference, C<$object>, as the
1032warnings category.
1033
1034Return TRUE if that warnings category has been set to FATAL in the first
1035scope where the object is used.
1036Otherwise returns FALSE.
1037
7e6d00f8
PM
1038=item warnings::warn($message)
1039
1040Print C<$message> to STDERR.
1041
1042Use the warnings category with the same name as the current package.
1043
1044If that warnings category has been set to "FATAL" in the calling module
1045then die. Otherwise return.
1046
1047=item warnings::warn($category, $message)
1048
1049Print C<$message> to STDERR.
1050
1051If the warnings category, C<$category>, has been set to "FATAL" in the
1052calling module then die. Otherwise return.
d3a7d8c7 1053
7e6d00f8 1054=item warnings::warn($object, $message)
e476b1b5 1055
7e6d00f8 1056Print C<$message> to STDERR.
e476b1b5 1057
7e6d00f8
PM
1058Use the name of the class for the object reference, C<$object>, as the
1059warnings category.
e476b1b5 1060
7e6d00f8
PM
1061If that warnings category has been set to "FATAL" in the scope where C<$object>
1062is first used then die. Otherwise return.
599cee73 1063
e476b1b5 1064
7e6d00f8
PM
1065=item warnings::warnif($message)
1066
1067Equivalent to:
1068
1069 if (warnings::enabled())
1070 { warnings::warn($message) }
1071
1072=item warnings::warnif($category, $message)
1073
1074Equivalent to:
1075
1076 if (warnings::enabled($category))
1077 { warnings::warn($category, $message) }
1078
1079=item warnings::warnif($object, $message)
1080
1081Equivalent to:
1082
1083 if (warnings::enabled($object))
1084 { warnings::warn($object, $message) }
d3a7d8c7 1085
5e7ad92a 1086=item warnings::register_categories(@names)
13781810
FR
1087
1088This registers warning categories for the given names and is primarily for
d2ec25a5 1089use by the warnings::register pragma.
13781810 1090
e476b1b5
GS
1091=back
1092
d2ec25a5 1093See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
599cee73
PM
1094
1095=cut
1096
599cee73
PM
1097KEYWORDS
1098
d3a7d8c7
GS
1099$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
1100
c3186b65
PM
1101sub Croaker
1102{
4dd71923 1103 require Carp; # this initializes %CarpInternal
dbab294c 1104 local $Carp::CarpInternal{'warnings'};
c3186b65 1105 delete $Carp::CarpInternal{'warnings'};
8becbb3b 1106 Carp::croak(@_);
c3186b65
PM
1107}
1108
4c02ac93
NC
1109sub _bits {
1110 my $mask = shift ;
599cee73
PM
1111 my $catmask ;
1112 my $fatal = 0 ;
6e9af7e4
PM
1113 my $no_fatal = 0 ;
1114
1115 foreach my $word ( @_ ) {
1116 if ($word eq 'FATAL') {
327afb7f 1117 $fatal = 1;
6e9af7e4
PM
1118 $no_fatal = 0;
1119 }
1120 elsif ($word eq 'NONFATAL') {
1121 $fatal = 0;
1122 $no_fatal = 1;
327afb7f 1123 }
d3a7d8c7
GS
1124 elsif ($catmask = $Bits{$word}) {
1125 $mask |= $catmask ;
1126 $mask |= $DeadBits{$word} if $fatal ;
6e9af7e4 1127 $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
599cee73 1128 }
d3a7d8c7 1129 else
c3186b65 1130 { Croaker("Unknown warnings category '$word'")}
599cee73
PM
1131 }
1132
1133 return $mask ;
1134}
1135
4c02ac93
NC
1136sub bits
1137{
1138 # called from B::Deparse.pm
1139 push @_, 'all' unless @_ ;
1140 return _bits(undef, @_) ;
1141}
1142
c4a853d1 1143sub import
6e9af7e4 1144{
599cee73 1145 shift;
6e9af7e4 1146
7fc874e8 1147 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 1148
f1f33818
PM
1149 if (vec($mask, $Offsets{'all'}, 1)) {
1150 $mask |= $Bits{'all'} ;
1151 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1152 }
c91312d5
H
1153
1154 # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
1155 push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
c4a853d1 1156
4c02ac93
NC
1157 # Empty @_ is equivalent to @_ = 'all' ;
1158 ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
599cee73
PM
1159}
1160
c4a853d1 1161sub unimport
6e9af7e4 1162{
599cee73 1163 shift;
6e9af7e4
PM
1164
1165 my $catmask ;
7fc874e8 1166 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
6e9af7e4 1167
d3a7d8c7 1168 if (vec($mask, $Offsets{'all'}, 1)) {
f1f33818 1169 $mask |= $Bits{'all'} ;
d3a7d8c7
GS
1170 $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
1171 }
6e9af7e4 1172
c91312d5
H
1173 # append 'all' when implied (empty import list or after a lone "FATAL")
1174 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
6e9af7e4
PM
1175
1176 foreach my $word ( @_ ) {
1177 if ($word eq 'FATAL') {
c4a853d1 1178 next;
6e9af7e4
PM
1179 }
1180 elsif ($catmask = $Bits{$word}) {
1181 $mask &= ~($catmask | $DeadBits{$word} | $All);
1182 }
1183 else
1184 { Croaker("Unknown warnings category '$word'")}
1185 }
1186
1187 ${^WARNING_BITS} = $mask ;
599cee73
PM
1188}
1189
9df0f64f 1190my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
1191
96183d25 1192sub MESSAGE () { 4 };
8787a747
NC
1193sub FATAL () { 2 };
1194sub NORMAL () { 1 };
1195
7e6d00f8 1196sub __chk
599cee73 1197{
d3a7d8c7
GS
1198 my $category ;
1199 my $offset ;
7e6d00f8 1200 my $isobj = 0 ;
8787a747 1201 my $wanted = shift;
96183d25
NC
1202 my $has_message = $wanted & MESSAGE;
1203
1204 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
1205 my $sub = (caller 1)[3];
1206 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
1207 Croaker("Usage: $sub($syntax)");
1208 }
1209
1210 my $message = pop if $has_message;
d3a7d8c7
GS
1211
1212 if (@_) {
1213 # check the category supplied.
1214 $category = shift ;
9df0f64f 1215 if (my $type = ref $category) {
1216 Croaker("not an object")
1217 if exists $builtin_type{$type};
1218 $category = $type;
7e6d00f8
PM
1219 $isobj = 1 ;
1220 }
d3a7d8c7 1221 $offset = $Offsets{$category};
c3186b65 1222 Croaker("Unknown warnings category '$category'")
d3a7d8c7
GS
1223 unless defined $offset;
1224 }
1225 else {
0ca4541c 1226 $category = (caller(1))[0] ;
d3a7d8c7 1227 $offset = $Offsets{$category};
c3186b65 1228 Croaker("package '$category' not registered for warnings")
d3a7d8c7
GS
1229 unless defined $offset ;
1230 }
1231
f0a8fd68 1232 my $i;
7e6d00f8
PM
1233
1234 if ($isobj) {
f0a8fd68
NC
1235 my $pkg;
1236 $i = 2;
7e6d00f8
PM
1237 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
1238 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
1239 }
1240 $i -= 2 ;
1241 }
1242 else {
4f527b71 1243 $i = _error_loc(); # see where Carp will allocate the error
7e6d00f8
PM
1244 }
1245
7fc874e8
FC
1246 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
1247 # explicitly returns undef.
1248 my(@callers_bitmask) = (caller($i))[9] ;
1249 my $callers_bitmask =
1250 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
8787a747
NC
1251
1252 my @results;
96183d25 1253 foreach my $type (FATAL, NORMAL) {
8787a747
NC
1254 next unless $wanted & $type;
1255
1256 push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
1257 vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
1258 }
96183d25
NC
1259
1260 # &enabled and &fatal_enabled
1261 return $results[0] unless $has_message;
1262
1263 # &warnif, and the category is neither enabled as warning nor as fatal
1264 return if $wanted == (NORMAL | FATAL | MESSAGE)
1265 && !($results[0] || $results[1]);
1266
1267 require Carp;
1268 Carp::croak($message) if $results[0];
1269 # will always get here for &warn. will only get here for &warnif if the
1270 # category is enabled
1271 Carp::carp($message);
7e6d00f8
PM
1272}
1273
13781810
FR
1274sub _mkMask
1275{
1276 my ($bit) = @_;
1277 my $mask = "";
1278
1279 vec($mask, $bit, 1) = 1;
1280 return $mask;
1281}
1282
5e7ad92a 1283sub register_categories
13781810
FR
1284{
1285 my @names = @_;
1286
1287 for my $name (@names) {
1288 if (! defined $Bits{$name}) {
1289 $Bits{$name} = _mkMask($LAST_BIT);
1290 vec($Bits{'all'}, $LAST_BIT, 1) = 1;
1291 $Offsets{$name} = $LAST_BIT ++;
1292 foreach my $k (keys %Bits) {
1293 vec($Bits{$k}, $LAST_BIT, 1) = 0;
1294 }
1295 $DeadBits{$name} = _mkMask($LAST_BIT);
1296 vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
1297 }
1298 }
1299}
1300
4f527b71 1301sub _error_loc {
4dd71923 1302 require Carp;
4f527b71 1303 goto &Carp::short_error_loc; # don't introduce another stack frame
13781810 1304}
4f527b71 1305
7e6d00f8
PM
1306sub enabled
1307{
8787a747 1308 return __chk(NORMAL, @_);
599cee73
PM
1309}
1310
ec983580
AR
1311sub fatal_enabled
1312{
8787a747 1313 return __chk(FATAL, @_);
ec983580 1314}
d3a7d8c7 1315
e476b1b5
GS
1316sub warn
1317{
96183d25 1318 return __chk(FATAL | MESSAGE, @_);
e476b1b5
GS
1319}
1320
7e6d00f8
PM
1321sub warnif
1322{
96183d25 1323 return __chk(NORMAL | FATAL | MESSAGE, @_);
7e6d00f8 1324}
0d658bf5 1325
8787a747
NC
1326# These are not part of any public interface, so we can delete them to save
1327# space.
b9929960 1328delete @warnings::{qw(NORMAL FATAL MESSAGE)};
8787a747 1329
599cee73 13301;