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