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