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 # With an argument of 'tree', just dump the contents of $tree and exits.
  12 # Also accepts the standard regen_lib -q and -v args.
  13 #
  14 # This script is normally invoked from regen.pl.
  15
  16 $VERSION = '1.02_03';
  17
  18 BEGIN {
  19     require 'regen/regen_lib.pl';
  20     push @INC, './lib';
  21 }
  22 use strict ;
  23
  24 sub DEFAULT_ON  () { 1 }
  25 sub DEFAULT_OFF () { 2 }
  26
  27 my $tree = {
  28
  29 'all' => [ 5.008, {
  30         'io'            => [ 5.008, {
  31                                 'pipe'          => [ 5.008, DEFAULT_OFF],
  32                                 'unopened'      => [ 5.008, DEFAULT_OFF],
  33                                 'closed'        => [ 5.008, DEFAULT_OFF],
  34                                 'newline'       => [ 5.008, DEFAULT_OFF],
  35                                 'exec'          => [ 5.008, DEFAULT_OFF],
  36                                 'layer'         => [ 5.008, DEFAULT_OFF],
  37                            }],
  38         'syntax'        => [ 5.008, {
  39                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
  40                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
  41                                 'precedence'    => [ 5.008, DEFAULT_OFF],
  42                                 'bareword'      => [ 5.008, DEFAULT_OFF],
  43                                 'reserved'      => [ 5.008, DEFAULT_OFF],
  44                                 'digit'         => [ 5.008, DEFAULT_OFF],
  45                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
  46                                 'printf'        => [ 5.008, DEFAULT_OFF],
  47                                 'prototype'     => [ 5.008, DEFAULT_OFF],
  48                                 'qw'            => [ 5.008, DEFAULT_OFF],
  49                                 'illegalproto'  => [ 5.011, DEFAULT_OFF],
  50                            }],
  51         'severe'        => [ 5.008, {
  52                                 'inplace'       => [ 5.008, DEFAULT_ON],
  53                                 'internal'      => [ 5.008, DEFAULT_ON],
  54                                 'debugging'     => [ 5.008, DEFAULT_ON],
  55                                 'malloc'        => [ 5.008, DEFAULT_ON],
  56                            }],
  57         'deprecated'    => [ 5.008, DEFAULT_OFF],
  58         'void'          => [ 5.008, DEFAULT_OFF],
  59         'recursion'     => [ 5.008, DEFAULT_OFF],
  60         'redefine'      => [ 5.008, DEFAULT_OFF],
  61         'numeric'       => [ 5.008, DEFAULT_OFF],
  62         'uninitialized' => [ 5.008, DEFAULT_OFF],
  63         'once'          => [ 5.008, DEFAULT_OFF],
  64         'misc'          => [ 5.008, DEFAULT_OFF],
  65         'regexp'        => [ 5.008, DEFAULT_OFF],
  66         'glob'          => [ 5.008, DEFAULT_OFF],
  67         'untie'         => [ 5.008, DEFAULT_OFF],
  68         'substr'        => [ 5.008, DEFAULT_OFF],
  69         'taint'         => [ 5.008, DEFAULT_OFF],
  70         'signal'        => [ 5.008, DEFAULT_OFF],
  71         'closure'       => [ 5.008, DEFAULT_OFF],
  72         'overflow'      => [ 5.008, DEFAULT_OFF],
  73         'portable'      => [ 5.008, DEFAULT_OFF],
  74         'utf8'          => [ 5.008, DEFAULT_OFF],
  75         'exiting'       => [ 5.008, DEFAULT_OFF],
  76         'pack'          => [ 5.008, DEFAULT_OFF],
  77         'unpack'        => [ 5.008, DEFAULT_OFF],
  78         'threads'       => [ 5.008, DEFAULT_OFF],
  79         'imprecision'   => [ 5.011, DEFAULT_OFF],
  80
  81          #'default'     => [ 5.008, DEFAULT_ON ],
  82         }],
  83 } ;
  84
  85 my %list ;
  86 my %Value ;
  87 my %ValueToName ;
  88 my %NameToValue ;
  89
  90 my %v_list = () ;
  91
  92 sub valueWalk
  93 {
  94     my $tre = shift ;
  95     my @list = () ;
  96     my ($k, $v) ;
  97
  98     foreach $k (sort keys %$tre) {
  99         $v = $tre->{$k};
 100         die "duplicate key $k\n" if defined $list{$k} ;
 101         die "Value associated with key '$k' is not an ARRAY reference"
 102             if !ref $v || ref $v ne 'ARRAY' ;
 103
 104         my ($ver, $rest) = @{ $v } ;
 105         push @{ $v_list{$ver} }, $k;
 106
 107         if (ref $rest)
 108           { valueWalk ($rest) }
 109
 110     }
 111
 112 }
 113
 114 sub orderValues
 115 {
 116     my $index = 0;
 117     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
 118         foreach my $name (@{ $v_list{$ver} } ) {
 119             $ValueToName{ $index } = [ uc $name, $ver ] ;
 120             $NameToValue{ uc $name } = $index ++ ;
 121         }
 122     }
 123
 124     return $index ;
 125 }
 126
 127 ###########################################################################
 128
 129 sub walk
 130 {
 131     my $tre = shift ;
 132     my @list = () ;
 133     my ($k, $v) ;
 134
 135     foreach $k (sort keys %$tre) {
 136         $v = $tre->{$k};
 137         die "duplicate key $k\n" if defined $list{$k} ;
 138         die "Can't find key '$k'"
 139             if ! defined $NameToValue{uc $k} ;
 140         push @{ $list{$k} }, $NameToValue{uc $k} ;
 141         die "Value associated with key '$k' is not an ARRAY reference"
 142             if !ref $v || ref $v ne 'ARRAY' ;
 143
 144         my ($ver, $rest) = @{ $v } ;
 145         if (ref $rest)
 146           { push (@{ $list{$k} }, walk ($rest)) }
 147
 148         push @list, @{ $list{$k} } ;
 149     }
 150
 151    return @list ;
 152 }
 153
 154 ###########################################################################
 155
 156 sub mkRange
 157 {
 158     my @a = @_ ;
 159     my @out = @a ;
 160
 161     for my $i (1 .. @a - 1) {
 162         $out[$i] = ".."
 163           if $a[$i] == $a[$i - 1] + 1
 164              && ($i >= @a  - 1 || $a[$i] + 1 == $a[$i + 1] );
 165     }
 166     $out[-1] = $a[-1] if $out[-1] eq "..";
 167
 168     my $out = join(",",@out);
 169
 170     $out =~ s/,(\.\.,)+/../g ;
 171     return $out;
 172 }
 173
 174 ###########################################################################
 175 sub printTree
 176 {
 177     my $tre = shift ;
 178     my $prefix = shift ;
 179     my ($k, $v) ;
 180
 181     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 182     my @keys = sort keys %$tre ;
 183
 184     while ($k = shift @keys) {
 185         $v = $tre->{$k};
 186         die "Value associated with key '$k' is not an ARRAY reference"
 187             if !ref $v || ref $v ne 'ARRAY' ;
 188
 189         my $offset ;
 190         if ($tre ne $tree) {
 191             print $prefix . "|\n" ;
 192             print $prefix . "+- $k" ;
 193             $offset = ' ' x ($max + 4) ;
 194         }
 195         else {
 196             print $prefix . "$k" ;
 197             $offset = ' ' x ($max + 1) ;
 198         }
 199
 200         my ($ver, $rest) = @{ $v } ;
 201         if (ref $rest)
 202         {
 203             my $bar = @keys ? "|" : " ";
 204             print " -" . "-" x ($max - length $k ) . "+\n" ;
 205             printTree ($rest, $prefix . $bar . $offset )
 206         }
 207         else
 208           { print "\n" }
 209     }
 210
 211 }
 212
 213 ###########################################################################
 214
 215 sub mkHexOct
 216 {
 217     my ($f, $max, @a) = @_ ;
 218     my $mask = "\x00" x $max ;
 219     my $string = "" ;
 220
 221     foreach (@a) {
 222         vec($mask, $_, 1) = 1 ;
 223     }
 224
 225     foreach (unpack("C*", $mask)) {
 226         if ($f eq 'x') {
 227             $string .= '\x' . sprintf("%2.2x", $_)
 228         }
 229         else {
 230             $string .= '\\' . sprintf("%o", $_)
 231         }
 232     }
 233     return $string ;
 234 }
 235
 236 sub mkHex
 237 {
 238     my($max, @a) = @_;
 239     return mkHexOct("x", $max, @a);
 240 }
 241
 242 sub mkOct
 243 {
 244     my($max, @a) = @_;
 245     return mkHexOct("o", $max, @a);
 246 }
 247
 248 ###########################################################################
 249
 250 if (@ARGV && $ARGV[0] eq "tree")
 251 {
 252     printTree($tree, "    ") ;
 253     exit ;
 254 }
 255
 256 my $warn = safer_open('warnings.h-new', 'warnings.h');
 257 my $pm = safer_open('lib/warnings.pm-new', 'lib/warnings.pm');
 258
 259 print $pm read_only_top(lang => 'Perl', by => 'regen/warnings.pl');
 260 print $warn read_only_top(lang => 'C', by => 'regen/warnings.pl'), <<'EOM';
 261
 262 #define Off(x)                  ((x) / 8)
 263 #define Bit(x)                  (1 << ((x) % 8))
 264 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 265
 266
 267 #define G_WARN_OFF              0       /* $^W == 0 */
 268 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 269 #define G_WARN_ALL_ON           2       /* -W flag */
 270 #define G_WARN_ALL_OFF          4       /* -X flag */
 271 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 272 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 273
 274 #define pWARN_STD               NULL
 275 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
 276 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
 277
 278 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 279                                  (x) == pWARN_NONE)
 280
 281 /* if PL_warnhook is set to this value, then warnings die */
 282 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
 283 EOM
 284
 285 my $offset = 0 ;
 286
 287 valueWalk ($tree) ;
 288 my $index = orderValues();
 289
 290 die <<EOM if $index > 255 ;
 291 Too many warnings categories -- max is 255
 292     rewrite packWARN* & unpackWARN* macros
 293 EOM
 294
 295 walk ($tree) ;
 296
 297 $index *= 2 ;
 298 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 299
 300 my $k ;
 301 my $last_ver = 0;
 302 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 303     my ($name, $version) = @{ $ValueToName{$k} };
 304     print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
 305         if $last_ver != $version ;
 306     print $warn tab(5, "#define WARN_$name"), "$k\n" ;
 307     $last_ver = $version ;
 308 }
 309 print $warn "\n" ;
 310
 311 print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
 312 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 313 print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 314 print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 315
 316 print $warn <<'EOM';
 317
 318 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 319 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 320 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 321 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
 322 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
 323
 324 #define DUP_WARNINGS(p)         \
 325     (specialWARN(p) ? (STRLEN*)(p)      \
 326     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
 327                                              char))
 328
 329 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
 330 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
 331 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
 332 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
 333
 334 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
 335 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
 336 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
 337 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
 338
 339 #define WARNshift               8
 340
 341 #define packWARN(a)             (a                                      )
 342 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
 343 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
 344 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
 345
 346 #define unpackWARN1(x)          ((x)        & 0xFF)
 347 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 348 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 349 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 350
 351 #define ckDEAD(x)                                                       \
 352            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 353             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 354               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 355               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 356               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 357               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 358
 359 /* end of file warnings.h */
 360 EOM
 361
 362 read_only_bottom_close_and_rename($warn);
 363
 364 while (<DATA>) {
 365     last if /^KEYWORDS$/ ;
 366     print $pm $_ ;
 367 }
 368
 369 $last_ver = 0;
 370 print $pm "our %Offsets = (\n" ;
 371 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 372     my ($name, $version) = @{ $ValueToName{$k} };
 373     $name = lc $name;
 374     $k *= 2 ;
 375     if ( $last_ver != $version ) {
 376         print $pm "\n";
 377         print $pm tab(4, "    # Warnings Categories added in Perl $version");
 378         print $pm "\n\n";
 379     }
 380     print $pm tab(4, "    '$name'"), "=> $k,\n" ;
 381     $last_ver = $version;
 382 }
 383
 384 print $pm "  );\n\n" ;
 385
 386 print $pm "our %Bits = (\n" ;
 387 foreach $k (sort keys  %list) {
 388
 389     my $v = $list{$k} ;
 390     my @list = sort { $a <=> $b } @$v ;
 391
 392     print $pm tab(4, "    '$k'"), '=> "',
 393                 mkHex($warn_size, map $_ * 2 , @list),
 394                 '", # [', mkRange(@list), "]\n" ;
 395 }
 396
 397 print $pm "  );\n\n" ;
 398
 399 print $pm "our %DeadBits = (\n" ;
 400 foreach $k (sort keys  %list) {
 401
 402     my $v = $list{$k} ;
 403     my @list = sort { $a <=> $b } @$v ;
 404
 405     print $pm tab(4, "    '$k'"), '=> "',
 406                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 407                 '", # [', mkRange(@list), "]\n" ;
 408 }
 409
 410 print $pm "  );\n\n" ;
 411 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 412 print $pm '$LAST_BIT = ' . "$index ;\n" ;
 413 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
 414 while (<DATA>) {
 415     print $pm $_ ;
 416 }
 417
 418 read_only_bottom_close_and_rename($pm);
 419
 420 __END__
 421 package warnings;
 422
 423 our $VERSION = '1.12';
 424
 425 # Verify that we're called correctly so that warnings will work.
 426 # see also strict.pm.
 427 unless ( __FILE__ =~ /(^|[\/\\])\Q${\__PACKAGE__}\E\.pmc?$/ ) {
 428     my (undef, $f, $l) = caller;
 429     die("Incorrect use of pragma '${\__PACKAGE__}' at $f line $l.\n");
 430 }
 431
 432 =head1 NAME
 433
 434 warnings - Perl pragma to control optional warnings
 435
 436 =head1 SYNOPSIS
 437
 438     use warnings;
 439     no warnings;
 440
 441     use warnings "all";
 442     no warnings "all";
 443
 444     use warnings::register;
 445     if (warnings::enabled()) {
 446         warnings::warn("some warning");
 447     }
 448
 449     if (warnings::enabled("void")) {
 450         warnings::warn("void", "some warning");
 451     }
 452
 453     if (warnings::enabled($object)) {
 454         warnings::warn($object, "some warning");
 455     }
 456
 457     warnings::warnif("some warning");
 458     warnings::warnif("void", "some warning");
 459     warnings::warnif($object, "some warning");
 460
 461 =head1 DESCRIPTION
 462
 463 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 464 but the pragma is limited to the enclosing block, while the flag is global.
 465 See L<perllexwarn> for more information.
 466
 467 If no import list is supplied, all possible warnings are either enabled
 468 or disabled.
 469
 470 A number of functions are provided to assist module authors.
 471
 472 =over 4
 473
 474 =item use warnings::register
 475
 476 Creates a new warnings category with the same name as the package where
 477 the call to the pragma is used.
 478
 479 =item warnings::enabled()
 480
 481 Use the warnings category with the same name as the current package.
 482
 483 Return TRUE if that warnings category is enabled in the calling module.
 484 Otherwise returns FALSE.
 485
 486 =item warnings::enabled($category)
 487
 488 Return TRUE if the warnings category, C<$category>, is enabled in the
 489 calling module.
 490 Otherwise returns FALSE.
 491
 492 =item warnings::enabled($object)
 493
 494 Use the name of the class for the object reference, C<$object>, as the
 495 warnings category.
 496
 497 Return TRUE if that warnings category is enabled in the first scope
 498 where the object is used.
 499 Otherwise returns FALSE.
 500
 501 =item warnings::fatal_enabled()
 502
 503 Return TRUE if the warnings category with the same name as the current
 504 package has been set to FATAL in the calling module.
 505 Otherwise returns FALSE.
 506
 507 =item warnings::fatal_enabled($category)
 508
 509 Return TRUE if the warnings category C<$category> has been set to FATAL in
 510 the calling module.
 511 Otherwise returns FALSE.
 512
 513 =item warnings::fatal_enabled($object)
 514
 515 Use the name of the class for the object reference, C<$object>, as the
 516 warnings category.
 517
 518 Return TRUE if that warnings category has been set to FATAL in the first
 519 scope where the object is used.
 520 Otherwise returns FALSE.
 521
 522 =item warnings::warn($message)
 523
 524 Print C<$message> to STDERR.
 525
 526 Use the warnings category with the same name as the current package.
 527
 528 If that warnings category has been set to "FATAL" in the calling module
 529 then die. Otherwise return.
 530
 531 =item warnings::warn($category, $message)
 532
 533 Print C<$message> to STDERR.
 534
 535 If the warnings category, C<$category>, has been set to "FATAL" in the
 536 calling module then die. Otherwise return.
 537
 538 =item warnings::warn($object, $message)
 539
 540 Print C<$message> to STDERR.
 541
 542 Use the name of the class for the object reference, C<$object>, as the
 543 warnings category.
 544
 545 If that warnings category has been set to "FATAL" in the scope where C<$object>
 546 is first used then die. Otherwise return.
 547
 548
 549 =item warnings::warnif($message)
 550
 551 Equivalent to:
 552
 553     if (warnings::enabled())
 554       { warnings::warn($message) }
 555
 556 =item warnings::warnif($category, $message)
 557
 558 Equivalent to:
 559
 560     if (warnings::enabled($category))
 561       { warnings::warn($category, $message) }
 562
 563 =item warnings::warnif($object, $message)
 564
 565 Equivalent to:
 566
 567     if (warnings::enabled($object))
 568       { warnings::warn($object, $message) }
 569
 570 =item warnings::register_categories(@names)
 571
 572 This registers warning categories for the given names and is primarily for
 573 use by the warnings::register pragma, for which see L<perllexwarn>.
 574
 575 =back
 576
 577 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 578
 579 =cut
 580
 581 KEYWORDS
 582
 583 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 584
 585 sub Croaker
 586 {
 587     require Carp; # this initializes %CarpInternal
 588     local $Carp::CarpInternal{'warnings'};
 589     delete $Carp::CarpInternal{'warnings'};
 590     Carp::croak(@_);
 591 }
 592
 593 sub _bits {
 594     my $mask = shift ;
 595     my $catmask ;
 596     my $fatal = 0 ;
 597     my $no_fatal = 0 ;
 598
 599     foreach my $word ( @_ ) {
 600         if ($word eq 'FATAL') {
 601             $fatal = 1;
 602             $no_fatal = 0;
 603         }
 604         elsif ($word eq 'NONFATAL') {
 605             $fatal = 0;
 606             $no_fatal = 1;
 607         }
 608         elsif ($catmask = $Bits{$word}) {
 609             $mask |= $catmask ;
 610             $mask |= $DeadBits{$word} if $fatal ;
 611             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 612         }
 613         else
 614           { Croaker("Unknown warnings category '$word'")}
 615     }
 616
 617     return $mask ;
 618 }
 619
 620 sub bits
 621 {
 622     # called from B::Deparse.pm
 623     push @_, 'all' unless @_ ;
 624     return _bits(undef, @_) ;
 625 }
 626
 627 sub import
 628 {
 629     shift;
 630
 631     my $mask = ${^WARNING_BITS} ;
 632
 633     if (vec($mask, $Offsets{'all'}, 1)) {
 634         $mask |= $Bits{'all'} ;
 635         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 636     }
 637
 638     # Empty @_ is equivalent to @_ = 'all' ;
 639     ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
 640 }
 641
 642 sub unimport
 643 {
 644     shift;
 645
 646     my $catmask ;
 647     my $mask = ${^WARNING_BITS} ;
 648
 649     if (vec($mask, $Offsets{'all'}, 1)) {
 650         $mask |= $Bits{'all'} ;
 651         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 652     }
 653
 654     push @_, 'all' unless @_;
 655
 656     foreach my $word ( @_ ) {
 657         if ($word eq 'FATAL') {
 658             next;
 659         }
 660         elsif ($catmask = $Bits{$word}) {
 661             $mask &= ~($catmask | $DeadBits{$word} | $All);
 662         }
 663         else
 664           { Croaker("Unknown warnings category '$word'")}
 665     }
 666
 667     ${^WARNING_BITS} = $mask ;
 668 }
 669
 670 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 671
 672 sub MESSAGE () { 4 };
 673 sub FATAL () { 2 };
 674 sub NORMAL () { 1 };
 675
 676 sub __chk
 677 {
 678     my $category ;
 679     my $offset ;
 680     my $isobj = 0 ;
 681     my $wanted = shift;
 682     my $has_message = $wanted & MESSAGE;
 683
 684     unless (@_ == 1 || @_ == ($has_message ? 2 : 0)) {
 685         my $sub = (caller 1)[3];
 686         my $syntax = $has_message ? "[category,] 'message'" : '[category]';
 687         Croaker("Usage: $sub($syntax)");
 688     }
 689
 690     my $message = pop if $has_message;
 691
 692     if (@_) {
 693         # check the category supplied.
 694         $category = shift ;
 695         if (my $type = ref $category) {
 696             Croaker("not an object")
 697                 if exists $builtin_type{$type};
 698             $category = $type;
 699             $isobj = 1 ;
 700         }
 701         $offset = $Offsets{$category};
 702         Croaker("Unknown warnings category '$category'")
 703             unless defined $offset;
 704     }
 705     else {
 706         $category = (caller(1))[0] ;
 707         $offset = $Offsets{$category};
 708         Croaker("package '$category' not registered for warnings")
 709             unless defined $offset ;
 710     }
 711
 712     my $i;
 713
 714     if ($isobj) {
 715         my $pkg;
 716         $i = 2;
 717         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 718             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 719         }
 720         $i -= 2 ;
 721     }
 722     else {
 723         $i = _error_loc(); # see where Carp will allocate the error
 724     }
 725
 726     # Defaulting this to 0 reduces complexity in code paths below.
 727     my $callers_bitmask = (caller($i))[9] || 0 ;
 728
 729     my @results;
 730     foreach my $type (FATAL, NORMAL) {
 731         next unless $wanted & $type;
 732
 733         push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
 734                         vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
 735     }
 736
 737     # &enabled and &fatal_enabled
 738     return $results[0] unless $has_message;
 739
 740     # &warnif, and the category is neither enabled as warning nor as fatal
 741     return if $wanted == (NORMAL | FATAL | MESSAGE)
 742         && !($results[0] || $results[1]);
 743
 744     require Carp;
 745     Carp::croak($message) if $results[0];
 746     # will always get here for &warn. will only get here for &warnif if the
 747     # category is enabled
 748     Carp::carp($message);
 749 }
 750
 751 sub _mkMask
 752 {
 753     my ($bit) = @_;
 754     my $mask = "";
 755
 756     vec($mask, $bit, 1) = 1;
 757     return $mask;
 758 }
 759
 760 sub register_categories
 761 {
 762     my @names = @_;
 763
 764     for my $name (@names) {
 765         if (! defined $Bits{$name}) {
 766             $Bits{$name}     = _mkMask($LAST_BIT);
 767             vec($Bits{'all'}, $LAST_BIT, 1) = 1;
 768             $Offsets{$name}  = $LAST_BIT ++;
 769             foreach my $k (keys %Bits) {
 770                 vec($Bits{$k}, $LAST_BIT, 1) = 0;
 771             }
 772             $DeadBits{$name} = _mkMask($LAST_BIT);
 773             vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
 774         }
 775     }
 776 }
 777
 778 sub _error_loc {
 779     require Carp;
 780     goto &Carp::short_error_loc; # don't introduce another stack frame
 781 }
 782
 783 sub enabled
 784 {
 785     return __chk(NORMAL, @_);
 786 }
 787
 788 sub fatal_enabled
 789 {
 790     return __chk(FATAL, @_);
 791 }
 792
 793 sub warn
 794 {
 795     return __chk(FATAL | MESSAGE, @_);
 796 }
 797
 798 sub warnif
 799 {
 800     return __chk(NORMAL | FATAL | MESSAGE, @_);
 801 }
 802
 803 # These are not part of any public interface, so we can delete them to save
 804 # space.
 805 delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
 806
 807 1;