regen/warnings.pl

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