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