warnings.pl

   1 #!/usr/bin/perl
   2
   3 $VERSION = '1.01';
   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         'y2k'           => [ 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          #'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 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 470 # This file was created by warnings.pl
 471 # Any changes made here will be lost.
 472 #
 473
 474 package warnings;
 475
 476 our $VERSION = '1.02';
 477
 478 =head1 NAME
 479
 480 warnings - Perl pragma to control optional warnings
 481
 482 =head1 SYNOPSIS
 483
 484     use warnings;
 485     no warnings;
 486
 487     use warnings "all";
 488     no warnings "all";
 489
 490     use warnings::register;
 491     if (warnings::enabled()) {
 492         warnings::warn("some warning");
 493     }
 494
 495     if (warnings::enabled("void")) {
 496         warnings::warn("void", "some warning");
 497     }
 498
 499     if (warnings::enabled($object)) {
 500         warnings::warn($object, "some warning");
 501     }
 502
 503     warnings::warnif("some warning");
 504     warnings::warnif("void", "some warning");
 505     warnings::warnif($object, "some warning");
 506
 507 =head1 DESCRIPTION
 508
 509 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 510 but the pragma is limited to the enclosing block, while the flag is global.
 511 See L<perllexwarn> for more information.
 512
 513 If no import list is supplied, all possible warnings are either enabled
 514 or disabled.
 515
 516 A number of functions are provided to assist module authors.
 517
 518 =over 4
 519
 520 =item use warnings::register
 521
 522 Creates a new warnings category with the same name as the package where
 523 the call to the pragma is used.
 524
 525 =item warnings::enabled()
 526
 527 Use the warnings category with the same name as the current package.
 528
 529 Return TRUE if that warnings category is enabled in the calling module.
 530 Otherwise returns FALSE.
 531
 532 =item warnings::enabled($category)
 533
 534 Return TRUE if the warnings category, C<$category>, is enabled in the
 535 calling module.
 536 Otherwise returns FALSE.
 537
 538 =item warnings::enabled($object)
 539
 540 Use the name of the class for the object reference, C<$object>, as the
 541 warnings category.
 542
 543 Return TRUE if that warnings category is enabled in the first scope
 544 where the object is used.
 545 Otherwise returns FALSE.
 546
 547 =item warnings::warn($message)
 548
 549 Print C<$message> to STDERR.
 550
 551 Use the warnings category with the same name as the current package.
 552
 553 If that warnings category has been set to "FATAL" in the calling module
 554 then die. Otherwise return.
 555
 556 =item warnings::warn($category, $message)
 557
 558 Print C<$message> to STDERR.
 559
 560 If the warnings category, C<$category>, has been set to "FATAL" in the
 561 calling module then die. Otherwise return.
 562
 563 =item warnings::warn($object, $message)
 564
 565 Print C<$message> to STDERR.
 566
 567 Use the name of the class for the object reference, C<$object>, as the
 568 warnings category.
 569
 570 If that warnings category has been set to "FATAL" in the scope where C<$object>
 571 is first used then die. Otherwise return.
 572
 573
 574 =item warnings::warnif($message)
 575
 576 Equivalent to:
 577
 578     if (warnings::enabled())
 579       { warnings::warn($message) }
 580
 581 =item warnings::warnif($category, $message)
 582
 583 Equivalent to:
 584
 585     if (warnings::enabled($category))
 586       { warnings::warn($category, $message) }
 587
 588 =item warnings::warnif($object, $message)
 589
 590 Equivalent to:
 591
 592     if (warnings::enabled($object))
 593       { warnings::warn($object, $message) }
 594
 595 =back
 596
 597 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 598
 599 =cut
 600
 601 use Carp ;
 602
 603 KEYWORDS
 604
 605 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 606
 607 sub Croaker
 608 {
 609     delete $Carp::CarpInternal{'warnings'};
 610     croak(@_);
 611 }
 612
 613 sub bits
 614 {
 615     # called from B::Deparse.pm
 616
 617     push @_, 'all' unless @_;
 618
 619     my $mask;
 620     my $catmask ;
 621     my $fatal = 0 ;
 622     my $no_fatal = 0 ;
 623
 624     foreach my $word ( @_ ) {
 625         if ($word eq 'FATAL') {
 626             $fatal = 1;
 627             $no_fatal = 0;
 628         }
 629         elsif ($word eq 'NONFATAL') {
 630             $fatal = 0;
 631             $no_fatal = 1;
 632         }
 633         elsif ($catmask = $Bits{$word}) {
 634             $mask |= $catmask ;
 635             $mask |= $DeadBits{$word} if $fatal ;
 636             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 637         }
 638         else
 639           { Croaker("Unknown warnings category '$word'")}
 640     }
 641
 642     return $mask ;
 643 }
 644
 645 sub import
 646 {
 647     shift;
 648
 649     my $catmask ;
 650     my $fatal = 0 ;
 651     my $no_fatal = 0 ;
 652
 653     my $mask = ${^WARNING_BITS} ;
 654
 655     if (vec($mask, $Offsets{'all'}, 1)) {
 656         $mask |= $Bits{'all'} ;
 657         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 658     }
 659
 660     push @_, 'all' unless @_;
 661
 662     foreach my $word ( @_ ) {
 663         if ($word eq 'FATAL') {
 664             $fatal = 1;
 665             $no_fatal = 0;
 666         }
 667         elsif ($word eq 'NONFATAL') {
 668             $fatal = 0;
 669             $no_fatal = 1;
 670         }
 671         elsif ($catmask = $Bits{$word}) {
 672             $mask |= $catmask ;
 673             $mask |= $DeadBits{$word} if $fatal ;
 674             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 675         }
 676         else
 677           { Croaker("Unknown warnings category '$word'")}
 678     }
 679
 680     ${^WARNING_BITS} = $mask ;
 681 }
 682
 683 sub unimport
 684 {
 685     shift;
 686
 687     my $catmask ;
 688     my $mask = ${^WARNING_BITS} ;
 689
 690     if (vec($mask, $Offsets{'all'}, 1)) {
 691         $mask |= $Bits{'all'} ;
 692         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 693     }
 694
 695     push @_, 'all' unless @_;
 696
 697     foreach my $word ( @_ ) {
 698         if ($word eq 'FATAL') {
 699             next;
 700         }
 701         elsif ($catmask = $Bits{$word}) {
 702             $mask &= ~($catmask | $DeadBits{$word} | $All);
 703         }
 704         else
 705           { Croaker("Unknown warnings category '$word'")}
 706     }
 707
 708     ${^WARNING_BITS} = $mask ;
 709 }
 710
 711 sub __chk
 712 {
 713     my $category ;
 714     my $offset ;
 715     my $isobj = 0 ;
 716
 717     if (@_) {
 718         # check the category supplied.
 719         $category = shift ;
 720         if (ref $category) {
 721             Croaker ("not an object")
 722                 if $category !~ /^([^=]+)=/ ;
 723             $category = $1 ;
 724             $isobj = 1 ;
 725         }
 726         $offset = $Offsets{$category};
 727         Croaker("Unknown warnings category '$category'")
 728             unless defined $offset;
 729     }
 730     else {
 731         $category = (caller(1))[0] ;
 732         $offset = $Offsets{$category};
 733         Croaker("package '$category' not registered for warnings")
 734             unless defined $offset ;
 735     }
 736
 737     my $this_pkg = (caller(1))[0] ;
 738     my $i = 2 ;
 739     my $pkg ;
 740
 741     if ($isobj) {
 742         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 743             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 744         }
 745         $i -= 2 ;
 746     }
 747     else {
 748         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
 749             last if $pkg ne $this_pkg ;
 750         }
 751         $i = 2
 752             if !$pkg || $pkg eq $this_pkg ;
 753     }
 754
 755     my $callers_bitmask = (caller($i))[9] ;
 756     return ($callers_bitmask, $offset, $i) ;
 757 }
 758
 759 sub enabled
 760 {
 761     Croaker("Usage: warnings::enabled([category])")
 762         unless @_ == 1 || @_ == 0 ;
 763
 764     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 765
 766     return 0 unless defined $callers_bitmask ;
 767     return vec($callers_bitmask, $offset, 1) ||
 768            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 769 }
 770
 771
 772 sub warn
 773 {
 774     Croaker("Usage: warnings::warn([category,] 'message')")
 775         unless @_ == 2 || @_ == 1 ;
 776
 777     my $message = pop ;
 778     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 779     croak($message)
 780         if vec($callers_bitmask, $offset+1, 1) ||
 781            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 782     carp($message) ;
 783 }
 784
 785 sub warnif
 786 {
 787     Croaker("Usage: warnings::warnif([category,] 'message')")
 788         unless @_ == 2 || @_ == 1 ;
 789
 790     my $message = pop ;
 791     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 792
 793     return
 794         unless defined $callers_bitmask &&
 795                 (vec($callers_bitmask, $offset, 1) ||
 796                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 797
 798     croak($message)
 799         if vec($callers_bitmask, $offset+1, 1) ||
 800            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 801
 802     carp($message) ;
 803 }
 804
 805 1;