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