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