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