regen/warnings.pl

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