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