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