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