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