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         'untie'         => [ 5.008, DEFAULT_OFF],
  53         'substr'        => [ 5.008, DEFAULT_OFF],
  54         'taint'         => [ 5.008, DEFAULT_OFF],
  55         'signal'        => [ 5.008, DEFAULT_OFF],
  56         'closure'       => [ 5.008, DEFAULT_OFF],
  57         'overflow'      => [ 5.008, DEFAULT_OFF],
  58         'portable'      => [ 5.008, DEFAULT_OFF],
  59         'utf8'          => [ 5.008, DEFAULT_OFF],
  60         'exiting'       => [ 5.008, DEFAULT_OFF],
  61         'pack'          => [ 5.008, DEFAULT_OFF],
  62         'unpack'        => [ 5.008, DEFAULT_OFF],
  63         'threads'       => [ 5.008, DEFAULT_OFF],
  64         'assertions'    => [ 5.009, DEFAULT_OFF],
  65
  66          #'default'     => [ 5.008, DEFAULT_ON ],
  67         }],
  68 } ;
  69
  70 ###########################################################################
  71 sub tab {
  72     my($l, $t) = @_;
  73     $t .= "\t" x ($l - (length($t) + 1) / 8);
  74     $t;
  75 }
  76
  77 ###########################################################################
  78
  79 my %list ;
  80 my %Value ;
  81 my %ValueToName ;
  82 my %NameToValue ;
  83 my $index ;
  84
  85 my %v_list = () ;
  86
  87 sub valueWalk
  88 {
  89     my $tre = shift ;
  90     my @list = () ;
  91     my ($k, $v) ;
  92
  93     foreach $k (sort keys %$tre) {
  94         $v = $tre->{$k};
  95         die "duplicate key $k\n" if defined $list{$k} ;
  96         die "Value associated with key '$k' is not an ARRAY reference"
  97             if !ref $v || ref $v ne 'ARRAY' ;
  98
  99         my ($ver, $rest) = @{ $v } ;
 100         push @{ $v_list{$ver} }, $k;
 101
 102         if (ref $rest)
 103           { valueWalk ($rest) }
 104
 105     }
 106
 107 }
 108
 109 sub orderValues
 110 {
 111     my $index = 0;
 112     foreach my $ver ( sort { $a <=> $b } keys %v_list ) {
 113         foreach my $name (@{ $v_list{$ver} } ) {
 114             $ValueToName{ $index } = [ uc $name, $ver ] ;
 115             $NameToValue{ uc $name } = $index ++ ;
 116         }
 117     }
 118
 119     return $index ;
 120 }
 121
 122 ###########################################################################
 123
 124 sub walk
 125 {
 126     my $tre = shift ;
 127     my @list = () ;
 128     my ($k, $v) ;
 129
 130     foreach $k (sort keys %$tre) {
 131         $v = $tre->{$k};
 132         die "duplicate key $k\n" if defined $list{$k} ;
 133         #$Value{$index} = uc $k ;
 134         die "Can't find key '$k'"
 135             if ! defined $NameToValue{uc $k} ;
 136         push @{ $list{$k} }, $NameToValue{uc $k} ;
 137         die "Value associated with key '$k' is not an ARRAY reference"
 138             if !ref $v || ref $v ne 'ARRAY' ;
 139
 140         my ($ver, $rest) = @{ $v } ;
 141         if (ref $rest)
 142           { push (@{ $list{$k} }, walk ($rest)) }
 143
 144         push @list, @{ $list{$k} } ;
 145     }
 146
 147    return @list ;
 148 }
 149
 150 ###########################################################################
 151
 152 sub mkRange
 153 {
 154     my @a = @_ ;
 155     my @out = @a ;
 156     my $i ;
 157
 158
 159     for ($i = 1 ; $i < @a; ++ $i) {
 160         $out[$i] = ".."
 161           if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
 162     }
 163
 164     my $out = join(",",@out);
 165
 166     $out =~ s/,(\.\.,)+/../g ;
 167     return $out;
 168 }
 169
 170 ###########################################################################
 171 sub printTree
 172 {
 173     my $tre = shift ;
 174     my $prefix = shift ;
 175     my ($k, $v) ;
 176
 177     my $max = (sort {$a <=> $b} map { length $_ } keys %$tre)[-1] ;
 178     my @keys = sort keys %$tre ;
 179
 180     while ($k = shift @keys) {
 181         $v = $tre->{$k};
 182         die "Value associated with key '$k' is not an ARRAY reference"
 183             if !ref $v || ref $v ne 'ARRAY' ;
 184
 185         my $offset ;
 186         if ($tre ne $tree) {
 187             print $prefix . "|\n" ;
 188             print $prefix . "+- $k" ;
 189             $offset = ' ' x ($max + 4) ;
 190         }
 191         else {
 192             print $prefix . "$k" ;
 193             $offset = ' ' x ($max + 1) ;
 194         }
 195
 196         my ($ver, $rest) = @{ $v } ;
 197         if (ref $rest)
 198         {
 199             my $bar = @keys ? "|" : " ";
 200             print " -" . "-" x ($max - length $k ) . "+\n" ;
 201             printTree ($rest, $prefix . $bar . $offset )
 202         }
 203         else
 204           { print "\n" }
 205     }
 206
 207 }
 208
 209 ###########################################################################
 210
 211 sub mkHexOct
 212 {
 213     my ($f, $max, @a) = @_ ;
 214     my $mask = "\x00" x $max ;
 215     my $string = "" ;
 216
 217     foreach (@a) {
 218         vec($mask, $_, 1) = 1 ;
 219     }
 220
 221     foreach (unpack("C*", $mask)) {
 222         if ($f eq 'x') {
 223             $string .= '\x' . sprintf("%2.2x", $_)
 224         }
 225         else {
 226             $string .= '\\' . sprintf("%o", $_)
 227         }
 228     }
 229     return $string ;
 230 }
 231
 232 sub mkHex
 233 {
 234     my($max, @a) = @_;
 235     return mkHexOct("x", $max, @a);
 236 }
 237
 238 sub mkOct
 239 {
 240     my($max, @a) = @_;
 241     return mkHexOct("o", $max, @a);
 242 }
 243
 244 ###########################################################################
 245
 246 if (@ARGV && $ARGV[0] eq "tree")
 247 {
 248     printTree($tree, "    ") ;
 249     exit ;
 250 }
 251
 252 unlink "warnings.h";
 253 unlink "lib/warnings.pm";
 254 open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
 255 binmode WARN;
 256 open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
 257 binmode PM;
 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 "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 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.04';
 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 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 513 but the pragma is limited to the enclosing block, while the flag is global.
 514 See L<perllexwarn> for more information.
 515
 516 If no import list is supplied, all possible warnings are either enabled
 517 or disabled.
 518
 519 A number of functions are provided to assist module authors.
 520
 521 =over 4
 522
 523 =item use warnings::register
 524
 525 Creates a new warnings category with the same name as the package where
 526 the call to the pragma is used.
 527
 528 =item warnings::enabled()
 529
 530 Use the warnings category with the same name as the current package.
 531
 532 Return TRUE if that warnings category is enabled in the calling module.
 533 Otherwise returns FALSE.
 534
 535 =item warnings::enabled($category)
 536
 537 Return TRUE if the warnings category, C<$category>, is enabled in the
 538 calling module.
 539 Otherwise returns FALSE.
 540
 541 =item warnings::enabled($object)
 542
 543 Use the name of the class for the object reference, C<$object>, as the
 544 warnings category.
 545
 546 Return TRUE if that warnings category is enabled in the first scope
 547 where the object is used.
 548 Otherwise returns FALSE.
 549
 550 =item warnings::warn($message)
 551
 552 Print C<$message> to STDERR.
 553
 554 Use the warnings category with the same name as the current package.
 555
 556 If that warnings category has been set to "FATAL" in the calling module
 557 then die. Otherwise return.
 558
 559 =item warnings::warn($category, $message)
 560
 561 Print C<$message> to STDERR.
 562
 563 If the warnings category, C<$category>, has been set to "FATAL" in the
 564 calling module then die. Otherwise return.
 565
 566 =item warnings::warn($object, $message)
 567
 568 Print C<$message> to STDERR.
 569
 570 Use the name of the class for the object reference, C<$object>, as the
 571 warnings category.
 572
 573 If that warnings category has been set to "FATAL" in the scope where C<$object>
 574 is first used then die. Otherwise return.
 575
 576
 577 =item warnings::warnif($message)
 578
 579 Equivalent to:
 580
 581     if (warnings::enabled())
 582       { warnings::warn($message) }
 583
 584 =item warnings::warnif($category, $message)
 585
 586 Equivalent to:
 587
 588     if (warnings::enabled($category))
 589       { warnings::warn($category, $message) }
 590
 591 =item warnings::warnif($object, $message)
 592
 593 Equivalent to:
 594
 595     if (warnings::enabled($object))
 596       { warnings::warn($object, $message) }
 597
 598 =back
 599
 600 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
 601
 602 =cut
 603
 604 KEYWORDS
 605
 606 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 607
 608 sub Croaker
 609 {
 610     require Carp;
 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 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
 714
 715 sub __chk
 716 {
 717     my $category ;
 718     my $offset ;
 719     my $isobj = 0 ;
 720
 721     if (@_) {
 722         # check the category supplied.
 723         $category = shift ;
 724         if (my $type = ref $category) {
 725             Croaker("not an object")
 726                 if exists $builtin_type{$type};
 727             $category = $type;
 728             $isobj = 1 ;
 729         }
 730         $offset = $Offsets{$category};
 731         Croaker("Unknown warnings category '$category'")
 732             unless defined $offset;
 733     }
 734     else {
 735         $category = (caller(1))[0] ;
 736         $offset = $Offsets{$category};
 737         Croaker("package '$category' not registered for warnings")
 738             unless defined $offset ;
 739     }
 740
 741     my $this_pkg = (caller(1))[0] ;
 742     my $i = 2 ;
 743     my $pkg ;
 744
 745     if ($isobj) {
 746         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
 747             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
 748         }
 749         $i -= 2 ;
 750     }
 751     else {
 752         $i = _error_loc(); # see where Carp will allocate the error
 753     }
 754
 755     my $callers_bitmask = (caller($i))[9] ;
 756     return ($callers_bitmask, $offset, $i) ;
 757 }
 758
 759 sub _error_loc {
 760     require Carp::Heavy;
 761     goto &Carp::short_error_loc; # don't introduce another stack frame
 762 }
 763
 764 sub enabled
 765 {
 766     Croaker("Usage: warnings::enabled([category])")
 767         unless @_ == 1 || @_ == 0 ;
 768
 769     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 770
 771     return 0 unless defined $callers_bitmask ;
 772     return vec($callers_bitmask, $offset, 1) ||
 773            vec($callers_bitmask, $Offsets{'all'}, 1) ;
 774 }
 775
 776
 777 sub warn
 778 {
 779     Croaker("Usage: warnings::warn([category,] 'message')")
 780         unless @_ == 2 || @_ == 1 ;
 781
 782     my $message = pop ;
 783     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
 784     require Carp;
 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     require Carp;
 805     Carp::croak($message)
 806         if vec($callers_bitmask, $offset+1, 1) ||
 807            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
 808
 809     Carp::carp($message) ;
 810 }
 811
 812 1;