warnings.pl

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