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