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