warnings.pl

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