regen/warnings.pl

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