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