regen/warnings.pl

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