regen/warnings.pl

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