warnings.pl

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