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