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