warnings.pl

   1 #!/usr/bin/perl
   2
   3 $VERSION = '1.02_02';
   4
   5 BEGIN {
   6   push @INC, './lib';
   7 }
   8 use strict ;
   9
  10 sub DEFAULT_ON  () { 1 }
  11 sub DEFAULT_OFF () { 2 }
  12
  13 my $tree = {
  14
  15 'all' => [ 5.008, {
  16         'io'            => [ 5.008, {
  17                                 'pipe'          => [ 5.008, DEFAULT_OFF],
  18                                 'unopened'      => [ 5.008, DEFAULT_OFF],
  19                                 'closed'        => [ 5.008, DEFAULT_OFF],
  20                                 'newline'       => [ 5.008, DEFAULT_OFF],
  21                                 'exec'          => [ 5.008, DEFAULT_OFF],
  22                                 'layer'         => [ 5.008, DEFAULT_OFF],
  23                            }],
  24         'syntax'        => [ 5.008, {
  25                                 'ambiguous'     => [ 5.008, DEFAULT_OFF],
  26                                 'semicolon'     => [ 5.008, DEFAULT_OFF],
  27                                 'precedence'    => [ 5.008, DEFAULT_OFF],
  28                                 'bareword'      => [ 5.008, DEFAULT_OFF],
  29                                 'reserved'      => [ 5.008, DEFAULT_OFF],
  30                                 'digit'         => [ 5.008, DEFAULT_OFF],
  31                                 'parenthesis'   => [ 5.008, DEFAULT_OFF],
  32                                 'printf'        => [ 5.008, DEFAULT_OFF],
  33                                 'prototype'     => [ 5.008, DEFAULT_OFF],
  34                                 'qw'            => [ 5.008, DEFAULT_OFF],
  35                            }],
  36         'severe'        => [ 5.008, {
  37                                 'inplace'       => [ 5.008, DEFAULT_ON],
  38                                 'internal'      => [ 5.008, DEFAULT_ON],
  39                                 'debugging'     => [ 5.008, DEFAULT_ON],
  40                                 'malloc'        => [ 5.008, DEFAULT_ON],
  41                            }],
  42         'deprecated'    => [ 5.008, DEFAULT_OFF],
  43         'void'          => [ 5.008, DEFAULT_OFF],
  44         'recursion'     => [ 5.008, DEFAULT_OFF],
  45         'redefine'      => [ 5.008, DEFAULT_OFF],
  46         'numeric'       => [ 5.008, DEFAULT_OFF],
  47         'uninitialized' => [ 5.008, DEFAULT_OFF],
  48         'once'          => [ 5.008, DEFAULT_OFF],
  49         'misc'          => [ 5.008, DEFAULT_OFF],
  50         'regexp'        => [ 5.008, DEFAULT_OFF],
  51         'glob'          => [ 5.008, DEFAULT_OFF],
  52         'untie'         => [ 5.008, DEFAULT_OFF],
  53         'substr'        => [ 5.008, DEFAULT_OFF],
  54         'taint'         => [ 5.008, DEFAULT_OFF],
  55         'signal'        => [ 5.008, DEFAULT_OFF],
  56         'closure'       => [ 5.008, DEFAULT_OFF],
  57         'overflow'      => [ 5.008, DEFAULT_OFF],
  58         'portable'      => [ 5.008, DEFAULT_OFF],
  59         'utf8'          => [ 5.008, DEFAULT_OFF],
  60         'exiting'       => [ 5.008, DEFAULT_OFF],
  61         'pack'          => [ 5.008, DEFAULT_OFF],
  62         'unpack'        => [ 5.008, DEFAULT_OFF],
  63         'threads'       => [ 5.008, DEFAULT_OFF],
  64
  65          #'default'     => [ 5.008, DEFAULT_ON ],
  66         }],
  67 } ;
  68
  69 ###########################################################################
  70 sub tab {
  71     my($l, $t) = @_;
  72     $t .= "\t" x ($l - (length($t) + 1) / 8);
  73     $t;
  74 }
  75
  76 ###########################################################################
  77
  78 my %list ;
  79 my %Value ;
  80 my %ValueToName ;
  81 my %NameToValue ;
  82 my $index ;
  83
  84 my %v_list = () ;
  85
  86 sub valueWalk
  87 {
  88     my $tre = shift ;
  89     my @list = () ;
  90     my ($k, $v) ;
  91
  92     foreach $k (sort keys %$tre) {
  93         $v = $tre->{$k};
  94         die "duplicate key $k\n" if defined $list{$k} ;
  95         die "Value associated with key '$k' is not an ARRAY reference"
  96             if !ref $v || ref $v ne 'ARRAY' ;
  97
  98         my ($ver, $rest) = @{ $v } ;
  99         push @{ $v_list{$ver} }, $k;
 100
 101         if (ref $rest)
 102           { valueWalk ($rest) }
 103
 104     }
 105
 106 }
 107
 108 sub orderValues
 109 {
 110     my $index = 0;
 111     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
 112         foreach my $name (@{ $v_list{$ver} } ) {
 113             $ValueToName{ $index } = [ uc $name, $ver ] ;
 114             $NameToValue{ uc $name } = $index ++ ;
 115         }
 116     }
 117
 118     return $index ;
 119 }
 120
 121 ###########################################################################
 122
 123 sub walk
 124 {
 125     my $tre = shift ;
 126     my @list = () ;
 127     my ($k, $v) ;
 128
 129     foreach $k (sort keys %$tre) {
 130         $v = $tre->{$k};
 131         die "duplicate key $k\n" if defined $list{$k} ;
 132         #$Value{$index} = uc $k ;
 133         die "Can't find key '$k'"
 134             if ! defined $NameToValue{uc $k} ;
 135         push @{ $list{$k} }, $NameToValue{uc $k} ;
 136         die "Value associated with key '$k' is not an ARRAY reference"
 137             if !ref $v || ref $v ne 'ARRAY' ;
 138
 139         my ($ver, $rest) = @{ $v } ;
 140         if (ref $rest)
 141           { push (@{ $list{$k} }, walk ($rest)) }
 142
 143         push @list, @{ $list{$k} } ;
 144     }
 145
 146    return @list ;
 147 }
 148
 149 ###########################################################################
 150
 151 sub mkRange
 152 {
 153     my @a = @_ ;
 154     my @out = @a ;
 155     my $i ;
 156
 157
 158     for ($i = 1 ; $i < @a; ++ $i) {
 159         $out[$i] = ".."
 160           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 161     }
 162
 163     my $out = join(",",@out);
 164
 165     $out =~ s/,(\.\.,)+/../g ;
 166     return $out;
 167 }
 168
 169 ###########################################################################
 170 sub printTree
 171 {
 172     my $tre = shift ;
 173     my $prefix = shift ;
 174     my ($k, $v) ;
 175
 176     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 177     my @keys = sort keys %$tre ;
 178
 179     while ($k = shift @keys) {
 180         $v = $tre->{$k};
 181         die "Value associated with key '$k' is not an ARRAY reference"
 182             if !ref $v || ref $v ne 'ARRAY' ;
 183
 184         my $offset ;
 185         if ($tre ne $tree) {
 186             print $prefix . "|\n" ;
 187             print $prefix . "+- $k" ;
 188             $offset = ' ' x ($max + 4) ;
 189         }
 190         else {
 191             print $prefix . "$k" ;
 192             $offset = ' ' x ($max + 1) ;
 193         }
 194
 195         my ($ver, $rest) = @{ $v } ;
 196         if (ref $rest)
 197         {
 198             my $bar = @keys ? "|" : " ";
 199             print " -" . "-" x ($max - length $k ) . "+\n" ;
 200             printTree ($rest, $prefix . $bar . $offset )
 201         }
 202         else
 203           { print "\n" }
 204     }
 205
 206 }
 207
 208 ###########################################################################
 209
 210 sub mkHexOct
 211 {
 212     my ($f, $max, @a) = @_ ;
 213     my $mask = "\x00" x $max ;
 214     my $string = "" ;
 215
 216     foreach (@a) {
 217         vec($mask, $_, 1) = 1 ;
 218     }
 219
 220     foreach (unpack("C*", $mask)) {
 221         if ($f eq 'x') {
 222             $string .= '\x' . sprintf("%2.2x", $_)
 223         }
 224         else {
 225             $string .= '\\' . sprintf("%o", $_)
 226         }
 227     }
 228     return $string ;
 229 }
 230
 231 sub mkHex
 232 {
 233     my($max, @a) = @_;
 234     return mkHexOct("x", $max, @a);
 235 }
 236
 237 sub mkOct
 238 {
 239     my($max, @a) = @_;
 240     return mkHexOct("o", $max, @a);
 241 }
 242
 243 ###########################################################################
 244
 245 if (@ARGV && $ARGV[0] eq "tree")
 246 {
 247     printTree($tree, "    ") ;
 248     exit ;
 249 }
 250
 251 unlink "warnings.h";
 252 unlink "lib/warnings.pm";
 253 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 254 binmode WARN;
 255 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 256 binmode PM;
 257
 258 print WARN <<'EOM' ;
 259 /* -*- buffer-read-only: t -*-
 260    !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 261    This file is built by warnings.pl
 262    Any changes made here will be lost!
 263 */
 264
 265
 266 #define Off(x)                  ((x) / 8)
 267 #define Bit(x)                  (1 << ((x) % 8))
 268 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 269
 270
 271 #define G_WARN_OFF              0       /* $^W == 0 */
 272 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 273 #define G_WARN_ALL_ON           2       /* -W flag */
 274 #define G_WARN_ALL_OFF          4       /* -X flag */
 275 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 276 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 277
 278 #define pWARN_STD               NULL
 279 #define pWARN_ALL               (((STRLEN*)0)+1)    /* use warnings 'all' */
 280 #define pWARN_NONE              (((STRLEN*)0)+2)    /* no  warnings 'all' */
 281
 282 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 283                                  (x) == pWARN_NONE)
 284
 285 /* if PL_warnhook is set to this value, then warnings die */
 286 #define PERL_WARNHOOK_FATAL     (&PL_sv_placeholder)
 287 EOM
 288
 289 my $offset = 0 ;
 290
 291 $index = $offset ;
 292 #@{ $list{"all"} } = walk ($tree) ;
 293 valueWalk ($tree) ;
 294 my $index = orderValues();
 295
 296 die <<EOM if $index > 255 ;
 297 Too many warnings categories -- max is 255
 298     rewrite packWARN* & unpackWARN* macros
 299 EOM
 300
 301 walk ($tree) ;
 302
 303 $index *= 2 ;
 304 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 305
 306 my $k ;
 307 my $last_ver = 0;
 308 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 309     my ($name, $version) = @{ $ValueToName{$k} };
 310     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
 311         if $last_ver != $version ;
 312     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
 313     $last_ver = $version ;
 314 }
 315 print WARN "\n" ;
 316
 317 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 318 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 319 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 320 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 321
 322 print WARN <<'EOM';
 323
 324 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 325 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 326 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 327 #define isWARN_on(c,x)  (IsSet((U8 *)(c + 1), 2*(x)))
 328 #define isWARNf_on(c,x) (IsSet((U8 *)(c + 1), 2*(x)+1))
 329
 330 #define DUP_WARNINGS(p)         \
 331     (specialWARN(p) ? (STRLEN*)(p)      \
 332     : (STRLEN*)CopyD(p, PerlMemShared_malloc(sizeof(*p)+*p), sizeof(*p)+*p, \
 333                                              char))
 334
 335 #define ckWARN(w)               Perl_ckwarn(aTHX_ packWARN(w))
 336 #define ckWARN2(w1,w2)          Perl_ckwarn(aTHX_ packWARN2(w1,w2))
 337 #define ckWARN3(w1,w2,w3)       Perl_ckwarn(aTHX_ packWARN3(w1,w2,w3))
 338 #define ckWARN4(w1,w2,w3,w4)    Perl_ckwarn(aTHX_ packWARN4(w1,w2,w3,w4))
 339
 340 #define ckWARN_d(w)             Perl_ckwarn_d(aTHX_ packWARN(w))
 341 #define ckWARN2_d(w1,w2)        Perl_ckwarn_d(aTHX_ packWARN2(w1,w2))
 342 #define ckWARN3_d(w1,w2,w3)     Perl_ckwarn_d(aTHX_ packWARN3(w1,w2,w3))
 343 #define ckWARN4_d(w1,w2,w3,w4)  Perl_ckwarn_d(aTHX_ packWARN4(w1,w2,w3,w4))
 344
 345 #define packWARN(a)             (a                                      )
 346 #define packWARN2(a,b)          ((a) | ((b)<<8)                         )
 347 #define packWARN3(a,b,c)        ((a) | ((b)<<8) | ((c)<<16)             )
 348 #define packWARN4(a,b,c,d)      ((a) | ((b)<<8) | ((c)<<16) | ((d) <<24))
 349
 350 #define unpackWARN1(x)          ((x)        & 0xFF)
 351 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 352 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 353 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 354
 355 #define ckDEAD(x)                                                       \
 356            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 357             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 358               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 359               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 360               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 361               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 362
 363 /* end of file warnings.h */
 364 /* ex: set ro: */
 365 EOM
 366
 367 close WARN ;
 368
 369 while (<DATA>) {
 370     last if /^KEYWORDS$/ ;
 371     print PM $_ ;
 372 }
 373
 374 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 375
 376 $last_ver = 0;
 377 print PM "our %Offsets = (\n" ;
 378 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 379     my ($name, $version) = @{ $ValueToName{$k} };
 380     $name = lc $name;
 381     $k *= 2 ;
 382     if ( $last_ver != $version ) {
 383         print PM "\n";
 384         print PM tab(4, "    # Warnings Categories added in Perl $version");
 385         print PM "\n\n";
 386     }
 387     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 388     $last_ver = $version;
 389 }
 390
 391 print PM "  );\n\n" ;
 392
 393 print PM "our %Bits = (\n" ;
 394 foreach $k (sort keys  %list) {
 395
 396     my $v = $list{$k} ;
 397     my @list = sort { $a <=> $b } @$v ;
 398
 399     print PM tab(4, "    '$k'"), '=> "',
 400                 # mkHex($warn_size, @list),
 401                 mkHex($warn_size, map $_ * 2 , @list),
 402                 '", # [', mkRange(@list), "]\n" ;
 403 }
 404
 405 print PM "  );\n\n" ;
 406
 407 print PM "our %DeadBits = (\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 + 1 , @list),
 416                 '", # [', mkRange(@list), "]\n" ;
 417 }
 418
 419 print PM "  );\n\n" ;
 420 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 421 print PM '$LAST_BIT = ' . "$index ;\n" ;
 422 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 423 while (<DATA>) {
 424     print PM $_ ;
 425 }
 426
 427 print PM "# ex: set ro:\n";
 428 close 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;