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