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