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