This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix handling of registered warning categories
[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
006c1a1d 19$VERSION = '1.38';
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) ;
006c1a1d
Z
341 for (my $i = $index; $i & 3; $i++) {
342 push @{$list{all}}, $i;
343 }
0d658bf5 344
c4a853d1
RS
345 $index *= 2 ;
346 $warn_size = int($index / 8) + ($index % 8 != 0) ;
599cee73 347
c4a853d1
RS
348 my $k ;
349 my $last_ver = 0;
350 foreach $k (sort { $a <=> $b } keys %ValueToName) {
351 my ($name, $version) = @{ $ValueToName{$k} };
352 print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
353 if $last_ver != $version ;
354 $name =~ y/:/_/;
3c3f8cd6 355 print $warn tab(6, "#define WARN_$name"), " $k\n" ;
c4a853d1
RS
356 $last_ver = $version ;
357 }
358 print $warn "\n" ;
599cee73 359
3c3f8cd6
AB
360 print $warn tab(6, '#define WARNsize'), " $warn_size\n" ;
361 print $warn tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ;
362 print $warn tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ;
599cee73 363
c4a853d1 364 print $warn <<'EOM';
599cee73 365
a2637ca0
FC
366#define isLEXWARN_on \
367 cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)
368#define isLEXWARN_off \
369 cBOOL(!PL_curcop || PL_curcop->cop_warnings == pWARN_STD)
d5a71f30 370#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
72dc9ed5
NC
371#define isWARN_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)))
372#define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
373
374#define DUP_WARNINGS(p) \
594cd643
NC
375 (specialWARN(p) ? (STRLEN*)(p) \
376 : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
377 char))
d5a71f30 378
feff94e1
KW
379/*
380
381=head1 Warning and Dieing
382
383=for apidoc Am|bool|ckWARN|U32 w
384
385Returns a boolean as to whether or not warnings are enabled for the warning
386category C<w>. If the category is by default enabled even if not within the
387scope of S<C<use warnings>>, instead use the L</ckWARN_d> macro.
388
389=for apidoc Am|bool|ckWARN_d|U32 w
390
391Like C<L</ckWARN>>, but for use if and only if the warning category is by
392default enabled even if not within the scope of S<C<use warnings>>.
393
394=for apidoc Am|bool|ckWARN2|U32 w1|U32 w2
395
396Like C<L</ckWARN>>, but takes two warnings categories as input, and returns
397TRUE if either is enabled. If either category is by default enabled even if
398not within the scope of S<C<use warnings>>, instead use the L</ckWARN2_d>
399macro. The categories must be completely independent, one may not be
400subclassed from the other.
401
402=for apidoc Am|bool|ckWARN2_d|U32 w1|U32 w2
403
404Like C<L</ckWARN2>>, but for use if and only if either warning category is by
405default enabled even if not within the scope of S<C<use warnings>>.
406
407=for apidoc Am|bool|ckWARN3|U32 w1|U32 w2|U32 w3
408
409Like C<L</ckWARN2>>, but takes three warnings categories as input, and returns
410TRUE if any is enabled. If any of the categories is by default enabled even
411if not within the scope of S<C<use warnings>>, instead use the L</ckWARN3_d>
412macro. The categories must be completely independent, one may not be
413subclassed from any other.
414
415=for apidoc Am|bool|ckWARN3_d|U32 w1|U32 w2|U32 w3
416
417Like C<L</ckWARN3>>, but for use if and only if any of the warning categories
418is by default enabled even if not within the scope of S<C<use warnings>>.
419
420=for apidoc Am|bool|ckWARN4|U32 w1|U32 w2|U32 w3|U32 w4
421
422Like C<L</ckWARN3>>, but takes four warnings categories as input, and returns
423TRUE if any is enabled. If any of the categories is by default enabled even
424if not within the scope of S<C<use warnings>>, instead use the L</ckWARN4_d>
425macro. The categories must be completely independent, one may not be
426subclassed from any other.
427
428=for apidoc Am|bool|ckWARN4_d|U32 w1|U32 w2|U32 w3|U32 w4
429
430Like C<L</ckWARN4>>, but for use if and only if any of the warning categories
431is by default enabled even if not within the scope of S<C<use warnings>>.
432
433=cut
434
435*/
436
f54ba1c2 437#define ckWARN(w) Perl_ckwarn(aTHX_ packWARN(w))
7c08c4c5
KW
438
439/* The w1, w2 ... should be independent warnings categories; one shouldn't be
440 * a subcategory of any other */
441
f54ba1c2
DM
442#define ckWARN2(w1,w2) Perl_ckwarn(aTHX_ packWARN2(w1,w2))
443#define ckWARN3(w1,w2,w3) Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
444#define ckWARN4(w1,w2,w3,w4) Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
445
446#define ckWARN_d(w) Perl_ckwarn_d(aTHX_ packWARN(w))
447#define ckWARN2_d(w1,w2) Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
448#define ckWARN3_d(w1,w2,w3) Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
449#define ckWARN4_d(w1,w2,w3,w4) Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
12bcd1a6 450
98fe6610
NC
451#define WARNshift 8
452
3b9e3074 453#define packWARN(a) (a )
7c08c4c5
KW
454
455/* The a, b, ... should be independent warnings categories; one shouldn't be
456 * a subcategory of any other */
457
3b9e3074
SH
458#define packWARN2(a,b) ((a) | ((b)<<8) )
459#define packWARN3(a,b,c) ((a) | ((b)<<8) | ((c)<<16) )
460#define packWARN4(a,b,c,d) ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
12bcd1a6
PM
461
462#define unpackWARN1(x) ((x) & 0xFF)
463#define unpackWARN2(x) (((x) >>8) & 0xFF)
464#define unpackWARN3(x) (((x) >>16) & 0xFF)
465#define unpackWARN4(x) (((x) >>24) & 0xFF)
466
467#define ckDEAD(x) \
006c1a1d
Z
468 (PL_curcop && \
469 !specialWARN(PL_curcop->cop_warnings) && \
470 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) || \
471 (unpackWARN2(x) && \
472 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) || \
473 (unpackWARN3(x) && \
474 (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) || \
475 (unpackWARN4(x) && \
476 isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
12bcd1a6 477
4438c4b7 478/* end of file warnings.h */
599cee73
PM
479EOM
480
c4a853d1
RS
481 read_only_bottom_close_and_rename($warn);
482}
599cee73
PM
483
484while (<DATA>) {
3d8ff825
TC
485 last if /^VERSION$/ ;
486 print $pm $_ ;
487}
488
489print $pm qq(our \$VERSION = "$::VERSION";\n);
490
491while (<DATA>) {
599cee73 492 last if /^KEYWORDS$/ ;
424a4936 493 print $pm $_ ;
599cee73
PM
494}
495
c4a853d1 496my $last_ver = 0;
3c3f8cd6 497print $pm "our %Offsets = (" ;
0d658bf5
PM
498foreach my $k (sort { $a <=> $b } keys %ValueToName) {
499 my ($name, $version) = @{ $ValueToName{$k} };
500 $name = lc $name;
d3a7d8c7 501 $k *= 2 ;
0d658bf5 502 if ( $last_ver != $version ) {
424a4936 503 print $pm "\n";
3c3f8cd6
AB
504 print $pm tab(6, " # Warnings Categories added in Perl $version");
505 print $pm "\n";
0d658bf5 506 }
3c3f8cd6 507 print $pm tab(6, " '$name'"), "=> $k,\n" ;
0d658bf5 508 $last_ver = $version;
d3a7d8c7
GS
509}
510
3c3f8cd6 511print $pm ");\n\n" ;
d3a7d8c7 512
424a4936 513print $pm "our %Bits = (\n" ;
c4a853d1 514foreach my $k (sort keys %list) {
599cee73
PM
515
516 my $v = $list{$k} ;
517 my @list = sort { $a <=> $b } @$v ;
518
3c3f8cd6 519 print $pm tab(6, " '$k'"), '=> "',
0ca4541c 520 mkHex($warn_size, map $_ * 2 , @list),
599cee73
PM
521 '", # [', mkRange(@list), "]\n" ;
522}
523
3c3f8cd6 524print $pm ");\n\n" ;
599cee73 525
424a4936 526print $pm "our %DeadBits = (\n" ;
c4a853d1 527foreach my $k (sort keys %list) {
599cee73
PM
528
529 my $v = $list{$k} ;
530 my @list = sort { $a <=> $b } @$v ;
531
3c3f8cd6 532 print $pm tab(6, " '$k'"), '=> "',
0ca4541c 533 mkHex($warn_size, map $_ * 2 + 1 , @list),
599cee73
PM
534 '", # [', mkRange(@list), "]\n" ;
535}
536
3c3f8cd6
AB
537print $pm ");\n\n" ;
538print $pm "# These are used by various things, including our own tests\n";
539print $pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ;
540print $pm tab(6, 'our $DEFAULT'), '= "', mkHex($warn_size, map $_ * 2, @def),
21a5c8db 541 '", # [', mkRange(sort { $a <=> $b } @def), "]\n" ;
3c3f8cd6
AB
542print $pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ;
543print $pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ;
599cee73 544while (<DATA>) {
effd17dc 545 if ($_ eq "=for warnings.pl tree-goes-here\n") {
3c3f8cd6 546 print $pm warningsTree($tree, " ");
effd17dc
DD
547 next;
548 }
424a4936 549 print $pm $_ ;
599cee73
PM
550}
551
ce716c52 552read_only_bottom_close_and_rename($pm);
599cee73
PM
553
554__END__
4438c4b7 555package warnings;
599cee73 556
3d8ff825 557VERSION
f2c3e829
RGS
558
559# Verify that we're called correctly so that warnings will work.
67ba812d
AP
560# Can't use Carp, since Carp uses us!
561# String regexps because constant folding = smaller optree = less memory vs regexp literal
f2c3e829 562# see also strict.pm.
67ba812d
AP
563die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2]
564 if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' )
565 && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' );
b75c8c73 566
effd17dc
DD
567KEYWORDS
568
effd17dc
DD
569sub Croaker
570{
571 require Carp; # this initializes %CarpInternal
572 local $Carp::CarpInternal{'warnings'};
573 delete $Carp::CarpInternal{'warnings'};
574 Carp::croak(@_);
575}
576
006c1a1d
Z
577sub _expand_bits {
578 my $bits = shift;
579 my $want_len = ($LAST_BIT + 7) >> 3;
580 my $len = length($bits);
581 if ($len != $want_len) {
582 if ($bits eq "") {
583 $bits = "\x00" x $want_len;
584 } elsif ($len > $want_len) {
585 substr $bits, $want_len, $len-$want_len, "";
586 } else {
587 my $a = vec($bits, $Offsets{all} >> 1, 2);
588 $a |= $a << 2;
589 $a |= $a << 4;
590 $bits .= chr($a) x ($want_len - $len);
591 }
592 }
593 return $bits;
594}
595
effd17dc
DD
596sub _bits {
597 my $mask = shift ;
598 my $catmask ;
599 my $fatal = 0 ;
600 my $no_fatal = 0 ;
601
006c1a1d 602 $mask = _expand_bits($mask);
effd17dc
DD
603 foreach my $word ( @_ ) {
604 if ($word eq 'FATAL') {
605 $fatal = 1;
606 $no_fatal = 0;
607 }
608 elsif ($word eq 'NONFATAL') {
609 $fatal = 0;
610 $no_fatal = 1;
611 }
612 elsif ($catmask = $Bits{$word}) {
613 $mask |= $catmask ;
614 $mask |= $DeadBits{$word} if $fatal ;
006c1a1d 615 $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
effd17dc
DD
616 }
617 else
56873d42 618 { Croaker("Unknown warnings category '$word'")}
effd17dc
DD
619 }
620
621 return $mask ;
622}
623
624sub bits
625{
626 # called from B::Deparse.pm
627 push @_, 'all' unless @_ ;
006c1a1d 628 return _bits("", @_) ;
effd17dc
DD
629}
630
631sub import
632{
633 shift;
634
635 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
636
006c1a1d
Z
637 # append 'all' when implied (empty import list or after a lone
638 # "FATAL" or "NONFATAL")
639 push @_, 'all'
640 if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
effd17dc 641
006c1a1d 642 ${^WARNING_BITS} = _bits($mask, @_);
effd17dc
DD
643}
644
645sub unimport
646{
647 shift;
648
649 my $catmask ;
650 my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
651
effd17dc
DD
652 # append 'all' when implied (empty import list or after a lone "FATAL")
653 push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
654
006c1a1d 655 $mask = _expand_bits($mask);
effd17dc
DD
656 foreach my $word ( @_ ) {
657 if ($word eq 'FATAL') {
658 next;
659 }
660 elsif ($catmask = $Bits{$word}) {
006c1a1d 661 $mask = ~(~$mask | $catmask | $DeadBits{$word});
effd17dc
DD
662 }
663 else
56873d42 664 { Croaker("Unknown warnings category '$word'")}
effd17dc
DD
665 }
666
667 ${^WARNING_BITS} = $mask ;
668}
669
670my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
671
672sub MESSAGE () { 4 };
673sub FATAL () { 2 };
674sub NORMAL () { 1 };
675
676sub __chk
677{
678 my $category ;
679 my $offset ;
680 my $isobj = 0 ;
681 my $wanted = shift;
682 my $has_message = $wanted & MESSAGE;
683
684 unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
685 my $sub = (caller 1)[3];
686 my $syntax = $has_message ? "[category,] 'message'" : '[category]';
687 Croaker("Usage: $sub($syntax)");
688 }
689
690 my $message = pop if $has_message;
691
692 if (@_) {
56873d42
DD
693 # check the category supplied.
694 $category = shift ;
695 if (my $type = ref $category) {
696 Croaker("not an object")
697 if exists $builtin_type{$type};
effd17dc 698 $category = $type;
56873d42
DD
699 $isobj = 1 ;
700 }
701 $offset = $Offsets{$category};
702 Croaker("Unknown warnings category '$category'")
effd17dc
DD
703 unless defined $offset;
704 }
705 else {
56873d42
DD
706 $category = (caller(1))[0] ;
707 $offset = $Offsets{$category};
708 Croaker("package '$category' not registered for warnings")
effd17dc
DD
709 unless defined $offset ;
710 }
711
712 my $i;
713
714 if ($isobj) {
56873d42
DD
715 my $pkg;
716 $i = 2;
717 while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
718 last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
719 }
effd17dc
DD
720 $i -= 2 ;
721 }
722 else {
56873d42 723 $i = _error_loc(); # see where Carp will allocate the error
effd17dc
DD
724 }
725
726 # Default to 0 if caller returns nothing. Default to $DEFAULT if it
727 # explicitly returns undef.
728 my(@callers_bitmask) = (caller($i))[9] ;
729 my $callers_bitmask =
730 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
006c1a1d 731 length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
effd17dc
DD
732
733 my @results;
734 foreach my $type (FATAL, NORMAL) {
735 next unless $wanted & $type;
736
006c1a1d 737 push @results, vec($callers_bitmask, $offset + $type - 1, 1);
effd17dc
DD
738 }
739
740 # &enabled and &fatal_enabled
741 return $results[0] unless $has_message;
742
743 # &warnif, and the category is neither enabled as warning nor as fatal
744 return if $wanted == (NORMAL | FATAL | MESSAGE)
745 && !($results[0] || $results[1]);
746
747 require Carp;
748 Carp::croak($message) if $results[0];
749 # will always get here for &warn. will only get here for &warnif if the
750 # category is enabled
751 Carp::carp($message);
752}
753
754sub _mkMask
755{
756 my ($bit) = @_;
757 my $mask = "";
758
759 vec($mask, $bit, 1) = 1;
760 return $mask;
761}
762
763sub register_categories
764{
765 my @names = @_;
766
767 for my $name (@names) {
768 if (! defined $Bits{$name}) {
006c1a1d
Z
769 $Offsets{$name} = $LAST_BIT;
770 $Bits{$name} = _mkMask($LAST_BIT++);
771 $DeadBits{$name} = _mkMask($LAST_BIT++);
772 if (length($Bits{$name}) > length($Bits{all})) {
773 $Bits{all} .= "\x55";
774 $DeadBits{all} .= "\xaa";
effd17dc 775 }
effd17dc
DD
776 }
777 }
778}
779
780sub _error_loc {
781 require Carp;
782 goto &Carp::short_error_loc; # don't introduce another stack frame
783}
784
785sub enabled
786{
787 return __chk(NORMAL, @_);
788}
789
790sub fatal_enabled
791{
792 return __chk(FATAL, @_);
793}
794
795sub warn
796{
797 return __chk(FATAL | MESSAGE, @_);
798}
799
800sub warnif
801{
802 return __chk(NORMAL | FATAL | MESSAGE, @_);
803}
804
805# These are not part of any public interface, so we can delete them to save
806# space.
807delete @warnings::{qw(NORMAL FATAL MESSAGE)};
808
8091;
810__END__
599cee73
PM
811=head1 NAME
812
4438c4b7 813warnings - Perl pragma to control optional warnings
599cee73
PM
814
815=head1 SYNOPSIS
816
4438c4b7
JH
817 use warnings;
818 no warnings;
599cee73 819
4438c4b7
JH
820 use warnings "all";
821 no warnings "all";
599cee73 822
d3a7d8c7
GS
823 use warnings::register;
824 if (warnings::enabled()) {
825 warnings::warn("some warning");
826 }
827
828 if (warnings::enabled("void")) {
e476b1b5
GS
829 warnings::warn("void", "some warning");
830 }
831
7e6d00f8
PM
832 if (warnings::enabled($object)) {
833 warnings::warn($object, "some warning");
834 }
835
721f911b
PM
836 warnings::warnif("some warning");
837 warnings::warnif("void", "some warning");
838 warnings::warnif($object, "some warning");
7e6d00f8 839
599cee73
PM
840=head1 DESCRIPTION
841
188c4f6f
RS
842The C<warnings> pragma gives control over which warnings are enabled in
843which parts of a Perl program. It's a more flexible alternative for
844both the command line flag B<-w> and the equivalent Perl variable,
845C<$^W>.
33edcb80
RS
846
847This pragma works just like the C<strict> pragma.
848This means that the scope of the warning pragma is limited to the
849enclosing block. It also means that the pragma setting will not
850leak across files (via C<use>, C<require> or C<do>). This allows
851authors to independently define the degree of warning checks that will
852be applied to their module.
853
854By default, optional warnings are disabled, so any legacy code that
855doesn't attempt to control the warnings will work unchanged.
856
3c3f8cd6 857All warnings are enabled in a block by either of these:
33edcb80
RS
858
859 use warnings;
860 use warnings 'all';
861
3c3f8cd6 862Similarly all warnings are disabled in a block by either of these:
33edcb80
RS
863
864 no warnings;
865 no warnings 'all';
866
867For example, consider the code below:
868
869 use warnings;
870 my @a;
871 {
872 no warnings;
873 my $b = @a[0];
874 }
875 my $c = @a[0];
876
877The code in the enclosing block has warnings enabled, but the inner
878block has them disabled. In this case that means the assignment to the
879scalar C<$c> will trip the C<"Scalar value @a[0] better written as $a[0]">
880warning, but the assignment to the scalar C<$b> will not.
881
882=head2 Default Warnings and Optional Warnings
883
884Before the introduction of lexical warnings, Perl had two classes of
56873d42 885warnings: mandatory and optional.
33edcb80
RS
886
887As its name suggests, if your code tripped a mandatory warning, you
888would get a warning whether you wanted it or not.
889For example, the code below would always produce an C<"isn't numeric">
890warning about the "2:".
891
892 my $a = "2:" + 3;
893
894With the introduction of lexical warnings, mandatory warnings now become
895I<default> warnings. The difference is that although the previously
896mandatory warnings are still enabled by default, they can then be
897subsequently enabled or disabled with the lexical warning pragma. For
898example, in the code below, an C<"isn't numeric"> warning will only
899be reported for the C<$a> variable.
900
901 my $a = "2:" + 3;
902 no warnings;
903 my $b = "2:" + 3;
904
905Note that neither the B<-w> flag or the C<$^W> can be used to
906disable/enable default warnings. They are still mandatory in this case.
907
908=head2 What's wrong with B<-w> and C<$^W>
909
910Although very useful, the big problem with using B<-w> on the command
911line to enable warnings is that it is all or nothing. Take the typical
912scenario when you are writing a Perl program. Parts of the code you
913will write yourself, but it's very likely that you will make use of
914pre-written Perl modules. If you use the B<-w> flag in this case, you
915end up enabling warnings in pieces of code that you haven't written.
916
917Similarly, using C<$^W> to either disable or enable blocks of code is
918fundamentally flawed. For a start, say you want to disable warnings in
919a block of code. You might expect this to be enough to do the trick:
920
921 {
922 local ($^W) = 0;
923 my $a =+ 2;
924 my $b; chop $b;
925 }
926
927When this code is run with the B<-w> flag, a warning will be produced
928for the C<$a> line: C<"Reversed += operator">.
929
930The problem is that Perl has both compile-time and run-time warnings. To
931disable compile-time warnings you need to rewrite the code like this:
932
933 {
934 BEGIN { $^W = 0 }
935 my $a =+ 2;
936 my $b; chop $b;
937 }
938
939The other big problem with C<$^W> is the way you can inadvertently
940change the warning setting in unexpected places in your code. For example,
941when the code below is run (without the B<-w> flag), the second call
942to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas
943the first will not.
944
945 sub doit
946 {
947 my $b; chop $b;
948 }
949
950 doit();
951
952 {
953 local ($^W) = 1;
954 doit()
955 }
956
957This is a side-effect of C<$^W> being dynamically scoped.
958
959Lexical warnings get around these limitations by allowing finer control
960over where warnings can or can't be tripped.
961
962=head2 Controlling Warnings from the Command Line
963
964There are three Command Line flags that can be used to control when
965warnings are (or aren't) produced:
966
967=over 5
968
969=item B<-w>
970X<-w>
971
972This is the existing flag. If the lexical warnings pragma is B<not>
973used in any of you code, or any of the modules that you use, this flag
974will enable warnings everywhere. See L<Backward Compatibility> for
975details of how this flag interacts with lexical warnings.
976
977=item B<-W>
978X<-W>
979
3c3f8cd6 980If the B<-W> flag is used on the command line, it will enable all warnings
33edcb80
RS
981throughout the program regardless of whether warnings were disabled
982locally using C<no warnings> or C<$^W =0>.
983This includes all files that get
984included via C<use>, C<require> or C<do>.
985Think of it as the Perl equivalent of the "lint" command.
986
987=item B<-X>
988X<-X>
989
3c3f8cd6 990Does the exact opposite to the B<-W> flag, i.e. it disables all warnings.
33edcb80
RS
991
992=back
993
994=head2 Backward Compatibility
995
996If you are used to working with a version of Perl prior to the
997introduction of lexically scoped warnings, or have code that uses both
998lexical warnings and C<$^W>, this section will describe how they interact.
999
1000How Lexical Warnings interact with B<-w>/C<$^W>:
1001
1002=over 5
1003
1004=item 1.
1005
1006If none of the three command line flags (B<-w>, B<-W> or B<-X>) that
1007control warnings is used and neither C<$^W> nor the C<warnings> pragma
1008are used, then default warnings will be enabled and optional warnings
1009disabled.
1010This means that legacy code that doesn't attempt to control the warnings
1011will work unchanged.
1012
1013=item 2.
1014
1015The B<-w> flag just sets the global C<$^W> variable as in 5.005. This
1016means that any legacy code that currently relies on manipulating C<$^W>
56873d42 1017to control warning behavior will still work as is.
33edcb80
RS
1018
1019=item 3.
1020
1021Apart from now being a boolean, the C<$^W> variable operates in exactly
1022the same horrible uncontrolled global way, except that it cannot
1023disable/enable default warnings.
1024
1025=item 4.
1026
1027If a piece of code is under the control of the C<warnings> pragma,
1028both the C<$^W> variable and the B<-w> flag will be ignored for the
1029scope of the lexical warning.
1030
1031=item 5.
1032
1033The only way to override a lexical warnings setting is with the B<-W>
1034or B<-X> command line flags.
1035
1036=back
1037
1038The combined effect of 3 & 4 is that it will allow code which uses
1039the C<warnings> pragma to control the warning behavior of $^W-type
1040code (using a C<local $^W=0>) if it really wants to, but not vice-versa.
1041
1042=head2 Category Hierarchy
1043X<warning, categories>
1044
1045A hierarchy of "categories" have been defined to allow groups of warnings
1046to be enabled/disabled in isolation.
1047
1048The current hierarchy is:
1049
1050=for warnings.pl tree-goes-here
1051
1052Just like the "strict" pragma any of these categories can be combined
1053
1054 use warnings qw(void redefine);
1055 no warnings qw(io syntax untie);
1056
1057Also like the "strict" pragma, if there is more than one instance of the
56873d42 1058C<warnings> pragma in a given scope the cumulative effect is additive.
33edcb80
RS
1059
1060 use warnings qw(void); # only "void" warnings enabled
1061 ...
1062 use warnings qw(io); # only "void" & "io" warnings enabled
1063 ...
1064 no warnings qw(void); # only "io" warnings enabled
1065
1066To determine which category a specific warning has been assigned to see
1067L<perldiag>.
1068
1069Note: Before Perl 5.8.0, the lexical warnings category "deprecated" was a
1070sub-category of the "syntax" category. It is now a top-level category
1071in its own right.
1072
3664866e
AB
1073Note: Before 5.21.0, the "missing" lexical warnings category was
1074internally defined to be the same as the "uninitialized" category. It
1075is now a top-level category in its own right.
1076
33edcb80
RS
1077=head2 Fatal Warnings
1078X<warning, fatal>
1079
2e4abf26
DG
1080The presence of the word "FATAL" in the category list will escalate
1081warnings in those categories into fatal errors in that lexical scope.
1082
1083B<NOTE:> FATAL warnings should be used with care, particularly
1084C<< FATAL => 'all' >>.
1085
1086Libraries using L<warnings::warn|/FUNCTIONS> for custom warning categories
1087generally don't expect L<warnings::warn|/FUNCTIONS> to be fatal and can wind up
1088in an unexpected state as a result. For XS modules issuing categorized
1089warnings, such unanticipated exceptions could also expose memory leak bugs.
1090
1091Moreover, the Perl interpreter itself has had serious bugs involving
1092fatalized warnings. For a summary of resolved and unresolved problems as
1093of January 2015, please see
1094L<this perl5-porters post|http://www.nntp.perl.org/group/perl.perl5.porters/2015/01/msg225235.html>.
1095
1096While some developers find fatalizing some warnings to be a useful
1097defensive programming technique, using C<< FATAL => 'all' >> to fatalize
1098all possible warning categories -- including custom ones -- is particularly
1099risky. Therefore, the use of C<< FATAL => 'all' >> is
1100L<discouraged|perlpolicy/discouraged>.
1101
1102The L<strictures|strictures/VERSION-2> module on CPAN offers one example of
1103a warnings subset that the module's authors believe is relatively safe to
1104fatalize.
1105
1106B<NOTE:> users of FATAL warnings, especially those using
1107C<< FATAL => 'all' >>, should be fully aware that they are risking future
1108portability of their programs by doing so. Perl makes absolutely no
1109commitments to not introduce new warnings or warnings categories in the
1110future; indeed, we explicitly reserve the right to do so. Code that may
1111not warn now may warn in a future release of Perl if the Perl5 development
1112team deems it in the best interests of the community to do so. Should code
1113using FATAL warnings break due to the introduction of a new warning we will
1114NOT consider it an incompatible change. Users of FATAL warnings should
1115take special caution during upgrades to check to see if their code triggers
1116any new warnings and should pay particular attention to the fine print of
1117the documentation of the features they use to ensure they do not exploit
1118features that are documented as risky, deprecated, or unspecified, or where
1119the documentation says "so don't do that", or anything with the same sense
1120and spirit. Use of such features in combination with FATAL warnings is
1121ENTIRELY AT THE USER'S RISK.
1122
1123The following documentation describes how to use FATAL warnings but the
1124perl5 porters strongly recommend that you understand the risks before doing
1125so, especially for library code intended for use by others, as there is no
1126way for downstream users to change the choice of fatal categories.
1127
1128In the code below, the use of C<time>, C<length>
33edcb80
RS
1129and C<join> can all produce a C<"Useless use of xxx in void context">
1130warning.
1131
1132 use warnings;
1133
1134 time;
1135
1136 {
1137 use warnings FATAL => qw(void);
1138 length "abc";
1139 }
1140
1141 join "", 1,2,3;
1142
1143 print "done\n";
1144
1145When run it produces this output
1146
1147 Useless use of time in void context at fatal line 3.
56873d42 1148 Useless use of length in void context at fatal line 7.
33edcb80
RS
1149
1150The scope where C<length> is used has escalated the C<void> warnings
1151category into a fatal error, so the program terminates immediately when it
1152encounters the warning.
1153
1154To explicitly turn off a "FATAL" warning you just disable the warning
1155it is associated with. So, for example, to disable the "void" warning
1156in the example above, either of these will do the trick:
1157
1158 no warnings qw(void);
1159 no warnings FATAL => qw(void);
1160
1161If you want to downgrade a warning that has been escalated into a fatal
1162error back to a normal warning, you can use the "NONFATAL" keyword. For
1163example, the code below will promote all warnings into fatal errors,
1164except for those in the "syntax" category.
1165
1166 use warnings FATAL => 'all', NONFATAL => 'syntax';
1167
1168As of Perl 5.20, instead of C<< use warnings FATAL => 'all'; >> you can
1169use:
1170
1171 use v5.20; # Perl 5.20 or greater is required for the following
1172 use warnings 'FATAL'; # short form of "use warnings FATAL => 'all';"
1173
1174If you want your program to be compatible with versions of Perl before
11755.20, you must use C<< use warnings FATAL => 'all'; >> instead. (In
1176previous versions of Perl, the behavior of the statements
1177C<< use warnings 'FATAL'; >>, C<< use warnings 'NONFATAL'; >> and
1178C<< no warnings 'FATAL'; >> was unspecified; they did not behave as if
1179they included the C<< => 'all' >> portion. As of 5.20, they do.)
1180
33edcb80
RS
1181=head2 Reporting Warnings from a Module
1182X<warning, reporting> X<warning, registering>
1183
1184The C<warnings> pragma provides a number of functions that are useful for
1185module authors. These are used when you want to report a module-specific
1186warning to a calling module has enabled warnings via the C<warnings>
1187pragma.
1188
1189Consider the module C<MyMod::Abc> below.
1190
1191 package MyMod::Abc;
1192
1193 use warnings::register;
1194
1195 sub open {
1196 my $path = shift;
1197 if ($path !~ m#^/#) {
1198 warnings::warn("changing relative path to /var/abc")
1199 if warnings::enabled();
1200 $path = "/var/abc/$path";
1201 }
1202 }
1203
1204 1;
1205
1206The call to C<warnings::register> will create a new warnings category
1207called "MyMod::Abc", i.e. the new category name matches the current
1208package name. The C<open> function in the module will display a warning
1209message if it gets given a relative path as a parameter. This warnings
1210will only be displayed if the code that uses C<MyMod::Abc> has actually
1211enabled them with the C<warnings> pragma like below.
1212
1213 use MyMod::Abc;
1214 use warnings 'MyMod::Abc';
1215 ...
1216 abc::open("../fred.txt");
1217
1218It is also possible to test whether the pre-defined warnings categories are
1219set in the calling module with the C<warnings::enabled> function. Consider
1220this snippet of code:
1221
1222 package MyMod::Abc;
1223
1224 sub open {
4a21999a
TC
1225 if (warnings::enabled("deprecated")) {
1226 warnings::warn("deprecated",
1227 "open is deprecated, use new instead");
1228 }
33edcb80
RS
1229 new(@_);
1230 }
1231
1232 sub new
1233 ...
1234 1;
1235
1236The function C<open> has been deprecated, so code has been included to
1237display a warning message whenever the calling module has (at least) the
1238"deprecated" warnings category enabled. Something like this, say.
1239
1240 use warnings 'deprecated';
1241 use MyMod::Abc;
1242 ...
1243 MyMod::Abc::open($filename);
1244
1245Either the C<warnings::warn> or C<warnings::warnif> function should be
1246used to actually display the warnings message. This is because they can
1247make use of the feature that allows warnings to be escalated into fatal
1248errors. So in this case
1249
1250 use MyMod::Abc;
1251 use warnings FATAL => 'MyMod::Abc';
1252 ...
1253 MyMod::Abc::open('../fred.txt');
1254
1255the C<warnings::warnif> function will detect this and die after
1256displaying the warning message.
1257
1258The three warnings functions, C<warnings::warn>, C<warnings::warnif>
1259and C<warnings::enabled> can optionally take an object reference in place
1260of a category name. In this case the functions will use the class name
1261of the object as the warnings category.
1262
1263Consider this example:
1264
1265 package Original;
1266
1267 no warnings;
1268 use warnings::register;
1269
1270 sub new
1271 {
1272 my $class = shift;
1273 bless [], $class;
1274 }
1275
1276 sub check
1277 {
1278 my $self = shift;
1279 my $value = shift;
1280
1281 if ($value % 2 && warnings::enabled($self))
1282 { warnings::warn($self, "Odd numbers are unsafe") }
1283 }
1284
1285 sub doit
1286 {
1287 my $self = shift;
1288 my $value = shift;
1289 $self->check($value);
1290 # ...
1291 }
1292
1293 1;
1294
1295 package Derived;
1296
1297 use warnings::register;
1298 use Original;
1299 our @ISA = qw( Original );
1300 sub new
1301 {
1302 my $class = shift;
1303 bless [], $class;
1304 }
1305
1306
1307 1;
1308
56873d42 1309The code below makes use of both modules, but it only enables warnings from
33edcb80
RS
1310C<Derived>.
1311
1312 use Original;
1313 use Derived;
1314 use warnings 'Derived';
1315 my $a = Original->new();
1316 $a->doit(1);
1317 my $b = Derived->new();
1318 $a->doit(1);
1319
1320When this code is run only the C<Derived> object, C<$b>, will generate
56873d42 1321a warning.
33edcb80
RS
1322
1323 Odd numbers are unsafe at main.pl line 7
1324
1325Notice also that the warning is reported at the line where the object is first
1326used.
1327
1328When registering new categories of warning, you can supply more names to
1329warnings::register like this:
1330
1331 package MyModule;
1332 use warnings::register qw(format precision);
1333
1334 ...
fe2e802c 1335
33edcb80 1336 warnings::warnif('MyModule::format', '...');
599cee73 1337
33edcb80 1338=head1 FUNCTIONS
e476b1b5
GS
1339
1340=over 4
1341
d3a7d8c7
GS
1342=item use warnings::register
1343
7e6d00f8
PM
1344Creates a new warnings category with the same name as the package where
1345the call to the pragma is used.
1346
1347=item warnings::enabled()
1348
1349Use the warnings category with the same name as the current package.
1350
1351Return TRUE if that warnings category is enabled in the calling module.
1352Otherwise returns FALSE.
1353
1354=item warnings::enabled($category)
1355
1356Return TRUE if the warnings category, C<$category>, is enabled in the
1357calling module.
1358Otherwise returns FALSE.
1359
1360=item warnings::enabled($object)
1361
1362Use the name of the class for the object reference, C<$object>, as the
1363warnings category.
1364
1365Return TRUE if that warnings category is enabled in the first scope
1366where the object is used.
1367Otherwise returns FALSE.
1368
ec983580
AR
1369=item warnings::fatal_enabled()
1370
1371Return TRUE if the warnings category with the same name as the current
1372package has been set to FATAL in the calling module.
1373Otherwise returns FALSE.
1374
1375=item warnings::fatal_enabled($category)
1376
1377Return TRUE if the warnings category C<$category> has been set to FATAL in
1378the calling module.
1379Otherwise returns FALSE.
1380
1381=item warnings::fatal_enabled($object)
1382
1383Use the name of the class for the object reference, C<$object>, as the
1384warnings category.
1385
1386Return TRUE if that warnings category has been set to FATAL in the first
1387scope where the object is used.
1388Otherwise returns FALSE.
1389
7e6d00f8
PM
1390=item warnings::warn($message)
1391
1392Print C<$message> to STDERR.
1393
1394Use the warnings category with the same name as the current package.
1395
1396If that warnings category has been set to "FATAL" in the calling module
1397then die. Otherwise return.
1398
1399=item warnings::warn($category, $message)
1400
1401Print C<$message> to STDERR.
1402
1403If the warnings category, C<$category>, has been set to "FATAL" in the
1404calling module then die. Otherwise return.
d3a7d8c7 1405
7e6d00f8 1406=item warnings::warn($object, $message)
e476b1b5 1407
7e6d00f8 1408Print C<$message> to STDERR.
e476b1b5 1409
7e6d00f8
PM
1410Use the name of the class for the object reference, C<$object>, as the
1411warnings category.
e476b1b5 1412
7e6d00f8
PM
1413If that warnings category has been set to "FATAL" in the scope where C<$object>
1414is first used then die. Otherwise return.
599cee73 1415
e476b1b5 1416
7e6d00f8
PM
1417=item warnings::warnif($message)
1418
1419Equivalent to:
1420
1421 if (warnings::enabled())
1422 { warnings::warn($message) }
1423
1424=item warnings::warnif($category, $message)
1425
1426Equivalent to:
1427
1428 if (warnings::enabled($category))
1429 { warnings::warn($category, $message) }
1430
1431=item warnings::warnif($object, $message)
1432
1433Equivalent to:
1434
1435 if (warnings::enabled($object))
1436 { warnings::warn($object, $message) }
d3a7d8c7 1437
5e7ad92a 1438=item warnings::register_categories(@names)
13781810
FR
1439
1440This registers warning categories for the given names and is primarily for
d2ec25a5 1441use by the warnings::register pragma.
13781810 1442
e476b1b5
GS
1443=back
1444
d2ec25a5 1445See also L<perlmodlib/Pragmatic Modules> and L<perldiag>.
599cee73
PM
1446
1447=cut