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