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