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