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