warnings.pl

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