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