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