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