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 binmode WARN;
 257 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 258 binmode PM;
 259
 260 print WARN <<'EOM' ;
 261 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 262    This file is built by warnings.pl
 263    Any changes made here will be lost!
 264 */
 265
 266
 267 #define Off(x)                  ((x) / 8)
 268 #define Bit(x)                  (1 << ((x) % 8))
 269 #define IsSet(a, x)             ((a)[Off(x)] & Bit(x))
 270
 271
 272 #define G_WARN_OFF              0       /* $^W == 0 */
 273 #define G_WARN_ON               1       /* -w flag and $^W != 0 */
 274 #define G_WARN_ALL_ON           2       /* -W flag */
 275 #define G_WARN_ALL_OFF          4       /* -X flag */
 276 #define G_WARN_ONCE             8       /* set if 'once' ever enabled */
 277 #define G_WARN_ALL_MASK         (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 278
 279 #define pWARN_STD               Nullsv
 280 #define pWARN_ALL               (Nullsv+1)      /* use warnings 'all' */
 281 #define pWARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 282
 283 #define specialWARN(x)          ((x) == pWARN_STD || (x) == pWARN_ALL ||        \
 284                                  (x) == pWARN_NONE)
 285 EOM
 286
 287 my $offset = 0 ;
 288
 289 $index = $offset ;
 290 #@{ $list{"all"} } = walk ($tree) ;
 291 valueWalk ($tree) ;
 292 my $index = orderValues();
 293
 294 die <<EOM if $index > 255 ;
 295 Too many warnings categories -- max is 255
 296     rewrite packWARN* & unpackWARN* macros
 297 EOM
 298
 299 walk ($tree) ;
 300
 301 $index *= 2 ;
 302 my $warn_size = int($index / 8) + ($index % 8 != 0) ;
 303
 304 my $k ;
 305 my $last_ver = 0;
 306 foreach $k (sort { $a <=> $b } keys %ValueToName) {
 307     my ($name, $version) = @{ $ValueToName{$k} };
 308     print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
 309         if $last_ver != $version ;
 310     print WARN tab(5, "#define WARN_$name"), "$k\n" ;
 311     $last_ver = $version ;
 312 }
 313 print WARN "\n" ;
 314
 315 print WARN tab(5, '#define WARNsize'),  "$warn_size\n" ;
 316 #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
 317 print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
 318 print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
 319 my $WARN_TAINTstring = mkOct($warn_size, map $_ * 2, @{ $list{'taint'} });
 320
 321 print WARN tab(5, '#define WARN_TAINTstring'), qq["$WARN_TAINTstring"\n] ;
 322
 323 print WARN <<'EOM';
 324
 325 #define isLEXWARN_on    (PL_curcop->cop_warnings != pWARN_STD)
 326 #define isLEXWARN_off   (PL_curcop->cop_warnings == pWARN_STD)
 327 #define isWARN_ONCE     (PL_dowarn & (G_WARN_ON|G_WARN_ONCE))
 328 #define isWARN_on(c,x)  (IsSet(SvPVX(c), 2*(x)))
 329 #define isWARNf_on(c,x) (IsSet(SvPVX(c), 2*(x)+1))
 330
 331 #define ckWARN(x)                                                       \
 332         ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&     \
 333               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 334                isWARN_on(PL_curcop->cop_warnings, x) ) )                \
 335           || (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 336
 337 #define ckWARN2(x,y)                                                    \
 338           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 339               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 340                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 341                 isWARN_on(PL_curcop->cop_warnings, y) ) )               \
 342             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 343
 344 #define ckWARN3(x,y,z)                                                  \
 345           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 346               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 347                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 348                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 349                 isWARN_on(PL_curcop->cop_warnings, z) ) )               \
 350             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 351
 352 #define ckWARN4(x,y,z,t)                                                \
 353           ( (isLEXWARN_on && PL_curcop->cop_warnings != pWARN_NONE &&   \
 354               (PL_curcop->cop_warnings == pWARN_ALL ||                  \
 355                 isWARN_on(PL_curcop->cop_warnings, x)  ||               \
 356                 isWARN_on(PL_curcop->cop_warnings, y)  ||               \
 357                 isWARN_on(PL_curcop->cop_warnings, z)  ||               \
 358                 isWARN_on(PL_curcop->cop_warnings, t) ) )               \
 359             ||  (isLEXWARN_off && PL_dowarn & G_WARN_ON) )
 360
 361 #define ckWARN_d(x)                                                     \
 362           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 363              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 364               isWARN_on(PL_curcop->cop_warnings, x) ) )
 365
 366 #define ckWARN2_d(x,y)                                                  \
 367           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 368              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 369                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 370                  isWARN_on(PL_curcop->cop_warnings, y) ) ) )
 371
 372 #define ckWARN3_d(x,y,z)                                                \
 373           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 374              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 375                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 376                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 377                  isWARN_on(PL_curcop->cop_warnings, z) ) ) )
 378
 379 #define ckWARN4_d(x,y,z,t)                                              \
 380           (isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL ||     \
 381              (PL_curcop->cop_warnings != pWARN_NONE &&                  \
 382                 (isWARN_on(PL_curcop->cop_warnings, x)  ||              \
 383                  isWARN_on(PL_curcop->cop_warnings, y)  ||              \
 384                  isWARN_on(PL_curcop->cop_warnings, z)  ||              \
 385                  isWARN_on(PL_curcop->cop_warnings, t) ) ) )
 386
 387 #define packWARN(a)             (a                                 )
 388 #define packWARN2(a,b)          ((a) | (b)<<8                      )
 389 #define packWARN3(a,b,c)        ((a) | (b)<<8 | (c) <<16           )
 390 #define packWARN4(a,b,c,d)      ((a) | (b)<<8 | (c) <<16 | (d) <<24)
 391
 392 #define unpackWARN1(x)          ((x)        & 0xFF)
 393 #define unpackWARN2(x)          (((x) >>8)  & 0xFF)
 394 #define unpackWARN3(x)          (((x) >>16) & 0xFF)
 395 #define unpackWARN4(x)          (((x) >>24) & 0xFF)
 396
 397 #define ckDEAD(x)                                                       \
 398            ( ! specialWARN(PL_curcop->cop_warnings) &&                  \
 399             ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
 400               isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
 401               isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
 402               isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
 403               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
 404
 405 /* end of file warnings.h */
 406
 407 EOM
 408
 409 close WARN ;
 410
 411 while (<DATA>) {
 412     last if /^KEYWORDS$/ ;
 413     print PM $_ ;
 414 }
 415
 416 #$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
 417
 418 $last_ver = 0;
 419 print PM "our %Offsets = (\n" ;
 420 foreach my $k (sort { $a <=> $b } keys %ValueToName) {
 421     my ($name, $version) = @{ $ValueToName{$k} };
 422     $name = lc $name;
 423     $k *= 2 ;
 424     if ( $last_ver != $version ) {
 425         print PM "\n";
 426         print PM tab(4, "    # Warnings Categories added in Perl $version");
 427         print PM "\n\n";
 428     }
 429     print PM tab(4, "    '$name'"), "=> $k,\n" ;
 430     $last_ver = $version;
 431 }
 432
 433 print PM "  );\n\n" ;
 434
 435 print PM "our %Bits = (\n" ;
 436 foreach $k (sort keys  %list) {
 437
 438     my $v = $list{$k} ;
 439     my @list = sort { $a <=> $b } @$v ;
 440
 441     print PM tab(4, "    '$k'"), '=> "',
 442                 # mkHex($warn_size, @list),
 443                 mkHex($warn_size, map $_ * 2 , @list),
 444                 '", # [', mkRange(@list), "]\n" ;
 445 }
 446
 447 print PM "  );\n\n" ;
 448
 449 print PM "our %DeadBits = (\n" ;
 450 foreach $k (sort keys  %list) {
 451
 452     my $v = $list{$k} ;
 453     my @list = sort { $a <=> $b } @$v ;
 454
 455     print PM tab(4, "    '$k'"), '=> "',
 456                 # mkHex($warn_size, @list),
 457                 mkHex($warn_size, map $_ * 2 + 1 , @list),
 458                 '", # [', mkRange(@list), "]\n" ;
 459 }
 460
 461 print PM "  );\n\n" ;
 462 print PM '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
 463 print PM '$LAST_BIT = ' . "$index ;\n" ;
 464 print PM '$BYTES    = ' . "$warn_size ;\n" ;
 465 while (<DATA>) {
 466     print PM $_ ;
 467 }
 468
 469 close PM ;
 470
 471 __END__
 472
 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.04';
 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 KEYWORDS
 606
 607 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 608
 609 sub Croaker
 610 {
 611     require Carp;
 612     delete $Carp::CarpInternal{'warnings'};
 613     Carp::croak(@_);
 614 }
 615
 616 sub bits
 617 {
 618     # called from B::Deparse.pm
 619
 620     push @_, 'all' unless @_;
 621
 622     my $mask;
 623     my $catmask ;
 624     my $fatal = 0 ;
 625     my $no_fatal = 0 ;
 626
 627     foreach my $word ( @_ ) {
 628         if ($word eq 'FATAL') {
 629             $fatal = 1;
 630             $no_fatal = 0;
 631         }
 632         elsif ($word eq 'NONFATAL') {
 633             $fatal = 0;
 634             $no_fatal = 1;
 635         }
 636         elsif ($catmask = $Bits{$word}) {
 637             $mask |= $catmask ;
 638             $mask |= $DeadBits{$word} if $fatal ;
 639             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 640         }
 641         else
 642           { Croaker("Unknown warnings category '$word'")}
 643     }
 644
 645     return $mask ;
 646 }
 647
 648 sub import
 649 {
 650     shift;
 651
 652     my $catmask ;
 653     my $fatal = 0 ;
 654     my $no_fatal = 0 ;
 655
 656     my $mask = ${^WARNING_BITS} ;
 657
 658     if (vec($mask, $Offsets{'all'}, 1)) {
 659         $mask |= $Bits{'all'} ;
 660         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 661     }
 662
 663     push @_, 'all' unless @_;
 664
 665     foreach my $word ( @_ ) {
 666         if ($word eq 'FATAL') {
 667             $fatal = 1;
 668             $no_fatal = 0;
 669         }
 670         elsif ($word eq 'NONFATAL') {
 671             $fatal = 0;
 672             $no_fatal = 1;
 673         }
 674         elsif ($catmask = $Bits{$word}) {
 675             $mask |= $catmask ;
 676             $mask |= $DeadBits{$word} if $fatal ;
 677             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
 678         }
 679         else
 680           { Croaker("Unknown warnings category '$word'")}
 681     }
 682
 683     ${^WARNING_BITS} = $mask ;
 684 }
 685
 686 sub unimport
 687 {
 688     shift;
 689
 690     my $catmask ;
 691     my $mask = ${^WARNING_BITS} ;
 692
 693     if (vec($mask, $Offsets{'all'}, 1)) {
 694         $mask |= $Bits{'all'} ;
 695         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
 696     }
 697
 698     push @_, 'all' unless @_;
 699
 700     foreach my $word ( @_ ) {
 701         if ($word eq 'FATAL') {
 702             next;
 703         }
 704         elsif ($catmask = $Bits{$word}) {
 705             $mask &= ~($catmask | $DeadBits{$word} | $All);
 706         }
 707         else
 708           { Croaker("Unknown warnings category '$word'")}
 709     }
 710
 711     ${^WARNING_BITS} = $mask ;
 712 }
 713
 714 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 715
 716 sub __chk
 717 {
 718     my $category ;
 719     my $offset ;
 720     my $isobj = 0 ;
 721
 722     if (@_) {
 723         # check the category supplied.
 724         $category = shift ;
 725         if (my $type = ref $category) {
 726             Croaker("not an object")
 727                 if exists $builtin_type{$type};
 728             $category = $type;
 729             $isobj = 1 ;
 730         }
 731         $offset = $Offsets{$category};
 732         Croaker("Unknown warnings category '$category'")
 733             unless defined $offset;
 734     }
 735     else {
 736         $category = (caller(1))[0] ;
 737         $offset = $Offsets{$category};
 738         Croaker("package '$category' not registered for warnings")
 739             unless defined $offset ;
 740     }
 741
 742     my $this_pkg = (caller(1))[0] ;
 743     my $i = 2 ;
 744     my $pkg ;
 745
 746     if ($isobj) {
 747         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 748             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 749         }
 750         $i -= 2 ;
 751     }
 752     else {
 753         $i = _error_loc(); # see where Carp will allocate the error
 754     }
 755
 756     my $callers_bitmask = (caller($i))[9] ;
 757     return ($callers_bitmask, $offset, $i) ;
 758 }
 759
 760 sub _error_loc {
 761     require Carp::Heavy;
 762     goto &Carp::short_error_loc; # don't introduce another stack frame
 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     require Carp;
 786     Carp::croak($message)
 787         if vec($callers_bitmask, $offset+1, 1) ||
 788            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 789     Carp::carp($message) ;
 790 }
 791
 792 sub warnif
 793 {
 794     Croaker("Usage: warnings::warnif([category,] 'message')")
 795         unless @_ == 2 || @_ == 1 ;
 796
 797     my $message = pop ;
 798     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 799
 800     return
 801         unless defined $callers_bitmask &&
 802                 (vec($callers_bitmask, $offset, 1) ||
 803                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
 804
 805     require Carp;
 806     Carp::croak($message)
 807         if vec($callers_bitmask, $offset+1, 1) ||
 808            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 809
 810     Carp::carp($message) ;
 811 }
 812
 813 1;