warnings.pl

   1 #!/usr/bin/perl
   2
   3
   4 $VERSION = '1.00';
   5
   6 BEGIN {
   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         'y2k'           => [ 5.008, DEFAULT_OFF],
  54         'untie'         => [ 5.008, DEFAULT_OFF],
  55         'substr'        => [ 5.008, DEFAULT_OFF],
  56         'taint'         => [ 5.008, DEFAULT_OFF],
  57         'signal'        => [ 5.008, DEFAULT_OFF],
  58         'closure'       => [ 5.008, DEFAULT_OFF],
  59         'overflow'      => [ 5.008, DEFAULT_OFF],
  60         'portable'      => [ 5.008, DEFAULT_OFF],
  61         'utf8'          => [ 5.008, DEFAULT_OFF],
  62         'exiting'       => [ 5.008, DEFAULT_OFF],
  63         'pack'          => [ 5.008, DEFAULT_OFF],
  64         'unpack'        => [ 5.008, DEFAULT_OFF],
  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 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 255
 256 print WARN <<'EOM' ;
 257 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 258    This file is built by warnings.pl
 259    Any changes made here will be lost!
 260 */
 261
 262
 263 #define Off(x)                  ((x) / 8)
 264 #define Bit(x)                  (1 << ((x) % 8))
 265 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 266
 267
 268 #define G_WARN_OFF              0       /* $^W == 0 */
 269 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 270 #define G_WARN_ALL_ON           2       /* -W flag */
 271 #define G_WARN_ALL_OFF          4       /* -X flag */
 272 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 273 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 274
 275 #define pWARN_STD               Nullsv
 276 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
 277 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 278
 279 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 280                                  (x) == pWARN_NONE)
 281 EOM
 282
 283 my $offset = 0 ;
 284
 285 $index = $offset ;
 286 #@{ $list{"all"} } = walk ($tree) ;
 287 valueWalk ($tree) ;
 288 my $index = orderValues();
 289
 290 die <<EOM if $index > 255 ;
 291 Too many warnings categories -- max is 255
 292     rewrite packWARN* & unpackWARN* macros
 293 EOM
 294
 295 walk ($tree) ;
 296
 297 $index *= 2 ;
 298 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 299
 300 my $k ;
 301 my $last_ver = 0;
 302 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 303     my ($name, $version) = @{ $ValueToName{$k} };
 304     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
 305         if $last_ver != $version ;
 306     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
 307     $last_ver = $version ;
 308 }
 309 print WARN "\n" ;
 310
 311 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 312 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 313 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 314 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 315 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
 316
 317 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
 318
 319 print WARN <<'EOM';
 320
 321 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 322 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 323 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 324 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 325 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
 326
 327 #define ckWARN(x)                                                       \
 328         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
 329               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 330                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
 331           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 332
 333 #define ckWARN2(x,y)                                                    \
 334           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 335               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 336                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 337                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
 338             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 339
 340 #define ckWARN3(x,y,z)                                                  \
 341           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 342               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 343                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 344                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 345                 isWARN_on(PL_curcop->cop_warnings, z) ) )               \
 346             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 347
 348 #define ckWARN4(x,y,z,t)                                                \
 349           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 350               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 351                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 352                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 353                 isWARN_on(PL_curcop->cop_warnings, z)  ||               \
 354                 isWARN_on(PL_curcop->cop_warnings, t) ) )               \
 355             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 356
 357 #define ckWARN_d(x)                                                     \
 358           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 359              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 360               isWARN_on(PL_curcop->cop_warnings, x) ) )
 361
 362 #define ckWARN2_d(x,y)                                                  \
 363           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 364              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 365                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 366                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 367
 368 #define ckWARN3_d(x,y,z)                                                \
 369           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 370              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 371                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 372                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 373                  isWARN_on(PL_curcop->cop_warnings, z) ) ) )
 374
 375 #define ckWARN4_d(x,y,z,t)                                              \
 376           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 377              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 378                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 379                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 380                  isWARN_on(PL_curcop->cop_warnings, z)  ||              \
 381                  isWARN_on(PL_curcop->cop_warnings, t) ) ) )
 382
 383 #define packWARN(a)             (a                                 )
 384 #define packWARN2(a,b)          ((a) | (b)<<8                      )
 385 #define packWARN3(a,b,c)        ((a) | (b)<<8 | (c) <<16           )
 386 #define packWARN4(a,b,c,d)      ((a) | (b)<<8 | (c) <<16 | (d) <<24)
 387
 388 #define unpackWARN1(x)          ((x)        & 0xFF)
 389 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 390 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 391 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 392
 393 #define ckDEAD(x)                                                       \
 394            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 395             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 396               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 397               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 398               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 399               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 400
 401 /* end of file warnings.h */
 402
 403 EOM
 404
 405 close WARN ;
 406
 407 while (<DATA>) {
 408     last if /^KEYWORDS$/ ;
 409     print PM $_ ;
 410 }
 411
 412 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 413
 414 $last_ver = 0;
 415 print PM "%Offsets = (\n" ;
 416 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 417     my ($name, $version) = @{ $ValueToName{$k} };
 418     $name = lc $name;
 419     $k *= 2 ;
 420     if ( $last_ver != $version ) {
 421         print PM "\n";
 422         print PM tab(4, "    # Warnings Categories added in Perl $version");
 423         print PM "\n\n";
 424     }
 425     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 426     $last_ver = $version;
 427 }
 428
 429 print PM "  );\n\n" ;
 430
 431 print PM "%Bits = (\n" ;
 432 foreach $k (sort keys  %list) {
 433
 434     my $v = $list{$k} ;
 435     my @list = sort { $a <=> $b } @$v ;
 436
 437     print PM tab(4, "    '$k'"), '=> "',
 438                 # mkHex($warn_size, @list),
 439                 mkHex($warn_size, map $_ * 2 , @list),
 440                 '", # [', mkRange(@list), "]\n" ;
 441 }
 442
 443 print PM "  );\n\n" ;
 444
 445 print PM "%DeadBits = (\n" ;
 446 foreach $k (sort keys  %list) {
 447
 448     my $v = $list{$k} ;
 449     my @list = sort { $a <=> $b } @$v ;
 450
 451     print PM tab(4, "    '$k'"), '=> "',
 452                 # mkHex($warn_size, @list),
 453                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 454                 '", # [', mkRange(@list), "]\n" ;
 455 }
 456
 457 print PM "  );\n\n" ;
 458 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 459 print PM '$LAST_BIT = ' . "$index ;\n" ;
 460 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 461 while (<DATA>) {
 462     print PM $_ ;
 463 }
 464
 465 close PM ;
 466
 467 __END__
 468
 469 # This file was created by warnings.pl
 470 # Any changes made here will be lost.
 471 #
 472
 473 package warnings;
 474
 475 our $VERSION = '1.00';
 476
 477 =head1 NAME
 478
 479 warnings - Perl pragma to control optional warnings
 480
 481 =head1 SYNOPSIS
 482
 483     use warnings;
 484     no warnings;
 485
 486     use warnings "all";
 487     no warnings "all";
 488
 489     use warnings::register;
 490     if (warnings::enabled()) {
 491         warnings::warn("some warning");
 492     }
 493
 494     if (warnings::enabled("void")) {
 495         warnings::warn("void", "some warning");
 496     }
 497
 498     if (warnings::enabled($object)) {
 499         warnings::warn($object, "some warning");
 500     }
 501
 502     warnings::warnif("some warning");
 503     warnings::warnif("void", "some warning");
 504     warnings::warnif($object, "some warning");
 505
 506 =head1 DESCRIPTION
 507
 508 If no import list is supplied, all possible warnings are either enabled
 509 or disabled.
 510
 511 A number of functions are provided to assist module authors.
 512
 513 =over 4
 514
 515 =item use warnings::register
 516
 517 Creates a new warnings category with the same name as the package where
 518 the call to the pragma is used.
 519
 520 =item warnings::enabled()
 521
 522 Use the warnings category with the same name as the current package.
 523
 524 Return TRUE if that warnings category is enabled in the calling module.
 525 Otherwise returns FALSE.
 526
 527 =item warnings::enabled($category)
 528
 529 Return TRUE if the warnings category, C<$category>, is enabled in the
 530 calling module.
 531 Otherwise returns FALSE.
 532
 533 =item warnings::enabled($object)
 534
 535 Use the name of the class for the object reference, C<$object>, as the
 536 warnings category.
 537
 538 Return TRUE if that warnings category is enabled in the first scope
 539 where the object is used.
 540 Otherwise returns FALSE.
 541
 542 =item warnings::warn($message)
 543
 544 Print C<$message> to STDERR.
 545
 546 Use the warnings category with the same name as the current package.
 547
 548 If that warnings category has been set to "FATAL" in the calling module
 549 then die. Otherwise return.
 550
 551 =item warnings::warn($category, $message)
 552
 553 Print C<$message> to STDERR.
 554
 555 If the warnings category, C<$category>, has been set to "FATAL" in the
 556 calling module then die. Otherwise return.
 557
 558 =item warnings::warn($object, $message)
 559
 560 Print C<$message> to STDERR.
 561
 562 Use the name of the class for the object reference, C<$object>, as the
 563 warnings category.
 564
 565 If that warnings category has been set to "FATAL" in the scope where C<$object>
 566 is first used then die. Otherwise return.
 567
 568
 569 =item warnings::warnif($message)
 570
 571 Equivalent to:
 572
 573     if (warnings::enabled())
 574       { warnings::warn($message) }
 575
 576 =item warnings::warnif($category, $message)
 577
 578 Equivalent to:
 579
 580     if (warnings::enabled($category))
 581       { warnings::warn($category, $message) }
 582
 583 =item warnings::warnif($object, $message)
 584
 585 Equivalent to:
 586
 587     if (warnings::enabled($object))
 588       { warnings::warn($object, $message) }
 589
 590 =back
 591
 592 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 593
 594 =cut
 595
 596 use Carp ;
 597
 598 KEYWORDS
 599
 600 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 601
 602 sub Croaker
 603 {
 604     delete $Carp::CarpInternal{'warnings'};
 605     croak @_ ;
 606 }
 607
 608 sub bits {
 609     my $mask ;
 610     my $catmask ;
 611     my $fatal = 0 ;
 612     foreach my $word (@_) {
 613         if  ($word eq 'FATAL') {
 614             $fatal = 1;
 615         }
 616         elsif ($catmask = $Bits{$word}) {
 617             $mask |= $catmask ;
 618             $mask |= $DeadBits{$word} if $fatal ;
 619         }
 620         else
 621           { Croaker("Unknown warnings category '$word'")}
 622     }
 623
 624     return $mask ;
 625 }
 626
 627 sub import {
 628     shift;
 629     my $mask = ${^WARNING_BITS} ;
 630     if (vec($mask, $Offsets{'all'}, 1)) {
 631         $mask |= $Bits{'all'} ;
 632         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 633     }
 634     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
 635 }
 636
 637 sub unimport {
 638     shift;
 639     my $mask = ${^WARNING_BITS} ;
 640     if (vec($mask, $Offsets{'all'}, 1)) {
 641         $mask |= $Bits{'all'} ;
 642         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 643     }
 644     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
 645 }
 646
 647 sub __chk
 648 {
 649     my $category ;
 650     my $offset ;
 651     my $isobj = 0 ;
 652
 653     if (@_) {
 654         # check the category supplied.
 655         $category = shift ;
 656         if (ref $category) {
 657             Croaker ("not an object")
 658                 if $category !~ /^([^=]+)=/ ;
 659             $category = $1 ;
 660             $isobj = 1 ;
 661         }
 662         $offset = $Offsets{$category};
 663         Croaker("Unknown warnings category '$category'")
 664             unless defined $offset;
 665     }
 666     else {
 667         $category = (caller(1))[0] ;
 668         $offset = $Offsets{$category};
 669         Croaker("package '$category' not registered for warnings")
 670             unless defined $offset ;
 671     }
 672
 673     my $this_pkg = (caller(1))[0] ;
 674     my $i = 2 ;
 675     my $pkg ;
 676
 677     if ($isobj) {
 678         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 679             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 680         }
 681         $i -= 2 ;
 682     }
 683     else {
 684         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 685             last if $pkg ne $this_pkg ;
 686         }
 687         $i = 2
 688             if !$pkg || $pkg eq $this_pkg ;
 689     }
 690
 691     my $callers_bitmask = (caller($i))[9] ;
 692     return ($callers_bitmask, $offset, $i) ;
 693 }
 694
 695 sub enabled
 696 {
 697     Croaker("Usage: warnings::enabled([category])")
 698         unless @_ == 1 || @_ == 0 ;
 699
 700     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 701
 702     return 0 unless defined $callers_bitmask ;
 703     return vec($callers_bitmask, $offset, 1) ||
 704            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 705 }
 706
 707
 708 sub warn
 709 {
 710     Croaker("Usage: warnings::warn([category,] 'message')")
 711         unless @_ == 2 || @_ == 1 ;
 712
 713     my $message = pop ;
 714     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 715     croak($message)
 716         if vec($callers_bitmask, $offset+1, 1) ||
 717            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 718     carp($message) ;
 719 }
 720
 721 sub warnif
 722 {
 723     Croaker("Usage: warnings::warnif([category,] 'message')")
 724         unless @_ == 2 || @_ == 1 ;
 725
 726     my $message = pop ;
 727     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 728
 729     return
 730         unless defined $callers_bitmask &&
 731                 (vec($callers_bitmask, $offset, 1) ||
 732                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 733
 734     croak($message)
 735         if vec($callers_bitmask, $offset+1, 1) ||
 736            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 737
 738     carp($message) ;
 739 }
 740
 741 1;