regen/warnings.pl

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