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